theory Paths_Cycles
  imports Floyd_Warshall
begin

chapter \<open>Library for Paths, Arcs and Lengths\<close>

lemma length_eq_distinct:
  assumes "set xs = set ys" "distinct xs" "length xs = length ys"
  shows "distinct ys"
using assms card_distinct distinct_card by fastforce

section \<open>Arcs\<close>

fun arcs :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> (nat * nat) list" where
  "arcs a b [] = [(a,b)]" |
  "arcs a b (x # xs) = (a, x) # arcs x b xs"

definition arcs' :: "nat list \<Rightarrow> (nat * nat) set" where
  "arcs' xs = set (arcs (hd xs) (last xs) (butlast (tl xs)))"

lemma arcs'_decomp:
  "length xs > 1 \<Longrightarrow> (i, j) \<in> arcs' xs \<Longrightarrow> \<exists> zs ys. xs = zs @ i # j # ys"
proof (induction xs)
  case Nil thus ?case by auto
next
  case (Cons x xs)
  then have "length xs > 0" by auto
  then obtain y ys where xs: "xs = y # ys" by (metis Suc_length_conv less_imp_Suc_add)
  show ?case
  proof (cases "(i, j) = (x, y)")
    case True
    with xs have "x # xs = [] @ i # j # ys" by simp
    then show ?thesis by auto
  next
    case False
    then show ?thesis
    proof (cases "length ys > 0", goal_cases)
      case 2
      then have "ys = []" by auto
      then have "arcs' (x#xs) = {(x,y)}" using xs by (auto simp add: arcs'_def)
      with Cons.prems(2) 2(1) show ?case by auto
    next
      case True
      with xs Cons.prems(2) False have "(i, j) \<in> arcs' xs" by (auto simp add: arcs'_def)
      with Cons.IH[OF _ this] True xs obtain zs ys where "xs = zs @ i # j # ys" by auto
      then have "x # xs = (x # zs) @ i # j # ys" by simp
      then show ?thesis by blast
    qed
  qed
qed

lemma arcs_decomp_tail:
  "arcs j l (ys @ [i]) = arcs j i ys @ [(i, l)]"
by (induction ys arbitrary: j) auto

lemma arcs_decomp: "xs = ys @ y # zs \<Longrightarrow> arcs x z xs = arcs x y ys @ arcs y z zs"
by (induction ys arbitrary: x xs) simp+

lemma distinct_arcs_ex:
  "distinct xs \<Longrightarrow> i \<notin> set xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> \<exists> a b. a \<noteq> x \<and> (a,b) \<in> set (arcs i j xs)"
 apply (induction xs arbitrary: i)
  apply simp
 apply (rename_tac a xs i)
 apply (case_tac xs)
  apply simp
  apply metis
by auto

lemma cycle_rotate_2_aux:
  "(i, j) \<in> set (arcs a b (xs @ [c])) \<Longrightarrow> (i,j) \<noteq> (c,b) \<Longrightarrow> (i, j) \<in> set (arcs a c xs)"
by (induction xs arbitrary: a) auto

lemma arcs_set_elem1:
  assumes "j \<noteq> k" "k \<in> set (i # xs)"
  shows "\<exists> l. (k, l) \<in> set (arcs i j xs)" using assms
by (induction xs arbitrary: i) auto

lemma arcs_set_elem2:
  assumes "i \<noteq> k" "k \<in> set (j # xs)"
  shows "\<exists> l. (l, k) \<in> set (arcs i j xs)" using assms
proof (induction xs arbitrary: i)
  case Nil then show ?case by simp
next
  case (Cons x xs)
  then show ?case by (cases "k = x") auto
qed

section \<open>Length of Paths\<close>

lemmas (in linordered_ab_monoid_add) comm = add.commute

lemma len_add:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  shows "len M i j xs + len M i j xs = len (\<lambda>i j. M i j + M i j) i j xs"
proof (induction xs arbitrary: i j)
  case Nil thus ?case by auto
next
  case (Cons x xs)
  have "M i x + len M x j xs + (M i x + len M x j xs) = M i x + (len M x j xs + M i x) + len M x j xs"
    by (simp add: add.assoc)
  also have "\<dots> = M i x + (M i x + len M x j xs) + len M x j xs" by (simp add: comm)
  also have "\<dots> = (M i x + M i x) + (len M x j xs + len M x j xs)" by (simp add: add.assoc)
  finally have "M i x + len M x j xs + (M i x + len M x j xs)
                = (M i x + M i x) + len (\<lambda>i j. M i j + M i j) x j xs"
  using Cons by simp
  thus ?case by simp
qed

section \<open>Cycle Rotation\<close>

lemma cycle_rotate:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "length xs > 1" "(i, j) \<in> arcs' xs"
  shows "\<exists> ys zs. len M a a xs = len M i i (j # ys @ a # zs) \<and> xs = zs @ i # j # ys" using assms
proof -
  assume A: "length xs > 1" "(i, j) \<in> arcs' xs"
  from arcs'_decomp[OF this] obtain ys zs where xs: "xs = zs @ i # j # ys" by blast
  from len_decomp[OF this, of M a a]
  have "len M a a xs = len M a i zs + len M i a (j # ys)" .
  also have "\<dots> = len M i a (j # ys) + len M a i zs" by (simp add: comm)
  also from len_comp[of M i i "j # ys" a zs] have "\<dots> = len M i i (j # ys @ a # zs)" by auto
  finally show ?thesis using xs by auto
qed

lemma cycle_rotate_2:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "xs \<noteq> []" "(i, j) \<in> set (arcs a a xs)"
  shows "\<exists> ys. len M a a xs = len M i i (j # ys) \<and> set ys \<subseteq> set (a # xs) \<and> length ys < length xs"
using assms proof -
  assume A:"xs \<noteq> []" "(i, j) \<in> set (arcs a a xs)"
  { fix ys assume A:"a = i" "xs = j # ys"
    then have ?thesis by auto
  } note * = this
  { fix b ys assume A:"a = j" "xs = ys @ [i]"
    then have ?thesis
    proof (auto, goal_cases)
      case 1
      have "len M j j (ys @ [i]) = M i j + len M j i ys"
      using len_decomp[of "ys @ [i]" ys i "[]" M j j] by (auto simp: comm)
      thus ?case by blast
    qed
  } note ** = this
  { assume "length xs = 1"
    then obtain b where xs: "xs = [b]" by (metis One_nat_def length_0_conv length_Suc_conv)
    with A(2) have "a = i \<and> b = j \<or> a = j \<and> b = i" by auto
    then have ?thesis using * ** xs by auto
  } note *** = this
  show ?thesis
  proof (cases "length xs = 0")
    case True with A show ?thesis by auto
  next
    case False
    thus ?thesis
    proof (cases "length xs = 1", goal_cases)
      case True with *** show ?thesis by auto
    next
      case 2
      hence "length xs > 1" by linarith
      then obtain b c ys where ys:"xs = b # ys @ [c]"
      by (metis One_nat_def assms(1) 2(2) length_0_conv length_Cons list.exhaust rev_exhaust)
      thus ?thesis
      proof (cases "(i,j) = (a,b)", goal_cases)
        case True
        with ys * show ?thesis by auto
      next
        case False
        then show ?thesis
        proof (cases "(i,j) = (c,a)", goal_cases)
          case True
          with ys ** show ?thesis by auto
        next
          case 2
          with A(2) ys have "(i, j) \<in> arcs' xs"
          using cycle_rotate_2_aux by (auto simp: arcs'_def) (* slow *)
          from cycle_rotate[OF \<open>length xs > 1\<close> this, of M a] show ?thesis by auto
        qed
      qed
    qed
  qed
qed

lemma cycle_rotate_len_arcs:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "length xs > 1" "(i, j) \<in> arcs' xs"
  shows "\<exists> ys zs. len M a a xs = len M i i (j # ys @ a # zs)
                \<and> set (arcs a a xs) = set (arcs i i (j # ys @ a # zs)) \<and> xs = zs @ i # j # ys"
using assms
proof -
  assume A: "length xs > 1" "(i, j) \<in> arcs' xs"
  from arcs'_decomp[OF this] obtain ys zs where xs: "xs = zs @ i # j # ys" by blast
  from len_decomp[OF this, of M a a]
  have "len M a a xs = len M a i zs + len M i a (j # ys)" .
  also have "\<dots> = len M i a (j # ys) + len M a i zs" by (simp add: comm)
  also from len_comp[of M i i "j # ys" a zs] have "\<dots> = len M i i (j # ys @ a # zs)" by auto
  finally show ?thesis
  using xs arcs_decomp[OF xs, of a a] arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i] by force
qed

lemma cycle_rotate_2':
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "xs \<noteq> []" "(i, j) \<in> set (arcs a a xs)"
  shows "\<exists> ys. len M a a xs = len M i i (j # ys) \<and> set (i # j # ys) = set (a # xs)
             \<and> 1 + length ys = length xs \<and> set (arcs a a xs) = set (arcs i i (j # ys))"
proof -
  note A = assms
  { fix ys assume A:"a = i" "xs = j # ys"
    then have ?thesis by auto
  } note * = this
  { fix b ys assume A:"a = j" "xs = ys @ [i]"
    then have ?thesis
    proof (auto, goal_cases)
      case 1
      have "len M j j (ys @ [i]) = M i j + len M j i ys"
      using len_decomp[of "ys @ [i]" ys i "[]" M j j] by (auto simp: comm)
      moreover have "arcs j j (ys @ [i]) = arcs j i ys @ [(i, j)]" using arcs_decomp_tail by auto
      ultimately show ?case by auto
    qed
  } note ** = this
  { assume "length xs = 1"
    then obtain b where xs: "xs = [b]" by (metis One_nat_def length_0_conv length_Suc_conv)
    with A(2) have "a = i \<and> b = j \<or> a = j \<and> b = i" by auto
    then have ?thesis using * ** xs by auto
  } note *** = this
  show ?thesis
  proof (cases "length xs = 0")
    case True with A show ?thesis by auto
  next
    case False
    thus ?thesis
    proof (cases "length xs = 1", goal_cases)
      case True with *** show ?thesis by auto
    next
      case 2
      hence "length xs > 1" by linarith
      then obtain b c ys where ys:"xs = b # ys @ [c]"
      by (metis One_nat_def assms(1) 2(2) length_0_conv length_Cons list.exhaust rev_exhaust)
      thus ?thesis
      proof (cases "(i,j) = (a,b)")
        case True
        with ys * show ?thesis by blast
      next
        case False
        then show ?thesis
        proof (cases "(i,j) = (c,a)", goal_cases)
          case True
          with ys ** show ?thesis by force
        next
          case 2
          with A(2) ys have "(i, j) \<in> arcs' xs"
          using cycle_rotate_2_aux by (auto simp add: arcs'_def) (* slow *)
          from cycle_rotate_len_arcs[OF \<open>length xs > 1\<close> this, of M a] show ?thesis by auto
        qed
      qed
    qed
  qed
qed

section \<open>More on Cycle-Freeness\<close>

lemma cyc_free_diag_dest:
  assumes "cyc_free M n" "i \<le> n" "set xs \<subseteq> {0..n}"
  shows "len M i i xs \<ge> 0"
using assms by auto

lemma cycle_free_0_0:
  fixes M :: "('a::linordered_ab_monoid_add) mat"
  assumes "cycle_free M n"
  shows "M 0 0 \<ge> 0"
using cyc_free_diag_dest[OF cycle_free_diag_dest[OF assms], of 0 "[]"] by auto

section \<open>Helper Lemmas for Bouyer's Theorem on Approximation\<close>

lemma aux1: "i \<le> n \<Longrightarrow> j \<le> n \<Longrightarrow> set xs \<subseteq> {0..n} \<Longrightarrow> (a,b) \<in> set (arcs i j xs) \<Longrightarrow> a \<le> n \<and> b \<le> n"
by (induction xs arbitrary: i) auto

lemma arcs_distinct1:
  "i \<notin> set xs \<Longrightarrow> j \<notin> set xs \<Longrightarrow> distinct xs \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> (a,b) \<in> set (arcs i j xs) \<Longrightarrow> a \<noteq> b"
apply (induction xs arbitrary: i)
 apply fastforce
apply (rename_tac a' xs i)
apply (case_tac xs)
 apply auto
done

lemma arcs_distinct2:
  "i \<notin> set xs \<Longrightarrow> j \<notin> set xs \<Longrightarrow> distinct xs \<Longrightarrow> i \<noteq> j \<Longrightarrow> (a,b) \<in> set (arcs i j xs) \<Longrightarrow> a \<noteq> b"
by (induction xs arbitrary: i) auto

lemma arcs_distinct3: "distinct (a # b # c # xs) \<Longrightarrow> (i,j) \<in> set (arcs a b xs) \<Longrightarrow> i \<noteq> c \<and> j \<noteq> c"
by (induction xs arbitrary: a) force+

lemma arcs_elem:
  assumes "(a, b) \<in> set (arcs i j xs)" shows "a \<in> set (i # xs)" "b \<in> set (j # xs)"
using assms by (induction xs arbitrary: i) auto

lemma arcs_distinct_dest1:
  "distinct (i # a # zs) \<Longrightarrow> (b,c) \<in> set (arcs a j zs) \<Longrightarrow> b \<noteq> i"
using arcs_elem by fastforce

lemma arcs_distinct_fix:
  "distinct (a # x # xs @ [b]) \<Longrightarrow> (a,c) \<in> set (arcs a b (x # xs)) \<Longrightarrow> c = x"
using arcs_elem(1) by fastforce

lemma disjE3: "A \<or> B \<or> C \<Longrightarrow> (A \<Longrightarrow> G) \<Longrightarrow> (B \<Longrightarrow> G) \<Longrightarrow> (C \<Longrightarrow> G) \<Longrightarrow> G"
by auto

lemma arcs_predecessor:
  assumes "(a, b) \<in> set (arcs i j xs)" "a \<noteq> i"
  shows "\<exists> c. (c, a) \<in> set (arcs i j xs)" using assms
by (induction xs arbitrary: i) auto

lemma arcs_successor:
  assumes "(a, b) \<in> set (arcs i j xs)" "b \<noteq> j"
  shows "\<exists> c. (b,c) \<in> set (arcs i j xs)" using assms
apply (induction xs arbitrary: i)
 apply simp
apply (rename_tac aa xs i)
apply (case_tac xs)
by auto

lemma arcs_predecessor':
  assumes "(a, b) \<in> set (arcs i j (x # xs))" "(a,b) \<noteq> (i, x)"
  shows "\<exists> c. (c, a) \<in> set (arcs i j (x # xs))" using assms
by (induction xs arbitrary: i x) auto

lemma arcs_cases:
  assumes "(a, b) \<in> set (arcs i j xs)" "xs \<noteq> []"
  shows "(\<exists> ys. xs = b # ys \<and> a = i) \<or> (\<exists> ys. xs = ys @ [a] \<and> b = j)
       \<or> (\<exists> c d ys. (a,b) \<in> set (arcs c d ys) \<and> xs = c # ys @ [d])"
using assms
proof (induction xs arbitrary: i)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "(a, b) = (i, x)")
    case True
    with Cons.prems show ?thesis by auto
  next
    case False
    note F = this
    show ?thesis
    proof (cases "xs = []")
      case True
      with F Cons.prems show ?thesis by auto
    next
      case False
      from F Cons.prems have "(a, b) \<in> set (arcs x j xs)" by auto
      from Cons.IH[OF this False] have
        "(\<exists>ys. xs = b # ys \<and> a = x) \<or> (\<exists>ys. xs = ys @ [a] \<and> b = j)
         \<or> (\<exists>c d ys. (a, b) \<in> set (arcs c d ys) \<and> xs = c # ys @ [d])"
      .
      then show ?thesis
      proof (rule disjE3, goal_cases)
        case 1
        from 1 obtain ys where *: "xs = b # ys \<and> a = x" by auto
        show ?thesis
        proof (cases "ys = []")
          case True
          with * show ?thesis by auto
        next
          case False
          then obtain z zs where zs: "ys = zs @ [z]" by (metis append_butlast_last_id)
          with * show ?thesis by auto
        qed
      next
        case 2 then show ?case by auto
      next
        case 3 with False show ?case by auto
      qed
    qed
  qed
qed

lemma arcs_cases':
  assumes "(a, b) \<in> set (arcs i j xs)" "xs \<noteq> []"
  shows "(\<exists> ys. xs = b # ys \<and> a = i) \<or> (\<exists> ys. xs = ys @ [a] \<and> b = j) \<or> (\<exists> ys zs. xs = ys @ a # b # zs)"
using assms
proof (induction xs arbitrary: i)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "(a, b) = (i, x)")
    case True
    with Cons.prems show ?thesis by auto
  next
    case False
    note F = this
    show ?thesis
    proof (cases "xs = []")
      case True
      with F Cons.prems show ?thesis by auto
    next
      case False
      from F Cons.prems have "(a, b) \<in> set (arcs x j xs)" by auto
      from Cons.IH[OF this False] have
        "(\<exists>ys. xs = b # ys \<and> a = x) \<or> (\<exists>ys. xs = ys @ [a] \<and> b = j)
         \<or> (\<exists>ys zs. xs = ys @ a # b # zs)"
      .
      then show ?thesis
      proof (rule disjE3, goal_cases)
        case 1
        from 1 obtain ys where *: "xs = b # ys \<and> a = x" by auto
        show ?thesis
        proof (cases "ys = []")
          case True
          with * show ?thesis by auto
        next
          case False
          then obtain z zs where zs: "ys = zs @ [z]" by (metis append_butlast_last_id)
          with * show ?thesis by auto
        qed
      next
        case 2 then show ?case by auto
      next
        case 3
        then obtain ys zs where "xs = ys @ a # b # zs" by auto
        then have "x # xs = (x # ys) @ a # b # zs" by auto
        then show ?thesis by blast
      qed
    qed
  qed
qed

lemma arcs_successor':
  assumes "(a, b) \<in> set (arcs i j xs)" "b \<noteq> j"
  shows "\<exists> c. xs = [b] \<and> a = i \<or> (\<exists> ys. xs = b # c # ys \<and> a = i) \<or> (\<exists> ys. xs = ys @ [a,b] \<and> c = j)
       \<or> (\<exists> ys zs. xs = ys @ a # b # c # zs)"
using assms
proof (induction xs arbitrary: i)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "(a, b) = (i, x)")
    case True
    with Cons.prems show ?thesis by (cases xs) auto
  next
    case False
    note F = this
    show ?thesis
    proof (cases "xs = []")
      case True
      with F Cons.prems show ?thesis by auto
    next
      case False
      from F Cons.prems have "(a, b) \<in> set (arcs x j xs)" by auto
      from Cons.IH[OF this \<open>b \<noteq> j\<close>] obtain c where c:
        "xs = [b] \<and> a = x \<or> (\<exists>ys. xs = b # c # ys \<and> a = x) \<or> (\<exists>ys. xs = ys @ [a, b] \<and> c = j)
         \<or> (\<exists>ys zs. xs = ys @ a # b # c # zs)"
      ..
      then show ?thesis
      proof (standard, goal_cases)
        case 1 with Cons.prems show ?case by auto
      next
        case 2
        then show ?thesis
        proof (rule disjE3, goal_cases)
          case 1
          from 1 obtain ys where *: "xs = b # ys \<and> a = x" by auto
          show ?thesis
          proof (cases "ys = []")
            case True
            with * show ?thesis by auto
          next
            case False
            then obtain z zs where zs: "ys = z # zs" by (cases ys) auto
            with * show ?thesis by fastforce
          qed
        next
          case 2 then show ?case by auto
        next
          case 3
          then obtain ys zs where "xs = ys @ a # b # c # zs" by auto
          then have "x # xs = (x # ys) @ a # b # c # zs" by auto
          then show ?thesis by blast
        qed
      qed
    qed
  qed
qed

lemma list_last:
  "xs = [] \<or> (\<exists> y ys. xs = ys @ [y])"
by (induction xs) auto

lemma arcs_predecessor'':
  assumes "(a, b) \<in> set (arcs i j xs)" "a \<noteq> i"
 shows "\<exists> c. xs = [a] \<or> (\<exists> ys. xs = a # b # ys) \<or> (\<exists> ys. xs = ys @ [c,a] \<and> b = j)
       \<or> (\<exists> ys zs. xs = ys @ c # a # b # zs)"
using assms
proof (induction xs arbitrary: i)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  show ?case
  proof (cases "(a, b) = (i, x)")
    case True
    with Cons.prems show ?thesis by (cases xs) auto
  next
    case False
    note F = this
    show ?thesis
    proof (cases "xs = []")
      case True
      with F Cons.prems show ?thesis by auto
    next
      case False
      from F Cons.prems have *: "(a, b) \<in> set (arcs x j xs)" by auto
      from False obtain y ys where xs: "xs = y # ys" by (cases xs) auto
      show ?thesis
      proof (cases "(a,b) = (x,y)")
        case True with * xs show ?thesis by auto
      next
        case False
        with * xs have **: "(a, b) \<in> set (arcs y j ys)" by auto
        show ?thesis
        proof (cases "ys = []")
          case True with ** xs show ?thesis by force
        next
          case False
          from arcs_cases'[OF ** this] obtain ws zs where ***:
            "ys = b # ws \<and> a = y \<or> ys = ws @ [a] \<and> b = j \<or> ys = ws @ a # b # zs"
          by auto
          then show ?thesis
           apply rule
            using xs apply blast
           apply safe
            using xs list_last[of ws] apply -
            apply (rotate_tac 3)
            apply (case_tac "ws = []")
             apply auto[]
            apply (subgoal_tac "\<exists>y ys. ws = ys @ [y]")
             apply fastforce
            apply simp
           apply (case_tac "ws = []")
            apply (subgoal_tac "x # xs = [x] @ y # a # b # zs")
             apply (rule exI[where x = y])
             apply blast
            apply simp
           subgoal
           proof goal_cases
             case 1
             then obtain u us where "ws = us @ [u]" by auto
             with 1(1,2) have "x # xs = (x # y # us) @ u # a # b # zs" by auto
             then show ?case by blast
           qed
          done
        qed
      qed
    qed
  qed
qed

lemma arcs_ex_middle:
  "\<exists> b. (a, b) \<in> set (arcs i j (ys @ a # xs))"
by (induction xs arbitrary: i ys) (auto simp: arcs_decomp)

lemma arcs_ex_head:
  "\<exists> b. (i, b) \<in> set (arcs i j xs)"
by (cases xs) auto

subsection \<open>Successive\<close>

fun successive where
  "successive _ [] = True" |
  "successive P [_] = True" |
  "successive P (x # y # xs) \<longleftrightarrow> \<not> P y \<and> successive P xs \<or> \<not> P x \<and> successive P (y # xs)"

lemma "\<not> successive (\<lambda> x. x > (0 :: nat)) [Suc 0, Suc 0]" by simp
lemma "successive (\<lambda> x. x > (0 :: nat)) [Suc 0]" by simp
lemma "successive (\<lambda> x. x > (0 :: nat)) [Suc 0, 0, Suc 0]" by simp
lemma "\<not> successive (\<lambda> x. x > (0 :: nat)) [Suc 0, 0, Suc 0, Suc 0]" by simp
lemma "\<not> successive (\<lambda> x. x > (0 :: nat)) [Suc 0, 0, 0, Suc 0, Suc 0]" by simp
lemma "successive (\<lambda> x. x > (0 :: nat)) [Suc 0, 0, Suc 0, 0, Suc 0]" by simp
lemma "\<not> successive (\<lambda> x. x > (0 :: nat)) [Suc 0, Suc 0, 0, Suc 0]" by simp
lemma "successive (\<lambda> x. x > (0 :: nat)) [0, 0, Suc 0, 0]" by simp

lemma successive_step: "successive P (x # xs) \<Longrightarrow> \<not> P x \<Longrightarrow> successive P xs"
  apply (cases xs)
   apply simp
  apply (rename_tac y ys)
  apply (case_tac ys)
   apply auto
done

lemma successive_step_2: "successive P (x # y # xs) \<Longrightarrow> \<not> P y \<Longrightarrow> successive P xs"
  apply (cases xs)
   apply simp
  apply (rename_tac z zs)
  apply (case_tac zs)
   apply auto
done

lemma successive_stepI:
  "successive P xs \<Longrightarrow> \<not> P x \<Longrightarrow> successive P (x # xs)"
by (cases xs) auto

theorem list_two_induct[case_names Nil Single Cons]:
  fixes P :: "'a list \<Rightarrow> bool"
    and list :: "'a list"
  assumes Nil: "P []"
  assumes Single: "\<And> x. P [x]"
    and Cons: "\<And>x1 x2 xs. P xs \<Longrightarrow> P (x2 # xs) \<Longrightarrow> P (x1 # x2 # xs)"
  shows "P xs"
using assms
 apply (induction "length xs" arbitrary: xs rule: less_induct)
 apply (rename_tac xs)
 apply (case_tac xs)
  apply simp
 apply (rename_tac ys)
 apply (case_tac ys)
  apply simp
 apply (rename_tac zs)
 apply (case_tac zs)
by auto

lemma successive_end_1:
  "successive P xs \<Longrightarrow> \<not> P x \<Longrightarrow> successive P (xs @ [x])"
by (induction _ xs rule: list_two_induct) auto

lemma successive_ends_1:
  "successive P xs \<Longrightarrow> \<not> P x \<Longrightarrow> successive P ys \<Longrightarrow> successive P (xs @ x # ys)"
by (induction _ xs rule: list_two_induct) (fastforce intro: successive_stepI)+

lemma successive_ends_1':
  "successive P xs \<Longrightarrow> \<not> P x \<Longrightarrow> P y \<Longrightarrow> \<not> P z \<Longrightarrow> successive P ys \<Longrightarrow> successive P (xs @ x # y # z # ys)"
by (induction _ xs rule: list_two_induct) (fastforce intro: successive_stepI)+

lemma successive_end_2:
  "successive P xs \<Longrightarrow> \<not> P x \<Longrightarrow> successive P (xs @ [x,y])"
by (induction _ xs rule: list_two_induct) auto

lemma successive_end_2':
  "successive P (xs @ [x]) \<Longrightarrow> \<not> P x \<Longrightarrow> successive P (xs @ [x,y])"
by (induction _ xs rule: list_two_induct) auto

lemma successive_step_rev:
  "successive P (xs @ [x]) \<Longrightarrow> \<not> P x \<Longrightarrow> successive P xs"
by (induction _ xs rule: list_two_induct) auto

lemma successive_glue:
  "successive P (zs @ [z]) \<Longrightarrow> successive P (x # xs) \<Longrightarrow> \<not> P z \<or> \<not> P x \<Longrightarrow> successive P (zs @ [z] @ x # xs)"
proof goal_cases
  case A: 1
  show ?thesis
  proof (cases "P x")
    case False
    with A(1,2) successive_ends_1 successive_step show ?thesis by fastforce
  next
    case True
    with A(1,3) successive_step_rev have "\<not> P z" "successive P zs" by fastforce+
    with A(2) successive_ends_1 show ?thesis by fastforce
  qed
qed

lemma successive_glue':
  "successive P (zs @ [y]) \<and> \<not> P z \<or> successive P zs \<and> \<not> P y
  \<Longrightarrow> successive P (x # xs) \<and> \<not> P w \<or> successive P xs \<and> \<not> P x
  \<Longrightarrow> \<not> P z \<or> \<not> P w \<Longrightarrow> successive P (zs @ y # z # w # x # xs)"
by (metis append_Cons append_Nil successive.simps(3) successive_ends_1 successive_glue successive_stepI)

lemma successive_dest_head:
  "xs = w # x # ys \<Longrightarrow> successive P xs \<Longrightarrow> successive P (x # xs) \<and> \<not> P w \<or> successive P xs \<and> \<not> P x"
by auto

lemma successive_dest_tail:
  "xs = zs @ [y,z] \<Longrightarrow> successive P xs \<Longrightarrow> successive P (zs @ [y]) \<and> \<not> P z \<or> successive P zs \<and> \<not> P y"
 apply (induction _ xs arbitrary: zs rule: list_two_induct)
   apply simp+
 apply (rename_tac zs)
 apply (case_tac zs)
  apply simp
 apply (rename_tac ws)
 apply (case_tac ws)
  apply force+
done

lemma successive_split:
  "xs = ys @ zs \<Longrightarrow> successive P xs \<Longrightarrow> successive P ys \<and> successive P zs"
 apply (induction _ xs arbitrary: ys rule: list_two_induct)
   apply simp
  apply (rename_tac ys, case_tac ys)
   apply simp
  apply simp
 apply (rename_tac ys, case_tac ys)
  apply simp
 apply (rename_tac list, case_tac list)
  apply (auto intro: successive_stepI)
done

lemma successive_decomp:
  "xs = x # ys @ zs @ [z] \<Longrightarrow> successive P xs \<Longrightarrow> \<not> P x \<or> \<not> P z \<Longrightarrow> successive P (zs @ [z] @ (x # ys))"
by (metis Cons_eq_appendI successive_glue successive_split)

lemma successive_predecessor:
  assumes "(a, b) \<in> set (arcs i j xs)" "a \<noteq> i" "successive P (arcs i j xs)" "P (a,b)" "xs \<noteq> []"
 shows "\<exists> c. (xs = [a] \<and> c = i \<or> (\<exists> ys. xs = a # b # ys \<and> c = i) \<or> (\<exists> ys. xs = ys @ [c,a] \<and> b = j)
       \<or> (\<exists> ys zs. xs = ys @ c # a # b # zs)) \<and> \<not> P (c,a)"
proof -
  from arcs_predecessor''[OF assms(1,2)] obtain c where c:
    "xs = [a] \<or> (\<exists>ys. xs = a # b # ys) \<or> (\<exists>ys. xs = ys @ [c, a] \<and> b = j)
    \<or> (\<exists>ys zs. xs = ys @ c # a # b # zs)"
  by auto
  then show ?thesis
  proof (safe, goal_cases)
    case 1
    with assms have "arcs i j xs = [(i, a), (a, j)]" by auto
    with assms have "\<not> P (i, a)" by auto
    with 1 show ?case by simp
  next
    case 2
    with assms have "\<not> P (i, a)" by fastforce
    with 2 show ?case by auto
  next
    case 3
    with assms have "\<not> P (c, a)" using arcs_decomp successive_dest_tail by fastforce
    with 3 show ?case by auto
  next
    case 4
    with assms(3,4) have "\<not> P (c, a)" using arcs_decomp successive_split by fastforce
    with 4 show ?case by auto
  qed
qed

lemmas add_mono_right = add_mono[OF order_refl]
lemmas add_mono_left  = add_mono[OF _ order_refl]

subsubsection \<open>Obtaining successive and distinct paths\<close>

lemma canonical_successive:
  fixes A B
  defines "M \<equiv> \<lambda> i j. min (A i j) (B i j)"
  assumes "canonical A n"
  assumes "set xs \<subseteq> {0..n}"
  assumes "i \<le> n" "j \<le> n"
  shows "\<exists> ys. len M i j ys \<le> len M i j xs \<and> set ys \<subseteq> {0..n}
               \<and> successive (\<lambda> (a, b). M a b = A a b) (arcs i j ys)"
using assms
proof (induction xs arbitrary: i rule: list_two_induct)
  case Nil show ?case by fastforce
next
  case 2: (Single x i)
  show ?case
  proof (cases "M i x = A i x \<and> M x j = A x j")
    case False
    then have "successive (\<lambda>(a, b). M a b = A a b) (arcs i j [x])" by auto
    with 2 show ?thesis by blast
  next
    case True
    with 2 have "M i j \<le> M i x + M x j" unfolding min_def by fastforce
    with 2(3-) show ?thesis apply simp apply (rule exI[where x = "[]"]) by auto
  qed
next
  case 3: (Cons x y xs i)
  show ?case
  proof (cases "M i y \<le> M i x + M x y", goal_cases)
    case 1
    from 3 obtain ys where
      "len M i j ys \<le> len M i j (y # xs) \<and> set ys \<subseteq> {0..n}
       \<and> successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j ys)"
    by fastforce
    moreover from 1 have "len M i j (y # xs) \<le> len M i j (x # y # xs)"
    using add_mono by (auto simp: add.assoc[symmetric])
    ultimately show ?case by force
  next
    case False
    { assume "M i x = A i x" "M x y = A x y"
      with 3(3-) have "A i y \<le> M i x + M x y" by auto
      then have "M i y \<le> M i x + M x y" unfolding M_def min_def by auto
    } note * = this
    with False have "M i x \<noteq> A i x \<or> M x y \<noteq> A x y" by auto
    then show ?thesis
    proof (standard, goal_cases)
      case 1
      from 3 obtain ys where ys:
        "len M x j ys \<le> len M x j (y # xs)" "set ys \<subseteq> {0..n}"
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs x j ys)"
      by force+
      from 1 successive_stepI[OF ys(3), of "(i, x)"] have
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j (x # ys))"
      by auto
      moreover have "len M i j (x # ys) \<le> len M i j (x # y # xs)" using add_mono_right[OF ys(1)]
      by auto
      ultimately show ?case using 3(5) ys(2) by fastforce
    next
      case 2
      from 3 obtain ys where ys:
        "len M y j ys \<le> len M y j xs" "set ys \<subseteq> {0..n}"
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs y j ys)"
      by force+
      from this(3) 2 have
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j (x # y # ys))"
      by simp
      moreover from add_mono_right[OF ys(1)] have
        "len M i j (x # y # ys) \<le> len M i j (x # y # xs)"
      by (auto simp: add.assoc[symmetric])
      ultimately show ?thesis using ys(2) 3(5) by fastforce
    qed
  qed
qed

lemma canonical_successive_distinct:
  fixes A B
  defines "M \<equiv> \<lambda> i j. min (A i j) (B i j)"
  assumes "canonical A n"
  assumes "set xs \<subseteq> {0..n}"
  assumes "i \<le> n" "j \<le> n"
  assumes "distinct xs" "i \<notin> set xs" "j \<notin> set xs"
  shows "\<exists> ys. len M i j ys \<le> len M i j xs \<and> set ys \<subseteq> set xs
               \<and> successive (\<lambda> (a, b). M a b = A a b) (arcs i j ys)
               \<and> distinct ys \<and> i \<notin> set ys \<and> j \<notin> set ys"
using assms
proof (induction xs arbitrary: i rule: list_two_induct)
  case Nil show ?case by fastforce
next
  case 2: (Single x i)
  show ?case
  proof (cases "M i x = A i x \<and> M x j = A x j")
    case False
    then have "successive (\<lambda>(a, b). M a b = A a b) (arcs i j [x])" by auto
    with 2 show ?thesis by blast
  next
    case True
    with 2 have "M i j \<le> M i x + M x j" unfolding min_def by fastforce
    with 2(3-) show ?thesis apply simp apply (rule exI[where x = "[]"]) by auto
  qed
next
  case 3: (Cons x y xs i)
  show ?case
  proof (cases "M i y \<le> M i x + M x y")
    case 1: True
    from 3(2)[OF 3(3,4)] 3(5-10) obtain ys where ys:
      "len M i j ys \<le> len M i j (y # xs)" "set ys \<subseteq> set (x # y # xs)"
       "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j ys)"
       "distinct ys \<and> i \<notin> set ys \<and> j \<notin> set ys"
    by fastforce
    moreover from 1 have "len M i j (y # xs) \<le> len M i j (x # y # xs)"
    using add_mono by (auto simp: add.assoc[symmetric])
    ultimately have "len M i j ys \<le> len M i j (x # y # xs)" by auto
    then show ?thesis using ys(2-) by blast
  next
    case False
    { assume "M i x = A i x" "M x y = A x y"
      with 3(3-) have "A i y \<le> M i x + M x y" by auto
      then have "M i y \<le> M i x + M x y" unfolding M_def min_def by auto
    } note * = this
    with False have "M i x \<noteq> A i x \<or> M x y \<noteq> A x y" by auto
    then show ?thesis
    proof (standard, goal_cases)
      case 1
      from 3(2)[OF 3(3,4)] 3(5-10) obtain ys where ys:
        "len M x j ys \<le> len M x j (y # xs)" "set ys \<subseteq> set (y # xs)"
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs x j ys)"
        "distinct ys" "i \<notin> set ys" "x \<notin> set ys" "j \<notin> set ys"
      by fastforce
      from 1 successive_stepI[OF ys(3), of "(i, x)"] have
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j (x # ys))"
      by auto
      moreover have "len M i j (x # ys) \<le> len M i j (x # y # xs)" using add_mono_right[OF ys(1)]
      by auto
      moreover have "distinct (x # ys)" "i \<notin> set (x # ys)" "j \<notin> set (x # ys)" using ys(4-) 3(8-)
      by auto
      moreover from ys(2) have "set (x # ys) \<subseteq> set (x # y # xs)" by auto
      ultimately show ?case by fastforce
    next
      case 2
      from 3(1)[OF 3(3,4)] 3(5-) obtain ys where ys:
        "len M y j ys \<le> len M y j xs" "set ys \<subseteq> set xs"
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs y j ys)"
        "distinct ys" "j \<notin> set ys" "y \<notin> set ys" "i \<notin> set ys" "x \<notin> set ys"
      by fastforce
      from this(3) 2 have
        "successive (\<lambda>a. case a of (a, b) \<Rightarrow> M a b = A a b) (arcs i j (x # y # ys))"
      by simp
      moreover from add_mono_right[OF ys(1)] have
        "len M i j (x # y # ys) \<le> len M i j (x # y # xs)"
      by (auto simp: add.assoc[symmetric])
      moreover have "distinct (x # y # ys)" "i \<notin> set (x # y # ys)" "j \<notin> set (x # y # ys)"
      using ys(4-) 3(8-) by auto
      ultimately show ?thesis using ys(2) by fastforce
    qed
  qed
qed

lemma successive_snd_last: "successive P (xs @ [x, y]) \<Longrightarrow> P y \<Longrightarrow> \<not> P x"
by (induction _ xs rule: list_two_induct) auto

lemma canonical_shorten_rotate_neg_cycle:
  fixes A B
  defines "M \<equiv> \<lambda> i j. min (A i j) (B i j)"
  assumes "canonical A n"
  assumes "set xs \<subseteq> {0..n}"
  assumes "i \<le> n"
  assumes "len M i i xs < 0"
  shows "\<exists> j ys. len M j j ys < 0 \<and> set (j # ys) \<subseteq> set (i # xs)
               \<and> successive (\<lambda> (a, b). M a b = A a b) (arcs j j ys)
               \<and> distinct ys \<and> j \<notin> set ys \<and>
               (ys \<noteq> [] \<longrightarrow> M j (hd ys) \<noteq> A j (hd ys) \<or> M (last ys) j \<noteq> A (last ys) j)"
using assms
proof -
  note A = assms
  from negative_len_shortest[OF _ A(5)] obtain j ys where ys:
    "distinct (j # ys)" "len M j j ys < 0" "j \<in> set (i # xs)" "set ys \<subseteq> set xs"
  by blast
  from this(1,3) canonical_successive_distinct[OF A(2) subset_trans[OF this(4) A(3)], of j j B] A(3,4)
  obtain zs where zs:
    "len M j j zs \<le> len M j j ys"
    "set zs \<subseteq> set ys" "successive (\<lambda>(a, b). M a b = A a b) (arcs j j zs)"
    "distinct zs" "j \<notin> set zs"
  by (force simp: M_def)
  show ?thesis
  proof (cases "zs = []")
    assume "zs \<noteq> []"
    then obtain w ws where ws: "zs = w # ws" by (cases zs) auto
    show ?thesis
    proof (cases "ws = []")
      case False
      then obtain u us where us: "ws = us @ [u]" by (induction ws) auto
      show ?thesis
      proof (cases "M j w = A j w \<and> M u j = A u j")
        case True
        have "u \<le> n" "j \<le> n" "w \<le> n" using us ws zs(2) ys(3,4) A(3,4) by auto
        with A(2) True have "M u w \<le> M u j + M j w" unfolding M_def min_def by fastforce
        then have
          "len M u u (w # us) \<le> len M j j zs"
        using ws us by (simp add: len_comp comm) (auto intro: add_mono simp: add.assoc[symmetric])
        moreover have "set (u # w # us) \<subseteq> set (i # xs)" using ws us zs(2) ys(3,4) by auto
        moreover have "distinct (w # us)" "u \<notin> set (w # us)" using ws us zs(4) by auto
        moreover have "successive (\<lambda>(a, b). M a b = A a b) (arcs u u (w # us))"
        proof (cases us)
          case Nil
          with zs(3) ws us True show ?thesis by auto
        next
          case (Cons v vs)
          with zs(3) ws us True have "M w v \<noteq> A w v" by auto
          with ws us Cons zs(3) True arcs_decomp_tail successive_split show ?thesis by (simp, blast)
        qed
        moreover have "M (last (w # us)) u \<noteq> A (last (w # us)) u"
        proof (cases "us = []")
          case T: True
          with zs(3) ws us True show ?thesis by auto
        next
          case False
          then obtain v vs where vs: "us = vs @ [v]" by (induction us) auto
          with ws us have "arcs j j zs = arcs j v (w # vs) @ [(v, u), (u,j)]" by (simp add: arcs_decomp)
          with zs(3) True have "M v u \<noteq> A v u"
          using successive_snd_last[of "\<lambda>(a, b). M a b = A a b" "arcs j v (w # vs)"] by auto
          with vs show ?thesis by simp
        qed
        ultimately show ?thesis using zs(1) ys(2)
        by (intro exI[where x = u], intro exI[where x = "w # us"]) fastforce
      next
        case False
        with zs ws us ys show ?thesis by (intro exI[where x = j], intro exI[where x = "zs"]) auto
      qed
    next
      case True
      with True ws zs ys show ?thesis by (intro exI[where x = j], intro exI[where x = "zs"]) fastforce
    qed
  next
    case True
    with ys zs show ?thesis by (intro exI[where x = j], intro exI[where x = "zs"]) fastforce
  qed
qed

(* Generated by sledgehammer/z3 *)
lemma successive_arcs_extend_last:
  "successive P (arcs i j xs) \<Longrightarrow> \<not> P (i, hd xs) \<or> \<not> P (last xs, j) \<Longrightarrow> xs \<noteq> []
  \<Longrightarrow> successive P (arcs i j xs @ [(i, hd xs)])"
proof -
  assume a1: "\<not> P (i, hd xs) \<or> \<not> P (last xs, j)"
  assume a2: "successive P (arcs i j xs)"
  assume a3: "xs \<noteq> []"
  then have f4: "\<not> P (last xs, j) \<longrightarrow> successive P (arcs i (last xs) (butlast xs))"
    using a2 by (metis (no_types) append_butlast_last_id arcs_decomp_tail successive_step_rev)
  have f5: "arcs i j xs = arcs i (last xs) (butlast xs) @ [(last xs, j)]"
    using a3 by (metis (no_types) append_butlast_last_id arcs_decomp_tail)
  have "([] @ arcs i j xs @ [(i, hd xs)]) @ [(i, hd xs)] = arcs i j xs @ [(i, hd xs), (i, hd xs)]"
    by simp
  then have "P (last xs, j) \<longrightarrow> successive P (arcs i j xs @ [(i, hd xs)])"
    using a2 a1 by (metis (no_types) self_append_conv2 successive_end_2 successive_step_rev)
  then show ?thesis
    using f5 f4 successive_end_2 by fastforce
qed

lemma cycle_rotate_arcs:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "length xs > 1" "(i, j) \<in> arcs' xs"
  shows "\<exists> ys zs. set (arcs a a xs) = set (arcs i i (j # ys @ a # zs)) \<and> xs = zs @ i # j # ys" using assms
proof -
  assume A: "length xs > 1" "(i, j) \<in> arcs' xs"
  from arcs'_decomp[OF this] obtain ys zs where xs: "xs = zs @ i # j # ys" by blast
  with arcs_decomp[OF this, of a a] arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i]
  show ?thesis by force
qed

lemma cycle_rotate_len_arcs_successive:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "length xs > 1" "(i, j) \<in> arcs' xs" "successive P (arcs a a xs)" "\<not> P (a, hd xs) \<or> \<not> P (last xs, a)"
  shows "\<exists> ys zs. len M a a xs = len M i i (j # ys @ a # zs)
                \<and> set (arcs a a xs) = set (arcs i i (j # ys @ a # zs)) \<and> xs = zs @ i # j # ys
                \<and> successive P (arcs i i (j # ys @ a # zs))"
using assms
proof -
  note A = assms
  from arcs'_decomp[OF A(1,2)] obtain ys zs where xs: "xs = zs @ i # j # ys" by blast
  note arcs1 = arcs_decomp[OF xs, of a a]
  note arcs2 = arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i]
  have *:"successive P (arcs i i (j # ys @ a # zs))"
  proof (cases "ys = []")
    case True
    show ?thesis
    proof (cases zs)
      case Nil
      with A(3,4) xs True show ?thesis by auto
    next
      case (Cons z zs')
      with True arcs2 A(3,4) xs show ?thesis apply simp
      by (metis arcs.simps(1,2) arcs1 successive.simps(3) successive_split successive_step)
    qed
  next
    case False
    then obtain y ys' where ys: "ys = ys' @ [y]" by (metis append_butlast_last_id)
    show ?thesis
    proof (cases zs)
      case Nil
      with A(3,4) xs ys have
        "\<not> P (a, i) \<or> \<not> P (y, a)" "successive P (arcs a a (i # j # ys' @ [y]))"
      by simp+
      from successive_decomp[OF _ this(2,1)] show ?thesis using ys Nil arcs_decomp by fastforce
    next
      case (Cons z zs')
      with A(3,4) xs ys have
        "\<not> P (a, z) \<or> \<not> P (y, a)" "successive P (arcs a a (z # zs' @ i # j # ys' @ [y]))"
      by simp+
      from successive_decomp[OF _ this(2,1)] show ?thesis using ys Cons arcs_decomp by fastforce
    qed
  qed
  from len_decomp[OF xs, of M a a] have "len M a a xs = len M a i zs + len M i a (j # ys)" .
  also have "\<dots> = len M i a (j # ys) + len M a i zs" by (simp add: comm)
  also from len_comp[of M i i "j # ys" a zs] have "\<dots> = len M i i (j # ys @ a # zs)" by auto
  finally show ?thesis
  using * xs arcs_decomp[OF xs, of a a] arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i] by force
qed

lemma successive_successors:
  "xs = ys @ a # b # c # zs \<Longrightarrow> successive P (arcs i j xs) \<Longrightarrow> \<not> P (a,b) \<or> \<not> P (b, c)"
 apply (induction _ xs arbitrary: i ys rule: list_two_induct)
   apply fastforce
  apply fastforce
 apply (rename_tac ys, case_tac ys)
  apply fastforce
 apply (rename_tac list, case_tac list)
  apply fastforce+
done

lemma successive_successors':
  "xs = ys @ a # b # zs \<Longrightarrow> successive P xs \<Longrightarrow> \<not> P a \<or> \<not> P b"
using successive_split by fastforce

lemma cycle_rotate_len_arcs_successive':
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "length xs > 1" "(i, j) \<in> arcs' xs" "successive P (arcs a a xs)"
          "\<not> P (a, hd xs) \<or> \<not> P (last xs, a)"
  shows "\<exists> ys zs. len M a a xs = len M i i (j # ys @ a # zs)
                \<and> set (arcs a a xs) = set (arcs i i (j # ys @ a # zs)) \<and> xs = zs @ i # j # ys
                \<and> successive P (arcs i i (j # ys @ a # zs) @ [(i,j)])"
using assms
proof -
  note A = assms
  from arcs'_decomp[OF A(1,2)] obtain ys zs where xs: "xs = zs @ i # j # ys" by blast
  note arcs1 = arcs_decomp[OF xs, of a a]
  note arcs2 = arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i]
  have *:"successive P (arcs i i (j # ys @ a # zs) @ [(i,j)])"
  proof (cases "ys = []")
    case True
    show ?thesis
    proof (cases zs)
      case Nil
      with A(3,4) xs True show ?thesis by auto
    next
      case (Cons z zs')
      with True arcs2 A(3,4) xs show ?thesis
       apply simp
       apply (cases "P (a, z)")
        apply (simp add: arcs_decomp)
        apply (simp only: append_Cons[symmetric])
        using successive_split[of "((a, z) # arcs z i zs') @ [(i, j), (j, a)]" _ "[(j, a)]" P]
        apply auto[]
       subgoal (* Generated by sledgehammer *)
       proof simp
         assume a1: "successive P ((a, z) # arcs z a (zs' @ [i, j]))"
         assume a2: "\<not> P (a, z)"
         assume a3: "zs = z # zs'"
         assume a4: "ys = []"
         assume a5: "xs = z # zs' @ [i, j]"
         have f6: "\<forall>p pa ps. \<not> successive p ((pa::nat \<times> nat) # ps) \<or> p pa \<or> successive p ps"
           by (meson successive_step)
         have "(a, z) # arcs z i zs' @ (i, j) # arcs j a [] = arcs a a xs"
           using a4 a3 by (simp add: arcs1)
         then have "arcs z a (zs' @ [i, j]) = arcs z i zs' @ [(i, j), (j, a)]"
           using a5 by simp
         then show
           "\<not> P (j, a) \<and> successive P ((a, z) # arcs z i zs' @ [(i, j)])
          \<or> \<not> P (i, j) \<and> (successive P (arcs z i zs' @ [(i, j)])
          \<or> \<not> P (j, a) \<and> successive P ((a, z) # arcs z i zs' @ [(i, j)]))"
         using f6 a2 a1
         by (metis successive.simps(1) successive_dest_tail successive_ends_1 successive_stepI)
       qed
      done
    qed
  next
    case False
    then obtain y ys' where ys: "ys = ys' @ [y]" by (metis append_butlast_last_id)
    show ?thesis
    proof (cases zs)
      case Nil
      with A(3,4) xs ys have *:
        "\<not> P (a, i) \<or> \<not> P (y, a)" "successive P (arcs a a (i # j # ys' @ [y]))"
      by simp+
      from successive_decomp[OF _ this(2,1)] ys Nil arcs_decomp have
        "successive P (arcs i i (j # ys @ a # zs))"
      by fastforce
      moreover from * have "\<not> P (a, i) \<or> \<not> P (i, j)" by auto
      ultimately show ?thesis
      by (metis append_Cons last_snoc list.distinct(1) list.sel(1) Nil successive_arcs_extend_last)
    next
      case (Cons z zs')
      with A(3,4) xs ys have *:
        "\<not> P (a, z) \<or> \<not> P (y, a)" "successive P (arcs a a (z # zs' @ i # j # ys' @ [y]))"
      by simp+
      from successive_decomp[OF _ this(2,1)] ys Cons arcs_decomp have **:
        "successive P (arcs i i (j # ys @ a # zs))"
      by fastforce
      from Cons have "zs \<noteq> []" by auto
      then obtain w ws where ws: "zs = ws @ [w]" by (induction zs) auto
      with A(3,4) xs ys have *:
        "successive P (arcs a a (ws @ [w] @ i # j # ys' @ [y]))"
      by simp
      moreover from successive_successors[OF _ this] have "\<not> P (w, i) \<or> \<not> P (i, j)" by auto
      ultimately show ?thesis
      by (metis ** append_is_Nil_conv last.simps last_append list.distinct(2) list.sel(1)
                successive_arcs_extend_last ws)
    qed
  qed
  from len_decomp[OF xs, of M a a] have "len M a a xs = len M a i zs + len M i a (j # ys)" .
  also have "\<dots> = len M i a (j # ys) + len M a i zs" by (simp add: comm)
  also from len_comp[of M i i "j # ys" a zs] have "\<dots> = len M i i (j # ys @ a # zs)" by auto
  finally show ?thesis
  using * xs arcs_decomp[OF xs, of a a] arcs_decomp[of "j # ys @ a # zs" "j # ys" a zs i i] by force
qed

lemma cycle_rotate_3:
  fixes M :: "('a :: linordered_ab_monoid_add) mat"
  assumes "xs \<noteq> []" "(i, j) \<in> set (arcs a a xs)" "successive P (arcs a a xs)" "\<not> P (a, hd xs) \<or> \<not> P (last xs, a)"
  shows "\<exists> ys. len M a a xs = len M i i (j # ys) \<and> set (i # j # ys) = set (a # xs) \<and> 1 + length ys = length xs
             \<and> set (arcs a a xs) = set (arcs i i (j # ys))
             \<and> successive P (arcs i i (j # ys))"
proof -
  note A = assms
  { fix ys assume A:"a = i" "xs = j # ys"
    with assms(3) have ?thesis by auto
  } note * = this
  have **: ?thesis if A: "a = j" "xs = ys @ [i]" for ys using A
  proof (safe, goal_cases)
    case 1
    have "len M j j (ys @ [i]) = M i j + len M j i ys"
    using len_decomp[of "ys @ [i]" ys i "[]" M j j] by (auto simp: comm)
    moreover have "arcs j j (ys @ [i]) = arcs j i ys @ [(i, j)]" using arcs_decomp_tail by auto
    moreover with assms(3,4) A have "successive P ((i,j) # arcs j i ys)"
     apply simp
     apply (case_tac ys)
      apply simp
     apply simp
    by (metis arcs.simps(2) calculation(2) 1(1) successive_split successive_step)
    ultimately show ?case by auto
  qed
  { assume "length xs = 1"
    then obtain b where xs: "xs = [b]" by (metis One_nat_def length_0_conv length_Suc_conv)
    with A(2) have "a = i \<and> b = j \<or> a = j \<and> b = i" by auto
    then have ?thesis using * ** xs by auto
  } note *** = this
  show ?thesis
  proof (cases "length xs = 0")
    case True with A show ?thesis by auto
  next
    case False
    thus ?thesis
    proof (cases "length xs = 1", goal_cases)
      case True with *** show ?thesis by auto
    next
      case 2
      hence "length xs > 1" by linarith
      then obtain b c ys where ys:"xs = b # ys @ [c]"
      by (metis One_nat_def assms(1) 2(2) length_0_conv length_Cons list.exhaust rev_exhaust)
      thus ?thesis
      proof (cases "(i,j) = (a,b)")
        case True
        with ys * show ?thesis by blast
      next
        case False
        then show ?thesis
        proof (cases "(i,j) = (c,a)", goal_cases)
          case True
          with ys ** show ?thesis by force
        next
          case 2
          with A(2) ys have "(i, j) \<in> arcs' xs"
          using cycle_rotate_2_aux by (auto simp add: arcs'_def) (* slow *)
          from cycle_rotate_len_arcs_successive[OF \<open>length xs > 1\<close> this A(3,4), of M] show ?thesis
          by auto
        qed
      qed
    qed
  qed
qed

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_14
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun x :: "bool => bool => bool" where
"x True z = z"
| "x False z = False"

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

fun insert :: "Nat => Nat list => Nat list" where
"insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if t2 y z2 then cons2 y (cons2 z2 xs) else cons2 z2 (insert y xs))"

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

fun sorted :: "Nat list => bool" where
"sorted (nil2) = True"
| "sorted (cons2 z (nil2)) = True"
| "sorted (cons2 z (cons2 y2 xs)) =
     x (t2 z y2) (sorted (cons2 y2 xs))"

theorem property0 :
  "sorted (isort y)"
  oops

end


theory hw1
imports Main
begin

datatype \<Phi> = P int | Neg \<Phi> | Or \<Phi> \<Phi> (* using `int` for variable names *)
type_synonym \<Sigma> = "int \<Rightarrow> bool"
type_synonym \<Gamma> = "\<Phi> list"
type_synonym \<Delta> = "\<Phi> list"

fun interp :: "\<Sigma> \<Rightarrow> \<Phi> \<Rightarrow> bool" (infix "\<Turnstile>" 40) where
  "(op \<Turnstile>) \<sigma> (P n) = \<sigma> n"
| "(op \<Turnstile>) \<sigma> (Neg \<phi>) = (\<not> \<sigma> \<Turnstile> \<phi>)"
| "(op \<Turnstile>) \<sigma> (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = (\<sigma> \<Turnstile> \<phi>\<^sub>1 \<or> \<sigma> \<Turnstile> \<phi>\<^sub>2)"

abbreviation "And \<phi>\<^sub>1 \<phi>\<^sub>2 \<equiv> Neg (Or (Neg \<phi>\<^sub>1) (Neg \<phi>\<^sub>2))"
abbreviation "Imp \<phi>\<^sub>1 \<phi>\<^sub>2 \<equiv> Or (Neg \<phi>\<^sub>1) \<phi>\<^sub>2"
abbreviation "tt \<equiv> Or (P 0) (Neg (P 0))"
abbreviation "ff \<equiv> And (P 0) (Neg (P 0))"

fun BAnd :: "\<Phi> list \<Rightarrow> \<Phi>" where
  "BAnd [] = tt"
| "BAnd (\<phi> # \<phi>s) = And \<phi> (BAnd \<phi>s)"

fun BOr :: "\<Phi> list \<Rightarrow> \<Phi>" where
  "BOr [] = ff"
| "BOr (\<phi> # \<phi>s) = Or \<phi> (BOr \<phi>s)"

inductive proves :: "\<Gamma> \<Rightarrow> \<Delta> \<Rightarrow> bool" (infix "\<turnstile>" 40) where
  I    : "[\<phi>] \<turnstile> [\<phi>]"
(* | Cut  : "\<lbrakk>\<Gamma>\<^sub>1 \<turnstile> \<phi> # \<Delta>\<^sub>1; \<phi> # \<Gamma>\<^sub>2 \<turnstile> \<Delta>\<^sub>2\<rbrakk>
          \<Longrightarrow> \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> \<Delta>\<^sub>1 @ \<Delta>\<^sub>2" *)
| orL  : "\<lbrakk>\<phi>\<^sub>1 # \<Gamma>\<^sub>1 \<turnstile> \<Delta>\<^sub>1; \<phi>\<^sub>2 # \<Gamma>\<^sub>2 \<turnstile> \<Delta>\<^sub>2\<rbrakk>
          \<Longrightarrow> Or \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> \<Delta>\<^sub>1 @ \<Delta>\<^sub>2"
| orR1 : "\<Gamma> \<turnstile> (\<phi>\<^sub>1 # \<Delta>) \<Longrightarrow> \<Gamma> \<turnstile> Or \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Delta>"
| orR2 : "\<Gamma> \<turnstile> (\<phi>\<^sub>2 # \<Delta>) \<Longrightarrow> \<Gamma> \<turnstile> Or \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Delta>"
| notL : "\<Gamma> \<turnstile> (\<phi> # \<Delta>) \<Longrightarrow> Neg \<phi> # \<Gamma> \<turnstile> \<Delta>"
| notR : "\<phi> # \<Gamma> \<turnstile> \<Delta> \<Longrightarrow> \<Gamma> \<turnstile> Neg \<phi> # \<Delta>"
| WL   : "\<Gamma> \<turnstile> \<Delta> \<Longrightarrow> \<phi> # \<Gamma> \<turnstile> \<Delta>"
| WR   : "\<Gamma> \<turnstile> \<Delta> \<Longrightarrow> \<Gamma> \<turnstile> \<phi> # \<Delta>"
| CL   : "\<phi> # \<phi> # \<Gamma> \<turnstile> \<Delta> \<Longrightarrow> \<phi> # \<Gamma> \<turnstile> \<Delta>"
| CR   : "\<Gamma> \<turnstile> \<phi> # \<phi> # \<Delta> \<Longrightarrow> \<Gamma> \<turnstile> \<phi> # \<Delta>"
| PL   : "\<Gamma>\<^sub>1 @ [\<phi>\<^sub>1, \<phi>\<^sub>2] @ \<Gamma>\<^sub>2 \<turnstile> \<Delta> \<Longrightarrow> \<Gamma>\<^sub>1 @ [\<phi>\<^sub>2, \<phi>\<^sub>1] @ \<Gamma>\<^sub>2 \<turnstile> \<Delta>"
| PR   : "\<Gamma> \<turnstile> \<Delta>\<^sub>1 @ [\<phi>\<^sub>1, \<phi>\<^sub>2] @ \<Delta>\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile> \<Delta>\<^sub>1 @ [\<phi>\<^sub>2, \<phi>\<^sub>1] @ \<Delta>\<^sub>2"

theorem soundness: "\<Gamma> \<turnstile> \<Delta> \<Longrightarrow> \<sigma> \<Turnstile> Imp (BAnd \<Gamma>) (BOr \<Delta>)" sorry
theorem completeness: "\<sigma> \<Turnstile> Imp (BAnd \<Gamma>) (BOr \<Delta>) \<Longrightarrow> \<Gamma> \<turnstile> \<Delta>" sorry

(* Derived rules *)
lemma andL1: "\<phi>\<^sub>1 # \<Gamma> \<turnstile> \<Delta> \<Longrightarrow> And \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Gamma> \<turnstile> \<Delta>" by (auto simp: notL orR1 notR)
lemma andL2: "\<phi>\<^sub>2 # \<Gamma> \<turnstile> \<Delta> \<Longrightarrow> And \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Gamma> \<turnstile> \<Delta>" by (auto simp: notL orR2 notR)
lemma andR: "\<lbrakk>\<Gamma>\<^sub>1 \<turnstile> \<phi>\<^sub>1 # \<Delta>\<^sub>1; \<Gamma>\<^sub>2 \<turnstile> \<phi>\<^sub>2 # \<Delta>\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> And \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Delta>\<^sub>1 @ \<Delta>\<^sub>2"
by (auto simp: notR notL orL)
lemma impL: "\<lbrakk>\<Gamma>\<^sub>1 \<turnstile> \<phi>\<^sub>1 # \<Delta>\<^sub>1; \<phi>\<^sub>2 # \<Gamma>\<^sub>2 \<turnstile> \<Delta>\<^sub>2\<rbrakk> \<Longrightarrow> Imp \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> \<Delta>\<^sub>1 @ \<Delta>\<^sub>2" sorry
lemma impR: "\<phi>\<^sub>1 # \<Gamma> \<turnstile> \<phi>\<^sub>2 # \<Delta> \<Longrightarrow> \<Gamma> \<turnstile> Imp \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Delta>"
apply (rule CR) by (auto simp: orR1 notR orR2)

(** Q1 *)
inductive dual\<^sub>1 :: "(bool \<Rightarrow> bool) \<Rightarrow> (bool \<Rightarrow> bool) \<Rightarrow> bool" for R where
  du1: "R x = (\<not> (R' (\<not> x))) \<Longrightarrow> dual\<^sub>1 R R'"

inductive dual\<^sub>2 :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> (bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bool" for R where
  du2: "R x y = (\<not> (R' (\<not> x) (\<not> y))) \<Longrightarrow> dual\<^sub>2 R R'"

(* a *)
lemma "dual\<^sub>1 Not Not" by (auto simp add: du1)

(* b *)
fun q2b :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixr "\<triangleright>" 40) where
  "q2b False True = True"
| "q2b _ _ = False"

lemma "dual\<^sub>2 (op \<longrightarrow>) (op \<triangleright>)"
apply (rule du2)
by auto

(* TODO c *)

(** Q2 *)

abbreviation "valid \<phi> \<equiv> [] \<turnstile> [\<phi>]"

lemma a: "valid (Imp (And (P 0) (Neg (P 0))) (P 1))"
by (rule orR1, rule notR, rule notL, rule CR, rule orR2, rule notR, rule orR1, rule I)

lemma b: "valid (Imp (And (P 0) (Or (P 1) (P 2))) (Or (P 0) (P 2)))"
by (rule CR, rule orR1, rule notR, rule orR2, rule orR1, rule notL, rule orR1, rule notR, rule I)

(** Q3 *)

abbreviation "Eqv \<phi>\<^sub>1 \<phi>\<^sub>2 \<equiv> And (Imp \<phi>\<^sub>1 \<phi>\<^sub>2) (Imp \<phi>\<^sub>2 \<phi>\<^sub>1)"

lemma eqvR: "\<lbrakk>\<phi>\<^sub>1 # \<Gamma>\<^sub>1 \<turnstile> \<phi>\<^sub>2 # \<Delta>\<^sub>1; \<phi>\<^sub>2 # \<Gamma>\<^sub>2 \<turnstile> \<phi>\<^sub>1 # \<Delta>\<^sub>2\<rbrakk> \<Longrightarrow> \<Gamma>\<^sub>1 @ \<Gamma>\<^sub>2 \<turnstile> Eqv \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Delta>\<^sub>1 @ \<Delta>\<^sub>2"
apply (rule andR)
apply (rule CR, rule orR1, rule notR, rule orR2, simp)
apply (rule CR, rule orR1, rule notR, rule orR2, simp)
done

lemma eqvL1: "\<phi>\<^sub>1 # \<Gamma> \<turnstile> \<Delta> \<Longrightarrow> Eqv \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Gamma> \<turnstile> \<Delta>" sorry
lemma eqvL2: "\<phi>\<^sub>2 # \<Gamma> \<turnstile> \<Delta> \<Longrightarrow> Eqv \<phi>\<^sub>1 \<phi>\<^sub>2 # \<Gamma> \<turnstile> \<Delta>" sorry

end


header {* Examples of Forward Modal Semirings *}

theory FModal_Examples
  imports Domain_Semiring
begin

context fmodal_kleene_algebra
begin

section {* A Reachability Algorithm *}

text {* We first prove a refined reachability algorithm *}

lemma opti_iterate_var: "\<bar>x\<^sup>\<star>\<rangle>d(y) = \<bar>(a(y)\<cdot>x)\<^sup>\<star>\<rangle>d(y)"
proof -
  have "\<bar>x\<rangle>(\<bar>(a(y)\<cdot>x)\<^sup>\<star>\<rangle>d(y)) \<le> \<bar>(a(y)\<cdot>x)\<^sup>\<star>\<rangle>d(y)"
    by (smt fdia_split fdia_export_2 a_subid antidomain_semiring_domain_def fdiamond_def mult_isol mult_oner add_iso fdia_star_unfold_var_2)
  hence "\<bar>x\<^sup>\<star>\<rangle>d(y) \<le> \<bar>(a(y)\<cdot>x)\<^sup>\<star>\<rangle>d(y)"
    by (smt annil d2 domain_iso fdiamond_def min_zero mult_oner star_sim2 star_zero add_lub  fdia_star_induct fdia_simp_2)
  thus ?thesis
    by (smt a_zero annil dia_iso_var domain_very_strict kat_1_equiv_opp min_zero mult_oner star_iso eq_iff)
qed

lemma opti_iterate: "\<bar>x\<^sup>\<star>\<rangle>d(y) = d(y)+\<bar>(x\<cdot>a(y))\<^sup>\<star>\<rangle>(\<bar>x\<rangle>d(y))"
  by (smt opti_iterate_var a2_eq antidomain_semiring_domain_def fdia_star_unfold_var fdiamond_def opti_iterate_var  fdia_mult star_slide)

lemma opti_iterate_var_2: "\<bar>x\<^sup>\<star>\<rangle>d(y) = d(y)+\<bar>a(y)\<cdot>x\<rangle>(\<bar>x\<^sup>\<star>\<rangle>d(y))"
  by (smt a2_eq a_add a_export antidomain_semiring_domain_def d_7 fdia_star_unfold_var fdiamond_def mult_assoc)

section {* The Segerberg Formula *}

text {* We first define those states of $p$ for which all $x$ actions come from the outside. *}

definition Alpha :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("A")
  where "A x p = d(x\<cdot>p)\<cdot>a(p)"

lemma  A_dom: "A x p = d(A x p)"
  by (smt Alpha_def a_add a_closure antidomain_semiring_domain_def)

lemma A_fdia:  "A x p = (\<bar>x\<rangle>p)\<cdot>a(p)"
  by (smt Alpha_def fdiamond_def)

lemma A_fdia_var:  "A x p = (\<bar>x\<rangle>d(p))\<cdot>a(p)"
  by (smt A_fdia fdia_simp)

lemma a_A: "a(A x (a(p))) =  (\<bar>x]d(p))+a(p)"
  by (smt A_fdia add_comm' antidomain_semiring_domain_def fbox_add2 fbox_dom fbox_export_1 fbox_simp_2 fdia_fbox)

text {* We can now prove Segerberg's formula *}

lemma fsegerberg: "\<bar>x\<^sup>\<star>\<rangle>d(y) = d(y)+\<bar>x\<^sup>\<star>\<rangle>(A x y)"
proof -
  have  "\<bar>x\<^sup>\<star>\<rangle>d(y) \<le> d(y)+\<bar>x\<^sup>\<star>\<rangle>(A x y)"
    by (smt fdia_simp  fdia_add1 add_assoc  a_closure antidomain_semiring_domain_def d_6 dom_el_comm  fdia_simp_2  A_fdia_var  fdia_star_unfold_var A_dom a_export fdiamond_def  fdia_star_induct_eq d5 domain_invol)
  thus ?thesis
    by (smt A_fdia fdia_subdist_2 fdia_simp_2 a_closure add_iso add_comm fdia_star_unfoldr_var fdia_simp eq_iff)
qed

lemma fbox_segerberg: "\<bar>x\<^sup>\<star>]d(y) = d(y)\<cdot>\<bar>x\<^sup>\<star>]((\<bar>x]d(y))+a(y))"
(*
sledgehammer (fdia_simp fdia_simp_2 fbox_simp fbox_simp_2 a_closure a_5 dom_add_closed dom_mult_closed a_antitone a_de_morgan_var_1 a_de_morgan_var_2 a_de_morgan_var_3 a_de_morgan_var_4 fdia_fbox fbox_fdia a_one a_zero fbox_fdia_de_morgan_1 fdia_fbox_de_morgan_2  antidomain_semiring_domain_def a_A fsegerberg )
sledgehammer minimize [atp = remote_vampire] (a_A a_closure a_de_morgan_var_2 antidomain_semiring_domain_def fbox_simp fbox_simp_2 fdia_fbox fdia_simp fsegerberg)
*)
  by (smt a_A a_closure a_de_morgan_var_2 antidomain_semiring_domain_def fbox_simp_2 fdia_fbox fsegerberg)

(* lemma separability_extensionality: "(\<forall>p.\<bar>x\<rangle>p = \<bar>y\<rangle>p) \<longrightarrow> x = y"
nitpick -- nitpick found 3-element counterexample
*)

section {* Wellfoundedness and Loeb's Formula *}

text {* We now prove some facts about wellfoundedness *}

definition Omega :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("\<Omega>")
  where "\<Omega> x p = d(p)\<cdot>a(x\<cdot>p)"

text {* If $y$ is a set, then $\Omega(x,y)$ describes those elements
in $y$ from which no further $x$ transitions are possible
 *}

lemma omega_fdia: "\<Omega> x p = d(p)\<cdot>a(\<bar>x\<rangle>p)"
  by (smt Omega_def a_5 fdiamond_def)

lemma omega_le_1: "\<Omega> x p \<le> d(p)"
  by (smt Omega_def a_4 a_6 a_closure antidomain_semiring_domain_def d_a_galois1)

lemma omega_le_2: "\<Omega> x p \<le> a(\<bar>x\<rangle>p)"
  by (smt Omega_def a2_eq a_closure a_one a_zero annil antidomain_semiring_domain_def fbox_def fdia_fbox kat_1_equiv_opp min_zero mult_oner)

lemma omega_dom: "\<Omega> x p = d(\<Omega> x p)"
  by (smt Omega_def a_add a_de_morgan_var_3 antidomain_semiring_domain_def d5)

lemma omega_fbox: "\<Omega> x p = d(p)\<cdot>\<bar>x]a(p)"
  by (smt Omega_def a2_eq antidomain_semiring_domain_def fbox_def)

text {* The next lemma says that the states in $p$ that are non-final
are those from which there is an $x$-transition into $p$ *}

lemma a_omega: "a(\<Omega> x p) = a(p)+\<bar>x\<rangle>p"
  by (smt Omega_def a2_eq a_6 antidomain_semiring_domain_def fbox_def fdia_fbox)

lemma omega_fdia_3: "d(p)\<cdot>a(\<Omega> x p) = d(p)\<cdot>\<bar>x\<rangle>p"
  by (smt a_omega distl  a_comp_1 add_zerol')

text {* The next lemma says that if $p$ has n $x$-final states, then
$p$ is contained in the set of states from which there are
$x$-transitions into $p$. *}

lemma omega_zero_equiv_1:
  "(\<Omega> x p) = 0 \<longleftrightarrow> d(p) \<le> \<bar>x\<rangle>p"
  by (smt a_gla antidomain_semiring_domain_def fdia_simp_2 omega_fdia)

text {* Next we define a variant of L\"ob's formula *}

definition Loebian :: "'a \<Rightarrow> bool"
  where  "Loebian(x) = (\<forall>p.\<bar>x\<rangle>p \<le> \<bar>x\<rangle>(\<Omega> x p))"

definition PreLoebian :: "'a \<Rightarrow> bool"
  where  "PreLoebian(x) = (\<forall>p.(d(p) \<le> \<bar>x\<^sup>\<star>\<rangle>(\<Omega> x p)))"

text {* Next we define Noethericity *}

definition Noetherian :: "'a \<Rightarrow> bool"
  where  "Noetherian(x) = (\<forall>p.(\<Omega> x p) = 0 \<longrightarrow> d(p) = 0)"

lemma noetherian_alt:
  "Noetherian(x) \<longleftrightarrow> (\<forall>p.(d(p) \<le> \<bar>x\<rangle>p \<longrightarrow> d(p) = 0))"
  by (smt Noetherian_def a_gla antidomain_semiring_domain_def fdia_simp_2 omega_fdia)

text {* We now relate the three properties *}

lemma Noetherian_iff_PreLoebian: "Noetherian(x) = PreLoebian(x)"
proof
  assume hyp: "Noetherian(x)"
  have "\<forall>p.(d(p)\<cdot>a(\<bar>x\<^sup>\<star>\<rangle>(\<Omega> x p)) \<le> \<bar>x\<rangle>(d(p)\<cdot>a(\<bar>x\<^sup>\<star>\<rangle>(\<Omega> x p))))"
    by (smt omega_dom fdia_star_unfold_var_2 a_7 fdia_simp_2 omega_fdia_3 dom_subid mult_onel mult_isor dia_diff order_trans)
  with hyp show "PreLoebian(x)"
    by (smt noetherian_alt a_closure dom_mult_closed d_a_zero fdia_simp_2  PreLoebian_def)
next
  show "PreLoebian(x) ==> Noetherian(x)"
    by (smt Noetherian_def PreLoebian_def add_comm' add_zerol' fdia_zero leq_def)
qed

lemma Loebian_imp_Noetherian: "Loebian(x) \<Longrightarrow> Noetherian(x)"
  by (smt Loebian_def Noetherian_def Omega_def a_zero dom_weakly_local domain_very_strict fdemodalisation2 fdia_zero mult_onel mult_oner)

lemma d_transitive: "\<bar>x\<rangle>(\<bar>x\<rangle>p) \<le> \<bar>x\<rangle>p \<longrightarrow> \<bar>x\<rangle>p = \<bar>x\<^sup>\<star>\<rangle>\<bar>x\<rangle>p"
    by (smt fdia_star_induct_var fdiamond_def domain_iso fdia_simp mult_assoc mult_isor mult_oner star_plus_one star_slide_var subdistl eq_iff)

lemma d_transitive_PreLoebian_imp_Loebian:
  "\<lbrakk>(\<forall>p.\<bar>x\<rangle>(\<bar>x\<rangle>p) \<le> \<bar>x\<rangle>p);  PreLoebian(x)\<rbrakk> \<Longrightarrow> Loebian(x)"
  by (smt PreLoebian_def fdia_iso fdia_mult fdiamond_def mult_assoc star_slide_var d_transitive  Loebian_def)

lemma d_transitive_Noetherian_iff_Loebian:
  "\<lbrakk>\<forall>p.\<bar>x\<rangle>(\<bar>x\<rangle>p) \<le> \<bar>x\<rangle>p\<rbrakk> \<Longrightarrow> (Noetherian(x) = Loebian(x))"
  by (smt Loebian_imp_Noetherian Noetherian_iff_PreLoebian d_transitive_PreLoebian_imp_Loebian)

lemma Loeb_iff_box_Loeb: "(\<forall>y.\<bar>x\<rangle>y \<le> \<bar>x\<rangle>(\<Omega> x y)) = (\<forall>p.\<bar>x](a(\<bar>x]d(p))+d(p)) \<le> \<bar>x]d(p))"
  by  (smt a_antitone fdia_fbox_de_morgan_2 antidomain_semiring_domain_def a_omega fbox_fdia_de_morgan_1 add_comm fbox_simp a_closure fbox_fdia_de_morgan_1 a_de_morgan_var_2 fdia_simp omega_fdia dom_el_comm)

end

section {* Divergence Kleene Algebras and Separation of Termination *}

class fdivergence_kleene_algebra = fmodal_kleene_algebra + nabla_op +
  assumes nabla_closure:  "d(\<nabla>(x)) = \<nabla>(x)"
  and nabla_unfold: "\<nabla>(x) \<le> \<bar>x\<rangle>(\<nabla>(x))"
  and nabla_coinduction: "d(y) \<le> (\<bar>x\<rangle>d(y))+d(z) \<longrightarrow> d(y) \<le> (\<nabla>(x))+\<bar>x\<^sup>\<star>\<rangle>d(z)"

begin

lemma nabla_coinduction_var: "d(y) \<le> \<bar>x\<rangle>d(y) \<longrightarrow> d(y) \<le> \<nabla>(x)"
  by (smt a_one a_zero add_zeror antidomain_semiring_domain_def nabla_coinduction fdia_zero add_zeror)

lemma nabla_unfold_eq:  "\<bar>x\<rangle>(\<nabla>(x)) = \<nabla>(x)"
  by (smt fdia_iso nabla_closure nabla_unfold fdia_simp_2 nabla_coinduction_var nabla_unfold eq_iff)

lemma nabla_subdist: "\<nabla>(x) \<le> \<nabla>(x+y)"
  by (smt dia_iso_var nabla_closure nabla_unfold_eq order_prop nabla_coinduction_var)

lemma nabla_iso: "x \<le> y \<longrightarrow> \<nabla>(x) \<le> \<nabla>(y)"
  by (metis leq_def nabla_subdist)

lemma nabla_omega: "\<Omega> x (d y) = 0 \<longrightarrow> d(y) \<le> \<nabla>(x)"
  by (smt omega_fdia domain_invol d_a_zero fdia_simp_2 nabla_coinduction_var)

lemma nabla_noether: "\<nabla>(x) = 0 \<Longrightarrow> Noetherian(x)"
  by (smt Noetherian_def add_comm' add_zerol' fdia_simp leq_def nabla_coinduction_var omega_zero_equiv_1)

lemma nabla_preloeb: "\<nabla>(x) = 0 \<Longrightarrow> PreLoebian(x)"
  by (smt Noetherian_iff_PreLoebian nabla_noether)

lemma star_nabla_1: "\<bar>x\<^sup>\<star>\<rangle>(\<nabla> x)  = (\<nabla> x)"
    by (smt d_transitive nabla_unfold_eq order_refl eq_iff)

lemma separation_of_termination: "y\<cdot>x \<le> x\<cdot>(x+y)\<^sup>\<star>+y \<Longrightarrow> (((\<nabla> x)+(\<nabla> y) = 0) = (\<nabla>(x+y) = 0))"
proof
  assume lazycomm: "y\<cdot>x \<le> x\<cdot>(x+y)\<^sup>\<star>+y" and  xy_wf: "(\<nabla> x)+(\<nabla> y) = 0"
  hence "\<nabla>(x+y) \<le> (\<bar>x\<rangle>(\<nabla>(x+y))) + \<bar>y\<rangle>(\<bar>x\<^sup>\<star>\<rangle>(\<Omega> x (\<nabla>(x+y))))"
    by (smt fdia_add2 nabla_unfold_eq no_trivial_inverse nabla_preloeb PreLoebian_def nabla_closure fdia_iso fdia_simp_2 add_iso add_comm)
  hence "\<nabla>(x+y) \<le> (\<bar>x\<rangle>(\<nabla>(x+y))) + (\<bar>x\<rangle>(\<bar>(x+y)\<^sup>\<star>\<rangle>(\<Omega> x (\<nabla>(x+y)))))  + \<bar>y\<rangle>(\<Omega> x (\<nabla>(x+y)))"  using lazycomm
    by (smt lazycomm_var dia_iso_var add_iso add_comm add_assoc' fdia_add2 fdia_mult order_prop)
  hence "\<nabla>(x+y) \<le> (\<bar>x\<rangle>(\<nabla>(x+y))) + \<bar>y\<rangle>(\<Omega> x (\<nabla>(x+y)))"
    by (smt add_comm add_iso domain_iso fdia_iso nabla_closure omega_le_1 star_nabla_1 add_idem order_trans)
  with xy_wf show "\<nabla>(x+y) = 0"
    by (smt domain_iso d5 d_a_galois1 add_comm omega_fdia fdia_simp_2  no_trivial_inverse nabla_noether noetherian_alt omega_dom Noetherian_def nabla_closure)
next
show "\<nabla>(x+y) = 0 \<Longrightarrow> (\<nabla> x)+(\<nabla> y) = 0"
  by (smt add_comm' add_zerol' antisym_conv min_zero nabla_subdist)
qed

end

section {* A PDL Textbook Exercise *}

context fmodal_kleene_algebra
begin

lemma meyer_2: "(\<bar>(x\<cdot>x)\<^sup>\<star>]d(p))\<cdot>(\<bar>x\<cdot>(x\<cdot>x)\<^sup>\<star>]a(p)) = d(p)\<cdot>\<bar>x\<^sup>\<star>]((a(p)+\<bar>x]a(p))\<cdot>(d(p)+\<bar>x]d(p)))"
sorry

end

end


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

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

datatype A = X | Y

datatype R
         = Nil | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

fun eqA :: "A => A => bool" where
"eqA (X) (X) = True"
| "eqA (X) (Y) = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun eps :: "R => bool" where
"eps x =
   (case x of
      Eps => True
      | Plus p q => ((eps p) | (eps q))
      | Seq r q2 => ((eps r) & (eps q2))
      | Star y => True
      | other => False)"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil)"

fun step :: "R => A => R" where
"step x y =
   (case x of
      Atom a => (if eqA a y then Eps else Nil)
      | Plus p q => plus (step p y) (step q y)
      | Seq r q2 => plus (seq (step r y) q2) (seq (epsR r) (step q2 y))
      | Star p2 => seq (step p2 y) x
      | other => Nil)"

fun recognise :: "R => A list => bool" where
"recognise x (nil2) = eps x"
| "recognise x (cons2 z xs) = recognise (step x z) xs"

fun deeps :: "R => R" where
"deeps (Nil) = Nil"
| "deeps (Eps) = Nil"
| "deeps (Atom a) = Atom a"
| "deeps (Plus p q) = Plus (deeps p) (deeps q)"
| "deeps (Seq r q2) =
     (if ((eps r) & (eps q2)) then Plus (deeps r) (deeps q2) else
        Seq r q2)"
| "deeps (Star p2) = deeps p2"

theorem property0 :
  "((recognise (Star p) s) = (recognise (Star (deeps p)) s))"
  oops

end


section "Bitvector based Sets of Naturals"
theory Impl_Bit_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
  Native_Word.Code_Target_Integer_Bit
begin
  text \<open>
    Based on the Native-Word library, using bit-operations on arbitrary
    precision integers. Fast for sets of small numbers,
    direct and fast implementations of equal, union, inter, diff.

    Note: On Poly/ML 5.5.1, bit-operations on arbitrary precision integers are
      rather inefficient. Use MLton instead, here they are efficiently implemented.
\<close>

  type_synonym bitset = integer

  definition bs_\<alpha> :: "bitset \<Rightarrow> nat set" where "bs_\<alpha> s \<equiv> { n . bit s n}"

  context
    includes integer.lifting bit_operations_syntax
  begin

  definition bs_empty :: "unit \<Rightarrow> bitset" where "bs_empty \<equiv> \<lambda>_. 0"

  lemma bs_empty_correct: "bs_\<alpha> (bs_empty ()) = {}"
    unfolding bs_\<alpha>_def bs_empty_def
    apply transfer
    by auto

  definition bs_isEmpty :: "bitset \<Rightarrow> bool" where "bs_isEmpty s \<equiv> s=0"

  lemma bs_isEmpty_correct: "bs_isEmpty s \<longleftrightarrow> bs_\<alpha> s = {}"
    unfolding bs_isEmpty_def bs_\<alpha>_def
    by transfer (auto simp: bit_eq_iff)

  term set_bit
  definition bs_insert :: "nat \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_insert i s \<equiv> set_bit s i True"

  lemma bs_insert_correct: "bs_\<alpha> (bs_insert i s) = insert i (bs_\<alpha> s)"
    unfolding bs_\<alpha>_def bs_insert_def
    by transfer (auto simp add: bit_simps)

  definition bs_delete :: "nat \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_delete i s \<equiv> set_bit s i False"

  lemma bs_delete_correct: "bs_\<alpha> (bs_delete i s) = (bs_\<alpha> s) - {i}"
    unfolding bs_\<alpha>_def bs_delete_def
    by transfer (auto simp add: bit_simps split: if_splits)

  definition bs_mem :: "nat \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_mem i s \<equiv> bit s i"

  lemma bs_mem_correct: "bs_mem i s \<longleftrightarrow> i\<in>bs_\<alpha> s"
    unfolding bs_mem_def bs_\<alpha>_def by transfer auto

  definition bs_eq :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_eq s1 s2 \<equiv> (s1=s2)"

  lemma bs_eq_correct: "bs_eq s1 s2 \<longleftrightarrow> bs_\<alpha> s1 = bs_\<alpha> s2"
    unfolding bs_eq_def bs_\<alpha>_def
    including integer.lifting
    by transfer (simp add: bit_eq_iff set_eq_iff)

  definition bs_subset_eq :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_subset_eq s1 s2 \<equiv> s1 AND NOT s2 = 0"

  lemma bs_subset_eq_correct: "bs_subset_eq s1 s2 \<longleftrightarrow> bs_\<alpha> s1 \<subseteq> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_subset_eq_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

  definition bs_disjoint :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_disjoint s1 s2 \<equiv> s1 AND s2 = 0"

  lemma bs_disjoint_correct: "bs_disjoint s1 s2 \<longleftrightarrow> bs_\<alpha> s1 \<inter> bs_\<alpha> s2 = {}"
    unfolding bs_\<alpha>_def bs_disjoint_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

  definition bs_union :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_union s1 s2 = s1 OR s2"

  lemma bs_union_correct: "bs_\<alpha> (bs_union s1 s2) = bs_\<alpha> s1 \<union> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_union_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

  definition bs_inter :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_inter s1 s2 = s1 AND s2"

  lemma bs_inter_correct: "bs_\<alpha> (bs_inter s1 s2) = bs_\<alpha> s1 \<inter> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_inter_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

  definition bs_diff :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_diff s1 s2 = s1 AND NOT s2"

  lemma bs_diff_correct: "bs_\<alpha> (bs_diff s1 s2) = bs_\<alpha> s1 - bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_diff_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

  definition bs_UNIV :: "unit \<Rightarrow> bitset" where "bs_UNIV \<equiv> \<lambda>_. -1"

  lemma bs_UNIV_correct: "bs_\<alpha> (bs_UNIV ()) = UNIV"
    unfolding bs_\<alpha>_def bs_UNIV_def
    by transfer (auto)

  definition bs_complement :: "bitset \<Rightarrow> bitset" where
    "bs_complement s = NOT s"

  lemma bs_complement_correct: "bs_\<alpha> (bs_complement s) = - bs_\<alpha> s"
    unfolding bs_\<alpha>_def bs_complement_def
    by transfer (simp add: bit_eq_iff, auto simp add: bit_simps)

end

  lemmas bs_correct[simp] =
    bs_empty_correct
    bs_isEmpty_correct
    bs_insert_correct
    bs_delete_correct
    bs_mem_correct
    bs_eq_correct
    bs_subset_eq_correct
    bs_disjoint_correct
    bs_union_correct
    bs_inter_correct
    bs_diff_correct
    bs_UNIV_correct
    bs_complement_correct

subsection \<open>Autoref Setup\<close>

definition bs_set_rel_def_internal:
  "bs_set_rel Rk \<equiv>
    if Rk=nat_rel then br bs_\<alpha> (\<lambda>_. True) else {}"
lemma bs_set_rel_def:
  "\<langle>nat_rel\<rangle>bs_set_rel \<equiv> br bs_\<alpha> (\<lambda>_. True)"
  unfolding bs_set_rel_def_internal relAPP_def by simp

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

lemma bs_set_rel_sv[relator_props]: "single_valued (\<langle>nat_rel\<rangle>bs_set_rel)"
  unfolding bs_set_rel_def by auto

term bs_empty

lemma [autoref_rules]: "(bs_empty (),{})\<in>\<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_UNIV (),UNIV)\<in>\<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_isEmpty,op_set_isEmpty)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

term insert
lemma [autoref_rules]: "(bs_insert,insert)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

term op_set_delete
lemma [autoref_rules]: "(bs_delete,op_set_delete)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_mem,(\<in>))\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_eq,(=))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_subset_eq,(\<subseteq>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_union,(\<union>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_inter,(\<inter>))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_diff,(-))\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_complement,uminus)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_disjoint,op_set_disjoint)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

export_code
    bs_empty
    bs_isEmpty
    bs_insert
    bs_delete
    bs_mem
    bs_eq
    bs_subset_eq
    bs_disjoint
    bs_union
    bs_inter
    bs_diff
    bs_UNIV
    bs_complement
 in SML

(*

    TODO: Iterator

  definition "maxbi s \<equiv> GREATEST i. s!!i"

  lemma cmp_BIT_append_conv[simp]: "i < i BIT b \<longleftrightarrow> ((i\<ge>0 \<and> b=1) \<or> i>0)"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma BIT_append_cmp_conv[simp]: "i BIT b < i \<longleftrightarrow> ((i<0 \<and> (i=-1 \<longrightarrow> b=0)))"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma BIT_append_eq[simp]: fixes i :: int shows "i BIT b = i \<longleftrightarrow> (i=0 \<and> b=0) \<or> (i=-1 \<and> b=1)"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma int_no_bits_eq_zero[simp]:
    fixes s::int shows "(\<forall>i. \<not>s!!i) \<longleftrightarrow> s=0"
    apply clarsimp
    by (metis bin_eqI bin_nth_code(1))

  lemma int_obtain_bit:
    fixes s::int
    assumes "s\<noteq>0"
    obtains i where "s!!i"
    by (metis assms int_no_bits_eq_zero)

  lemma int_bit_bound:
    fixes s::int
    assumes "s\<ge>0" and "s!!i"
    shows "i \<le> Bits_Integer.log2 s"
  proof (rule ccontr)
    assume "\<not>i\<le>Bits_Integer.log2 s"
    hence "i>Bits_Integer.log2 s" by simp
    hence "i - 1 \<ge> Bits_Integer.log2 s" by simp
    hence "s AND bin_mask (i - 1) = s" by (simp add: int_and_mask `s\<ge>0`)
    hence "\<not> (s!!i)"
      by clarsimp (metis Nat.diff_le_self bin_nth_mask bin_nth_ops(1) leD)
    thus False using `s!!i` ..
  qed

  lemma int_bit_bound':
    fixes s::int
    assumes "s\<ge>0" and "s!!i"
    shows "i < Bits_Integer.log2 s + 1"
    using assms int_bit_bound by smt

  lemma int_obtain_bit_pos:
    fixes s::int
    assumes "s>0"
    obtains i where "s!!i" "i < Bits_Integer.log2 s + 1"
    by (metis assms int_bit_bound' int_no_bits_eq_zero less_imp_le less_irrefl)

  lemma maxbi_set: fixes s::int shows "s>0 \<Longrightarrow> s!!maxbi s"
    unfolding maxbi_def
    apply (rule int_obtain_bit_pos, assumption)
    apply (rule GreatestI_nat, assumption)
    apply (intro allI impI)
    apply (rule int_bit_bound'[rotated], assumption)
    by auto

  lemma maxbi_max: fixes s::int shows "i>maxbi s \<Longrightarrow> \<not> s!!i"
    oops

  function get_maxbi :: "nat \<Rightarrow> int \<Rightarrow> nat" where
    "get_maxbi n s = (let
        b = 1<<n
      in
        if b\<le>s then get_maxbi (n+1) s
        else n
    )"
    by pat_completeness auto

  termination
    apply (rule "termination"[of "measure (\<lambda>(n,s). nat (s + 1 - (1<<n)))"])
    apply simp
    apply auto
    by (smt bin_mask_ge0 bin_mask_p1_conv_shift)

  partial_function (tailrec)
    bs_iterate_aux :: "nat \<Rightarrow> bitset \<Rightarrow> ('\<sigma> \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
    where "bs_iterate_aux i s c f \<sigma> = (
    if s < 1 << i then \<sigma>
    else if \<not>c \<sigma> then \<sigma>
    else if test_bit s i then bs_iterate_aux (i+1) s c f (f i \<sigma>)
    else bs_iterate_aux (i+1) s c f \<sigma>
  )"

  definition bs_iteratei :: "bitset \<Rightarrow> (nat,'\<sigma>) set_iterator" where
    "bs_iteratei s = bs_iterate_aux 0 s"

  definition bs_set_rel_def_internal:
    "bs_set_rel Rk \<equiv>
      if Rk=nat_rel then br bs_\<alpha> (\<lambda>_. True) else {}"
  lemma bs_set_rel_def:
    "\<langle>nat_rel\<rangle>bs_set_rel \<equiv> br bs_\<alpha> (\<lambda>_. True)"
    unfolding bs_set_rel_def_internal relAPP_def by simp

  definition "bs_to_list \<equiv> it_to_list bs_iteratei"

  lemma "(1::int)<<i = 2^i"
    by (simp add: shiftl_int_def)

  lemma
    fixes s :: int
    assumes "s\<ge>0"
    shows "s < 1<<i \<longleftrightarrow> Bits_Integer.log2 s \<le> i"
    using assms
  proof (induct i arbitrary: s)
    case 0 thus ?case by auto
  next
    case (Suc i)
    note GE=`0\<le>s`
    show ?case proof
      assume "s < 1 << Suc i"

      have "s \<le> (s >> 1) BIT 1"

      hence "(s >> 1) < (1<<i)" using GE apply auto
      with Suc.hyps[of "s div 2"]

    apply auto

  lemma "distinct (bs_to_list s)"
    unfolding bs_to_list_def it_to_list_def bs_iteratei_def[abs_def]
  proof -
    {
      fix l i
      assume "distinct l"
      show "distinct (bs_iterate_aux 0 s (\<lambda>_. True) (\<lambda>x l. l @ [x]) [])"

    }

    apply auto

    lemma "set (bs_to_list s) = bs_\<alpha> s"

  lemma autoref_iam_is_iterator[autoref_ga_rules]:
    shows "is_set_to_list nat_rel bs_set_rel bs_to_list"
    unfolding is_set_to_list_def is_set_to_sorted_list_def
    apply clarsimp
    unfolding it_to_sorted_list_def
    apply (refine_rcg refine_vcg)
    apply (simp_all add: bs_set_rel_def br_def)

  proof (clarsimp)

  definition

"iterate s c f \<sigma> \<equiv> let
    i=0;
    b=0;
    (_,_,s) = while
  in

  end"

*)

end


section \<open>Combinatorics problems\<close>

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

theory IMO_2018_SL_C1_sol
imports Complex_Main
begin

lemma sum_geom_nat:
  fixes q::nat
  assumes "q > 1"
  shows "(\<Sum>k\<in>{0..<n}. q^k) = (q^n - 1) div (q - 1)"
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case
    by (smt Nat.add_diff_assoc2 One_nat_def Suc_1 Suc_leI add.commute assms div_mult_self4 le_trans mult_eq_if nat_one_le_power one_le_numeral power.simps(2) sum.op_ivl_Suc zero_less_diff zero_order(3))
qed

declare [[smt_timeout = 20]]

lemma div_diff_nat:
  fixes a b c :: nat
  assumes "c dvd a" "c dvd b"
  shows "(a - b) div c = a div c  - b div c"
  using assms
  by (smt add_diff_cancel_left' div_add dvd_diff_nat le_iff_add nat_less_le neq0_conv not_less zero_less_diff)

lemma sum_geom_nat':
  fixes q::nat
  assumes "q > 1" "m \<le> n"
  shows "(\<Sum>k\<in>{m..<n}. q^k) = (q^n - q^m) div (q - 1)"
  using assms
proof (induction n)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  show ?case
  proof (cases "m \<le> n")
    case True
    then have "sum ((^) q) {m..<Suc n} = (q ^ n - q ^ m) div (q - 1) + q^n"
      using Suc
      by simp
    also have "... = ((q ^ n - q ^ m) + (q - 1) * q^n) div (q - 1)"
      using \<open>q > 1\<close>
      by auto
    also have "... = ((q ^ n - q ^ m) + (q^(n+1) - q^n)) div (q - 1)"
      by (simp add: algebra_simps)
    also have "... = (q ^ (n+1) - q ^ m) div (q - 1)"
      using True assms(1) by auto
    finally show ?thesis
      by simp
  next
    case False
    then have "m = n + 1"
      using Suc(3)
      by auto
    then show ?thesis
      by simp
  qed
qed

theorem IMO2018SL_C1:
  fixes n :: nat
  assumes "n \<ge> 3"
  shows "\<exists> (S::nat set). card S = 2*n \<and> (\<forall> x \<in> S. x > 0) \<and>
        (\<forall> m. 2 \<le> m \<and> m \<le> n \<longrightarrow> (\<exists> S1 S2. S1 \<inter> S2 = {} \<and> S1 \<union> S2 = S \<and> card S1 = m \<and> \<Sum> S1 = \<Sum> S2))"
proof-
  let ?Sa = "{(3::nat)^k | k. k \<in> {1..<n}}" and ?Sb = "{2 * (3::nat)^k | k. k \<in> {1..<n}}" and ?Sc = "{1::nat, (3^n + 9) div 2 - 1}"
  let ?S = "?Sa \<union> ?Sb \<union> ?Sc"

  have "finite ?Sa" "finite ?Sb" "finite ?Sc" "finite (?Sa \<union> ?Sb)"
    by auto

  have "?Sa \<inter> ?Sb = {}"
  proof safe
    fix ka kb
    assume "ka \<in> {1..<n}" "kb \<in> {1..<n}" "(3::nat)^ka = 2*3^kb"
    have "odd ((3::nat)^ka)" "even (2*3^kb)"
      by simp_all
    then have False
      using \<open>(3::nat)^ka = 2*3^kb\<close>
      by simp
    then show "3^ka \<in> {}"
      by simp
  qed

  have "1 < ((3::nat) ^ n + 9) div 2"
    by linarith

  have "\<not> 3 dvd (((3::nat) ^ n + 9) div 2 - 1)"
  proof-
    have "3 dvd ((3::nat) ^ n + 9) div 2"
    proof-
      have "(3::nat) ^ n + 9 = (3^2) * (3::nat)^(n-2) + 9"
        using \<open>n \<ge> 3\<close>
        by (metis One_nat_def add_leD2 le_add_diff_inverse numeral_3_eq_3 one_add_one plus_1_eq_Suc power_add)
      then have "(3::nat) ^ n + 9 = 9*(3^(n-2) + 1)"
        by simp
      then have "((3::nat) ^ n + 9) div 2 = (9 * (3^(n-2) + 1)) div 2"
        by auto
      then have "((3::nat) ^ n + 9) div 2 = 9 * ((3^(n-2) + 1) div 2)"
        by (metis One_nat_def div_mult_swap dvd_mult_div_cancel even_add even_power even_succ_div_two num.distinct(1) numeral_3_eq_3 numeral_eq_one_iff one_add_one plus_1_eq_Suc)
      then show ?thesis
        by simp
    qed
    then show ?thesis
      using \<open>((3::nat) ^ n + 9) div 2 > 1\<close>
      by (meson dvd_diffD1 less_imp_le_nat nat_dvd_1_iff_1 numeral_eq_one_iff semiring_norm(86))
  qed

  have "(?Sa \<union> ?Sb) \<inter> ?Sc = {}"
  proof-
    have "?Sa \<inter> ?Sc = {}"
    proof safe
      fix k
      assume "k \<in> {1..<n}" "(3::nat) ^ k = 1"
      then show "3 ^ k \<in> {}"
        by simp
    next
      fix k
      assume "k \<in> {1..<n}" "(3::nat) ^ k = (3 ^ n + 9) div 2 - 1"
      moreover
      have "3 dvd (3::nat) ^ k"
        using \<open>k \<in> {1..<n}\<close>
        by auto
      ultimately
      have False
        using \<open>\<not> 3 dvd (3 ^ n + 9) div 2 - 1\<close>
        by simp
      then show "3 ^ k \<in> {}"
        by simp
    qed

    moreover

    have "?Sb \<inter> ?Sc = {}"
    proof safe
      fix k
      assume "k \<in> {1..<n}" "2 * (3::nat) ^ k = 1"
      then show "2 * 3 ^ k \<in> {}"
        by simp
    next
      fix k
      assume "k \<in> {1..<n}" "2 * (3::nat) ^ k = (3 ^ n + 9) div 2 - 1"
      moreover
      have "3 dvd 2 * (3::nat) ^ k"
        using \<open>k \<in> {1..<n}\<close>
        by auto
      ultimately
      have False
        using \<open>\<not> 3 dvd (3 ^ n + 9) div 2 - 1\<close>
        by simp
      then show "2 * 3 ^ k \<in> {}"
        by simp
    qed

    ultimately
    show ?thesis
      by blast
  qed

  show ?thesis
  proof (rule_tac x="?S" in exI, safe)
    show "card ?S = 2*n"
    proof-
      have "card (?Sa \<union> ?Sb) = (n - 1) + (n - 1)"
      proof-
        have "inj_on ((^) (3::nat)) {1..<n}"
          unfolding inj_on_def
          by auto
        then have "card ?Sa = n-1"
          using card_image[of "\<lambda> k. 3^k" "{1..<n}"]
          by (smt Collect_cong Setcompr_eq_image card_atLeastLessThan)

        moreover

        have "inj_on (\<lambda> k. 2 * (3::nat) ^ k) {1..<n}"
          unfolding inj_on_def
          by auto

        then have "card ?Sb = n-1"
          using card_image[of "\<lambda> k. 2 * 3^k" "{1..<n}"]
          by (smt Collect_cong Setcompr_eq_image card_atLeastLessThan)

        ultimately
        show ?thesis
          using \<open>n \<ge> 3\<close> card_Un_disjoint[of ?Sa ?Sb] \<open>?Sa \<inter> ?Sb = {}\<close> \<open>finite ?Sa\<close> \<open>finite ?Sb\<close>
          by smt
      qed

      moreover

      have "card {1, ((3::nat)^n + 9) div 2 - 1} = 2"
        using \<open>1 < ((3::nat) ^ n + 9) div 2\<close>
        by auto

      ultimately

      show "card ?S = 2*n"
        using \<open>n \<ge> 3\<close> card_Un_disjoint[of "?Sa \<union> ?Sb" ?Sc] \<open>(?Sa \<union> ?Sb) \<inter> ?Sc = {}\<close> \<open>finite (?Sa \<union> ?Sb)\<close> \<open>finite ?Sc\<close>
        by (smt Nat.add_diff_assoc2 Suc_1 Suc_eq_plus1 add_Suc_right card_infinite diff_add_inverse2 le_trans mult_2 nat.simps(3) one_le_numeral)
    qed
  next
    fix k
    assume "k \<in> {1..<n}"
    then show "0 < (3::nat) ^ k" "0 < 2 * (3::nat) ^ k"
      by simp_all
  next
    show "0 < ((3::nat) ^ n + 9) div 2 - 1"
      using \<open>1 < (3 ^ n + 9) div 2\<close> zero_less_diff
      by blast
  next
    fix m
    assume "2 \<le> m" "m \<le> n"
    let ?Am' = "{2 * (3::nat)^k | k. k \<in> {n-m+1..<n}}" and ?Am'' = "{(3::nat) ^ (n-m+1)}"
    let ?Am = "?Am' \<union> ?Am''"
    let ?Bm = "?S - ?Am"

    have "?Am' \<subseteq> ?Sb"
      using \<open>m \<le> n\<close>
      by auto

    have "?Am'' \<subseteq> ?Sa"
      using \<open>m \<le> n\<close> \<open>2 \<le> m\<close>
      by force

    have "?Am \<inter> ?Bm = {}"
      by blast

    moreover

    have Am: "?Am' \<inter> ?Am'' = {}"  "finite ?Am'" "finite ?Am''"
      using \<open>?Am' \<subseteq> ?Sb\<close> \<open>?Am'' \<subseteq> ?Sa\<close> \<open>?Sa \<inter> ?Sb = {}\<close>
      by auto

    have "finite ?Am" "finite ?Bm"
      by auto

    have "?Am \<union> ?Bm = ?S"
    proof-
      have "?Am \<subseteq> ?S"
        using \<open>?Am' \<subseteq> ?Sb\<close> \<open>?Am'' \<subseteq> ?Sa\<close>
        by blast
      then show ?thesis
        by blast
    qed

    moreover

    have "card ?Am = m"
    proof-
      have "inj_on (\<lambda> k. 2 * (3::nat) ^ k) {n-m+1..<n}"
        unfolding inj_on_def
        by auto
      then show ?thesis
        using card_image[of "\<lambda> k. 2 * (3::nat)^k" "{n-m+1..<n}"]
              card_Un_disjoint[of ?Am' ?Am''] Am
        unfolding Setcompr_eq_image
        by (smt Int_insert_right_if1 One_nat_def Suc_eq_plus1 Un_insert_right \<open>({2 * 3 ^ k |k. k \<in> {n - m + 1..<n}} \<union> {3 ^ (n - m + 1)}) \<inter> ({3 ^ k |k. k \<in> {1..<n}} \<union> {2 * 3 ^ k |k. k \<in> {1..<n}} \<union> {1, (3 ^ n + 9) div 2 - 1} - ({2 * 3 ^ k |k. k \<in> {n - m + 1..<n}} \<union> {3 ^ (n - m + 1)})) = {}\<close> \<open>2 \<le> m\<close> \<open>m \<le> n\<close> add.commute add_diff_inverse_nat add_le_cancel_left card.insert card_atLeastLessThan card_empty diff_Suc_Suc diff_diff_cancel disjoint_insert(2) finite.emptyI insertCI insert_absorb le_trans linorder_not_le one_le_numeral)
    qed

    moreover
    have "\<Sum> ?Am = \<Sum> ?Bm"
    proof-
      have "(\<Sum> ?Am) = 3^n"
      proof-
        have "\<Sum> ?Am' = (\<Sum>k\<in>{n-m+1..<n}. 2*3^k)"
        proof-
          have "inj_on (\<lambda> k. 2*(3::nat)^k) {n-m+1..<n}"
            unfolding inj_on_def
            by auto
          then show ?thesis
            unfolding Setcompr_eq_image
            by (simp add: sum.reindex_cong)
        qed
        also have "... = 2 * (\<Sum>k\<in>{n-m+1..<n}. 3^k)"
          by (simp add: sum_distrib_left)
        also have "... = 3^n - 3^(n-m+1)"
          using sum_geom_nat'[of 3 "n-m+1" n] \<open>m \<ge> 2\<close> \<open>m \<le> n\<close>
          by simp
        finally
        have "\<Sum> ?Am' = 3^n - 3^(n-m+1)"
          .

        moreover

        have "\<Sum> ?Am'' = 3^(n-m+1)"
          by simp

        moreover

        have "\<Sum> ?Am = \<Sum> ?Am' + \<Sum> ?Am''"
          using Am
          by (simp add: sum.union_disjoint)

        ultimately

        have "(\<Sum> ?Am) = (3^n - 3^(n-m+1)) + 3^(n-m+1)"
          by simp
        also have "... = 3^n"
        proof-
          have "(3::nat)^(n-m+1) \<le> 3^n"
            using \<open>m \<le> n\<close> \<open>2 \<le> m\<close>
            by (metis Nat.le_diff_conv2 add.commute add_leD2 diff_diff_cancel diff_le_self one_le_numeral power_increasing)
          then show ?thesis
            by simp
        qed
        finally show ?thesis
          .
      qed

      moreover

      have "\<Sum> ?Bm = 3^n"
      proof-
        have "\<Sum> ?S = 2*3^n"
        proof-
          have "\<Sum> ?Sa = (\<Sum> k\<in>{1..<n}. 3^k)"
          proof-
            have "inj_on ((^) (3::nat)) {1..<n}"
              unfolding inj_on_def
              by auto
            then show ?thesis
              unfolding Setcompr_eq_image
              by (simp add: sum.reindex_cong)
          qed

          have "\<Sum> ?Sa = (3^n - 1) div 2 - 1"
          proof-
            have "inj_on (\<lambda> k. (3::nat) ^ k) {1..<n}"
              unfolding inj_on_def
              by auto
            then have "\<Sum> ?Sa = (\<Sum> k \<in> {1..<n}. 3 ^ k)"
              unfolding Setcompr_eq_image
              by (simp add: sum.reindex_cong)
            then show ?thesis
              using sum_geom_nat'[of 3 1 n] \<open>n \<ge> 3\<close>
              by simp
          qed

          moreover

          have "\<Sum> ?Sb = 2 * ((3^n - 1) div 2 - 1)"
          proof-
            have "inj_on (\<lambda> k. 2 * (3::nat) ^ k) {1..<n}"
              unfolding inj_on_def
              by auto
            then have "\<Sum> ?Sb = (\<Sum> k \<in> {1..<n}. 2 * 3 ^ k)"
              unfolding Setcompr_eq_image
              by (simp add: sum.reindex_cong)
            also have "... = 2 * (\<Sum> k \<in> {1..<n}. 3 ^ k)"
              by (simp add: sum_distrib_left)
            also have "... = 2 * (\<Sum> ?Sa)"
            proof-
              have "inj_on (\<lambda> k. (3::nat) ^ k) {1..<n}"
                unfolding inj_on_def
                by auto
              then show ?thesis
                unfolding Setcompr_eq_image
                by (simp add: sum.reindex_cong)
            qed
            finally
            show ?thesis
              using \<open>\<Sum> ?Sa = (3^n - 1) div 2 - 1\<close>
              by simp
          qed

          moreover

          have "\<Sum> ?Sc = (3 ^ n + 9) div 2"
            by auto

          moreover

          have "\<Sum> ?S = \<Sum> ?Sa + \<Sum> ?Sb + \<Sum> ?Sc"
            using \<open>?Sa \<inter> ?Sb = {}\<close> \<open>(?Sa \<union> ?Sb) \<inter> ?Sc = {}\<close>
            using \<open>finite ?Sa\<close> \<open>finite ?Sb\<close> \<open>finite ?Sc\<close> \<open>finite (?Sa \<union> ?Sb)\<close>
            using sum.union_disjoint
            by (metis (no_types, lifting))

          moreover

          have "(((3::nat)^n - 1) div 2 - 1) + 2 * ((3^n - 1) div 2 - 1) + (3 ^ n + 9) div 2 = 2*3^n" (is "?lhs = 2*3^n")
          proof-
            have "((3::nat)^n - 1) div 2 - 1 = (3^n - 3) div 2"
              by simp
            then have "?lhs =  3*((3^n - 3) div 2) + (3 ^ n + 9) div 2"
              by simp
            also have "... = ((3*3^n - 9) + (3^n + 9)) div 2"
              by (simp add: div_mult_swap)
            also have "... = 2*3^n"
            proof-
              have "9 \<le> (3::nat) * 3 ^ n"
                using \<open>n \<ge> 3\<close>
                by (smt Suc_1 \<open>(3 ^ n - 1) div 2 - 1 = (3 ^ n - 3) div 2\<close> calculation diff_add_inverse2 diff_diff_cancel diff_is_0_eq dvd_mult_div_cancel even_add even_power le_add1 le_add_same_cancel2 le_antisym le_trans linear mult_Suc numeral_3_eq_3 odd_two_times_div_two_succ plus_1_eq_Suc power_mult self_le_ge2_pow)
              then have "((3::nat)*3^n - 9) + (3^n + 9) = 4*3^n"
                by simp
              then show ?thesis
                by simp
            qed
            finally
            show ?thesis
              .
          qed

          ultimately
          show ?thesis
            by simp
        qed
        also have "\<Sum> ?S = \<Sum> ?Am + \<Sum> ?Bm"
          using \<open>?Am \<union> ?Bm = ?S\<close> \<open>?Am \<inter> ?Bm = {}\<close> \<open>finite ?Am\<close> \<open>finite ?Bm\<close>
          using sum.union_disjoint[of ?Am ?Bm id]
          by simp
        then show ?thesis
          using \<open>\<Sum> ?Am = 3^n\<close>
          by (metis (no_types, lifting) add_left_cancel calculation mult_2)
      qed

      ultimately

      show ?thesis
        by simp
    qed

    ultimately

    show "\<exists>S1 S2. S1 \<inter> S2 = {} \<and> S1 \<union> S2 = ?S \<and> card S1 = m \<and> \<Sum> S1 = \<Sum> S2"
      by blast
  qed
qed

end