(*  Title:       Effects of the function mtf2 on index and before_in
    Author:      Max Haslbeck
*)

section "Effect of mtf2"

theory MTF2_Effects
imports Move_to_Front
begin

lemma difind_difelem:
       "i < length xs \<Longrightarrow> distinct xs \<Longrightarrow> xs ! j = a \<Longrightarrow> j < length xs \<Longrightarrow> i \<noteq> j
          \<Longrightarrow> ~ a = xs ! i"
apply(rule ccontr) by(metis index_nth_id)

lemma fullchar: assumes  "index xs q < length xs"
  shows
    "(i < length xs) =
  (index xs q < i \<and> i < length xs
    \<or> index xs q = i
    \<or> index xs q - n \<le> i \<and> i < index xs q
    \<or> i < index xs q - n)"
using assms by auto

lemma mtf2_effect:
    "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> (index xs q < i \<and> i < length xs \<longrightarrow>( index (mtf2 n q xs) (xs!i) = index xs (xs!i) \<and> index xs q < index (mtf2 n q xs) (xs!i) \<and> index (mtf2 n q xs) (xs!i) < length xs))
    \<and> (index xs q = i \<longrightarrow> (index (mtf2 n q xs) (xs!i) = index xs q - n \<and> index (mtf2 n q xs) (xs!i) = index xs q - n))
    \<and> (index xs q - n \<le> i \<and> i < index xs q \<longrightarrow> (index (mtf2 n q xs) (xs!i) = Suc (index xs (xs!i)) \<and> index xs q - n < index (mtf2 n q xs) (xs!i) \<and> index (mtf2 n q xs) (xs!i) \<le> index xs q))
    \<and> (i < index xs q - n \<longrightarrow> (index (mtf2 n q xs) (xs!i) = index xs (xs!i) \<and> index (mtf2 n q xs) (xs!i) < index xs q - n))"
unfolding mtf2_def
apply (induct n)
proof -
  case (Suc n)
  note indH=Suc(1)[OF Suc(2) Suc(3), simplified Suc(2) if_True]
  note qinxs=Suc(2)[simp]
  note distxs=Suc(3)[simp]
  show ?case (is ?toshow)
  apply(simp only: qinxs if_True)
  proof (cases "index xs q \<ge> Suc n")
    case True
    note True1=this
from True have onemore: "[index xs q - Suc n..<index xs q] = (index xs q - Suc n) # [index xs q - n..<index xs q]"
              using Suc_diff_Suc upt_rec by auto

        from onemore have yeah: "swaps [index xs q - Suc n..<index xs q] xs
            = swap (index xs q - Suc n) (swaps  [index xs q - n..<index xs q] xs)" by auto

      have sis: "Suc (index xs q - Suc n) = index xs q - n" using True Suc_diff_Suc by auto

      have indq: "index xs q < length xs"
        apply(rule index_less) by auto

      let ?i' = "index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i)"
      let ?x = "(xs!i)" and  ?xs="(swaps  [index xs q - n..<index xs q] xs)"
              and ?n="(index xs q - Suc n)"
      have "?i'
          =  index (swap (index xs q - Suc n) (swaps  [index xs q - n..<index xs q] xs)) (xs!i)" using yeah by auto
      also have "\<dots> = (if ?x = ?xs ! ?n then Suc ?n else if ?x = ?xs ! Suc ?n then ?n else index ?xs ?x)"
        apply(rule index_swap_distinct)
          apply(simp)
          apply(simp add: sis) using indq by linarith
      finally have i': "?i' = (if ?x = ?xs ! ?n then Suc ?n else if ?x = ?xs ! Suc ?n then ?n else index ?xs ?x)" .

      let ?i''="index (swaps [index xs q - n..<index xs q] xs) (xs ! i)"

    show "(index xs q < i \<and> i < length xs \<longrightarrow>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs (xs ! i) \<and>
     index xs q < index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) \<and>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) < length xs) \<and>
    (index xs q = i \<longrightarrow>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs q - Suc n \<and>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs q - Suc n) \<and>
    (index xs q - Suc n \<le> i \<and> i < index xs q \<longrightarrow>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = Suc (index xs (xs ! i)) \<and>
     index xs q - Suc n < index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) \<and>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) \<le> index xs q) \<and>
    (i < index xs q - Suc n \<longrightarrow>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs (xs ! i) \<and>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) < index xs q - Suc n)"
    apply(intro conjI)
    apply(intro impI) apply(elim conjE) prefer 4 apply(intro impI)  prefer 4 apply(intro impI) apply(elim conjE)
      prefer 4 apply(intro impI) prefer 4
    proof (goal_cases)
      case 1
      have indH1: "(index xs q < i \<and> i < length xs \<longrightarrow>
                      ?i'' =  index xs (xs ! i))" using indH by auto
      assume ass: "index xs q < i" and ass2:"i < length xs"
      then have a: "?i'' =  index xs (xs ! i)" using indH1 by auto
      also have a': "\<dots> = i" apply(rule index_nth_id) using ass2 by(auto)
      finally have ii: "?i'' = i" .
      have fstF: "~ ?x = ?xs ! ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
        using indq apply (simp add: less_imp_diff_less)
        apply(simp)
        apply(rule nth_index) apply(simp) using ass2 apply(simp)
        apply(rule index_less)
          apply(simp) using ass2 apply(simp)
          apply(simp)
        using ii ass by auto
      have sndF: "~ ?x = ?xs ! Suc ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
        using indq True apply (simp add: Suc_diff_Suc less_imp_diff_less)
        apply(simp)
        apply(rule nth_index) apply(simp) using ass2 apply(simp)
        apply(rule index_less)
          apply(simp) using ass2 apply(simp)
          apply(simp)
        using ii ass Suc_diff_Suc True by auto

      have "?i' = index xs (xs ! i)" unfolding i' using fstF sndF a by simp
      then show ?case using a' ass ass2 by auto
    next
      case 2
      have indH2: "index xs q = i \<longrightarrow> ?i'' = index xs (xs ! i) - n" using indH by auto
      assume "index xs q = i"
      then have ass: "i = index xs q" by auto
      with indH2 have a: "i - n = ?i''" by auto
      from ass have c: "index xs (xs ! i) = i" by auto
      have "Suc (index xs q - Suc n) = i - n" using ass True Suc_diff_Suc by auto
      also have "\<dots> = ?i''" using a by auto
      finally have a: "Suc ?n = ?i''" .

      have sndTrue: "?x = ?xs ! Suc ?n" apply(simp add: a)
              apply(rule nth_index[symmetric]) by (simp add: ass)
      have fstFalse: "~ ?x = ?xs ! ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
        using indq True apply (simp add: Suc_diff_Suc less_imp_diff_less)
        apply(simp)
        apply(rule nth_index) apply(simp) using ass  apply(simp)
        apply(rule index_less)
          apply(simp) using ass  apply(simp)
          apply(simp)
        using a by auto

      have "?i' = index xs (xs ! index xs q) - Suc n"
          unfolding i' using sndTrue fstFalse by simp
      with ass show ?case by auto
    next
      case 3
      have indH3: "index xs q - n \<le> i \<and> i < index xs q
              \<longrightarrow>  ?i'' = Suc (index xs (xs ! i))" using indH by auto
      assume ass: "index xs q - Suc n \<le> i" and
              ass2: "i < index xs q"
      from ass2 have ilen: "i < length xs" using indq dual_order.strict_trans by blast
      show ?case
      proof (cases "index xs q - n \<le> i")
        case False
        then have "i < index xs q - n" by auto
        moreover have "(i < index xs q - n \<longrightarrow> ?i'' = index xs (xs ! i))" using indH by auto
        ultimately have d: "?i'' = index xs (xs ! i)" by simp
        from False ass have b: "index xs q - Suc n = i" by auto
        have "index xs q < length xs" apply(rule index_less) by (auto)
        have c: "index xs (xs ! i) = i"
          apply(rule index_nth_id) apply(simp) using indq ass2 using less_trans by blast
        from b c d have f: "?i'' = index xs q - Suc n" by auto
        have fstT: "?xs ! ?n = ?x"
            apply(simp only: f[symmetric]) apply(rule nth_index)
            by (simp add: ilen)

        have "?i' = Suc (index xs q - Suc n)"
          unfolding i' using fstT by simp
        also have "\<dots> = Suc (index xs (xs ! i))" by(simp only: b c)
        finally show ?thesis using c False ass by auto
      next
        case True
        with ass2 indH3 have a: "?i'' = Suc (index xs (xs ! i))" by auto
        have jo: "index xs (xs ! i) = i" apply(rule index_nth_id) using ilen by(auto)
        have fstF: "~ ?x = ?xs ! ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
          using indq apply (simp add: less_imp_diff_less)
          apply(simp)
          apply(rule nth_index) apply(simp) using ilen apply(simp)
          apply(rule index_less)
            apply(simp) using ilen apply(simp)
            apply(simp)
          apply(simp only: a jo) using True by auto
        have sndF: "~ ?x = ?xs ! Suc ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
          using True1 apply (simp add: Suc_diff_Suc less_imp_diff_less)
          apply(simp)
          apply(rule nth_index) apply(simp) using ilen apply(simp)
          apply(rule index_less)
            apply(simp) using ilen apply(simp)
            apply(simp)
          apply(simp only: a jo) using True1 apply (simp add: Suc_diff_Suc less_imp_diff_less)
          using True by auto
        have "?i' = Suc (index xs (xs ! i))" unfolding i' using fstF sndF a by simp
        then show ?thesis using ass ass2 jo by auto
      qed
    next
      case 4
      assume ass: "i < index xs q - Suc n"
      then have ass2: "i < index xs q - n" by auto
      moreover have "(i < index xs q - n \<longrightarrow> ?i'' = index xs (xs ! i))" using indH by auto
      ultimately have a: "?i'' = index xs (xs ! i)" by auto
      from ass2 have "i < index xs q" by auto
      then have ilen: "i < length xs" using indq dual_order.strict_trans by blast

      have jo: "index xs (xs ! i) = i" apply(rule index_nth_id) using ilen by(auto)
      have fstF: "~ ?x = ?xs ! ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
        using indq apply (simp add: less_imp_diff_less)
        apply(simp)
        apply(rule nth_index) apply(simp) using ilen apply(simp)
        apply(rule index_less)
          apply(simp) using ilen apply(simp)
          apply(simp)
        apply(simp only: a jo) using ass by auto
      have sndF: "~ ?x = ?xs ! Suc ?n" apply(rule difind_difelem[where j="index (swaps [index xs q - n..<index xs q] xs) (xs!i)"])
        using True1 apply (simp add: Suc_diff_Suc less_imp_diff_less)
        apply(simp)
        apply(rule nth_index) apply(simp) using ilen apply(simp)
        apply(rule index_less)
          apply(simp) using ilen apply(simp)
          apply(simp)
        apply(simp only: a jo) using True1 apply (simp add: Suc_diff_Suc less_imp_diff_less)
        using ass by auto
      have "?i' = (index xs (xs ! i))" unfolding i' using fstF sndF a by simp
      then show ?case using jo ass by auto
    qed
  next
    case False

    then have smalla: "index xs q - Suc n = index xs q - n" by auto
    then have nomore: "swaps [index xs q - Suc n..<index xs q] xs
            =swaps [index xs q - n..<index xs q] xs" by auto
    show "(index xs q < i \<and> i < length xs \<longrightarrow>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs (xs ! i) \<and>
     index xs q < index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) \<and>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) < length xs) \<and>
    (index xs q = i \<longrightarrow>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs q - Suc n \<and>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs q - Suc n) \<and>
    (index xs q - Suc n \<le> i \<and> i < index xs q \<longrightarrow>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = Suc (index xs (xs ! i)) \<and>
     index xs q - Suc n < index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) \<and>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) \<le> index xs q) \<and>
    (i < index xs q - Suc n \<longrightarrow>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) = index xs (xs ! i) \<and>
     index (swaps [index xs q - Suc n..<index xs q] xs) (xs ! i) < index xs q - Suc n)"
      unfolding nomore smalla by (rule indH)
  qed
next
  case 0
  then show ?case apply(simp)
  proof (safe, goal_cases)
    case 1
    have " index xs (xs ! i) = i" apply(rule index_nth_id) using 1 by auto
    with 1 show ?case by auto
  next
    case 2
    have "xs ! index xs q = q" using 2 by(auto)
    with 2 show ?case by auto
  next
    case 3
    have a: "index xs q < length xs" apply(rule index_less) using 3 by auto
    have "index xs (xs ! i) = i" apply(rule index_nth_id) apply(fact 3(2)) using 3(3) a by auto
    with 3 show ?case by auto
  qed
qed

lemma mtf2_forward_effect1:
  "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> index xs q < i \<and> i < length xs
      \<Longrightarrow> index (mtf2 n q xs) (xs ! i) = index xs (xs ! i) \<and> index xs q < index (mtf2 n q xs) (xs ! i) \<and> index (mtf2 n q xs) (xs ! i) < length xs" and
  mtf2_forward_effect2: "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> index xs q = i
      \<Longrightarrow> index (mtf2 n q xs) (xs!i) = index xs q - n \<and> index xs q - n = index (mtf2 n q xs) (xs!i)" and
  mtf2_forward_effect3: "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> index xs q - n \<le> i \<and> i < index xs q
      \<Longrightarrow> index (mtf2 n q xs) (xs!i) = Suc (index xs (xs!i)) \<and> index xs q - n < index (mtf2 n q xs) (xs!i) \<and> index (mtf2 n q xs) (xs!i) \<le> index xs q" and
  mtf2_forward_effect4: "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> i < index xs q - n
      \<Longrightarrow> index (mtf2 n q xs) (xs!i) = index xs (xs!i) \<and> index (mtf2 n q xs) (xs!i) < index xs q - n"
apply(safe) using mtf2_effect by metis+

lemma yes[simp]: "index xs x < length xs
      \<Longrightarrow> (xs!index xs x ) = x" apply(rule nth_index) by (simp add: index_less_size_conv)

lemma mtf2_forward_effect1':
  "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> index xs q < index xs x \<and> index xs x < length xs
      \<Longrightarrow> index (mtf2 n q xs) x = index xs x \<and> index xs q < index (mtf2 n q xs) x \<and> index (mtf2 n q xs) x < length xs"
 using mtf2_forward_effect1[where xs=xs and i="index xs x"] yes
 by(auto)

lemma
 mtf2_forward_effect2': "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> index xs q = index xs x
      \<Longrightarrow> index (mtf2 n q xs) (xs!index xs x) = index xs q - n \<and> index xs q - n = index (mtf2 n q xs) (xs!index xs x)"
 using mtf2_forward_effect2[where xs=xs and i="index xs x"]
by fast

lemma
  mtf2_forward_effect3': "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> index xs q - n \<le> index xs x \<Longrightarrow> index xs x < index xs q
      \<Longrightarrow> index (mtf2 n q xs) (xs!index xs x) = Suc (index xs (xs!index xs x)) \<and> index xs q - n < index (mtf2 n q xs) (xs!index xs x) \<and> index (mtf2 n q xs) (xs!index xs x) \<le> index xs q"
 using mtf2_forward_effect3[where xs=xs and i="index xs x"]
by fast

lemma
  mtf2_forward_effect4': "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> index xs x < index xs q - n
      \<Longrightarrow> index (mtf2 n q xs) (xs!index xs x) = index xs (xs!index xs x) \<and> index (mtf2 n q xs) (xs!index xs x) < index xs q - n"
 using mtf2_forward_effect4[where xs=xs and i="index xs x"]
by fast

lemma mtf2_forward_beforeq: "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> i < index xs q
        \<Longrightarrow> index (mtf2 n q xs) (xs!i) \<le> index xs q"
apply (cases "i < index xs q - n")
  using mtf2_forward_effect4 apply force
  using mtf2_forward_effect3 using leI by metis

lemma x_stays_before_y_if_y_not_moved_to_front:
  assumes "q \<in> set xs" "distinct xs" "x \<in> set xs" "y \<in> set xs" "y \<noteq> q"
   and "x < y in xs"
  shows "x < y in (mtf2 n q xs)"
proof -
  from assms(3) obtain i where i: "i = index xs x" and i2: "i < length xs" by auto
  from assms(4) obtain j where j: "j = index xs y" and j2: "j < length xs" by auto
  have "x < y in xs \<Longrightarrow> x < y in (mtf2 n q xs)"
  apply(cases i xs rule: splitit[where q=q and n=n])
     apply(simp add: i  assms(1,2) mtf2_forward_effect1' before_in_def)
     apply(cases j xs rule: splitit[where q=q and n=n])
      apply (metis before_in_def assms(1-3) i j less_imp_diff_less mtf2_effect nth_index set_mtf2)
      apply(simp add: i j assms mtf2_forward_effect1' mtf2_forward_effect2' before_in_def)
      apply(simp add: i j assms mtf2_forward_effect1' mtf2_forward_effect2' before_in_def)
      apply(simp add: i j assms mtf2_forward_effect1' mtf2_forward_effect3' before_in_def)
      apply(rule j2)
     apply(cases j xs rule: splitit[where q=q and n=n])
      apply (smt before_in_def assms(1-3) i j le_less_trans mtf2_forward_effect1 mtf2_forward_effect3 nth_index set_mtf2)
      using assms(4,5) j apply simp
      apply (smt Suc_leI before_in_def assms(1-3) i j le_less_trans lessI mtf2_forward_effect3 nth_index set_mtf2)
      apply (simp add: before_in_def i j)
      apply(rule j2)
     apply(cases j xs rule: splitit[where q=q and n=n])
      apply (smt before_in_def assms(1-3) i j le_less_trans mtf2_forward_effect1 mtf2_forward_effect4 nth_index set_mtf2)
      using assms(4-5) j apply simp
      apply (smt before_in_def assms(1-3) i j le_less_trans less_imp_le_nat mtf2_forward_effect3 mtf2_forward_effect4 nth_index set_mtf2)
      apply (metis before_in_def assms(1-3) i j mtf2_forward_effect4 nth_index set_mtf2)
      apply(rule j2)
     apply(rule i2) done
   with assms(6) show ?thesis by auto
qed

corollary swapped_by_mtf2: "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> x \<in> set xs \<Longrightarrow>  y \<in> set xs \<Longrightarrow>
      x < y in xs \<Longrightarrow> y < x in (mtf2 n q xs) \<Longrightarrow> y = q"
apply(rule ccontr) using x_stays_before_y_if_y_not_moved_to_front not_before_in by (metis before_in_setD1)

lemma x_stays_before_y_if_y_not_moved_to_front_2dir: "q \<in> set xs \<Longrightarrow> distinct xs \<Longrightarrow> x \<in> set xs \<Longrightarrow>  y \<in> set xs \<Longrightarrow> y \<noteq> q \<Longrightarrow>
      x < y in xs = x < y in (mtf2 n q xs)"
oops

lemma mtf2_backwards_effect1:
  assumes "index xs q < length xs" "q \<in> set xs" "distinct xs"
    "index xs q < index (mtf2 n q xs) (xs ! i) \<and> index (mtf2 n q xs) (xs ! i) < length xs"
    "i < length xs"
  shows  "index xs q <  i \<and> i  < length xs"
proof -
  from assms(4) have "~ (index xs q - n = index (mtf2 n q xs) (xs ! i))" by auto
  with assms mtf2_forward_effect2 have 1: "~ (index xs q = i)" by metis
  from assms(4) have "~ (index xs q - n < index (mtf2 n q xs) (xs ! i) \<and> index (mtf2 n q xs) (xs ! i) \<le> index xs q)" by auto
  with assms mtf2_forward_effect3 have 2: "~ (index xs q - n \<le> i \<and> i < index xs q)" by metis
  from assms(4) have "~ (index (mtf2 n q xs) (xs ! i) < index xs q - n)" by auto
  with assms mtf2_forward_effect4 have 3: "~ (i < index xs q - n)" by metis

  from fullchar[OF assms(1)] assms(5) 1 2 3 show "index xs q <  i \<and> i  < length xs" by metis
qed

lemma mtf2_backwards_effect2:
  assumes "index xs q < length xs" "q \<in> set xs" "distinct xs" "index (mtf2 n q xs) (xs ! i) = index xs q - n"
    "i < length xs"
    shows "index xs q = i"
proof -
  from assms(4) have "~ (index xs q < index (mtf2 n q xs) (xs ! i) \<and> index (mtf2 n q xs) (xs ! i) < length xs)" by auto
  with assms mtf2_forward_effect1 have 1: "~ (index xs q < i \<and> i < length xs)" by metis
  from assms(4) have "~ (index xs q - n < index (mtf2 n q xs) (xs ! i) \<and> index (mtf2 n q xs) (xs ! i) \<le> index xs q)" by auto
  with assms mtf2_forward_effect3 have 2: "~ (index xs q - n \<le> i \<and> i < index xs q)" by metis
  from assms(4) have "~ (index (mtf2 n q xs) (xs ! i) < index xs q - n)" by auto
  with assms mtf2_forward_effect4 have 3: "~ (i < index xs q - n)" by metis

  from fullchar[OF assms(1)] assms(5) 1 2 3 show "index xs q = i" by metis
qed

lemma mtf2_backwards_effect3:
  assumes "index xs q < length xs" "q \<in> set xs" "distinct xs"
    "index xs q - n < index (mtf2 n q xs) (xs ! i) \<and> index (mtf2 n q xs) (xs ! i) \<le> index xs q"
    "i < length xs"
  shows "index xs q - n \<le> i \<and> i < index xs q"
proof -
  from assms(4) have "~ (index xs q < index (mtf2 n q xs) (xs ! i) \<and> index (mtf2 n q xs) (xs ! i) < length xs)" by auto
  with assms mtf2_forward_effect1 have 2: "~ (index xs q <  i \<and> i  < length xs)" by metis
  from assms(4) have "~ (index xs q - n = index (mtf2 n q xs) (xs ! i))" by auto
  with assms mtf2_forward_effect2 have 1: "~ (index xs q = i)" by metis
  from assms(4) have "~ (index (mtf2 n q xs) (xs ! i) < index xs q - n)" by auto
  with assms mtf2_forward_effect4 have 3: "~ (i < index xs q - n)" by metis

  from fullchar[OF assms(1)] assms(5) 1 2 3 show "index xs q - n \<le> i \<and> i < index xs q" by metis
qed

lemma mtf2_backwards_effect4:
  assumes "index xs q < length xs" "q \<in> set xs" "distinct xs"
   "index (mtf2 n q xs) (xs ! i) < index xs q - n"
   "i < length xs"
  shows "i < index xs q - n"
proof -
  from assms(4) have "~ (index xs q < index (mtf2 n q xs) (xs ! i) \<and> index (mtf2 n q xs) (xs ! i) < length xs)" by auto
  with assms mtf2_forward_effect1 have 2: "~ (index xs q <  i \<and> i  < length xs)" by metis
  from assms(4) have "~ (index xs q - n = index (mtf2 n q xs) (xs ! i))" by auto
  with assms mtf2_forward_effect2 have 1: "~ (index xs q = i)" by metis
  from assms(4) have "~ (index xs q - n < index (mtf2 n q xs) (xs ! i) \<and> index (mtf2 n q xs) (xs ! i) \<le> index xs q)" by auto
  with assms mtf2_forward_effect3 have 3: "~ (index xs q - n \<le> i \<and> i < index xs q)" by metis

  from fullchar[OF assms(1)] assms(5) 1 2 3 show "i < index xs q - n" by metis
qed

lemma mtf2_backwards_effect4':
 assumes "index xs q < length xs" "q \<in> set xs" "distinct xs"
  "index (mtf2 n q xs) x < index xs q - n"
  "x \<in> set xs"
 shows "(index xs x) < index xs q - n"
 using assms mtf2_backwards_effect4[where xs=xs and i="index xs x"] yes
by auto

lemma
  assumes distA: "distinct A" and
          asm: "q \<in> set A"
  shows
      mtf2_mono:  "q< x in A \<Longrightarrow> q < x in (mtf2 n q A)" and
      mtf2_q_after: "index (mtf2 n q A) q =  index A q - n"
proof -

    have lele: "(q < x in A \<longrightarrow> q < x in swaps [index A q - n..<index A q] A) \<and> (index (swaps [index A q - n..<index A q] A) q =  index A q - n)"
    apply(induct n) apply(simp)
    proof -
      fix n
      assume ind: "(q < x in A \<longrightarrow> q < x in swaps [index A q - n..<index A q] A)
            \<and> index (swaps [index A q - n..<index A q] A) q =  index A q - n"
      then have iH: " q < x in A \<Longrightarrow> q < x in swaps [index A q - n..<index A q] A" by auto
      from ind have indH2: "index (swaps [index A q - n..<index A q] A) q =  index A q - n" by auto

      show "(q < x in A \<longrightarrow> q < x in swaps [index A q - Suc n..<index A q] A) \<and>
          index (swaps [index A q - Suc n..<index A q] A) q = index A q - Suc n" (is "?part1 \<and> ?part2")
      proof (cases "index A q \<ge> Suc n")
          case True
          then have onemore: "[index A q - Suc n..<index A q] = (index A q - Suc n) # [index A q - n..<index A q]"
                using Suc_diff_Suc upt_rec by auto

          from onemore have yeah: "swaps [index A q - Suc n..<index A q] A
              = swap (index A q - Suc n) (swaps  [index A q - n..<index A q] A)" by auto

            from indH2 have gr: "index (swaps [index A q - n..<index A q] A) q =  Suc(index A q - Suc n)" using Suc_diff_Suc True by auto
            have whereisq: "swaps [index A q - n..<index A q] A ! Suc (index A q - Suc n) = q"
                unfolding gr[symmetric] apply(rule nth_index) using asm by auto

          have indSi: "index A q < length A" using asm index_less by auto
          have 3: "Suc (index A q - Suc n) < length (swaps [index A q - n..<index A q] A)" using True
            apply(auto simp: Suc_diff_Suc asm) using indSi by auto
          have 1: "q \<noteq> swaps [index A q - n..<index A q] A ! (index A q - Suc n)"
              proof
                assume as: "q = swaps [index A q - n..<index A q] A ! (index A q - Suc n)"
                {
                  fix xs x
                  have "Suc x < length xs \<Longrightarrow> xs ! x = q \<Longrightarrow> xs ! Suc x = q \<Longrightarrow> \<not> distinct xs"
                  by (metis Suc_lessD index_nth_id n_not_Suc_n)
                } note cool=this

                have "\<not> distinct (swaps [index A q - n..<index A q] A)"
                  apply(rule cool[of "(index A q - Suc n)"])
                    apply(simp only: 3)
                    apply(simp only: as[symmetric])
                    by(simp only: whereisq)
                then show "False" using distA by auto
              qed

          have part1: ?part1
          proof
            assume qx: "q < x in A"
            {
              fix q x B i
               assume a1: "q < x in B"
               assume a2: "~ q = B ! i"
               assume a3: "distinct B"
               assume a4: "Suc i < length B"

               have "dist_perm B B" by(simp add: a3)
               moreover have "Suc i < length B" using a4 by auto
               moreover have "q < x in B \<and> \<not> (q = B ! i \<and> x = B ! Suc i)" using a1 a2 by auto
               ultimately have "q < x in swap i B"
                using before_in_swap[of B B] by simp
           } note grr=this

            have 2: "distinct (swaps [index A q - n..<index A q] A)" using distA by auto

            show "q < x in swaps [index A q - Suc n..<index A q] A"
              apply(simp only: yeah)
              apply(rule grr[OF iH[OF qx]]) using 1 2 3 by auto
           qed

           let ?xs = "(swaps [index A q - n..<index A q] A)"
           let ?n = "(index A q - Suc n)"
           have "?xs ! Suc ?n = swaps [index A q - n..<index A q] A ! (index (swaps [index A q - n..<index A q] A) q)"
              using indH2 Suc_diff_Suc True by auto
           also have "\<dots> = q" apply(rule nth_index) using asm by auto
           finally have sndTrue: "?xs ! Suc ?n = q" .
           have fstFalse: "~ q = ?xs ! ?n" by (fact 1)

           have "index (swaps [index A q - Suc n..<index A q] A) q
              = index (swap (index A q - Suc n) ?xs) q" by (simp only: yeah)
           also have "\<dots> = (if q = ?xs ! ?n then Suc ?n else if q = ?xs ! Suc ?n then ?n else index ?xs q)"
            apply(rule index_swap_distinct)
              apply(simp add: distA)
              by (fact 3)
           also have "\<dots> = ?n" using fstFalse sndTrue by auto
           finally have part2: ?part2 .

           from part1 part2 show "?part1 \<and> ?part2" by simp
        next
          case False
          then have a: "index A q - Suc n = index A q - n" by auto
          then have b: "[index A q - Suc n..<index A q] = [index A q - n..<index A q]" by auto
          show ?thesis apply(simp only: b a) by (fact ind)
        qed
      qed

    show "q < x in A \<Longrightarrow> q < x in (mtf2 n q A)"
        "(index (mtf2 n q A) q) =  index A q - n"
    unfolding mtf2_def
      using asm lele apply(simp)
      using asm lele by(simp)
qed

subsection "effect of mtf2 on index"

lemma swapsthrough: "distinct xs \<Longrightarrow> q \<in> set xs \<Longrightarrow> index ( swaps [index xs q - entf..<index xs q] xs ) q = index xs q - entf"
proof (induct entf)
  case (Suc e)
  note iH=this
  show ?case
  proof (cases "index xs q - e")
    case 0
    then have "[index xs q - Suc e..<index xs q]
        = [index xs q - e..<index xs q]" by force
    then have "index (swaps [index xs q - Suc e..<index xs q] xs) q
          =  index xs q - e" using Suc by auto
    also have "\<dots> = index xs q - (Suc e)" using 0 by auto
    finally show "index (swaps [index xs q - Suc e..<index xs q] xs) q = index xs q - Suc e" .
  next
    case (Suc f)

    have gaa: "Suc (index xs q - Suc e) = index xs q - e" using Suc by auto

    from Suc have "index xs q - e \<le> index xs q" by auto
    also have "\<dots> < length xs" by(simp add: index_less_size_conv iH)
    finally have indle: "index xs q - e < length xs".

    have arg: "Suc (index xs q - Suc e) < length (swaps [index xs q - e..<index xs q] xs)"
      apply(auto) unfolding gaa using indle by simp
    then have arg2: "index xs q - Suc e < length (swaps [index xs q - e..<index xs q] xs)" by auto
    from Suc have nexter: "index xs q - e = Suc (index xs q - (Suc e))" by auto
    then have aaa: "[index xs q - Suc e..<index xs q]
        = (index xs q - Suc e)#[index xs q - e..<index xs q]" using upt_rec by auto

    let ?i="index xs q - Suc e"
    let ?rest="swaps [index xs q - e..<index xs q] xs"
    from iH nexter have indj: "index ?rest q = Suc ?i" by auto

    from iH(2) have "distinct ?rest" by auto

    have "?rest ! (index ?rest q) = q" apply(rule nth_index) by(simp add: iH)
    with indj have whichcase: "q = ?rest ! Suc ?i" by auto

    with \<open>distinct ?rest\<close> have whichcase2: "~ q = ?rest ! ?i"
          by (metis Suc_lessD arg index_nth_id n_not_Suc_n)

    from aaa have "index (swaps [index xs q - Suc e..<index xs q] xs) q
        = index (swap (index xs q - Suc e) (swaps [index xs q - e..<index xs q] xs)) q"
          by auto
    also have "\<dots> = (if q = ?rest ! ?i then (Suc ?i) else if q = ?rest ! (Suc ?i) then ?i else index ?rest q)"
        apply(simp only: swap_def arg if_True)
        apply(rule index_swap_if_distinct)
          apply(simp add: iH)
          apply(simp only: arg2)
          by(simp only: arg)
    also have "\<dots> = ?i" using whichcase whichcase2 by simp
    finally show "index (swaps [index xs q - Suc e..<index xs q] xs) q =
              index xs q - Suc e" .
  qed
next
  case 0
  show ?case by simp
qed

term "mtf2"
lemma mtf2_moves_to_front: "distinct xs \<Longrightarrow> q \<in> set xs \<Longrightarrow> index (mtf2 (length xs) q xs) q  = 0"
unfolding mtf2_def
proof -
  assume distxs: "distinct xs"
  assume qinxs: "q \<in> set xs"
  have " index (if q \<in> set xs then swaps [index xs q - length xs..<index xs q] xs else xs) q
    = index ( swaps [index xs q - length xs..<index xs q] xs) q" using qinxs by auto
  also have "\<dots> = index xs q - (length xs)" apply(rule swapsthrough) using distxs qinxs by auto
  also have "\<dots> = 0" using index_less_size_conv qinxs by (simp add: index_le_size)
  finally show "index (if q \<in> set xs then swaps [index xs q - length xs..<index xs q] xs else xs) q = 0" .
qed

lemma xy_relativorder_mtf2:
  assumes
    "q\<noteq>x" "q\<noteq>y" "distinct xs" "x\<in>set xs" "y\<in>set xs" "q\<in>set xs"
  shows "x < y in mtf2 n q xs
          = x < y in xs"
using assms
by (metis before_in_setD2 not_before_in x_stays_before_y_if_y_not_moved_to_front)

lemma mtf2_moves_to_frontm1: "distinct xs \<Longrightarrow> q \<in> set xs \<Longrightarrow> index (mtf2 (length xs -1) q xs) q  = 0"
unfolding mtf2_def
proof -
  assume distxs: "distinct xs"
  assume qinxs: "q \<in> set xs"
  have " index (if q \<in> set xs then swaps [index xs q - (length xs -1)..<index xs q] xs else xs) q
    = index ( swaps [index xs q - (length xs -1)..<index xs q] xs) q" using qinxs by auto
  also have "\<dots> = index xs q - (length xs -1)" apply(rule swapsthrough) using distxs qinxs by auto
  also have "\<dots> = 0" using index_less_size_conv qinxs
by (metis Suc_pred' gr0I length_pos_if_in_set less_irrefl less_trans_Suc zero_less_diff)
  finally show "index (if q \<in> set xs then swaps [index xs q - (length xs -1)..<index xs q] xs else xs) q = 0" .
qed

lemma mtf2_moves_to_front': "distinct xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> x\<noteq>y \<Longrightarrow> x < y in mtf2 (length xs-1) x xs = True"
using mtf2_moves_to_frontm1 by (metis before_in_def gr0I index_eq_index_conv set_mtf2)

lemma mtf2_moves_to_front'': "distinct xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> x\<noteq>y \<Longrightarrow> x < y in mtf2 (length xs) x xs = True"
using mtf2_moves_to_front by (metis before_in_def gr0I index_eq_index_conv set_mtf2)

end


theory nicomachus_theorem
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

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

fun sum :: "Nat => Nat" where
"sum (Z) = Z"
| "sum (S n) = plus (sum n) (S n)"

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

fun cubes :: "Nat => Nat" where
"cubes (Z) = Z"
| "cubes (S n) = plus (cubes n) (mult (mult (S n) (S n)) (S n))"

(*hipster plus sum mult cubes *)
lemma lemma_a [thy_expl]: "plus x2 Z = x2"
by (hipster_induct_schemes plus.simps)

lemma lemma_aa [thy_expl]: "plus (plus x2 y2) z2 = plus x2 (plus y2 z2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ab [thy_expl]: "plus x2 (S y2) = S (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ac [thy_expl]: "plus x1 (plus y1 x1) = plus y1 (plus x1 x1)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ad [thy_expl]: "plus x2 (plus y2 y2) = plus y2 (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ae [thy_expl]: "plus x2 (S y2) = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_af [thy_expl]: "plus (S x2) y2 = S (plus y2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ag [thy_expl]: "plus (plus x2 y2) (plus x2 z2) = plus (plus x2 z2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps Nat.exhaust)

lemma lemma_ah [thy_expl]: "plus (plus x2 y2) (plus z2 x2) = plus (plus z2 x2) (plus x2 y2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_ai [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus z2 x2)"
by (hipster_induct_schemes plus.simps)

lemma lemma_aj [thy_expl]: "plus x2 y2 = plus y2 x2"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ak [thy_expl]: "mult x2 Z = Z"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_al [thy_expl]: "mult x1 (S y1) = plus x1 (mult x1 y1)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_am [thy_expl]: "mult x2 (plus y2 y2) = mult y2 (plus x2 x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_an [thy_expl]: "mult x2 (S y2) = plus x2 (mult y2 x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ao [thy_expl]: "mult (plus x2 y2) x2 = mult x2 (plus x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps Nat.exhaust)

lemma lemma_ap [thy_expl]: "mult (mult x1 y1) x1 = mult x1 (mult x1 y1)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_aq [thy_expl]: "mult (plus x2 x2) y2 = mult x2 (plus y2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ar [thy_expl]: "mult (mult x2 x2) y2 = mult y2 (mult x2 x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_as [thy_expl]: "plus (mult x1 y1) (mult y1 z1) = mult y1 (plus x1 z1)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_at [thy_expl]: "plus (mult x2 y2) (mult z2 x2) = mult x2 (plus z2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_au [thy_expl]: "mult (plus x2 y2) (plus x2 z2) = mult (plus x2 z2) (plus x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_av [thy_expl]: "mult (plus x2 y2) (plus z2 y2) = mult (plus z2 y2) (plus x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_aw [thy_expl]: "mult (mult x2 y2) (plus x2 z2) = mult (plus x2 z2) (mult x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ax [thy_expl]: "mult (mult x2 y2) (plus y2 z2) = mult (plus y2 z2) (mult x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ay [thy_expl]: "mult (mult x2 y2) (mult z2 x2) = mult (mult z2 x2) (mult x2 y2)"
by (hipster_induct_schemes mult.simps plus.simps Nat.exhaust)

lemma lemma_az [thy_expl]: "mult (plus x2 x2) (plus y2 z2) = mult (plus y2 z2) (plus x2 x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_ba [thy_expl]: "mult (plus x2 x2) (mult y2 z2) = mult (mult y2 z2) (plus x2 x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_bb [thy_expl]: "mult (S x2) (S y2) = mult (S y2) (S x2)"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_bc [thy_expl]: "mult x2 y2 = mult y2 x2"
by (hipster_induct_schemes mult.simps plus.simps)

lemma lemma_bd [thy_expl]: "mult x2 (mult y2 z2) = mult y2 (mult x2 z2)"
by (hipster_induct_schemes mult.simps plus.simps Nat.exhaust)

lemma lemma_be [thy_expl]: "plus (mult x1 y1) (mult x1 z1) = mult x1 (plus y1 z1)"
by (hipster_induct_schemes mult.simps plus.simps)

(*hipster mult plus sum*)
lemma lemma_bf [thy_expl]: "plus (sum x1) (sum x1) = plus x1 (mult x1 x1)"
by (hipster_induct_schemes mult.simps plus.simps sum.simps Nat.exhaust)

(*hipster cubes mult plus sum*)
lemma lemma_bg [thy_expl]: "mult (plus x1 x1) (sum y1) = mult (mult x1 y1) (S y1)"
by (hipster_induct_schemes cubes.simps mult.simps plus.simps sum.simps)

lemma lemma_bh [thy_expl]: "mult (plus x1 x1) (sum y1) = mult (mult y1 x1) (S y1)"
by (hipster_induct_schemes cubes.simps mult.simps plus.simps sum.simps)

lemma lemma_bi [thy_expl]: "mult (S x3) (mult x3 x3) = mult (plus x3 x3) (sum x3)"
by (hipster_induct_schemes cubes.simps plus.simps mult.simps sum.simps)

(*hipster mult plus sum cubes*)

lemma lemma_ai2 [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus x2 z2)"
by (hipster_induct_schemes plus.simps)

(*mult (sum x) (sum x) = cubes x \<Longrightarrow>
         S (plus (plus x (sum x)) (mult (plus x (sum x)) (S (plus x (sum x))))) =
         plus (cubes x) (S (plus (plus x (mult x (S x))) (mult x (S (plus x (mult x (S x))))))*)

lemma unknown [thy_expl]: "mult (sum x) (sum x) = cubes x"
apply(induction x)
apply simp_all
apply(simp_all add: lemma_bf lemma_be lemma_bc lemma_aj lemma_ai2)
(*sledgehammer*)
apply (metis mult.simps sum.simps cubes.simps plus.simps Nat.exhaust lemma_aa lemma_ab lemma_ai2 lemma_aj lemma_al lemma_as lemma_bc lemma_be lemma_bf)
done
(*lemma lemma_ai [thy_expl]: "plus x2 (plus y2 z2) = plus y2 (plus z2 x2)"
*)
theorem x0 :
  "!! (n :: Nat) . (cubes n) = (mult (sum n) (sum n))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>Common discrete functions\<close>

theory Discrete
imports Complex_MainRLT
begin

subsection \<open>Discrete logarithm\<close>

context
begin

qualified fun log :: "nat \<Rightarrow> nat"
  where [simp del]: "log n = (if n < 2 then 0 else Suc (log (n div 2)))"

lemma log_induct [consumes 1, case_names one double]:
  fixes n :: nat
  assumes "n > 0"
  assumes one: "P 1"
  assumes double: "\<And>n. n \<ge> 2 \<Longrightarrow> P (n div 2) \<Longrightarrow> P n"
  shows "P n"
using \<open>n > 0\<close> proof (induct n rule: log.induct)
  fix n
  assume "\<not> n < 2 \<Longrightarrow>
          0 < n div 2 \<Longrightarrow> P (n div 2)"
  then have *: "n \<ge> 2 \<Longrightarrow> P (n div 2)" by simp
  assume "n > 0"
  show "P n"
  proof (cases "n = 1")
    case True
    with one show ?thesis by simp
  next
    case False
    with \<open>n > 0\<close> have "n \<ge> 2" by auto
    with * have "P (n div 2)" .
    with \<open>n \<ge> 2\<close> show ?thesis by (rule double)
  qed
qed

lemma log_zero [simp]: "log 0 = 0"
  by (simp add: log.simps)

lemma log_one [simp]: "log 1 = 0"
  by (simp add: log.simps)

lemma log_Suc_zero [simp]: "log (Suc 0) = 0"
  using log_one by simp

lemma log_rec: "n \<ge> 2 \<Longrightarrow> log n = Suc (log (n div 2))"
  by (simp add: log.simps)

lemma log_twice [simp]: "n \<noteq> 0 \<Longrightarrow> log (2 * n) = Suc (log n)"
  by (simp add: log_rec)

lemma log_half [simp]: "log (n div 2) = log n - 1"
proof (cases "n < 2")
  case True
  then have "n = 0 \<or> n = 1" by arith
  then show ?thesis by (auto simp del: One_nat_def)
next
  case False
  then show ?thesis by (simp add: log_rec)
qed

lemma log_exp [simp]: "log (2 ^ n) = n"
  by (induct n) simp_all

lemma log_mono: "mono log"
proof
  fix m n :: nat
  assume "m \<le> n"
  then show "log m \<le> log n"
  proof (induct m arbitrary: n rule: log.induct)
    case (1 m)
    then have mn2: "m div 2 \<le> n div 2" by arith
    show "log m \<le> log n"
    proof (cases "m \<ge> 2")
      case False
      then have "m = 0 \<or> m = 1" by arith
      then show ?thesis by (auto simp del: One_nat_def)
    next
      case True then have "\<not> m < 2" by simp
      with mn2 have "n \<ge> 2" by arith
      from True have m2_0: "m div 2 \<noteq> 0" by arith
      with mn2 have n2_0: "n div 2 \<noteq> 0" by arith
      from \<open>\<not> m < 2\<close> "1.hyps" mn2 have "log (m div 2) \<le> log (n div 2)" by blast
      with m2_0 n2_0 have "log (2 * (m div 2)) \<le> log (2 * (n div 2))" by simp
      with m2_0 n2_0 \<open>m \<ge> 2\<close> \<open>n \<ge> 2\<close> show ?thesis by (simp only: log_rec [of m] log_rec [of n]) simp
    qed
  qed
qed

lemma log_exp2_le:
  assumes "n > 0"
  shows "2 ^ log n \<le> n"
  using assms
proof (induct n rule: log_induct)
  case one
  then show ?case by simp
next
  case (double n)
  with log_mono have "log n \<ge> Suc 0"
    by (simp add: log.simps)
  assume "2 ^ log (n div 2) \<le> n div 2"
  with \<open>n \<ge> 2\<close> have "2 ^ (log n - Suc 0) \<le> n div 2" by simp
  then have "2 ^ (log n - Suc 0) * 2 ^ 1 \<le> n div 2 * 2" by simp
  with \<open>log n \<ge> Suc 0\<close> have "2 ^ log n \<le> n div 2 * 2"
    unfolding power_add [symmetric] by simp
  also have "n div 2 * 2 \<le> n" by (cases "even n") simp_all
  finally show ?case .
qed

lemma log_exp2_gt: "2 * 2 ^ log n > n"
proof (cases "n > 0")
  case True
  thus ?thesis
  proof (induct n rule: log_induct)
    case (double n)
    thus ?case
      by (cases "even n") (auto elim!: evenE oddE simp: field_simps log.simps)
  qed simp_all
qed simp_all

lemma log_exp2_ge: "2 * 2 ^ log n \<ge> n"
  using log_exp2_gt[of n] by simp

lemma log_le_iff: "m \<le> n \<Longrightarrow> log m \<le> log n"
  by (rule monoD [OF log_mono])

lemma log_eqI:
  assumes "n > 0" "2^k \<le> n" "n < 2 * 2^k"
  shows   "log n = k"
proof (rule antisym)
  from \<open>n > 0\<close> have "2 ^ log n \<le> n" by (rule log_exp2_le)
  also have "\<dots> < 2 ^ Suc k" using assms by simp
  finally have "log n < Suc k" by (subst (asm) power_strict_increasing_iff) simp_all
  thus "log n \<le> k" by simp
next
  have "2^k \<le> n" by fact
  also have "\<dots> < 2^(Suc (log n))" by (simp add: log_exp2_gt)
  finally have "k < Suc (log n)" by (subst (asm) power_strict_increasing_iff) simp_all
  thus "k \<le> log n" by simp
qed

lemma log_altdef: "log n = (if n = 0 then 0 else nat \<lfloor>Transcendental.log 2 (real_of_nat n)\<rfloor>)"
proof (cases "n = 0")
  case False
  have "\<lfloor>Transcendental.log 2 (real_of_nat n)\<rfloor> = int (log n)"
  proof (rule floor_unique)
    from False have "2 powr (real (log n)) \<le> real n"
      by (simp add: powr_realpow log_exp2_le)
    hence "Transcendental.log 2 (2 powr (real (log n))) \<le> Transcendental.log 2 (real n)"
      using False by (subst Transcendental.log_le_cancel_iff) simp_all
    also have "Transcendental.log 2 (2 powr (real (log n))) = real (log n)" by simp
    finally show "real_of_int (int (log n)) \<le> Transcendental.log 2 (real n)" by simp
  next
    have "real n < real (2 * 2 ^ log n)"
      by (subst of_nat_less_iff) (rule log_exp2_gt)
    also have "\<dots> = 2 powr (real (log n) + 1)"
      by (simp add: powr_add powr_realpow)
    finally have "Transcendental.log 2 (real n) < Transcendental.log 2 \<dots>"
      using False by (subst Transcendental.log_less_cancel_iff) simp_all
    also have "\<dots> = real (log n) + 1" by simp
    finally show "Transcendental.log 2 (real n) < real_of_int (int (log n)) + 1" by simp
  qed
  thus ?thesis by simp
qed simp_all

subsection \<open>Discrete square root\<close>

qualified definition sqrt :: "nat \<Rightarrow> nat"
  where "sqrt n = Max {m. m\<^sup>2 \<le> n}"

lemma sqrt_aux:
  fixes n :: nat
  shows "finite {m. m\<^sup>2 \<le> n}" and "{m. m\<^sup>2 \<le> n} \<noteq> {}"
proof -
  { fix m
    assume "m\<^sup>2 \<le> n"
    then have "m \<le> n"
      by (cases m) (simp_all add: power2_eq_square)
  } note ** = this
  then have "{m. m\<^sup>2 \<le> n} \<subseteq> {m. m \<le> n}" by auto
  then show "finite {m. m\<^sup>2 \<le> n}" by (rule finite_subset) rule
  have "0\<^sup>2 \<le> n" by simp
  then show *: "{m. m\<^sup>2 \<le> n} \<noteq> {}" by blast
qed

lemma sqrt_unique:
  assumes "m^2 \<le> n" "n < (Suc m)^2"
  shows   "Discrete.sqrt n = m"
proof -
  have "m' \<le> m" if "m'^2 \<le> n" for m'
  proof -
    note that
    also note assms(2)
    finally have "m' < Suc m" by (rule power_less_imp_less_base) simp_all
    thus "m' \<le> m" by simp
  qed
  with \<open>m^2 \<le> n\<close> sqrt_aux[of n] show ?thesis unfolding Discrete.sqrt_def
    by (intro antisym Max.boundedI Max.coboundedI) simp_all
qed

lemma sqrt_code[code]: "sqrt n = Max (Set.filter (\<lambda>m. m\<^sup>2 \<le> n) {0..n})"
proof -
  from power2_nat_le_imp_le [of _ n] have "{m. m \<le> n \<and> m\<^sup>2 \<le> n} = {m. m\<^sup>2 \<le> n}" by auto
  then show ?thesis by (simp add: sqrt_def Set.filter_def)
qed

lemma sqrt_inverse_power2 [simp]: "sqrt (n\<^sup>2) = n"
proof -
  have "{m. m \<le> n} \<noteq> {}" by auto
  then have "Max {m. m \<le> n} \<le> n" by auto
  then show ?thesis
    by (auto simp add: sqrt_def power2_nat_le_eq_le intro: antisym)
qed

lemma sqrt_zero [simp]: "sqrt 0 = 0"
  using sqrt_inverse_power2 [of 0] by simp

lemma sqrt_one [simp]: "sqrt 1 = 1"
  using sqrt_inverse_power2 [of 1] by simp

lemma mono_sqrt: "mono sqrt"
proof
  fix m n :: nat
  have *: "0 * 0 \<le> m" by simp
  assume "m \<le> n"
  then show "sqrt m \<le> sqrt n"
    by (auto intro!: Max_mono \<open>0 * 0 \<le> m\<close> finite_less_ub simp add: power2_eq_square sqrt_def)
qed

lemma mono_sqrt': "m \<le> n \<Longrightarrow> Discrete.sqrt m \<le> Discrete.sqrt n"
  using mono_sqrt unfolding mono_def by auto

lemma sqrt_greater_zero_iff [simp]: "sqrt n > 0 \<longleftrightarrow> n > 0"
proof -
  have *: "0 < Max {m. m\<^sup>2 \<le> n} \<longleftrightarrow> (\<exists>a\<in>{m. m\<^sup>2 \<le> n}. 0 < a)"
    by (rule Max_gr_iff) (fact sqrt_aux)+
  show ?thesis
  proof
    assume "0 < sqrt n"
    then have "0 < Max {m. m\<^sup>2 \<le> n}" by (simp add: sqrt_def)
    with * show "0 < n" by (auto dest: power2_nat_le_imp_le)
  next
    assume "0 < n"
    then have "1\<^sup>2 \<le> n \<and> 0 < (1::nat)" by simp
    then have "\<exists>q. q\<^sup>2 \<le> n \<and> 0 < q" ..
    with * have "0 < Max {m. m\<^sup>2 \<le> n}" by blast
    then show "0 < sqrt n" by  (simp add: sqrt_def)
  qed
qed

lemma sqrt_power2_le [simp]: "(sqrt n)\<^sup>2 \<le> n" (* FIXME tune proof *)
proof (cases "n > 0")
  case False then show ?thesis by simp
next
  case True then have "sqrt n > 0" by simp
  then have "mono (times (Max {m. m\<^sup>2 \<le> n}))" by (auto intro: mono_times_nat simp add: sqrt_def)
  then have *: "Max {m. m\<^sup>2 \<le> n} * Max {m. m\<^sup>2 \<le> n} = Max (times (Max {m. m\<^sup>2 \<le> n}) ` {m. m\<^sup>2 \<le> n})"
    using sqrt_aux [of n] by (rule mono_Max_commute)
  have "\<And>a. a * a \<le> n \<Longrightarrow> Max {m. m * m \<le> n} * a \<le> n"
  proof -
    fix q
    assume "q * q \<le> n"
    show "Max {m. m * m \<le> n} * q \<le> n"
    proof (cases "q > 0")
      case False then show ?thesis by simp
    next
      case True then have "mono (times q)" by (rule mono_times_nat)
      then have "q * Max {m. m * m \<le> n} = Max (times q ` {m. m * m \<le> n})"
        using sqrt_aux [of n] by (auto simp add: power2_eq_square intro: mono_Max_commute)
      then have "Max {m. m * m \<le> n} * q = Max (times q ` {m. m * m \<le> n})" by (simp add: ac_simps)
      moreover have "finite ((*) q ` {m. m * m \<le> n})"
        by (metis (mono_tags) finite_imageI finite_less_ub le_square)
      moreover have "\<exists>x. x * x \<le> n"
        by (metis \<open>q * q \<le> n\<close>)
      ultimately show ?thesis
        by simp (metis \<open>q * q \<le> n\<close> le_cases mult_le_mono1 mult_le_mono2 order_trans)
    qed
  qed
  then have "Max ((*) (Max {m. m * m \<le> n}) ` {m. m * m \<le> n}) \<le> n"
    apply (subst Max_le_iff)
      apply (metis (mono_tags) finite_imageI finite_less_ub le_square)
     apply auto
    apply (metis le0 mult_0_right)
    done
  with * show ?thesis by (simp add: sqrt_def power2_eq_square)
qed

lemma sqrt_le: "sqrt n \<le> n"
  using sqrt_aux [of n] by (auto simp add: sqrt_def intro: power2_nat_le_imp_le)

text \<open>Additional facts about the discrete square root, thanks to Julian Biendarra, Manuel Eberl\<close>

lemma Suc_sqrt_power2_gt: "n < (Suc (Discrete.sqrt n))^2"
  using Max_ge[OF Discrete.sqrt_aux(1), of "Discrete.sqrt n + 1" n]
  by (cases "n < (Suc (Discrete.sqrt n))^2") (simp_all add: Discrete.sqrt_def)

lemma le_sqrt_iff: "x \<le> Discrete.sqrt y \<longleftrightarrow> x^2 \<le> y"
proof -
  have "x \<le> Discrete.sqrt y \<longleftrightarrow> (\<exists>z. z\<^sup>2 \<le> y \<and> x \<le> z)"
    using Max_ge_iff[OF Discrete.sqrt_aux, of x y] by (simp add: Discrete.sqrt_def)
  also have "\<dots> \<longleftrightarrow> x^2 \<le> y"
  proof safe
    fix z assume "x \<le> z" "z ^ 2 \<le> y"
    thus "x^2 \<le> y" by (intro le_trans[of "x^2" "z^2" y]) (simp_all add: power2_nat_le_eq_le)
  qed auto
  finally show ?thesis .
qed

lemma le_sqrtI: "x^2 \<le> y \<Longrightarrow> x \<le> Discrete.sqrt y"
  by (simp add: le_sqrt_iff)

lemma sqrt_le_iff: "Discrete.sqrt y \<le> x \<longleftrightarrow> (\<forall>z. z^2 \<le> y \<longrightarrow> z \<le> x)"
  using Max.bounded_iff[OF Discrete.sqrt_aux] by (simp add: Discrete.sqrt_def)

lemma sqrt_leI:
  "(\<And>z. z^2 \<le> y \<Longrightarrow> z \<le> x) \<Longrightarrow> Discrete.sqrt y \<le> x"
  by (simp add: sqrt_le_iff)

lemma sqrt_Suc:
  "Discrete.sqrt (Suc n) = (if \<exists>m. Suc n = m^2 then Suc (Discrete.sqrt n) else Discrete.sqrt n)"
proof cases
  assume "\<exists> m. Suc n = m^2"
  then obtain m where m_def: "Suc n = m^2" by blast
  then have lhs: "Discrete.sqrt (Suc n) = m" by simp
  from m_def sqrt_power2_le[of n]
    have "(Discrete.sqrt n)^2 < m^2" by linarith
  with power2_less_imp_less have lt_m: "Discrete.sqrt n < m" by blast
  from m_def Suc_sqrt_power2_gt[of "n"]
    have "m^2 \<le> (Suc(Discrete.sqrt n))^2"
      by linarith
  with power2_nat_le_eq_le have "m \<le> Suc (Discrete.sqrt n)" by blast
  with lt_m have "m = Suc (Discrete.sqrt n)" by simp
  with lhs m_def show ?thesis by fastforce
next
  assume asm: "\<not> (\<exists> m. Suc n = m^2)"
  hence "Suc n \<noteq> (Discrete.sqrt (Suc n))^2" by simp
  with sqrt_power2_le[of "Suc n"]
    have "Discrete.sqrt (Suc n) \<le> Discrete.sqrt n" by (intro le_sqrtI) linarith
  moreover have "Discrete.sqrt (Suc n) \<ge> Discrete.sqrt n"
    by (intro monoD[OF mono_sqrt]) simp_all
  ultimately show ?thesis using asm by simp
qed

end

end


section \<open>Relabel-to-Front Algorithm\<close>
theory Relabel_To_Front
imports
  Prpu_Common_Inst
  Graph_Topological_Ordering
begin
  text \<open>As an example for an implementation, Cormen et al.\ discuss the
    relabel-to-front algorithm.
    It iterates over a queue of nodes, discharging each node, and putting
    a node to the front of the queue if it has been relabeled.
\<close>

subsection \<open>Admissible Network\<close>
text \<open>The admissible network consists of those edges over which we
  can push flow. \<close>

context Network
begin
  definition adm_edges :: "'capacity flow \<Rightarrow> (nat\<Rightarrow>nat) \<Rightarrow> _"
    where "adm_edges f l \<equiv> {(u,v)\<in>cfE_of f. l u = l v + 1}"

  lemma adm_edges_inv_disj: "adm_edges f l \<inter> (adm_edges f l)\<inverse> = {}"
    unfolding adm_edges_def by auto

  lemma finite_adm_edges[simp, intro!]: "finite (adm_edges f l)"
    apply (rule finite_subset[of _ "cfE_of f"])
    by (auto simp: adm_edges_def)

end \<comment> \<open>Network\<close>

text \<open>The edge of a push operation is admissible.\<close>
lemma (in push_effect_locale) uv_adm: "(u,v)\<in>adm_edges f l"
  unfolding adm_edges_def by auto

text \<open>
  A push operation will not create new admissible edges, but the
  edge that we pushed over may become inadmissible \cormen{26.27}.
\<close>
lemma (in Labeling) push_adm_edges:
  assumes "push_precond f l e"
  shows "adm_edges f l - {e} \<subseteq> adm_edges (push_effect f e) l" (is ?G1)
    and "adm_edges (push_effect f e) l \<subseteq> adm_edges f l" (is ?G2)
proof -
  from assms consider (sat) "sat_push_precond f l e"
                 | (nonsat) "nonsat_push_precond f l e"
    by (auto simp: push_precond_eq_sat_or_nonsat)
  hence "?G1 \<and> ?G2"
  proof cases
    case sat have "adm_edges (push_effect f e) l = adm_edges f l - {e}"
      unfolding sat_push_alt[OF sat]
    proof -
      (* TODO: Clean up. Use push_effect_locale! *)
      let ?f'="(augment_edge f e (cf e))"
      interpret l': Labeling c s t ?f' l
        using push_pres_Labeling[OF assms]
        unfolding sat_push_alt[OF sat] .

      from sat have G1: "e\<in>adm_edges f l"
        unfolding sat_push_precond_def adm_edges_def by auto

      have "l'.cf.E \<subseteq> insert (prod.swap e) cf.E - {e}" "l'.cf.E \<supseteq> cf.E - {e}"
        unfolding l'.cf_def cf_def
        unfolding augment_edge_def residualGraph_def Graph.E_def
        by (auto split!: if_splits prod.splits)
      hence "l'.cf.E = insert (prod.swap e) cf.E - {e} \<or> l'.cf.E = cf.E - {e}"
        by auto
      thus "adm_edges ?f' l = adm_edges f l - {e}"
      proof (cases rule: disjE[consumes 1])
        case 1
        from sat have "e \<in> adm_edges f l" unfolding sat_push_precond_def adm_edges_def by auto
        with adm_edges_inv_disj have "prod.swap e \<notin> adm_edges f l" by (auto simp: swap_in_iff_inv)
        thus "adm_edges ?f' l = adm_edges f l - {e}" using G1
          unfolding adm_edges_def 1
          by auto
      next
        case 2
        thus "adm_edges ?f' l = adm_edges f l - {e}"
          unfolding adm_edges_def 2
          by auto
      qed
    qed
    thus ?thesis by auto
  next
    case nonsat
    hence "adm_edges (push_effect f e) l = adm_edges f l"
    proof (cases e; simp add: nonsat_push_alt)
      fix u v assume [simp]: "e=(u,v)"

      let ?f'="(augment_edge f (u,v) (excess f u))"
      interpret l': Labeling c s t ?f' l
        using push_pres_Labeling[OF assms] nonsat_push_alt nonsat
        by auto

      from nonsat have "e \<in> adm_edges f l"
        unfolding nonsat_push_precond_def adm_edges_def by auto
      with adm_edges_inv_disj have AUX: "prod.swap e \<notin> adm_edges f l"
        by (auto simp: swap_in_iff_inv)

      from nonsat have
        "excess f u < cf (u,v)" "0 < excess f u"
        and [simp]: "l u = l v + 1"
        unfolding nonsat_push_precond_def by auto
      hence "l'.cf.E \<subseteq> insert (prod.swap e) cf.E" "l'.cf.E \<supseteq> cf.E"
        unfolding l'.cf_def cf_def
        unfolding augment_edge_def residualGraph_def Graph.E_def
        apply (safe)
        apply (simp split: if_splits)
        apply (simp split: if_splits)
        subgoal
          by (metis (full_types) capacity_const diff_0_right
                diff_strict_left_mono not_less)
        subgoal
          by (metis add_le_same_cancel1 f_non_negative linorder_not_le)
        done
      hence "l'.cf.E = insert (prod.swap e) cf.E \<or> l'.cf.E = cf.E"
        by auto
      thus "adm_edges ?f' l = adm_edges f l" using AUX
        unfolding adm_edges_def
        by auto
    qed
    thus ?thesis by auto
  qed
  thus ?G1 ?G2 by auto
qed

text \<open>After a relabel operation, there is at least
  one admissible edge leaving the relabeled node,
  but no admissible edges do enter the relabeled node~\cormen{26.28}.
  Moreover, the part of the admissible network not adjacent to the relabeled
  node does not change.
\<close>

lemma (in Labeling) relabel_adm_edges:
  assumes PRE: "relabel_precond f l u"
  defines "l' \<equiv> relabel_effect f l u"
  shows "adm_edges f l' \<inter> cf.outgoing u \<noteq> {}" (is ?G1)
    and "adm_edges f l' \<inter> cf.incoming u = {}" (is ?G2)
    and "adm_edges f l' - cf.adjacent u = adm_edges f l - cf.adjacent u" (is ?G3)
proof -
  from PRE have
        NOT_SINK: "u\<noteq>t"
    and ACTIVE: "excess f u > 0"
    and NO_ADM: "\<And>v. (u,v)\<in>cf.E \<Longrightarrow> l u \<noteq> l v + 1"
  unfolding relabel_precond_def by auto

  have NE: "{l v |v. (u, v) \<in> cf.E} \<noteq> {}"
    using active_has_cf_outgoing[OF ACTIVE] cf.outgoing_def by blast
  obtain v
    where VUE: "(u,v)\<in>cf.E" and [simp]: "l v = Min {l v |v. (u, v) \<in> cf.E}"
    using Min_in[OF finite_min_cf_outgoing[of u] NE] by auto
  hence "(u,v) \<in> adm_edges f l' \<inter> cf.outgoing u"
    unfolding l'_def relabel_effect_def adm_edges_def cf.outgoing_def
    by (auto simp: cf_no_self_loop)
  thus ?G1 by blast

  {
    fix uh
    assume "(uh,u) \<in> adm_edges f l'"
    hence 1: "l' uh = l' u + 1" and UHUE: "(uh,u) \<in> cf.E"
      unfolding adm_edges_def by auto
    hence "uh \<noteq> u" using cf_no_self_loop by auto
    hence [simp]: "l' uh = l uh" unfolding l'_def relabel_effect_def by simp
    from 1 relabel_increase_u[OF PRE, folded l'_def] have "l uh > l u + 1"
      by simp
    with valid[OF UHUE] have False by auto
  }
  thus ?G2 by (auto simp: cf.incoming_def)

  show ?G3
    unfolding adm_edges_def
    by (auto
        simp: l'_def relabel_effect_def cf.adjacent_def
        simp: cf.incoming_def cf.outgoing_def
        split: if_splits)

qed

subsection \<open>Neighbor Lists\<close>
text \<open>
  For each node, the algorithm will cycle through the adjacent edges
  when discharging. This cycling takes place across the boundaries of
  discharge operations, i.e.\ when a node is discharged, discharging will
  start at the edge where the last discharge operation stopped.

  The crucial invariant for the neighbor lists is that already visited
  edges are not admissible.

  Formally, we maintain a function \<open>n :: node \<Rightarrow> node set\<close> from
  each node to the set of target nodes of not yet visited edges.
\<close>

locale neighbor_invar = Height_Bounded_Labeling +
  fixes n :: "node \<Rightarrow> node set"
  assumes neighbors_adm: "\<lbrakk>v \<in> adjacent_nodes u - n u\<rbrakk> \<Longrightarrow> (u,v) \<notin> adm_edges f l"
  assumes neighbors_adj: "n u \<subseteq> adjacent_nodes u"
  assumes neighbors_finite[simp, intro!]: "finite (n u)"
begin

lemma nbr_is_hbl: "Height_Bounded_Labeling c s t f l" by unfold_locales

lemma push_pres_nbr_invar:
  assumes PRE: "push_precond f l e"
  shows "neighbor_invar c s t (push_effect f e) l n"
proof (cases e)
  case [simp]: (Pair u v)
  show ?thesis proof simp
    from PRE interpret push_effect_locale c s t f l u v
      by unfold_locales simp
    from push_pres_height_bound[OF PRE]
    interpret l': Height_Bounded_Labeling c s t f' l .

    show "neighbor_invar c s t f' l n"
      apply unfold_locales
      using push_adm_edges[OF PRE] neighbors_adm neighbors_adj
      by auto
  qed
qed

lemma relabel_pres_nbr_invar:
  assumes PRE: "relabel_precond f l u"
  shows "neighbor_invar c s t f (relabel_effect f l u) (n(u:=adjacent_nodes u))"
proof -
  let ?l' = "relabel_effect f l u"
  from relabel_pres_height_bound[OF PRE]
  interpret l': Height_Bounded_Labeling c s t f ?l' .

  show ?thesis
    using neighbors_adj
  proof (unfold_locales; clarsimp split: if_splits)
    fix a b
    assume A: "a\<noteq>u" "b\<in>adjacent_nodes a" "b \<notin> n a" "(a,b)\<in>adm_edges f ?l'"
    hence "(a,b)\<in>cf.E" unfolding adm_edges_def by auto
    with A relabel_adm_edges(2,3)[OF PRE] neighbors_adm
    show False
      apply (auto) (* TODO: Clean up this mess *)
      by (smt DiffD2 Diff_triv adm_edges_def cf.incoming_def
          mem_Collect_eq prod.simps(2) relabel_preserve_other)
  qed
qed

lemma excess_nz_iff_gz: "\<lbrakk> u\<in>V; u\<noteq>s \<rbrakk> \<Longrightarrow> excess f u \<noteq> 0 \<longleftrightarrow> excess f u > 0"
  using excess_non_negative' by force

lemma no_neighbors_relabel_precond:
  assumes "n u = {}" "u\<noteq>t" "u\<noteq>s" "u\<in>V" "excess f u \<noteq> 0"
  shows "relabel_precond f l u"
  using assms neighbors_adm cfE_ss_invE
  unfolding relabel_precond_def adm_edges_def
  by (auto simp: adjacent_nodes_def excess_nz_iff_gz)

lemma remove_neighbor_pres_nbr_invar: "(u,v)\<notin>adm_edges f l
  \<Longrightarrow> neighbor_invar c s t f l (n (u := n u - {v}))"
  apply unfold_locales
  using neighbors_adm neighbors_adj
  by (auto split: if_splits)

end

subsection \<open>Discharge Operation\<close>
context Network
begin
text \<open>The discharge operation performs push and relabel operations on a
  node until it becomes inactive.
  The lemmas in this section are based on the ideas described in
 the proof of \cormen{26.29}.
\<close>

definition "discharge f l n u \<equiv> do {
  assert (u \<in> V - {s,t});
  while\<^sub>T (\<lambda>(f,l,n). excess f u \<noteq> 0) (\<lambda>(f,l,n). do {
    v \<leftarrow> select v. v\<in>n u;
    case v of
      None \<Rightarrow> do {
        l \<leftarrow> relabel f l u;
        return (f,l,n(u := adjacent_nodes u))
      }
    | Some v \<Rightarrow> do {
        assert (v\<in>V \<and> (u,v)\<in>E\<union>E\<inverse>);
        if ((u,v) \<in> cfE_of f \<and> l u = l v + 1) then do {
          f \<leftarrow> push f l (u,v);
          return (f,l,n)
        } else do {
          assert ( (u,v) \<notin> adm_edges f l );
          return (f,l,n( u := n u - {v} ))
        }
      }
  }) (f,l,n)
}"

end \<comment> \<open>Network\<close>

text \<open>Invariant for the discharge loop\<close>
locale discharge_invar =
        neighbor_invar c s t f l n
  + lo: neighbor_invar c s t fo lo no
  for c s t and u :: node and fo lo no f l n +
  assumes lu_incr: "lo u \<le> l u"
  assumes u_node: "u\<in>V-{s,t}"
  assumes no_relabel_adm_edges: "lo u = l u \<Longrightarrow> adm_edges f l \<subseteq> adm_edges fo lo"
  assumes no_relabel_excess:
    "\<lbrakk>lo u = l u; u\<noteq>v; excess fo v \<noteq> excess f v\<rbrakk> \<Longrightarrow> (u,v)\<in>adm_edges fo lo"
  assumes adm_edges_leaving_u: "(u',v)\<in>adm_edges f l - adm_edges fo lo \<Longrightarrow> u'=u"
  assumes relabel_u_no_incoming_adm: "lo u \<noteq> l u \<Longrightarrow> (v,u)\<notin>adm_edges f l"
  assumes algo_rel: "((f,l),(fo,lo)) \<in> pr_algo_rel\<^sup>*"
begin

lemma u_node_simp1[simp]: "u\<noteq>s" "u\<noteq>t" "s\<noteq>u" "t\<noteq>u" using u_node by auto
lemma u_node_simp2[simp, intro!]: "u\<in>V" using u_node by auto

lemma dis_is_lbl: "Labeling c s t f l" by unfold_locales
lemma dis_is_hbl: "Height_Bounded_Labeling c s t f l" by unfold_locales
lemma dis_is_nbr: "neighbor_invar c s t f l n" by unfold_locales

lemma new_adm_imp_relabel:
  "(u',v)\<in>adm_edges f l - adm_edges fo lo \<Longrightarrow> lo u \<noteq> l u"
  using no_relabel_adm_edges adm_edges_leaving_u by auto

lemma push_pres_dis_invar:
  assumes PRE: "push_precond f l (u,v)"
  shows "discharge_invar c s t u fo lo no (push_effect f (u,v)) l n"
proof -
  from PRE interpret push_effect_locale by unfold_locales

  from push_pres_nbr_invar[OF PRE] interpret neighbor_invar c s t f' l n .

  show "discharge_invar c s t u fo lo no f' l n"
    apply unfold_locales
    subgoal using lu_incr by auto
    subgoal by auto
    subgoal using no_relabel_adm_edges push_adm_edges(2)[OF PRE] by auto
    subgoal for v' proof -
      assume LOU: "lo u = l u"
      assume EXNE: "excess fo v' \<noteq> excess f' v'"
      assume UNV': "u\<noteq>v'"
      {
        assume "excess fo v' \<noteq> excess f v'"
        from no_relabel_excess[OF LOU UNV' this] have ?thesis .
      } moreover {
        assume "excess fo v' = excess f v'"
        with EXNE have "excess f v' \<noteq> excess f' v'" by simp
        hence "v'=v" using UNV' by (auto simp: excess'_if split: if_splits)
        hence ?thesis using no_relabel_adm_edges[OF LOU] uv_adm by auto
      } ultimately show ?thesis by blast
    qed
    subgoal
      by (meson Diff_iff push_adm_edges(2)[OF PRE] adm_edges_leaving_u subsetCE)
    subgoal
      using push_adm_edges(2)[OF PRE] relabel_u_no_incoming_adm by blast
    subgoal
      using converse_rtrancl_into_rtrancl[
              OF pr_algo_rel.push[OF dis_is_hbl PRE] algo_rel]
      .
    done
qed

lemma relabel_pres_dis_invar:
  assumes PRE: "relabel_precond f l u"
  shows "discharge_invar c s t u fo lo no f
            (relabel_effect f l u) (n(u := adjacent_nodes u))"
proof -
  let ?l' = "relabel_effect f l u"
  let ?n' = "n(u := adjacent_nodes u)"
  from relabel_pres_nbr_invar[OF PRE]
  interpret l': neighbor_invar c s t f ?l' ?n' .

  note lu_incr
  also note relabel_increase_u[OF PRE]
  finally have INCR: "lo u < ?l' u" .

  show ?thesis
    apply unfold_locales
    using INCR
    apply simp_all
    subgoal for u' v
    proof clarsimp
      assume IN': "(u', v) \<in> adm_edges f ?l'"
         and NOT_INO: "(u', v) \<notin> adm_edges fo lo"
      {
        assume IN: "(u', v) \<in> adm_edges f l"
        with adm_edges_leaving_u NOT_INO have "u'=u" by auto
      } moreover {
        assume NOT_IN: "(u', v) \<notin> adm_edges f l"
        with IN' relabel_adm_edges[OF PRE] have "u'=u"
          unfolding cf.incoming_def cf.outgoing_def cf.adjacent_def
          by auto
      } ultimately show ?thesis by blast
    qed
    subgoal
      using relabel_adm_edges(2)[OF PRE]
      unfolding adm_edges_def cf.incoming_def
      by fastforce
    subgoal
      using converse_rtrancl_into_rtrancl[
              OF pr_algo_rel.relabel[OF dis_is_hbl PRE] algo_rel]
      .
    done
qed

lemma neighbors_in_E: "v\<in>n u \<Longrightarrow> (u,v)\<in>E\<union>E\<inverse>"
  using neighbors_adj[of u] E_ss_VxV unfolding adjacent_nodes_def by auto

lemma relabeled_node_has_outgoing:
  assumes "relabel_precond f l u"
  shows "\<exists>v. (u,v)\<in>cfE_of f"
  using assms unfolding relabel_precond_def
  using active_has_cf_outgoing unfolding cf.outgoing_def by auto

end

lemma (in neighbor_invar) discharge_invar_init:
  assumes "u\<in>V-{s,t}"
  shows "discharge_invar c s t u f l n f l n"
  using assms
  by unfold_locales auto

context Network begin
text \<open>
  The discharge operation preserves the invariant, and discharges the node.
\<close>
lemma discharge_correct[THEN order_trans, refine_vcg]:
  assumes DINV: "neighbor_invar c s t f l n"
  assumes NOT_ST: "u\<noteq>t" "u\<noteq>s" and UIV: "u\<in>V"
  shows "discharge f l n u
    \<le> SPEC (\<lambda>(f',l',n'). discharge_invar c s t u f l n f' l' n'
                       \<and> excess f' u = 0)"
  unfolding discharge_def push_def relabel_def
  apply (refine_vcg WHILET_rule[where
            I="\<lambda>(f',l',n'). discharge_invar c s t u f l n f' l' n'"
        and R="inv_image (pr_algo_rel <*lex*> finite_psubset)
                (\<lambda>(f',l',n'). ((f',l'),n' u))"]
      )
  apply (vc_solve
      solve: wf_lex_prod DINV
      solve: neighbor_invar.discharge_invar_init[OF DINV]
      solve: neighbor_invar.no_neighbors_relabel_precond
      solve: discharge_invar.relabel_pres_dis_invar
      solve: discharge_invar.push_pres_dis_invar
      solve: discharge_invar.push_precondI_nz pr_algo_rel.relabel
      solve: pr_algo_rel.push[OF discharge_invar.dis_is_hbl]
      solve: discharge_invar.remove_neighbor_pres_dis_invar
      solve: discharge_invar.neighbors_in_V
      solve: discharge_invar.relabeled_node_has_outgoing
      solve: discharge_invar.dis_is_hbl
      intro: discharge_invar.dis_is_nbr
      solve: discharge_invar.dis_is_lbl
      simp: NOT_ST
      simp: neighbor_invar.neighbors_finite[OF discharge_invar.dis_is_nbr] UIV)
  subgoal by (auto dest: discharge_invar.neighbors_in_E)
  subgoal unfolding adm_edges_def by auto
  subgoal by (auto)
  done

end \<comment> \<open>Network\<close>

subsection \<open>Main Algorithm\<close>
text \<open>We state the main algorithm and prove its
  termination and correctness\<close>

context Network
begin
text \<open>Initially, all edges are unprocessed. \<close>
definition "rtf_init_n u \<equiv> if u\<in>V-{s,t} then adjacent_nodes u else {}"

lemma rtf_init_n_finite[simp, intro!]: "finite (rtf_init_n u)"
  unfolding rtf_init_n_def
  by auto

lemma init_no_adm_edges[simp]: "adm_edges pp_init_f pp_init_l = {}"
  unfolding adm_edges_def pp_init_l_def
  using card_V_ge2
  by auto

lemma rtf_init_neighbor_invar:
  "neighbor_invar c s t pp_init_f pp_init_l rtf_init_n"
proof -
  from pp_init_height_bound
  interpret Height_Bounded_Labeling c s t pp_init_f pp_init_l .

  have [simp]: "rtf_init_n u \<subseteq> adjacent_nodes u" for u
    by (auto simp: rtf_init_n_def)

  show ?thesis by unfold_locales auto
qed

definition "relabel_to_front \<equiv> do {
  let f = pp_init_f;
  let l = pp_init_l;
  let n = rtf_init_n;

  let L_left=[];
  L_right \<leftarrow> spec l. distinct l \<and> set l = V - {s,t};

  (f,l,n,L_left,L_right) \<leftarrow> while\<^sub>T
    (\<lambda>(f,l,n,L_left,L_right). L_right \<noteq> [])
    (\<lambda>(f,l,n,L_left,L_right). do {
      let u = hd L_right;
      assert (u \<in> V);
      let old_lu = l u;

      (f,l,n) \<leftarrow> discharge f l n u;

      if (l u \<noteq> old_lu) then do {
        \<comment> \<open>Move \<open>u\<close> to front of \<open>l\<close>, and restart scanning \<open>L\<close>\<close>
        let (L_left,L_right) = ([u],L_left @ tl L_right);
        return (f,l,n,L_left,L_right)
      } else do {
        \<comment> \<open>Goto next node in \<open>l\<close>\<close>
        let (L_left,L_right) = (L_left@[u], tl L_right);
        return (f,l,n,L_left,L_right)
      }

    }) (f,l,n,L_left,L_right);

  assert (neighbor_invar c s t f l n);

  return f
}"

end \<comment> \<open>Network\<close>

text \<open>Invariant for the main algorithm:
  \<^enum> Nodes in the queue left of the current node are not active
  \<^enum> The queue is a topological sort of the admissible network
  \<^enum> All nodes except source and sink are on the queue
\<close>

locale rtf_invar = neighbor_invar +
  fixes L_left L_right :: "node list"
  assumes left_no_excess: "\<forall>u\<in>set (L_left). excess f u = 0"
  assumes L_sorted: "is_top_sorted (adm_edges f l) (L_left @ L_right)"
  assumes L_set: "set L_left \<union> set L_right = V-{s,t}"
begin
  lemma rtf_is_nbr: "neighbor_invar c s t f l n" by unfold_locales

  lemma L_distinct: "distinct (L_left @ L_right)"
    using is_top_sorted_distinct[OF L_sorted] .

  lemma terminated_imp_maxflow:
    assumes [simp]: "L_right = []"
    shows "isMaxFlow f"
  proof -
    from L_set left_no_excess have "\<forall>u\<in>V-{s,t}. excess f u = 0" by auto
    with no_excess_imp_maxflow show ?thesis .
  qed

end

context Network begin
lemma rtf_init_invar:
  assumes DIS: "distinct L_left" and L_set: "set L_left = V-{s,t}"
  shows "rtf_invar c s t pp_init_f pp_init_l rtf_init_n [] L_left"
proof -
  from rtf_init_neighbor_invar
  interpret neighbor_invar c s t pp_init_f pp_init_l rtf_init_n .
  show ?thesis using DIS L_set by unfold_locales auto
qed

theorem relabel_to_front_correct:
  "relabel_to_front \<le> SPEC isMaxFlow"
  unfolding relabel_to_front_def
  apply (rewrite in "while\<^sub>T _ \<hole>" vcg_intro_frame)
  apply (refine_vcg
      WHILET_rule[where
            I="\<lambda>(f,l,n,L_left,L_right). rtf_invar c s t f l n L_left L_right"
        and R="inv_image
                (pr_algo_rel\<^sup>+ <*lex*> less_than)
                (\<lambda>(f,l,n,L_left,L_right). ((f,l),length L_right))"
        ]
      )
  apply (vc_solve simp: rtf_init_invar rtf_invar.rtf_is_nbr)
  subgoal by (blast intro: wf_lex_prod wf_trancl)
  subgoal for _ f l n L_left L_right proof -
    assume "rtf_invar c s t f l n L_left L_right"
    then interpret rtf_invar c s t f l n L_left L_right .

    assume "L_right \<noteq> []" then obtain u L_right'
      where [simp]: "L_right = u#L_right'" by (cases L_right) auto

    from L_set have [simp]: "u\<in>V" "u\<noteq>s" "u\<noteq>t" "s\<noteq>u" "t\<noteq>u" by auto

    from L_distinct have [simp]: "u\<notin>set L_left" "u\<notin>set L_right'" by auto

    show ?thesis
      apply (rule vcg_rem_frame)
      apply (rewrite in "do {(_,_,_) \<leftarrow> discharge _ _ _ _; \<hole>}" vcg_intro_frame)
      apply refine_vcg
      apply (vc_solve simp: rtf_is_nbr split del: if_split)
      subgoal for f' l' n' proof -
        assume "discharge_invar c s t u f l n f' l' n'"
        then interpret l': discharge_invar c s t u f l n f' l' n' .

        assume [simp]: "excess f' u = 0"

        show ?thesis
          apply (rule vcg_rem_frame)
          apply refine_vcg
          apply (vc_solve)
          subgoal proof -
            assume RELABEL: "l' u \<noteq> l u"

            have AUX1: "x=u" if "(x, u) \<in> (adm_edges f' l')\<^sup>*" for x
              using that l'.relabel_u_no_incoming_adm[OF RELABEL[symmetric]]
              by (auto elim: rtranclE)

            have TS1: "is_top_sorted (adm_edges f l) (L_left @ L_right')"
              using L_sorted by (auto intro: is_top_sorted_remove_elem)

            \<comment> \<open>Intuition:\<close>
              \<comment> \<open>new edges come from \<open>u\<close>, but \<open>u\<close> has no incoming edges, nor is it in \<open>L_left@L_right'\<close>.\<close>
              \<comment> \<open>thus, these new edges cannot add effective constraints.\<close>
            from l'.adm_edges_leaving_u
              and l'.relabel_u_no_incoming_adm[OF RELABEL[symmetric]]
            have "adm_edges f' l' \<subseteq> adm_edges f l \<union> {u}\<times>UNIV"
              and "adm_edges f' l' \<inter> UNIV\<times>{u}={}" by auto
            from is_top_sorted_isolated_constraint[OF this _ TS1]
            have AUX2: "is_top_sorted (adm_edges f' l') (L_left @ L_right')"
              by simp

            show "rtf_invar c s t f' l' n' [u] (L_left @ L_right')"
              apply unfold_locales
              subgoal by simp
              subgoal using AUX2 by (auto simp: is_top_sorted_cons dest!: AUX1)
              subgoal using L_set by auto
              done
          qed
          subgoal using l'.algo_rel by (auto dest: rtranclD)
          subgoal proof -
            assume NO_RELABEL[simp]: "l' u = l u"
            \<comment> \<open>Intuition: non-zero excess would imply an admissible edge contrary to \<open>top_sorted\<close>.\<close>
            have AUX: "excess f' v = 0" if "v\<in>set L_left" for v
            proof (rule ccontr)
              from that \<open>u\<notin>set L_left\<close> have "u \<noteq> v" by blast
              moreover assume "excess f' v \<noteq> 0"
              moreover from that left_no_excess have "excess f v = 0" by auto
              ultimately have "(u,v)\<in>adm_edges f l"
                using l'.no_relabel_excess[OF NO_RELABEL[symmetric]]
                by auto

              with L_sorted that show False
                by (auto simp: is_top_sorted_append is_top_sorted_cons)
            qed
            show "rtf_invar c s t f' l' n' (L_left @ [u]) L_right'"
              apply unfold_locales
              subgoal by (auto simp: AUX)
              subgoal
                apply (rule is_top_sorted_antimono[
                  OF l'.no_relabel_adm_edges[OF NO_RELABEL[symmetric]]])
                using L_sorted by simp
              subgoal using L_set by auto
              done
          qed
          subgoal using l'.algo_rel by (auto dest: rtranclD)
          done
      qed
      done
  qed
  subgoal by (auto intro: rtf_invar.terminated_imp_maxflow)
  done

end \<comment> \<open>Network\<close>

end


(*  Title:      ZF/Induct/Comb.thy
    Author:     Lawrence C Paulson
    Copyright   1994  University of Cambridge
*)

section \<open>Combinatory Logic example: the Church-Rosser Theorem\<close>

theory Comb
imports ZF
begin

text \<open>
  Curiously, combinators do not include free variables.

  Example taken from \<^cite>\<open>camilleri92\<close>.
\<close>

subsection \<open>Definitions\<close>

text \<open>Datatype definition of combinators \<open>S\<close> and \<open>K\<close>.\<close>

consts comb :: i
datatype comb =
  K
| S
| app ("p \<in> comb", "q \<in> comb")  (infixl \<open>\<bullet>\<close> 90)

text \<open>
  Inductive definition of contractions, \<open>\<rightarrow>\<^sup>1\<close> and
  (multi-step) reductions, \<open>\<rightarrow>\<close>.
\<close>

consts contract  :: i
abbreviation contract_syntax :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<rightarrow>\<^sup>1\<close> 50)
  where "p \<rightarrow>\<^sup>1 q \<equiv> \<langle>p,q\<rangle> \<in> contract"

abbreviation contract_multi :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<rightarrow>\<close> 50)
  where "p \<rightarrow> q \<equiv> \<langle>p,q\<rangle> \<in> contract^*"

inductive
  domains "contract" \<subseteq> "comb \<times> comb"
  intros
    K:   "\<lbrakk>p \<in> comb;  q \<in> comb\<rbrakk> \<Longrightarrow> K\<bullet>p\<bullet>q \<rightarrow>\<^sup>1 p"
    S:   "\<lbrakk>p \<in> comb;  q \<in> comb;  r \<in> comb\<rbrakk> \<Longrightarrow> S\<bullet>p\<bullet>q\<bullet>r \<rightarrow>\<^sup>1 (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap1: "\<lbrakk>p\<rightarrow>\<^sup>1q;  r \<in> comb\<rbrakk> \<Longrightarrow> p\<bullet>r \<rightarrow>\<^sup>1 q\<bullet>r"
    Ap2: "\<lbrakk>p\<rightarrow>\<^sup>1q;  r \<in> comb\<rbrakk> \<Longrightarrow> r\<bullet>p \<rightarrow>\<^sup>1 r\<bullet>q"
  type_intros comb.intros

text \<open>
  Inductive definition of parallel contractions, \<open>\<Rrightarrow>\<^sup>1\<close> and
  (multi-step) parallel reductions, \<open>\<Rrightarrow>\<close>.
\<close>

consts parcontract :: i

abbreviation parcontract_syntax :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<Rrightarrow>\<^sup>1\<close> 50)
  where "p \<Rrightarrow>\<^sup>1 q \<equiv> \<langle>p,q\<rangle> \<in> parcontract"

abbreviation parcontract_multi :: "[i,i] \<Rightarrow> o"  (infixl \<open>\<Rrightarrow>\<close> 50)
  where "p \<Rrightarrow> q \<equiv> \<langle>p,q\<rangle> \<in> parcontract^+"

inductive
  domains "parcontract" \<subseteq> "comb \<times> comb"
  intros
    refl: "\<lbrakk>p \<in> comb\<rbrakk> \<Longrightarrow> p \<Rrightarrow>\<^sup>1 p"
    K:    "\<lbrakk>p \<in> comb;  q \<in> comb\<rbrakk> \<Longrightarrow> K\<bullet>p\<bullet>q \<Rrightarrow>\<^sup>1 p"
    S:    "\<lbrakk>p \<in> comb;  q \<in> comb;  r \<in> comb\<rbrakk> \<Longrightarrow> S\<bullet>p\<bullet>q\<bullet>r \<Rrightarrow>\<^sup>1 (p\<bullet>r)\<bullet>(q\<bullet>r)"
    Ap:   "\<lbrakk>p\<Rrightarrow>\<^sup>1q;  r\<Rrightarrow>\<^sup>1s\<rbrakk> \<Longrightarrow> p\<bullet>r \<Rrightarrow>\<^sup>1 q\<bullet>s"
  type_intros comb.intros

text \<open>
  Misc definitions.
\<close>

definition I :: i
  where "I \<equiv> S\<bullet>K\<bullet>K"

definition diamond :: "i \<Rightarrow> o"
  where "diamond(r) \<equiv>
    \<forall>x y. \<langle>x,y\<rangle>\<in>r \<longrightarrow> (\<forall>y'. <x,y'>\<in>r \<longrightarrow> (\<exists>z. \<langle>y,z\<rangle>\<in>r \<and> <y',z> \<in> r))"

subsection \<open>Transitive closure preserves the Church-Rosser property\<close>

lemma diamond_strip_lemmaD [rule_format]:
  "\<lbrakk>diamond(r);  \<langle>x,y\<rangle>:r^+\<rbrakk> \<Longrightarrow>
    \<forall>y'. <x,y'>:r \<longrightarrow> (\<exists>z. <y',z>: r^+ \<and> \<langle>y,z\<rangle>: r)"
    unfolding diamond_def
  apply (erule trancl_induct)
   apply (blast intro: r_into_trancl)
  apply clarify
  apply (drule spec [THEN mp], assumption)
  apply (blast intro: r_into_trancl trans_trancl [THEN transD])
  done

lemma diamond_trancl: "diamond(r) \<Longrightarrow> diamond(r^+)"
  apply (simp (no_asm_simp) add: diamond_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule trancl_induct)
   apply auto
   apply (best intro: r_into_trancl trans_trancl [THEN transD]
     dest: diamond_strip_lemmaD)+
  done

inductive_cases Ap_E [elim!]: "p\<bullet>q \<in> comb"

subsection \<open>Results about Contraction\<close>

text \<open>
  For type checking: replaces \<^term>\<open>a \<rightarrow>\<^sup>1 b\<close> by \<open>a, b \<in>
  comb\<close>.
\<close>

lemmas contract_combE2 = contract.dom_subset [THEN subsetD, THEN SigmaE2]
  and contract_combD1 = contract.dom_subset [THEN subsetD, THEN SigmaD1]
  and contract_combD2 = contract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_contract_eq: "field(contract) = comb"
  by (blast intro: contract.K elim!: contract_combE2)

lemmas reduction_refl =
  field_contract_eq [THEN equalityD2, THEN subsetD, THEN rtrancl_refl]

lemmas rtrancl_into_rtrancl2 =
  r_into_rtrancl [THEN trans_rtrancl [THEN transD]]

declare reduction_refl [intro!] contract.K [intro!] contract.S [intro!]

lemmas reduction_rls =
  contract.K [THEN rtrancl_into_rtrancl2]
  contract.S [THEN rtrancl_into_rtrancl2]
  contract.Ap1 [THEN rtrancl_into_rtrancl2]
  contract.Ap2 [THEN rtrancl_into_rtrancl2]

lemma "p \<in> comb \<Longrightarrow> I\<bullet>p \<rightarrow> p"
  \<comment> \<open>Example only: not used\<close>
  unfolding I_def by (blast intro: reduction_rls)

lemma comb_I: "I \<in> comb"
  unfolding I_def by blast

subsection \<open>Non-contraction results\<close>

text \<open>Derive a case for each combinator constructor.\<close>

inductive_cases K_contractE [elim!]: "K \<rightarrow>\<^sup>1 r"
  and S_contractE [elim!]: "S \<rightarrow>\<^sup>1 r"
  and Ap_contractE [elim!]: "p\<bullet>q \<rightarrow>\<^sup>1 r"

lemma I_contract_E: "I \<rightarrow>\<^sup>1 r \<Longrightarrow> P"
  by (auto simp add: I_def)

lemma K1_contractD: "K\<bullet>p \<rightarrow>\<^sup>1 r \<Longrightarrow> (\<exists>q. r = K\<bullet>q \<and> p \<rightarrow>\<^sup>1 q)"
  by auto

lemma Ap_reduce1: "\<lbrakk>p \<rightarrow> q;  r \<in> comb\<rbrakk> \<Longrightarrow> p\<bullet>r \<rightarrow> q\<bullet>r"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (erule trans_rtrancl [THEN transD])
  apply (blast intro: contract_combD2 reduction_rls)
  done

lemma Ap_reduce2: "\<lbrakk>p \<rightarrow> q;  r \<in> comb\<rbrakk> \<Longrightarrow> r\<bullet>p \<rightarrow> r\<bullet>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
                      contract_combD2 reduction_rls)
  done

text \<open>Counterexample to the diamond property for \<open>\<rightarrow>\<^sup>1\<close>.\<close>

lemma KIII_contract1: "K\<bullet>I\<bullet>(I\<bullet>I) \<rightarrow>\<^sup>1 I"
  by (blast intro: comb_I)

lemma KIII_contract2: "K\<bullet>I\<bullet>(I\<bullet>I) \<rightarrow>\<^sup>1 K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I))"
  by (unfold I_def) (blast intro: contract.intros)

lemma KIII_contract3: "K\<bullet>I\<bullet>((K\<bullet>I)\<bullet>(K\<bullet>I)) \<rightarrow>\<^sup>1 I"
  by (blast intro: comb_I)

lemma not_diamond_contract: "\<not> diamond(contract)"
    unfolding diamond_def
  apply (blast intro: KIII_contract1 KIII_contract2 KIII_contract3
    elim!: I_contract_E)
  done

subsection \<open>Results about Parallel Contraction\<close>

text \<open>For type checking: replaces \<open>a \<Rrightarrow>\<^sup>1 b\<close> by \<open>a, b
  \<in> comb\<close>\<close>
lemmas parcontract_combE2 = parcontract.dom_subset [THEN subsetD, THEN SigmaE2]
  and parcontract_combD1 = parcontract.dom_subset [THEN subsetD, THEN SigmaD1]
  and parcontract_combD2 = parcontract.dom_subset [THEN subsetD, THEN SigmaD2]

lemma field_parcontract_eq: "field(parcontract) = comb"
  by (blast intro: parcontract.K elim!: parcontract_combE2)

text \<open>Derive a case for each combinator constructor.\<close>
inductive_cases
      K_parcontractE [elim!]: "K \<Rrightarrow>\<^sup>1 r"
  and S_parcontractE [elim!]: "S \<Rrightarrow>\<^sup>1 r"
  and Ap_parcontractE [elim!]: "p\<bullet>q \<Rrightarrow>\<^sup>1 r"

declare parcontract.intros [intro]

subsection \<open>Basic properties of parallel contraction\<close>

lemma K1_parcontractD [dest!]:
    "K\<bullet>p \<Rrightarrow>\<^sup>1 r \<Longrightarrow> (\<exists>p'. r = K\<bullet>p' \<and> p \<Rrightarrow>\<^sup>1 p')"
  by auto

lemma S1_parcontractD [dest!]:
    "S\<bullet>p \<Rrightarrow>\<^sup>1 r \<Longrightarrow> (\<exists>p'. r = S\<bullet>p' \<and> p \<Rrightarrow>\<^sup>1 p')"
  by auto

lemma S2_parcontractD [dest!]:
    "S\<bullet>p\<bullet>q \<Rrightarrow>\<^sup>1 r \<Longrightarrow> (\<exists>p' q'. r = S\<bullet>p'\<bullet>q' \<and> p \<Rrightarrow>\<^sup>1 p' \<and> q \<Rrightarrow>\<^sup>1 q')"
  by auto

lemma diamond_parcontract: "diamond(parcontract)"
  \<comment> \<open>Church-Rosser property for parallel contraction\<close>
    unfolding diamond_def
  apply (rule impI [THEN allI, THEN allI])
  apply (erule parcontract.induct)
     apply (blast elim!: comb.free_elims  intro: parcontract_combD2)+
  done

text \<open>
  \medskip Equivalence of \<^prop>\<open>p \<rightarrow> q\<close> and \<^prop>\<open>p \<Rrightarrow> q\<close>.
\<close>

lemma contract_imp_parcontract: "p\<rightarrow>\<^sup>1q \<Longrightarrow> p\<Rrightarrow>\<^sup>1q"
  by (induct set: contract) auto

lemma reduce_imp_parreduce: "p\<rightarrow>q \<Longrightarrow> p\<Rrightarrow>q"
  apply (frule rtrancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_contract_eq [THEN equalityD1, THEN subsetD])
  apply (erule rtrancl_induct)
   apply (blast intro: r_into_trancl)
  apply (blast intro: contract_imp_parcontract r_into_trancl
    trans_trancl [THEN transD])
  done

lemma parcontract_imp_reduce: "p\<Rrightarrow>\<^sup>1q \<Longrightarrow> p\<rightarrow>q"
  apply (induct set: parcontract)
     apply (blast intro: reduction_rls)
    apply (blast intro: reduction_rls)
   apply (blast intro: reduction_rls)
  apply (blast intro: trans_rtrancl [THEN transD]
    Ap_reduce1 Ap_reduce2 parcontract_combD1 parcontract_combD2)
  done

lemma parreduce_imp_reduce: "p\<Rrightarrow>q \<Longrightarrow> p\<rightarrow>q"
  apply (frule trancl_type [THEN subsetD, THEN SigmaD1])
  apply (drule field_parcontract_eq [THEN equalityD1, THEN subsetD])
  apply (erule trancl_induct, erule parcontract_imp_reduce)
  apply (erule trans_rtrancl [THEN transD])
  apply (erule parcontract_imp_reduce)
  done

lemma parreduce_iff_reduce: "p\<Rrightarrow>q \<longleftrightarrow> p\<rightarrow>q"
  by (blast intro: parreduce_imp_reduce reduce_imp_parreduce)

end