theory T184
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


(* Author: Tobias Nipkow *)

section "Hoare Logic"

subsection "Hoare Logic for Partial Correctness"

theory Hoare imports Big_Step begin

type_synonym assn = "state \<Rightarrow> bool"

definition
hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile> {P}c{Q} = (\<forall>s t. P s \<and> (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"

abbreviation state_subst :: "state \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> state"
  ("_[_'/_]" [1000,0,0] 999)
where "s[a/x] == s(x := aval a s)"

inductive
  hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50)
where
Skip: "\<turnstile> {P} SKIP {P}"  |

Assign:  "\<turnstile> {\<lambda>s. P(s[a/x])} x::=a {P}"  |

Seq: "\<lbrakk> \<turnstile> {P} c\<^sub>1 {Q};  \<turnstile> {Q} c\<^sub>2 {R} \<rbrakk>
      \<Longrightarrow> \<turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"  |

If: "\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q};  \<turnstile> {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
     \<Longrightarrow> \<turnstile> {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"  |

While: "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P} \<Longrightarrow>
        \<turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}"  |

conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk>
        \<Longrightarrow> \<turnstile> {P'} c {Q'}"

lemmas [simp] = hoare.Skip hoare.Assign hoare.Seq If

lemmas [intro!] = hoare.Skip hoare.Assign hoare.Seq hoare.If

text\<open>The assignment and While rule are awkward to use in actual proofs
because their pre and postcondition are of a very special form and the actual
goal would have to match this form exactly. Therefore we derive two variants
with arbitrary pre and postconditions.\<close>

lemma Assign': "\<forall>s. P s \<longrightarrow> Q(s[a/x]) \<Longrightarrow> \<turnstile> {P} x ::= a {Q}"
by (simp add: strengthen_pre[OF _ Assign])

lemma While':
assumes "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}" and "\<forall>s. P s \<and> \<not> bval b s \<longrightarrow> Q s"
shows "\<turnstile> {P} WHILE b DO c {Q}"
by(rule weaken_post[OF While[OF assms(1)] assms(2)])

end


subsection "Verification Condition Generator"
theory QuantK_VCG
imports QuantK_Hoare
begin

subsubsection "Ceiling integer division on extended natural numbers"

definition "mydiv (a::nat) (k::nat) = (if k dvd a then a div k else (a div k) + 1)"

lemma mydivcode: "k>0 \<Longrightarrow> D\<ge>k \<Longrightarrow> mydiv D k = Suc (mydiv (D-k) k)"
  unfolding mydiv_def apply (auto simp add: le_div_geq)
  using dvd_minus_self by auto

lemma mydivcode1: "mydiv 0 k = 0"
  unfolding mydiv_def by auto

lemma mydivcode2: "k>0 \<Longrightarrow> 0<D \<Longrightarrow> D<k \<Longrightarrow> mydiv D k = Suc 0"
  unfolding mydiv_def by auto

lemma mydiv_mono: "a\<le>b \<Longrightarrow> mydiv a k \<le> mydiv b k" unfolding mydiv_def
  apply(cases "k dvd a")
  subgoal apply(cases "k dvd b")  apply auto apply (auto simp add: div_le_mono)
    using div_le_mono le_Suc_eq by blast
  subgoal apply(cases "k dvd b")  apply auto apply (auto simp add: div_le_mono)
    by (metis Suc_leI add.right_neutral div_le_mono div_mult_mod_eq dvd_imp_mod_0 le_add1 le_antisym less_le)
     done

lemma mydiv_cancel: "0 < k \<Longrightarrow> mydiv (k * i) k = i"
  unfolding mydiv_def by auto

lemma assumes k: "k>0" and B: "B \<le> k*A"
  shows mydiv_le_E: "mydiv B k \<le> A"
proof -
  from mydiv_mono[OF B] and k mydiv_cancel show ?thesis
    by metis
qed
lemma mydiv_mult_leq: "0 < k \<Longrightarrow> l\<le>k \<Longrightarrow> mydiv (l*A) k \<le> A"
  by(simp add: mydiv_le_E)

lemma ediv_cancel2: "k>0 \<Longrightarrow> ediv (enat k * x) k = x"
  unfolding ediv_def apply(cases "x=\<infinity>") using mydiv_cancel by auto

lemma ediv_cancel3: "k>0 \<Longrightarrow> A \<le> enat k * ediv A k"
  unfolding ediv_def apply(cases "A=\<infinity>") using mydiv_cancel3 by auto

subsubsection "Definition of VCG"

datatype acom =
  Askip                  ("SKIP") |
  Aassign vname aexp     ("(_ ::= _)" [1000, 61] 61) |
  Aseq   acom acom       ("_;;/ _"  [60, 61] 60) |
  Aif bexp acom acom     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61) |
  Awhile qassn bexp acom  ("({_}/ WHILE _/ DO _)"  [0, 0, 61] 61)
 |  Abst nat acom  ("({_}/ Ab _)"  [0, 61] 61)

notation com.SKIP ("SKIP")

fun strip :: "acom \<Rightarrow> com" where
"strip SKIP = SKIP" |
"strip (x ::= a) = (x ::= a)" |
"strip (C\<^sub>1;; C\<^sub>2) = (strip C\<^sub>1;; strip C\<^sub>2)" |
"strip (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = (IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2)" |
"strip ({_} WHILE b DO C) = (WHILE b DO strip C)" |
"strip ({_} Ab C) = strip C"

fun pre :: "acom \<Rightarrow> qassn \<Rightarrow> qassn" where
"pre SKIP Q = (\<lambda>s. eSuc (Q s))" |
"pre (x ::= a) Q = (\<lambda>s. eSuc (Q (s[a/x])))" |
"pre (C\<^sub>1;; C\<^sub>2) Q = pre C\<^sub>1 (pre C\<^sub>2 Q)" |
"pre (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q =
  (\<lambda>s. eSuc (if bval b s then pre C\<^sub>1 Q s  else pre C\<^sub>2 Q s  ))" |
"pre ({P} WHILE b DO C) Q = (%s. P s + 1)" |
"pre ({k} Ab C) Q = (\<lambda>s. ediv (pre C (\<lambda>s. k*Q s) s) k)"

text \<open>In contrast to @{term pre}, @{term vc} produces a formula that is independent of the state:\<close>

fun vc :: "acom \<Rightarrow> qassn \<Rightarrow> bool" where
"vc SKIP Q = True" |
"vc (x ::= a) Q = True" |
"vc (C\<^sub>1 ;; C\<^sub>2) Q = ((vc C\<^sub>1 (pre C\<^sub>2 Q)) \<and> (vc C\<^sub>2 Q) )" |
"vc (IF b THEN C\<^sub>1 ELSE C\<^sub>2) Q = (vc C\<^sub>1 Q \<and> vc C\<^sub>2 Q)" |
"vc ({I} WHILE b DO C) Q =  ( (\<forall>s.  (pre C (\<lambda>s. I s + 1) s \<le> I s + \<up>(bval b s)) \<and> ( Q s \<le> I s + \<up> (\<not> bval b s))) \<and> vc C (%s. I s + 1))" |
"vc ({k} Ab C) Q = (vc C (\<lambda>s. enat k* Q s) \<and> k>0 \<^cancel>\<open>\<and> (\<forall>s. pre C (\<lambda>s. enat k * Q s) s \<le> enat k * ediv (pre C (\<lambda>s. enat k * Q s) s) k)\<close>)"

subsubsection "Soundness of VCG"

lemma vc_sound: "vc C Q \<Longrightarrow>  \<turnstile>\<^sub>2\<^sub>' {pre C Q} strip C { Q }"
proof (induct C arbitrary: Q)
  case (Aif b C1 C2)
  then have Aif1: "\<turnstile>\<^sub>2\<^sub>' {pre C1 Q} strip C1 {Q}" and Aif2: "\<turnstile>\<^sub>2\<^sub>' {pre C2 Q} strip C2 {Q}" by auto
    show ?case apply auto apply(rule hoareQ.conseq[where k=1])
      apply(rule hoareQ.If[where P="%s. if bval b s then pre C1 Q s else pre C2 Q s" and Q="Q"])
    subgoal
      apply(rule hoareQ.conseq[where k=1])
         apply (fact Aif1)
      subgoal for s apply(cases "bval b s") by auto
      apply auto done
    subgoal
      apply(rule hoareQ.conseq[where k=1])
        apply (fact Aif2)
      subgoal for s apply(cases "bval b s") by auto
      apply auto done
     apply auto
    done
next
  case (Awhile I b C)
  then have i: "(\<And>Q. vc C Q \<Longrightarrow> \<turnstile>\<^sub>2\<^sub>' {pre C Q} strip C {Q})"
   and ii': " \<forall>s. pre C (\<lambda>s. I s + 1) s \<le> I s + \<up> (bval b s)"
   and ii'': "\<And>s. Q s \<le>  I s + \<up> (\<not> bval b s)"
     and iii: "vc C (\<lambda>s. I s + 1)"
    by auto

  from i iii have  A: "\<turnstile>\<^sub>2\<^sub>' {pre C (\<lambda>s. I s + 1)} strip C {(\<lambda>s. I s + 1)}" by auto

  show ?case
    apply simp
    apply(rule conseq[where k=1])
       apply(rule While[where I=I])
       apply(rule weakenpre)
        apply(rule A)
      apply(rule ii') apply simp
    using ii'' apply auto done
next
  case (Abst k C)
  then have vc: "vc C (\<lambda>s. k* Q s)" and k: "k>0" by auto
  from Abst(1) vc have C: "\<turnstile>\<^sub>2\<^sub>' {pre C (%s. k*Q s)} strip C {(%s. k*Q s)}" by auto
  show ?case apply(simp)
    apply(rule conseq)
       apply(rule C) using k apply auto
      using ediv_cancel3 by auto
qed (auto intro: hoareQ.Skip hoareQ.Assign hoareQ.Seq )

lemma vc_sound': "\<lbrakk>vc C Q ; (\<forall>s. pre C Q s \<le> P s) \<rbrakk> \<Longrightarrow>  \<turnstile>\<^sub>2\<^sub>' {P} strip C { Q }"
  apply(rule hoareQ.conseq[where k=1])
    apply(rule vc_sound) by auto

lemma vc_sound'': "\<lbrakk>vc C Q' ; (\<forall>s.  pre C Q' s \<le> k * P s)  ; (\<And>s. enat k * Q s \<le> Q' s); k>0 \<rbrakk> \<Longrightarrow>  \<turnstile>\<^sub>2\<^sub>' {P} strip C { Q }"
  apply(rule hoareQ.conseq )
    apply(rule vc_sound) by auto

subsubsection "Completeness"

lemma pre_mono: assumes "\<And>s. P' s \<le> P s"
  shows "\<And>s. pre C P' s \<le> pre C P s"
  using assms by (induct C arbitrary: P P', auto simp: ediv_mono mult_left_mono )

lemma vc_mono: assumes "\<And>s. P' s \<le> P s"
  shows "vc C P \<Longrightarrow> vc C P'"
  using assms
proof (induct C arbitrary: P P')
  case (Awhile I b C Q)
  thus ?case
    apply (auto simp: pre_mono)
    using order.trans by blast
next
  case (Abst x1 C)
  then show ?case by (auto simp: mult_left_mono)
qed (auto simp: pre_mono)

lemma "\<turnstile>\<^sub>2\<^sub>' { P } c { Q } \<Longrightarrow> \<exists>C. strip C = c \<and> vc C Q \<and> (\<forall>s. pre C Q s \<le> P s)"
  (is "_ \<Longrightarrow>   \<exists>C. ?G P c Q C")
proof (induction rule: hoareQ.induct)
  case (conseq P c Q k P' Q')
  then obtain C where strip: "strip C = c" and vc: "vc C Q" and pre: "\<And>s. pre C Q s \<le> P s"
    by blast

  { fix s
    have "pre C (\<lambda>s. enat k * Q' s) s \<le> pre C Q s" using pre_mono conseq(3) by simp
    also
    from pre conseq(2) have "\<dots>  \<le> enat k * P' s" using order.trans by blast
    finally have  "pre C (\<lambda>s. enat k * Q' s) s  \<le> enat k * P' s" by auto
        then have  "ediv (pre C (\<lambda>s. enat k * Q' s) s) k  \<le> ediv (enat k * P' s) k" using ediv_mono by auto
    moreover note  ediv_cancel2[OF conseq(4)]
    ultimately have "ediv (pre C (\<lambda>s. enat k * Q' s) s) k \<le> P' s"
      by simp
  } note compensate=this

  show ?case
    apply(rule exI[where x="{k} Ab C"])
    apply(safe)
    subgoal using strip by simp
    subgoal apply simp apply safe
      subgoal using vc vc_mono conseq(3) by force
      subgoal by fact
      done
    subgoal apply simp using compensate by auto
        done
next
  case (Skip P)
  show ?case (is "\<exists>C. ?C C")
  proof show "?C Askip" by auto  qed
next
  case (Assign P a x)
  show ?case (is "\<exists>C. ?C C")
  proof show "?C(Aassign x a)" by auto  qed
next
  case (If P b c\<^sub>1 Q c\<^sub>2)
  from If(3) obtain C1 where strip1: "strip C1 = c\<^sub>1" and vc1: "vc C1 Q"
        and pre1: "(\<And>s. pre C1 Q s \<le> (P s + \<up>(bval b s)))"
         by blast
  from If(4) obtain C2 where strip2: "strip C2 = c\<^sub>2" and vc2: "vc C2 Q"
        and pre2: "(\<And>s. pre C2 (\<lambda>s. Q s) s \<le> (P s + \<up>(\<not> bval b s)))"
    by blast

  show ?case
    apply(rule exI[where x="IF b THEN C1 ELSE C2"], safe)
    subgoal using strip1 strip2 by auto
    subgoal  using vc1 vc2 by auto
    subgoal for s using pre1[of s] pre2[of s] by auto
    done
next
  case (Seq P\<^sub>1 c\<^sub>1 P\<^sub>2 c\<^sub>2 P\<^sub>3)
  from Seq(3) obtain C1 where strip1: "strip C1 = c\<^sub>1" and vc1: "vc C1 P\<^sub>2"
      and pre1: "(\<forall>s. pre C1 P\<^sub>2 s \<le>   P\<^sub>1 s)"    by blast
  from Seq(4) obtain C2 where strip2: "strip C2 = c\<^sub>2" and vc2: "vc C2 P\<^sub>3"
      and pre2: "\<And>s. pre C2 P\<^sub>3 s \<le>   P\<^sub>2 s"   by blast

  {
    fix s
    have "pre C1 (pre C2 P\<^sub>3) s \<le> P\<^sub>1 s"
      apply(rule order.trans[where b="pre C1 P\<^sub>2 s"])
       apply(rule pre_mono) using pre2 apply simp using pre1 by simp
  } note pre = this
  show ?case
    apply(rule exI[where x="C1 ;; C2"], safe)
    subgoal using strip1 strip2 by simp
    subgoal apply simp apply safe  using vc1 vc2 vc_mono pre2 by auto
    subgoal    apply simp using  pre by auto
      done
next
  case (While I b c)
  from While(2) obtain C where strip: "strip C = c" and vc: "vc C (\<lambda>a. I a + 1)"
    and pre: "\<And>s. pre C (\<lambda>a. I a + 1) s \<le> I s + \<up> (bval b s)" by blast
  show ?case
    apply(rule exI[where x="{I} WHILE b DO C"], safe)
    subgoal using strip by simp
    subgoal apply simp using pre vc by auto
    subgoal by simp
  done
qed

lemma "\<turnstile>\<^sub>Z { P } c { Q } \<Longrightarrow> \<exists>C. strip C = c \<and> vc C Q \<and> (\<forall>s. pre C Q s \<le> P s)"
  (is "_ \<Longrightarrow>   \<exists>C. ?G P c Q C")
proof (induction rule: hoareQ'.induct)
  case (ZSkip P)
  show ?case (is "\<exists>C. ?C C")
  proof show "?C Askip" by auto
  qed
next
  case (ZAssign P a x)
  show ?case (is "\<exists>C. ?C C")
  proof show "?C(Aassign x a)" by simp qed
next
  case (ZIf P b c\<^sub>1 Q c\<^sub>2)
  from ZIf(3) obtain C1 where strip1: "strip C1 = c\<^sub>1" and vc1: "vc C1 Q" and pre1: "(\<And>s. pre C1 Q s \<le> P s + \<up> (bval b s))"  by blast
  from ZIf(4) obtain C2 where strip2: "strip C2 = c\<^sub>2" and vc2: "vc C2 Q" and pre2: "(\<And>s. pre C2 Q s \<le> P s + \<up> (\<not> bval b s))"  by blast

  show ?case apply(rule exI[where x="IF b THEN C1 ELSE C2"])
    apply(safe)
    subgoal using strip1 strip2 by auto
    subgoal using vc1 vc2 by auto
    subgoal for s apply auto
        subgoal using pre1[of s] by auto
        subgoal using pre2[of s] by auto
        done
      done
next
  case (ZSeq P\<^sub>1 c\<^sub>1 P\<^sub>2 c\<^sub>2 P\<^sub>3)
  from ZSeq(3) obtain C1 where strip1: "strip C1 = c\<^sub>1" and vc1: "vc C1 P\<^sub>2" and pre1: "(\<forall>s. pre C1 P\<^sub>2 s \<le> P\<^sub>1 s)"  by blast
  from ZSeq(4) obtain C2 where strip2: "strip C2 = c\<^sub>2" and vc2: "vc C2 P\<^sub>3" and pre2: "(\<forall>s. pre C2 P\<^sub>3 s \<le> P\<^sub>2 s)"  by blast
  {
    fix s
    have "pre C1 (pre C2 P\<^sub>3) s \<le> P\<^sub>1 s"
      apply(rule order.trans[where b="pre C1 P\<^sub>2 s"])
       apply(rule pre_mono) using pre2 apply simp using pre1 by simp
  } note pre = this
  show ?case apply(rule exI[where x="C1 ;; C2"])
    apply safe
    subgoal using strip1 strip2 by simp
    subgoal using vc1 vc2 vc_mono pre2 by auto
    subgoal using pre by auto
    done
next
  case (ZWhile I b c)
  from ZWhile(2) obtain C where strip: "strip C = c" and vc: "vc C (\<lambda>a. I a + 1)"
    and pre: "\<And>s. pre C (\<lambda>a. I a + 1) s \<le> I s + \<up> (bval b s)" by blast
  show ?case apply(rule exI[where x="{I} WHILE b DO C"])
    apply safe
    subgoal using strip by simp
    subgoal using pre vc by auto
    subgoal by simp
  done
next
  case (Zconseq' P c Q P' Q')
  then obtain C where "strip C = c" and vc: "vc C Q" and pre: "\<And>s. pre C Q s \<le> P s" by blast

  from pre_mono[OF Zconseq'(3)] have 1: "\<And>s. pre C Q' s \<le> pre C Q s" by auto

  show ?case
    apply(rule exI[where x=C])
    apply safe
      apply fact
    subgoal using vc Zconseq'(3) vc_mono by auto
    subgoal using pre Zconseq'(2) 1 using order.trans  by metis
    done
next
  case (Zconst k P c Q)
  then obtain C where strip: "strip C = c" and vc: "vc C (\<lambda>a. enat k * Q a)"
    and k: "k>0" and pre: "\<And>s. pre C (\<lambda>a. enat k * Q a) s \<le> enat k * P s" by blast
  show ?case
    apply(rule exI[where x="{k} Ab C"]) apply safe
    subgoal using strip by auto
    subgoal using vc k by auto
    subgoal apply auto using ediv_mono[OF pre] ediv_cancel2[OF k] by metis
    done
qed

end


section "Correctness of an optimizer"

theory Optimizer
  imports Lambda DenotEqualitiesFSet
begin

fun is_value :: "exp \<Rightarrow> bool" where
  "is_value (ENat n) = True" |
  "is_value (ELam x e) = (FV e = {})" |
  "is_value _ = False"

lemma is_value_is_val[simp]: "is_value e \<Longrightarrow> isval e \<and> FV e = {}"
  by (case_tac e) auto

fun opt :: "exp \<Rightarrow> nat \<Rightarrow> exp" where
  "opt (EVar x) k = EVar x" |
  "opt (ENat n) k = ENat n" |
  "opt (ELam x e) k = ELam x (opt e k)" |
  "opt (EApp e1 e2) 0 = EApp (opt e1 0) (opt e2 0)" |
  "opt (EApp e1 e2) (Suc k) =
    (let e1' = opt e1 (Suc k) in let e2' = opt e2 (Suc k) in
     (case e1' of
        ELam x e \<Rightarrow> if is_value e2' then opt (subst x e2' e) k
                   else EApp e1' e2'
     | _ \<Rightarrow> EApp e1' e2'))" |
  "opt (EPrim f e1 e2) k =
    (let e1' = opt e1 k in let e2' = opt e2 k in
    (case (e1', e2') of
       (ENat n1, ENat n2) \<Rightarrow> ENat (f n1 n2)
    | _ \<Rightarrow> EPrim f e1' e2'))" |
  "opt (EIf e1 e2 e3) k =
    (let e1' = opt e1 k in let e2' = opt e2 k in let e3' = opt e3 k in
    (case e1' of
      ENat n \<Rightarrow> if n = 0 then e3' else e2'
    | _ \<Rightarrow> EIf e1' e2' e3'))"

lemma opt_correct_aux: "E e = E (opt e k)"
proof (induction e k rule: opt.induct)
  case (5 e1 e2 k)
  then show ?case
    apply (cases "opt e1 (Suc k)")
         apply force
        apply force
       prefer 2 apply force
      prefer 2 apply force
     prefer 2 apply force
    apply (rename_tac x e)
    apply (cases "is_value (opt e2 (Suc k))")
     apply (subgoal_tac "E (EApp (ELam x e) (opt e2 (Suc k)))
                       = E (subst x (opt e2 (Suc k)) e)")
      prefer 2 apply (rule eval_app_lam)
      apply (simp del: E.simps)
     apply (subgoal_tac "E(EApp e1 e2) = E(EApp (ELam x e) (opt e2 (Suc k)))")
      prefer 2
      apply (rule e_app_cong)
       apply force+ done
next
  case (6 f e1 e2 k)
  then show ?case apply auto apply (cases "opt e1 k") apply auto
    apply (cases "opt e2 k") apply auto done
next
  case (7 e1 e2 e3 k)
  then show ?case by (cases "opt e1 k") auto
qed auto

theorem opt_correct: "e \<simeq> opt e k"
  using opt_correct_aux denot_sound_wrt_ctx_equiv by blast

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Functions from A to B, up to a Permutation of A\<close>

theory Twelvefold_Way_Entry4
imports Equiv_Relations_on_Functions
begin

subsection \<open>Definition of Bijections\<close>

definition msubset_of :: "'a set \<Rightarrow> ('a  \<Rightarrow> 'b) set \<Rightarrow> 'b multiset"
where
  "msubset_of A F = univ (\<lambda>f. image_mset f (mset_set A)) F"

definition functions_of :: "'a set \<Rightarrow> 'b multiset \<Rightarrow> ('a \<Rightarrow> 'b) set"
where
  "functions_of A B = {f \<in> A \<rightarrow>\<^sub>E set_mset B. image_mset f (mset_set A) = B}"

subsection \<open>Properties for Bijections\<close>

lemma msubset_of:
  assumes "F \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B"
  shows "size (msubset_of A F) = card A"
  and "set_mset (msubset_of A F) \<subseteq> B"
proof -
  from \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B\<close> obtain f where "f \<in> A \<rightarrow>\<^sub>E B"
    and F_eq: "F = domain_permutation A B `` {f}" using quotientE by blast
  have "msubset_of A F = univ (\<lambda>f. image_mset f (mset_set A)) F"
    unfolding msubset_of_def ..
  also have "\<dots> = univ (\<lambda>f. image_mset f (mset_set A)) (domain_permutation A B `` {f})"
    unfolding F_eq ..
  also have "\<dots> = image_mset f (mset_set A)"
    using equiv_domain_permutation image_mset_respects_domain_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') auto
  finally have msubset_of_eq: "msubset_of A F = image_mset f (mset_set A)" .
  show "size (msubset_of A F) = card A"
  proof -
    have "size (msubset_of A F) = size (image_mset f (mset_set A))"
      unfolding msubset_of_eq ..
    also have "\<dots> = card A"
      by (cases \<open>finite A\<close>) auto
    finally show ?thesis .
  qed
  show "set_mset (msubset_of A F) \<subseteq> B"
  proof -
    have "set_mset (msubset_of A F) = set_mset (image_mset f (mset_set A))"
      unfolding msubset_of_eq ..
    also have "\<dots> \<subseteq> B"
      using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> by (cases "finite A") auto
    finally show ?thesis .
  qed
qed

lemma functions_of:
  assumes "finite A"
  assumes "set_mset M \<subseteq> B"
  assumes "size M = card A"
  shows "functions_of A M \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B"
proof -
  obtain f where "f \<in> A \<rightarrow>\<^sub>E set_mset M" and "image_mset f (mset_set A) = M"
    using obtain_function_on_ext_funcset \<open>finite A\<close> \<open>size M = card A\<close> by blast
  from \<open>f \<in> A \<rightarrow>\<^sub>E set_mset M\<close> have "f \<in> A \<rightarrow>\<^sub>E B"
    using \<open>set_mset M \<subseteq> B\<close> PiE_iff subset_eq by blast
  have "functions_of A M = (domain_permutation A B) `` {f}"
  proof
    show "functions_of A M \<subseteq> domain_permutation A B `` {f}"
    proof
      fix f'
      assume "f' \<in> functions_of A M"
      from this have "M = image_mset f' (mset_set A)" and "f' \<in> A \<rightarrow>\<^sub>E f' ` A"
        using \<open>finite A\<close> unfolding functions_of_def by auto
      from this assms(1, 2) have "f' \<in> A \<rightarrow>\<^sub>E B"
        by (simp add: PiE_iff image_subset_iff)
      obtain p where "p permutes A \<and> (\<forall>x\<in>A. f x = f' (p x))"
        using \<open>finite A\<close> \<open>image_mset f (mset_set A) = M\<close> \<open>M = image_mset f' (mset_set A)\<close>
          image_mset_eq_implies_permutes by blast
      from this show "f' \<in> domain_permutation A B `` {f}"
        using \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close>
        unfolding domain_permutation_def by auto
    qed
  next
    show "domain_permutation A B `` {f} \<subseteq> functions_of A M"
    proof
      fix f'
      assume "f' \<in> domain_permutation A B `` {f}"
      from this have "(f, f') \<in> domain_permutation A B" by auto
      from this \<open>image_mset f (mset_set A) = M\<close> have "image_mset f' (mset_set A) = M"
        using congruentD[OF image_mset_respects_domain_permutation] by metis
      moreover from this \<open>(f, f') \<in> domain_permutation A B\<close> have "f' \<in> A \<rightarrow>\<^sub>E set_mset M"
        using \<open>finite A\<close> unfolding domain_permutation_def by auto
      ultimately show "f' \<in> functions_of A M"
        unfolding functions_of_def by auto
    qed
  qed
  from this \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> show ?thesis by (auto intro: quotientI)
qed

lemma functions_of_msubset_of:
  assumes "finite A"
  assumes "F \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B"
  shows "functions_of A (msubset_of A F) = F"
proof -
  from \<open>F \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B\<close> obtain f where "f \<in> A \<rightarrow>\<^sub>E B"
    and F_eq: "F = domain_permutation A B `` {f}" using quotientE by blast
  have "msubset_of A F = univ (\<lambda>f. image_mset f (mset_set A)) F"
    unfolding msubset_of_def ..
  also have "\<dots> = univ (\<lambda>f. image_mset f (mset_set A)) (domain_permutation A B `` {f})"
    unfolding F_eq ..
  also have "\<dots> = image_mset f (mset_set A)"
    using equiv_domain_permutation image_mset_respects_domain_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') auto
  finally have msubset_of_eq: "msubset_of A F = image_mset f (mset_set A)" .
  show ?thesis
  proof
    show "functions_of A (msubset_of A F) \<subseteq> F"
    proof
      fix f'
      assume "f' \<in> functions_of A (msubset_of A F)"
      from this have f': "f' \<in> A \<rightarrow>\<^sub>E f ` set_mset (mset_set A)"
      "image_mset f' (mset_set A) = image_mset f (mset_set A)"
        unfolding functions_of_def by (auto simp add: msubset_of_eq)
      from \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> have "f ` A \<subseteq> B" by auto
      note \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
      moreover from f'(1) \<open>finite A\<close> \<open>f ` A \<subseteq> B\<close> have "f' \<in> A \<rightarrow>\<^sub>E B" by auto
      moreover obtain p where "p permutes A \<and> (\<forall>x\<in>A. f x = f' (p x))"
        using \<open>finite A\<close> \<open>image_mset f' (mset_set A) = image_mset f (mset_set A)\<close>
          by (metis image_mset_eq_implies_permutes)
      ultimately show "f' \<in> F"
        unfolding F_eq domain_permutation_def by auto
    qed
  next
    show "F \<subseteq> functions_of A (msubset_of A F)"
    proof
      fix f'
      assume "f' \<in> F"
      from this have "f' \<in> A \<rightarrow>\<^sub>E B"
        unfolding F_eq domain_permutation_def by auto
      from \<open>f' \<in> F\<close> obtain p where "p permutes A \<and> (\<forall>x\<in>A. f x = f' (p x))"
        unfolding F_eq domain_permutation_def by auto
      from this have eq: "image_mset f' (mset_set A) = image_mset f (mset_set A)"
        using permutes_implies_image_mset_eq by blast
      moreover have "f' \<in> A \<rightarrow>\<^sub>E set_mset (image_mset f (mset_set A))"
        using \<open>finite A\<close> \<open>f' \<in> A \<rightarrow>\<^sub>E B\<close> eq[symmetric] by auto
      ultimately show "f' \<in> functions_of A (msubset_of A F)"
        unfolding functions_of_def msubset_of_eq by auto
    qed
  qed
qed

lemma msubset_of_functions_of:
  assumes "set_mset M \<subseteq> B" "size M = card A" "finite A"
  shows "msubset_of A (functions_of A M) = M"
proof -
  from assms have "functions_of A M \<in> (A \<rightarrow>\<^sub>E B) // domain_permutation A B"
    using functions_of by fastforce
  from this obtain f where "f \<in> A \<rightarrow>\<^sub>E B" and "functions_of A M = domain_permutation A B `` {f}"
    by (rule quotientE)
  from this have "f \<in> functions_of A M"
    using equiv_domain_permutation equiv_class_self by fastforce
  have "msubset_of A (functions_of A M) = univ (\<lambda>f. image_mset f (mset_set A)) (functions_of A M)"
    unfolding msubset_of_def ..
  also have "\<dots> = univ (\<lambda>f. image_mset f (mset_set A)) (domain_permutation A B `` {f})"
    unfolding \<open>functions_of A M = domain_permutation A B `` {f}\<close> ..
  also have "\<dots> = image_mset f (mset_set A)"
    using equiv_domain_permutation image_mset_respects_domain_permutation \<open>f \<in> A \<rightarrow>\<^sub>E B\<close>
    by (subst univ_commute') auto
  also have "image_mset f (mset_set A) = M"
    using \<open>f \<in> functions_of A M\<close> unfolding functions_of_def by simp
  finally show ?thesis .
qed

subsection \<open>Bijections\<close>

lemma bij_betw_msubset_of:
  assumes "finite A"
  shows "bij_betw (msubset_of A) ((A \<rightarrow>\<^sub>E B) // domain_permutation A B) {M. set_mset M \<subseteq> B \<and> size M = card A}"
proof (rule bij_betw_byWitness[where f'="\<lambda>M. functions_of A M"])
  show "\<forall>F\<in>(A \<rightarrow>\<^sub>E B) // domain_permutation A B. functions_of A (msubset_of A F) = F"
    using \<open>finite A\<close> by (auto simp add: functions_of_msubset_of)
  show "\<forall>M\<in>{M. set_mset M \<subseteq> B \<and> size M = card A}. msubset_of A (functions_of A M) = M"
    using \<open>finite A\<close> by (auto simp add: msubset_of_functions_of)
  show "msubset_of A ` ((A \<rightarrow>\<^sub>E B) // domain_permutation A B) \<subseteq> {M. set_mset M \<subseteq> B \<and> size M = card A}"
    using msubset_of by blast
  show "functions_of A ` {M. set_mset M \<subseteq> B \<and> size M = card A} \<subseteq> (A \<rightarrow>\<^sub>E B) // domain_permutation A B"
    using functions_of \<open>finite A\<close> by blast
qed

subsection \<open>Cardinality\<close>

lemma
  assumes "finite A" "finite B"
  shows "card ((A \<rightarrow>\<^sub>E B) // domain_permutation A B) = card B + card A - 1 choose card A"
proof -
  have "bij_betw (msubset_of A) ((A \<rightarrow>\<^sub>E B) // domain_permutation A B) {M. set_mset M \<subseteq> B \<and> size M = card A}"
    using \<open>finite A\<close> by (rule bij_betw_msubset_of)
  from this have "card ((A \<rightarrow>\<^sub>E B) // domain_permutation A B) = card {M. set_mset M \<subseteq> B \<and> size M = card A}"
    by (rule bij_betw_same_card)
  also have "card {M. set_mset M \<subseteq> B \<and> size M = card A} = card B + card A - 1 choose card A"
    using \<open>finite B\<close> by (rule card_multisets)
  finally show ?thesis .
qed

end


theory TheoremD13
imports TheoremD12
begin

context LocalLexing begin

lemma pointwise_natUnion_swap:
  assumes pointwise_f: "pointwise f"
  shows "f (natUnion G) = natUnion (\<lambda> u. f (G u))"
proof -
  note f_simp = pointwise_simp[OF pointwise_f]
  have h1: "f (natUnion G) = \<Union> {f {x} |x. x \<in> (natUnion G)}" using f_simp by blast
  have h2: "\<And> x. f (G x) =  \<Union> {f {y} |y. y \<in> G x}" using f_simp by metis
  show ?thesis
    apply (subst h1)
    apply (subst h2)
    apply (simp add: natUnion_def)
    by blast
qed

lemma pointwise_Gen: "pointwise Gen"
  by (simp add: pointwise_def Gen_def, blast)

lemma thmD13_part1:
  assumes start: "items_le k (\<J> k 0) = Gen (paths_le k (\<P> k 0))"
  assumes valid_k: "k \<le> length Doc"
  shows "items_le k (\<J> k u) = Gen (paths_le k (\<P> k u)) \<and> \<T> k u = \<Z> k u"
proof (induct u)
  case 0
    then show ?case using start by auto
next
  case (Suc u)
    from Suc have sub: "items_le k (\<J> k (Suc u)) \<subseteq> Gen (paths_le k (\<P> k (Suc u)))"
      using thmD9 valid_k by blast
    from Suc have sup: "items_le k (\<J> k (Suc u)) \<supseteq> Gen (paths_le k (\<P> k (Suc u)))"
      using thmD12 by blast
    from Suc have tokens: "\<T> k (Suc u) = \<Z> k (Suc u)"
      using \<T>_equals_\<Z>_induct_step by blast
    from sub sup tokens show ?case by blast
qed

lemma thmD13_part2:
  assumes start: "items_le k (\<J> k 0) = Gen (paths_le k (\<P> k 0))"
  assumes valid_k: "k \<le> length Doc"
  shows "items_le k (\<I> k) = Gen (paths_le k (\<Q> k))"
proof -
  note part1 = thmD13_part1[OF start valid_k]
  have e1: "items_le k (\<I> k) = natUnion (\<lambda> u. items_le k (\<J> k u))"
    using items_le_pointwise pointwise_natUnion_swap by auto
  have e2: "natUnion (\<lambda> u. items_le k (\<J> k u)) = natUnion  (\<lambda> u. Gen (paths_le k (\<P> k u)))"
    using part1 by auto
  have e3: "natUnion (\<lambda> u. Gen (paths_le k (\<P> k u))) = Gen (natUnion (\<lambda> u. paths_le k (\<P> k u)))"
    using pointwise_Gen pointwise_natUnion_swap by fastforce
  have e4: "natUnion (\<lambda> u. paths_le k (\<P> k u)) = paths_le k (natUnion (\<lambda> u. \<P> k u))"
    using paths_le_pointwise pointwise_natUnion_swap by fastforce
  from e1 e2 e3 e4 show ?thesis by simp
qed

theorem thmD13:
  assumes start: "items_le k (\<J> k 0) = Gen (paths_le k (\<P> k 0))"
  assumes valid_k: "k \<le> length Doc"
  shows "items_le k (\<J> k u) = Gen (paths_le k (\<P> k u)) \<and> \<T> k u = \<Z> k u
    \<and> items_le k (\<I> k) = Gen (paths_le k (\<Q> k))"
using thmD13_part1[OF start valid_k] thmD13_part2[OF start valid_k] by blast

end

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   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_prop_54
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "((t2 (t22 m n) n) = m)"
  oops

end


section \<open>Cheeger Inequality\label{sec:cheeger_ineq}\<close>

text \<open>The Cheeger inequality relates edge expansion (a combinatorial property) with the second
largest eigenvalue.\<close>

theory Expander_Graphs_Cheeger_Inequality
  imports Expander_Graphs_Eigenvalues
begin

unbundle intro_cong_syntax
hide_const Quantum.T

context regular_graph
begin

lemma edge_expansionD2:
  assumes "m = card (S \<inter> verts G)" "2*m \<le> n"
  shows "\<Lambda>\<^sub>e * m \<le> real (card (edges_betw S (-S)))"
proof -
  define S' where "S' = S \<inter> verts G"
  have "\<Lambda>\<^sub>e * m = \<Lambda>\<^sub>e * card S'"
    using assms(1) S'_def by simp
  also have "... \<le> real (card (edges_betw S' (-S')))"
    using assms unfolding S'_def by (intro edge_expansionD) auto
  also have "... = real (card (edges_betw S (-S)))"
    unfolding S'_def edges_betw_def
    by (intro arg_cong[where f="real"] arg_cong[where f="card"]) auto
  finally show ?thesis by simp
qed

lemma edges_betw_sym:
  "card (edges_betw S T) = card (edges_betw T S)" (is "?L = ?R")
proof -
  have "?L =  (\<Sum>a \<in> arcs G. of_bool (tail G a \<in> S \<and> head G a \<in> T))"
    unfolding edges_betw_def of_bool_def by (simp add:sum.If_cases Int_def)
  also have "... = (\<Sum>e \<in># edges G. of_bool (fst e \<in> S \<and> snd e \<in> T))"
    unfolding sum_unfold_sum_mset edges_def arc_to_ends_def
    by (simp add:image_mset.compositionality comp_def)
  also have "... =  (\<Sum>e \<in># edges G. of_bool (snd e \<in> S \<and> fst e \<in> T))"
    by (subst edges_sym[OF sym, symmetric])
        (simp add:image_mset.compositionality comp_def case_prod_beta)
  also have "... = (\<Sum>a \<in> arcs G. of_bool (tail G a \<in> T \<and> head G a \<in> S))"
    unfolding sum_unfold_sum_mset edges_def arc_to_ends_def
    by (simp add:image_mset.compositionality comp_def conj.commute)
  also have "... = ?R"
    unfolding edges_betw_def of_bool_def by (simp add:sum.If_cases Int_def)
  finally show ?thesis by simp
qed

lemma edges_betw_reg:
  assumes "S \<subseteq> verts G"
  shows "card (edges_betw S UNIV) = card S * d" (is "?L = ?R")
proof -
  have "?L = card (\<Union>(out_arcs G ` S))"
    unfolding edges_betw_def out_arcs_def by (intro arg_cong[where f="card"]) auto
  also have "... = (\<Sum>i\<in>S. card (out_arcs G i))"
    using finite_subset[OF assms] unfolding out_arcs_def
    by (intro card_UN_disjoint) auto
  also have "... = (\<Sum>i\<in>S. out_degree G i)"
    unfolding out_degree_def by simp
  also have "... = (\<Sum>i\<in>S. d)"
    using assms by (intro sum.cong reg) auto
  also have "... = ?R"
    by simp
  finally show ?thesis by simp
qed

text \<open>The following proof follows Hoory et al.~@{cite \<open>\S 4.5.1\<close> "hoory2006"}.\<close>

lemma cheeger_aux_2:
  assumes "n > 1"
  shows "\<Lambda>\<^sub>e \<ge> d*(1-\<Lambda>\<^sub>2)/2"
proof -
  have "real (card (edges_betw S (-S))) \<ge> (d * (1 - \<Lambda>\<^sub>2) / 2) * real (card S)"
    if "S \<subseteq> verts G" "2 * card S \<le> n" for S
  proof -
    let ?ct = "real (card (verts G - S))"
    let ?cs = "real (card S)"

    have "card (edges_betw S S)+card (edges_betw S (-S))=card(edges_betw S S\<union>edges_betw S (-S))"
      unfolding edges_betw_def by (intro card_Un_disjoint[symmetric]) auto
    also have "... = card (edges_betw S UNIV)"
      unfolding edges_betw_def by (intro arg_cong[where f="card"]) auto
    also have "... = d * ?cs"
      using edges_betw_reg[OF that(1)] by simp
    finally have "card (edges_betw S S) + card (edges_betw S (-S)) = d * ?cs" by simp
    hence 4: "card (edges_betw S S) = d * ?cs - card (edges_betw S (-S))"
      by simp

    have "card(edges_betw S(-S))+card(edges_betw(-S)(-S))=card(edges_betw S(-S)\<union>edges_betw(-S)(-S))"
      unfolding edges_betw_def by (intro card_Un_disjoint[symmetric]) auto
    also have "... = card (edges_betw UNIV (verts G - S))"
      unfolding edges_betw_def by (intro arg_cong[where f="card"]) auto
    also have "... = card (edges_betw (verts G - S) UNIV)"
      by (intro edges_betw_sym)
    also have "... = d * ?ct"
      using edges_betw_reg by auto
    finally have "card (edges_betw S (-S)) + card (edges_betw (-S) (-S)) = d * ?ct" by simp
    hence 5: "card (edges_betw (-S) (-S)) = d * ?ct - card (edges_betw S (-S))"
      by simp
    have 6: "card (edges_betw (-S) S) = card (edges_betw S (-S))"
      by (intro edges_betw_sym)

    have "?cs + ?ct =real (card (S \<union> (verts G- S)))"
      unfolding of_nat_add[symmetric] using finite_subset[OF that(1)]
      by (intro_cong "[\<sigma>\<^sub>1 of_nat, \<sigma>\<^sub>1 card]" more:card_Un_disjoint[symmetric]) auto
    also have "... = real n"
      unfolding n_def  using that(1) by (intro_cong "[\<sigma>\<^sub>1 of_nat, \<sigma>\<^sub>1 card]") auto
    finally have 7: "?cs + ?ct = n"  by simp

    define f  where
      "f x = real (card (verts G - S)) * of_bool (x \<in> S) - card S * of_bool (x \<notin> S)" for x

    have "g_inner f (\<lambda>_. 1) = ?cs * ?ct - real (card (verts G \<inter> {x. x \<notin> S})) * ?cs"
      unfolding g_inner_def f_def using Int_absorb1[OF that(1)] by (simp add:sum_subtractf)
    also have "... = ?cs * ?ct - ?ct * ?cs"
      by (intro_cong "[\<sigma>\<^sub>2 (-), \<sigma>\<^sub>2 (*), \<sigma>\<^sub>1 of_nat, \<sigma>\<^sub>1 card]") auto
    also have "... = 0" by simp
    finally have 11:" g_inner f (\<lambda>_. 1) = 0" by simp

    have "g_norm f^2 = (\<Sum>v\<in>verts G. f v^2)"
      unfolding g_norm_sq g_inner_def conjugate_real_def by (simp add:power2_eq_square)
    also have "...=(\<Sum>v\<in>verts G. ?ct^2*(of_bool (v \<in> S))\<^sup>2)+(\<Sum>v\<in>verts G. ?cs^2*(of_bool (v \<notin> S))\<^sup>2)"
      unfolding f_def power2_diff by (simp add:sum.distrib sum_subtractf power_mult_distrib)
    also have "... = real (card (verts G \<inter> S))*?ct^2 + real (card (verts G \<inter> {v. v \<notin> S})) * ?cs^2"
      unfolding of_bool_def by (simp add:if_distrib if_distribR sum.If_cases)
    also have "... = real(card S)*(real(card(verts G-S)))\<^sup>2 + real(card(verts G-S))*(real(card S))\<^sup>2"
      using that(1) by (intro_cong "[\<sigma>\<^sub>2(+), \<sigma>\<^sub>2 (*), \<sigma>\<^sub>2 power, \<sigma>\<^sub>1 of_nat, \<sigma>\<^sub>1 card]") auto
    also have "...  = real(card S)*real (card (verts G -S))*(?cs + ?ct)"
      by (simp add:power2_eq_square algebra_simps)
    also have "...  = real(card S)*real (card (verts G -S))*n"
      unfolding 7 by simp
    finally have 9:" g_norm f^2 = real(card S)*real (card (verts G -S))*real n" by simp

    have "(\<Sum>a \<in> arcs G. f (head G a) * f (tail G a)) =
      (card (edges_betw S S) * ?ct*?ct) + (card (edges_betw (-S) (-S)) * ?cs*?cs) -
      (card (edges_betw S (-S)) * ?ct*?cs) - (card (edges_betw (-S) S) * ?cs*?ct)"
      unfolding f_def by (simp add:of_bool_def algebra_simps Int_def if_distrib if_distribR
          edges_betw_def sum.If_cases)
    also have "... = d*?cs*?ct*(?cs+?ct) - card (edges_betw S (-S))*(?ct*?ct+2*?ct*?cs+?cs*?cs)"
      unfolding 4 5 6 by (simp add:algebra_simps)
    also have "... = d*?cs*?ct*n - (?ct+?cs)^2 * card (edges_betw S (-S))"
      unfolding power2_diff 7 power2_sum by (simp add:ac_simps power2_eq_square)
    also have "... = d *?cs*?ct*n - n^2 * card (edges_betw S (-S))"
      using 7 by (simp add:algebra_simps)
    finally have 8:"(\<Sum>a \<in> arcs G. f(head G a)*f(tail G a))=d*?cs*?ct*n-n^2*card(edges_betw S (-S))"
      by simp

    have "d*?cs*?ct*n-n^2*card(edges_betw S (-S)) = (\<Sum>a \<in> arcs G. f (head G a) * f (tail G a))"
      unfolding 8 by simp
    also have "... \<le> d * (g_inner f (g_step f))"
      unfolding g_inner_step_eq using d_gt_0
      by simp
    also have "... \<le> d * (\<Lambda>\<^sub>2 * g_norm f^2)"
      by (intro mult_left_mono os_expanderD 11) auto
    also have "... = d * \<Lambda>\<^sub>2 * ?cs*?ct*n"
      unfolding 9 by simp
    finally have "d*?cs*?ct*n-n^2*card(edges_betw S (-S)) \<le> d * \<Lambda>\<^sub>2 * ?cs*?ct*n"
      by simp
    hence "n * n * card (edges_betw S (-S)) \<ge> n * (d * ?cs * ?ct * (1-\<Lambda>\<^sub>2))"
      by (simp add:power2_eq_square algebra_simps)
    hence 10:"n * card (edges_betw S (-S)) \<ge> d * ?cs * ?ct * ( 1-\<Lambda>\<^sub>2)"
      using n_gt_0 by simp

    have "(d * (1 - \<Lambda>\<^sub>2) / 2) * ?cs = (d * (1-\<Lambda>\<^sub>2) * (1 - 1 / 2)) * ?cs"
      by simp
    also have "... \<le> d * (1-\<Lambda>\<^sub>2) * ((n - ?cs) / n) * ?cs"
      using that n_gt_0 \<Lambda>\<^sub>2_le_1
      by (intro mult_left_mono mult_right_mono mult_nonneg_nonneg) auto
    also have "... = (d * (1-\<Lambda>\<^sub>2) * ?ct / n) * ?cs"
      using 7 by simp
    also have "... = d * ?cs * ?ct * (1-\<Lambda>\<^sub>2) / n"
      by simp
    also have "... \<le> n * card (edges_betw S (-S)) / n"
      by (intro divide_right_mono 10) auto
    also have "... = card (edges_betw S (-S))"
      using n_gt_0 by simp
    finally show ?thesis by simp
  qed
  thus ?thesis
    by (intro edge_expansionI assms) auto
qed

end

lemma surj_onI:
  assumes "\<And>x. x \<in> B \<Longrightarrow> g x \<in> A \<and> f (g x) = x"
  shows "B \<subseteq> f ` A"
  using assms by force

lemma find_sorted_bij_1:
  fixes g :: "'a \<Rightarrow> ('b :: linorder)"
  assumes "finite S"
  shows "\<exists>f. bij_betw f {..<card S} S \<and> mono_on {..<card S} (g\<circ> f)"
proof -
  define h where "h x = from_nat_into S x" for x

  have h_bij:"bij_betw h {..<card S} S"
    unfolding h_def using bij_betw_from_nat_into_finite[OF assms] by simp

  define xs where "xs = sort_key (g \<circ> h) [0..<card S]"
  define f where "f i = h (xs ! i)" for i

  have l_xs: "length xs = card S"
    unfolding xs_def by auto
  have set_xs: "set xs = {..<card S}"
    unfolding xs_def by auto
  have dist_xs: "distinct xs"
    using l_xs set_xs by (intro card_distinct) simp
  have sorted_xs: "sorted (map (g \<circ> h) xs)"
    unfolding xs_def using sorted_sort_key by simp

  have "(\<lambda>i. xs ! i) ` {..<card S} = set xs"
    using l_xs by (auto simp:in_set_conv_nth)
  also have "... = {..<card S}"
    unfolding set_xs by simp
  finally have set_xs':
    "(\<lambda>i. xs ! i) ` {..<card S} = {..<card S}" by simp

  have "f ` {..<card S} = h ` ((\<lambda>i. xs ! i) ` {..<card S})"
    unfolding f_def image_image by simp
  also have "... = h ` {..<card S}"
    unfolding set_xs' by simp
  also have "... = S"
    using bij_betw_imp_surj_on[OF h_bij] by simp
  finally have 0: "f ` {..<card S} = S" by simp

  have "inj_on ((!) xs) {..<card S}"
    using dist_xs l_xs unfolding distinct_conv_nth
    by (intro inj_onI) auto
  hence "inj_on (h \<circ> (\<lambda>i. xs ! i)) {..<card S}"
    using set_xs' bij_betw_imp_inj_on[OF h_bij]
    by (intro comp_inj_on) auto
  hence 1: "inj_on f {..<card S}"
    unfolding f_def comp_def by simp
  have 2: "mono_on {..<card S} (g \<circ> f)"
    using sorted_nth_mono[OF sorted_xs] l_xs unfolding f_def
    by (intro mono_onI)  simp
  thus ?thesis
    using 0 1 2 unfolding bij_betw_def by auto
qed

lemma find_sorted_bij_2:
  fixes g :: "'a \<Rightarrow> ('b :: linorder)"
  assumes "finite S"
  shows "\<exists>f. bij_betw f S {..<card S} \<and> (\<forall>x y. x \<in> S \<and> y \<in> S \<and> f x < f y \<longrightarrow> g x \<le> g y)"
proof -
  obtain f where f_def: "bij_betw f {..<card S} S" "mono_on {..<card S} (g \<circ> f)"
    using find_sorted_bij_1 [OF assms] by auto

  define h where "h = the_inv_into {..<card S} f"
  have bij_h: "bij_betw h S {..<card S}"
    unfolding h_def by (intro bij_betw_the_inv_into f_def)

  moreover have "g x \<le> g y" if "h x < h y" "x \<in> S" "y \<in> S" for x y
  proof -
    have "h y < card S" "h x < card S" "h x \<le> h y"
      using bij_betw_apply[OF bij_h] that by auto
    hence "g (f (h x)) \<le> g (f (h y))"
      using f_def(2) unfolding mono_on_def by simp
    moreover have "f ` {..<card S} = S"
      using bij_betw_imp_surj_on[OF f_def(1)] by simp
    ultimately show "g x \<le> g y"
      unfolding h_def using that f_the_inv_into_f[OF bij_betw_imp_inj_on[OF f_def(1)]]
      by auto
  qed
  ultimately show ?thesis by auto
qed

context regular_graph_tts
begin

text \<open>Normalized Laplacian of the graph\<close>
definition L where "L = mat 1 - A"

lemma L_pos_semidefinite:
  fixes v :: "real ^'n"
  shows  "v \<bullet> (L *v v)  \<ge> 0"
proof -
  have "0 = v \<bullet> v - norm v^2" unfolding power2_norm_eq_inner by simp
  also have "... \<le> v \<bullet> v - abs (v \<bullet> (A *v v))"
    by (intro diff_mono rayleigh_bound) auto
  also have "... \<le> v \<bullet> v - v \<bullet> (A *v v)"
    by (intro diff_mono) auto
  also have "... = v \<bullet> (L *v v)"
    unfolding L_def by (simp add:algebra_simps)
  finally show ?thesis by simp
qed

text \<open>The following proof follows Hoory et al.~@{cite \<open>\S 4.5.2\<close> "hoory2006"}.\<close>

lemma cheeger_aux_1:
  assumes "n > 1"
  shows "\<Lambda>\<^sub>e \<le> d * sqrt (2 * (1-\<Lambda>\<^sub>2))"
proof -
  obtain v where v_def: "v \<bullet> 1 = 0" "v \<noteq> 0" "A *v v = \<Lambda>\<^sub>2 *s v"
    using \<Lambda>\<^sub>2_eq_\<gamma>\<^sub>2 \<gamma>\<^sub>2_ev[OF assms] by auto

  have "False" if "2*card {i. (1 *s v) $h i > 0} > n" "2*card {i. ((-1) *s v) $h i > 0} > n"
  proof -
    have "2 * n = n + n" by simp
    also have "... <2 * card {i.  (1 *s v) $h i > 0} + 2 * card {i. ((-1) *s v) $h i > 0}"
      by (intro add_strict_mono that)
    also have "... = 2 * (card {i.  (1 *s v) $h i > 0} + card {i.  ((-1) *s v) $h i > 0})"
      by simp
    also have "... = 2 * (card ({i.  (1 *s v) $h i > 0} \<union> {i.  ((-1) *s v) $h i > 0}))"
      by (intro arg_cong2[where f="(*)"] card_Un_disjoint[symmetric]) auto
    also have "... \<le> 2 * (card (UNIV :: 'n set))"
      by (intro mult_left_mono card_mono) auto
    finally have "2 * n < 2 * n"
      unfolding n_def card_n by auto
    thus ?thesis by simp
  qed
  then obtain \<beta>  :: real where \<beta>_def: "\<beta> = 1 \<or> \<beta>=(-1)" "2* card {i. (\<beta> *s v) $h i > 0 } \<le> n"
    unfolding not_le[symmetric] by blast

  define g where "g = \<beta> *s v"

  have g_orth: "g \<bullet> 1 = 0" unfolding g_def using v_def(1)
    by (simp add: scalar_mult_eq_scaleR)
  have g_nz: "g \<noteq> 0"
    unfolding g_def using \<beta>_def(1) v_def(2) by auto
  have g_ev: "A *v g = \<Lambda>\<^sub>2 *s g"
    unfolding g_def scalar_mult_eq_scaleR matrix_vector_mult_scaleR v_def(3) by auto
  have g_supp: "2 * card { i. g $h i > 0 } \<le> n"
    unfolding g_def using \<beta>_def(2) by auto

  define f where "f = (\<chi> i. max (g $h i) 0)"

  have "(L *v f) $h i \<le> (1-\<Lambda>\<^sub>2) * g $h i" (is "?L \<le> ?R") if "g $h i > 0" for i
  proof -
    have "?L = f $h i - (A *v f) $h i"
      unfolding L_def by (simp add:algebra_simps)
    also have "... = g $h i - (\<Sum>j \<in> UNIV. A $h i $h j * f $h j)"
      unfolding matrix_vector_mult_def f_def using that by auto
    also have "... \<le> g $h i - (\<Sum>j \<in> UNIV. A $h i $h j * g $h j)"
      unfolding f_def A_def by (intro diff_mono sum_mono mult_left_mono) auto
    also have "... = g $h i - (A *v g) $h i"
      unfolding matrix_vector_mult_def by simp
    also have "... = (1-\<Lambda>\<^sub>2) * g $h i"
      unfolding g_ev by (simp add:algebra_simps)
    finally show ?thesis by simp
  qed
  moreover have "f $h i \<noteq> 0 \<Longrightarrow> g $h i > 0 "for i
    unfolding f_def by simp
  ultimately have  0:"(L *v f) $h i \<le> (1-\<Lambda>\<^sub>2) * g $h i \<or> f $h i = 0" for i
    by auto

  text \<open>Part (i) in Hoory et al. (\S 4.5.2) but the operator L here is normalized.\<close>
  have "f \<bullet> (L *v f) = (\<Sum>i\<in>UNIV. (L *v f) $h i * f $h i)"
    unfolding inner_vec_def by (simp add:ac_simps)
  also have "... \<le> (\<Sum>i\<in>UNIV. ((1-\<Lambda>\<^sub>2) * g $h i) * f $h i)"
    by (intro sum_mono mult_right_mono' 0) (simp add:f_def)
  also have "... = (\<Sum>i\<in>UNIV. (1-\<Lambda>\<^sub>2) * f $h i * f $h i)"
    unfolding f_def by (intro sum.cong refl) auto
  also have "... = (1-\<Lambda>\<^sub>2) * (f \<bullet> f)"
    unfolding inner_vec_def by (simp add:sum_distrib_left ac_simps)
  also have "... = (1 - \<Lambda>\<^sub>2) * norm f^2"
    by (simp add: power2_norm_eq_inner)
  finally have h_part_i: "f \<bullet> (L *v f) \<le> (1 - \<Lambda>\<^sub>2) * norm f^2" by simp

  define f' where "f' x = f $h (enum_verts_inv x)" for x
  have f'_alt: "f = (\<chi> i. f' (enum_verts i))"
    unfolding f'_def Rep_inverse by simp

  define B\<^sub>f where "B\<^sub>f  = (\<Sum>a\<in>arcs G. \<bar>f' (tail G a)^2-f' (head G a)^2\<bar>)"

  have "(x + y)^2 \<le> 2 * (x^2  + y^2)" for x y :: real
  proof -
    have "(x + y)^2 = (x^2 + y^2) + 2 * x * y"
      unfolding power2_sum by simp
    also have "... \<le> (x^2 + y^2) + (x^2 + y^2)"
      by (intro add_mono sum_squares_bound) auto
    finally show ?thesis by simp
  qed
  hence "(\<Sum>a\<in>arcs G.(f'(tail G a)+ f'(head G a))\<^sup>2)\<le>(\<Sum>a\<in>arcs G. 2*(f'(tail G a)^2+f'(head G a)^2))"
    by (intro sum_mono) auto
  also have "... = 2*((\<Sum>a\<in>arcs G. f'(tail G a)^2) +  (\<Sum>a\<in>arcs G. f'(head G a)^2))"
    by (simp add:sum_distrib_left)
  also have "... = 4 * d * g_norm f'^2"
    unfolding sum_arcs_tail[where f="\<lambda>x. f' x^2"] sum_arcs_head[where f="\<lambda>x. f' x^2"]
      g_norm_sq g_inner_def by (simp add:power2_eq_square)
  also have "... = 4 * d * norm f^2"
    unfolding g_norm_conv f'_alt by simp
  finally have 1: "(\<Sum>i\<in>arcs G. (f' (tail G i) + f' (head G i))\<^sup>2) \<le> 4*d* norm f^2"
    by simp

  have "(\<Sum>a\<in>arcs G. (f' (tail G a) - f' (head G a))\<^sup>2) = (\<Sum>a\<in>arcs G. (f' (tail G a))\<^sup>2) +
    (\<Sum>a\<in>arcs G. (f' (head G a))\<^sup>2) - 2* (\<Sum>a\<in>arcs G. f' (tail G a) * f' (head G a))"
    unfolding power2_diff by (simp add:sum_subtractf sum_distrib_left ac_simps)
  also have "... =  2 * (d * (\<Sum>v\<in>verts G. (f' v)\<^sup>2) - (\<Sum>a\<in>arcs G. f' (tail G a) * f' (head G a)))"
    unfolding sum_arcs_tail[where f="\<lambda>x. f' x^2"] sum_arcs_head[where f="\<lambda>x. f' x^2"] by simp
  also have "... =  2 * (d * g_inner f' f' - d * g_inner f' (g_step f'))"
    unfolding g_inner_step_eq using d_gt_0
    by (intro_cong "[\<sigma>\<^sub>2 (*), \<sigma>\<^sub>2 (-)]") (auto simp:power2_eq_square g_inner_def ac_simps)
  also have "... = 2 * d * (g_inner f' f' -g_inner f' (g_step f'))"
    by (simp add:algebra_simps)
  also have "... = 2 * d * (f \<bullet> f - f \<bullet> (A *v f))"
    unfolding g_inner_conv g_step_conv f'_alt by simp
  also have "... = 2 * d * (f \<bullet> (L *v f))"
    unfolding L_def by (simp add:algebra_simps)
  finally have 2:"(\<Sum>a\<in>arcs G. (f' (tail G a) - f' (head G a))\<^sup>2) = 2 * d * (f \<bullet> (L *v f))" by simp

  have "B\<^sub>f = (\<Sum>a\<in>arcs G. \<bar>f' (tail G a)+f' (head G a)\<bar>*\<bar>f' (tail G a)-f' (head G a)\<bar>)"
    unfolding B\<^sub>f_def abs_mult[symmetric] by (simp add:algebra_simps power2_eq_square)
  also have "...\<le> L2_set (\<lambda>a. f'(tail G a) + f'(head G a)) (arcs G) *
    L2_set (\<lambda>a. f' (tail G a) - f'(head G a)) (arcs G)"
    by (intro L2_set_mult_ineq)
  also have "... \<le> sqrt (4*d* norm f^2) * sqrt (2 * d * (f \<bullet> (L *v f)))"
    unfolding L2_set_def 2
    by (intro mult_right_mono iffD2[OF real_sqrt_le_iff] 1 real_sqrt_ge_zero
        mult_nonneg_nonneg L_pos_semidefinite) auto
  also have "... = 2 * sqrt 2 * d * norm f * sqrt (f \<bullet> (L *v f))"
    by (simp add:real_sqrt_mult)
  finally have hoory_4_12: "B\<^sub>f \<le> 2 * sqrt 2 * d * norm f * sqrt (f \<bullet> (L *v f))"
    by simp
  text \<open>The last statement corresponds to Lemma 4.12 in Hoory et al.\<close>

  obtain \<rho> :: "'a \<Rightarrow> nat" where \<rho>_bij: "bij_betw \<rho> (verts G) {..<n}" and
    \<rho>_dec: "\<And>x y. x \<in> verts G \<Longrightarrow> y \<in> verts G \<Longrightarrow> \<rho> x < \<rho> y \<Longrightarrow> f' x \<ge> f' y"
    unfolding n_def
    using find_sorted_bij_2[where S="verts G" and g="(\<lambda>x. - f' x)"] by auto

  define \<phi> where "\<phi> = the_inv_into (verts G) \<rho>"
  have \<phi>_bij: "bij_betw \<phi> {..<n} (verts G)"
    unfolding \<phi>_def by (intro bij_betw_the_inv_into \<rho>_bij)

  have "edges G = {# e \<in># edges G . \<rho>(fst e) \<noteq> \<rho>(snd e) \<or> \<rho>(fst e) = \<rho>(snd e) #}"
    by simp
  also have "... = {# e \<in># edges G . \<rho>(fst e) \<noteq> \<rho>(snd e) #} + {#e\<in>#edges G. \<rho>(fst e)=\<rho>(snd e)#}"
    by (simp add:filter_mset_ex_predicates)
  also have "...={# e\<in>#edges G. \<rho>(fst e)<\<rho>(snd e)\<or>\<rho>(fst e)>\<rho>(snd e)#}+{#e\<in>#edges G. fst e=snd e#}"
    using bij_betw_imp_inj_on[OF \<rho>_bij] edge_set
    by (intro arg_cong2[where f="(+)"] filter_mset_cong refl inj_on_eq_iff[where A="verts G"])
     auto
  also have "... = {#e \<in># edges G. \<rho>(fst e) < \<rho> (snd e) #} +
    {#e \<in># edges G. \<rho>(fst e) > \<rho> (snd e) #} +
    {#e \<in># edges G. fst e = snd e #}"
    by (intro arg_cong2[where f="(+)"] filter_mset_ex_predicates[symmetric]) auto
  finally have edges_split: "edges G = {#e \<in># edges G. \<rho>(fst e) < \<rho> (snd e) #} +
    {#e \<in># edges G. \<rho>(fst e) > \<rho> (snd e) #} + {#e \<in># edges G. fst e = snd e #}"
    by simp

  have \<rho>_lt_n: "\<rho> x < n" if "x \<in> verts G" for x
    using bij_betw_apply[OF \<rho>_bij] that by auto

  have \<phi>_\<rho>_inv: "\<phi> (\<rho> x) = x" if "x \<in> verts G" for x
    unfolding \<phi>_def using bij_betw_imp_inj_on[OF \<rho>_bij]
    by (intro the_inv_into_f_f that) auto

  have \<rho>_\<phi>_inv: "\<rho> (\<phi> x) = x" if "x < n" for x
    unfolding \<phi>_def using bij_betw_imp_inj_on[OF \<rho>_bij] bij_betw_imp_surj_on[OF \<rho>_bij] that
    by (intro f_the_inv_into_f) auto

  define \<tau> where "\<tau> x = (if x < n then f' (\<phi> x) else 0)" for x

  have \<tau>_nonneg: "\<tau> k \<ge> 0" for k
    unfolding \<tau>_def f'_def f_def by auto

  have \<tau>_antimono: "\<tau> k \<ge> \<tau> l" if " k < l" for k l
  proof (cases "l \<ge> n")
    case True
    hence "\<tau> l = 0" unfolding \<tau>_def by simp
    then show ?thesis using \<tau>_nonneg by simp
  next
    case False
    hence "\<tau> l = f' (\<phi> l)"
      unfolding \<tau>_def by simp
    also have "... \<le> f' (\<phi> k)"
      using \<rho>_\<phi>_inv False that
      by (intro \<rho>_dec bij_betw_apply[OF \<phi>_bij]) auto
    also have "... = \<tau> k"
      unfolding \<tau>_def using False that by simp
    finally show ?thesis by simp
  qed

  define m :: nat where "m = Min {i. \<tau> i = 0 \<and> i \<le> n}"

  have "\<tau> n = 0"
    unfolding \<tau>_def by simp
  hence "m \<in> {i. \<tau> i = 0 \<and> i \<le> n}"
    unfolding m_def by (intro Min_in) auto

  hence m_rel_1: "\<tau> m = 0" and m_le_n: "m \<le> n" by auto

  have "\<tau> k > 0" if "k < m" for k
  proof (rule ccontr)
    assume "\<not>(\<tau> k > 0)"
    hence "\<tau> k = 0"
      by (intro order_antisym \<tau>_nonneg) simp
    hence "k \<in> {i. \<tau> i = 0 \<and> i \<le> n}"
      using that m_le_n by simp
    hence "m \<le> k"
      unfolding m_def by (intro Min_le) auto
    thus "False" using that by simp
  qed
  hence m_rel_2: "f' x > 0" if "x \<in> \<phi> ` {..<m}" for x
    unfolding \<tau>_def using m_le_n that by auto

  have "2 * m = 2 * card {..<m}" by simp
  also have "... = 2 * card (\<phi> ` {..<m})"
    using m_le_n inj_on_subset[OF bij_betw_imp_inj_on[OF \<phi>_bij]]
    by (intro_cong "[\<sigma>\<^sub>2 (*)]" more:card_image[symmetric]) auto
  also have "... \<le> 2 * card {x \<in> verts G. f' x > 0}"
    using m_rel_2 bij_betw_apply[OF \<phi>_bij] m_le_n
    by (intro mult_left_mono card_mono subsetI) auto
  also have "... = 2 * card (enum_verts_inv ` {x \<in> verts G. f $h (enum_verts_inv x) > 0})"
    unfolding f'_def using Abs_inject
    by (intro arg_cong2[where f="(*)"] card_image[symmetric] inj_onI) auto
  also have "... = 2 * card {x. f $h x > 0}"
    using Rep_inverse Rep_range unfolding f'_def by (intro_cong "[\<sigma>\<^sub>2 (*), \<sigma>\<^sub>1 card]"
        more:subset_antisym image_subsetI surj_onI[where g="enum_verts"]) auto
  also have "... = 2 * card {x. g $h x > 0}"
    unfolding f_def by (intro_cong "[\<sigma>\<^sub>2 (*), \<sigma>\<^sub>1 card]") auto
  also have "... \<le> n"
    by (intro g_supp)
  finally have m2_le_n: "2*m \<le> n" by simp

  have "\<tau> k \<le> 0" if "k > m" for k
    using m_rel_1 \<tau>_antimono that by metis
  hence "\<tau> k \<le> 0" if "k \<ge> m" for k
    using m_rel_1 that by (cases "k > m") auto
  hence \<tau>_supp: "\<tau> k = 0" if "k \<ge> m" for k
    using that  by (intro order_antisym \<tau>_nonneg) auto

  have 4: "\<rho> v \<le> x \<longleftrightarrow> v \<in> \<phi> ` {..x}" if "v \<in> verts G" "x < n" for v x
  proof -
    have "\<rho> v \<le> x \<longleftrightarrow> \<rho> v \<in> {..x}"
      by simp
    also have "... \<longleftrightarrow> \<phi> (\<rho> v) \<in> \<phi> ` {..x}"
      using bij_betw_imp_inj_on[OF \<phi>_bij] bij_betw_apply[OF \<rho>_bij] that
      by (intro inj_on_image_mem_iff[where B="{..<n}", symmetric]) auto
    also have "... \<longleftrightarrow> v \<in> \<phi> ` {..x}"
      unfolding \<phi>_\<rho>_inv[OF that(1)] by simp
    finally show ?thesis by simp
  qed

  have "B\<^sub>f = (\<Sum>a\<in>arcs G. \<bar>f' (tail G a)^2 - f' (head G a)^2\<bar>)"
    unfolding B\<^sub>f_def by simp
  also have "... = (\<Sum>e \<in># edges G. \<bar>f' (fst e)^2 - f' (snd e)^2\<bar>)"
    unfolding edges_def arc_to_ends_def sum_unfold_sum_mset
    by (simp add:image_mset.compositionality comp_def)
  also have "... =
    (\<Sum>e\<in>#{#e \<in># edges G. \<rho> (fst e) < \<rho> (snd e)#}. \<bar>(f' (fst e))\<^sup>2 - (f' (snd e))\<^sup>2\<bar>) +
    (\<Sum>e\<in>#{#e \<in># edges G. \<rho> (snd e) < \<rho> (fst e)#}. \<bar>(f' (fst e))\<^sup>2 - (f' (snd e))\<^sup>2\<bar>) +
    (\<Sum>e\<in>#{#e \<in># edges G. fst e = snd e#}. \<bar>(f' (fst e))\<^sup>2 - (f' (snd e))\<^sup>2\<bar>)"
    by (subst edges_split) simp
  also have "... =
    (\<Sum>e\<in>#{#e \<in># edges G. \<rho> (snd e) < \<rho> (fst e)#}. \<bar>(f' (fst e))\<^sup>2 - (f' (snd e))\<^sup>2\<bar>) +
    (\<Sum>e\<in>#{#e \<in># edges G. \<rho> (snd e) < \<rho> (fst e)#}. \<bar>(f' (snd e))\<^sup>2 - (f' (fst e))\<^sup>2\<bar>) +
    (\<Sum>e\<in>#{#e \<in># edges G. fst e = snd e#}. \<bar>(f' (fst e))\<^sup>2 - (f' (snd e))\<^sup>2\<bar>)"
    by (subst edges_sym[OF sym, symmetric]) (simp add:image_mset.compositionality
        comp_def image_mset_filter_mset_swap[symmetric] case_prod_beta)
  also have "... =
    (\<Sum>e\<in>#{#e \<in># edges G. \<rho> (snd e) < \<rho> (fst e)#}. \<bar>(f' (snd e))\<^sup>2 - (f' (fst e))\<^sup>2\<bar>) +
    (\<Sum>e\<in>#{#e \<in># edges G. \<rho> (snd e) < \<rho> (fst e)#}. \<bar>(f' (snd e))\<^sup>2 - (f' (fst e))\<^sup>2\<bar>) +
    (\<Sum>e\<in>#{#e \<in># edges G. fst e = snd e#}. 0)"
    by (intro_cong "[\<sigma>\<^sub>2 (+), \<sigma>\<^sub>1 sum_mset]" more:image_mset_cong) auto
  also have "... = 2 * (\<Sum>e\<in>#{#e\<in>#edges G. \<rho>(snd e)<\<rho>(fst e)#}. \<bar>(f' (snd e))\<^sup>2 - (f' (fst e))\<^sup>2\<bar>)"
    by simp
  also have "... = 2 *(\<Sum>a|a\<in>arcs G\<and>\<rho>(tail G a)>\<rho>(head G a). \<bar>f'(head G a)^2 - f'(tail G a)^2\<bar>)"
    unfolding edges_def arc_to_ends_def sum_unfold_sum_mset
    by (simp add:image_mset.compositionality comp_def image_mset_filter_mset_swap[symmetric])
  also have "... = 2 *
    (\<Sum>a|a\<in>arcs G\<and>\<rho>(tail G a)>\<rho>(head G a). \<bar>\<tau>(\<rho>(head G a))^2 - \<tau>(\<rho>(tail G a))^2\<bar>)"
    unfolding \<tau>_def using \<phi>_\<rho>_inv \<rho>_lt_n
    by (intro arg_cong2[where f="(*)"] sum.cong refl) auto
  also have "... = 2 * (\<Sum>a|a\<in>arcs G\<and>\<rho>(tail G a)>\<rho>(head G a). \<tau>(\<rho>(head G a))^2 - \<tau>(\<rho>(tail G a))^2)"
    using \<tau>_antimono power_mono \<tau>_nonneg
    by (intro arg_cong2[where f="(*)"] sum.cong refl abs_of_nonneg)(auto)
  also have "... = 2 *
    (\<Sum>a|a\<in>arcs G\<and>\<rho>(tail G a)>\<rho>(head G a). (-(\<tau>(\<rho>(tail G a))^2)) - (-(\<tau>(\<rho>(head G a))^2)))"
    by (simp add:algebra_simps)
  also have "... = 2 *(\<Sum>a|a\<in>arcs G\<and>\<rho>(tail G a)>\<rho>(head G a).
    (\<Sum>i=\<rho>(head G a)..<\<rho>(tail G a). (-(\<tau> (Suc i)^2)) - (-(\<tau> i^2))))"
    by (intro arg_cong2[where f="(*)"] sum.cong refl sum_Suc_diff'[symmetric]) auto
  also have "...=2*(\<Sum>(a, i)\<in>(SIGMA x:{a \<in> arcs G. \<rho> (head G a) < \<rho> (tail G a)}.
    {\<rho> (head G x)..<\<rho> (tail G x)}).  \<tau> i^2 - \<tau> (Suc i)^2)"
    by (subst sum.Sigma) auto
  also have "...=2*(\<Sum>p\<in>{(a,i).a \<in> arcs G\<and>\<rho>(head G a)\<le>i\<and>i<\<rho>(tail G a)}. \<tau>(snd p)^2-\<tau> (snd p+1)^2)"
    by (intro arg_cong2[where f="(*)"] sum.cong refl) (auto simp add:Sigma_def)
  also have "...=2*(\<Sum>p\<in>{(i,a).a \<in> arcs G\<and>\<rho>(head G a) \<le> i\<and>i < \<rho>(tail G a)}. \<tau>(fst p)^2-\<tau>(fst p+1)^2)"
    by (intro sum.reindex_cong[where l="prod.swap"] arg_cong2[where f="(*)"]) auto
  also have "...=2*
    (\<Sum>(i, a)\<in>(SIGMA x:{..<n}. {a \<in> arcs G. \<rho> (head G a)\<le>x \<and> x<\<rho>(tail G a)}). \<tau> i^2-\<tau> (i+1)^2)"
    using less_trans[OF _ \<rho>_lt_n] by (intro sum.cong arg_cong2[where f="(*)"]) auto
  also have "...=2*(\<Sum>i<n. (\<Sum>a|a\<in>arcs G \<and>\<rho>(head G a) \<le> i\<and>i < \<rho>(tail G a). \<tau> i^2 - \<tau> (i+1)^2))"
    by (subst sum.Sigma) auto
  also have "...=2*(\<Sum>i<n. card {a\<in>arcs G. \<rho>(head G a)\<le>i\<and>i<\<rho>(tail G a)} * (\<tau> i^2 - \<tau> (i+1)^2))"
    by simp
  also have "...=2*(\<Sum>i<n. card {a\<in>arcs G. \<rho>(head G a)\<le>i\<and>\<not>(\<rho>(tail G a)\<le>i)} * (\<tau> i^2 - \<tau> (i+1)^2))"
    by (intro_cong "[\<sigma>\<^sub>2 (*), \<sigma>\<^sub>1 card, \<sigma>\<^sub>1 of_nat]" more:sum.cong Collect_cong) auto
  also have "...=2*(\<Sum>i<n. card {a\<in>arcs G. head G a\<in>\<phi>`{..i}\<and>tail G a\<notin>\<phi>`{..i}} * (\<tau> i^2-\<tau> (i+1)^2))"
    using 4
    by (intro_cong "[\<sigma>\<^sub>2 (*), \<sigma>\<^sub>1 card, \<sigma>\<^sub>1 of_nat, \<sigma>\<^sub>2 (\<and>)]" more:sum.cong restr_Collect_cong) auto
  also have "... = 2 * (\<Sum>i<n. real (card (edges_betw (-\<phi>`{..i}) (\<phi>`{..i}))) * (\<tau> i^2-\<tau> (i+1)^2))"
    unfolding edges_betw_def by (auto simp:conj.commute)
  also have "... = 2 * (\<Sum>i<n. real (card (edges_betw (\<phi>`{..i}) (-\<phi>`{..i}))) * (\<tau> i^2-\<tau> (i+1)^2))"
    using edges_betw_sym by simp
  also have "... = 2 * (\<Sum>i<m. real (card (edges_betw (\<phi>`{..i}) (-\<phi>`{..i}))) * (\<tau> i^2-\<tau> (i+1)^2))"
    using \<tau>_supp m_le_n by (intro sum.mono_neutral_right arg_cong2[where f="(*)"]) auto
  finally have Bf_eq:
    "B\<^sub>f = 2 * (\<Sum>i<m. real (card (edges_betw (\<phi>`{..i}) (-\<phi>`{..i}))) * (\<tau> i^2-\<tau> (i+1)^2))"
    by simp

  have 3:"card (\<phi> ` {..i} \<inter> verts G) = i + 1" if "i < m" for i
  proof -
    have "card (\<phi> ` {..i} \<inter> verts G) = card (\<phi> ` {..i})"
      using m_le_n that by (intro arg_cong[where f="card"] Int_absorb2
          image_subsetI bij_betw_apply[OF \<phi>_bij]) auto
    also have "... = card {..i}"
      using m_le_n that by (intro card_image
          inj_on_subset[OF bij_betw_imp_inj_on[OF \<phi>_bij]]) auto
    also have "... = i+1" by simp
    finally show ?thesis
      by simp
  qed

  have "2 * \<Lambda>\<^sub>e * norm f^2 =  2 * \<Lambda>\<^sub>e * (g_norm f'^2)"
    unfolding g_norm_conv f'_alt by simp
  also have "... \<le> 2 * \<Lambda>\<^sub>e * (\<Sum>v\<in> verts G. f' v^2)"
    unfolding g_norm_sq g_inner_def by (simp add:power2_eq_square)
  also have "... = 2 * \<Lambda>\<^sub>e * (\<Sum>i<n. f' (\<phi> i)^2)"
    by (intro arg_cong2[where f="(*)"] refl sum.reindex_bij_betw[symmetric] \<phi>_bij)
  also have "... = 2 * \<Lambda>\<^sub>e * (\<Sum>i<n. \<tau> i^2)"
    unfolding \<tau>_def by (intro arg_cong2[where f="(*)"] refl sum.cong) auto
  also have "... = 2 * \<Lambda>\<^sub>e * (\<Sum>i<m. \<tau> i^2)"
    using \<tau>_supp m_le_n by (intro sum.mono_neutral_cong_right arg_cong2[where f="(*)"] refl) auto
  also have "... \<le> 2 * \<Lambda>\<^sub>e * ((\<Sum>i<m. \<tau> i^2) + (real 0 * \<tau> 0^2 - m * \<tau> m^2))"
    using \<tau>_supp[of "m"] by simp
  also have "... \<le> 2 * \<Lambda>\<^sub>e * ((\<Sum>i<m. \<tau> i^2) + (\<Sum>i<m. i*\<tau> i^2-(Suc i)*\<tau> (Suc i)^2))"
    by (subst sum_lessThan_telescope'[symmetric]) simp
  also have "... \<le> 2 * (\<Sum>i<m. (\<Lambda>\<^sub>e * (i+1)) * (\<tau> i^2-\<tau> (i+1)^2))"
    by (simp add:sum_distrib_left algebra_simps sum.distrib[symmetric])
  also have "... \<le> 2 * (\<Sum>i<m. real (card (edges_betw (\<phi>`{..i}) (-\<phi>`{..i}))) * (\<tau> i^2-\<tau> (i+1)^2))"
    using \<tau>_nonneg \<tau>_antimono power_mono 3 m2_le_n
    by (intro mult_left_mono sum_mono mult_right_mono edge_expansionD2) auto
  also have "... = B\<^sub>f"
    unfolding Bf_eq by simp
  finally have hoory_4_13: "2 * \<Lambda>\<^sub>e * norm f^2 \<le> B\<^sub>f"
    by simp
  text \<open>Corresponds to Lemma 4.13 in Hoory et al.\<close>

  have f_nz: "f \<noteq> 0"
  proof (rule ccontr)
    assume f_nz_assms: "\<not> (f \<noteq> 0)"
    have "g $h i \<le> 0" for i
    proof -
      have "g $h i \<le> max (g $h i) 0"
        by simp
      also have "... = 0"
        using f_nz_assms unfolding f_def vec_eq_iff by auto
      finally show ?thesis by simp
    qed
    moreover have "(\<Sum>i \<in> UNIV. 0-g $h i) = 0"
      using g_orth unfolding sum_subtractf inner_vec_def by auto
    ultimately have "\<forall>x\<in>UNIV. -(g $h x) = 0"
      by (intro iffD1[OF sum_nonneg_eq_0_iff]) auto
    thus "False"
      using g_nz unfolding vec_eq_iff by simp
  qed
  hence norm_f_gt_0: "norm f> 0"
    by simp

  have "\<Lambda>\<^sub>e * norm f * norm f \<le> sqrt 2 * real d * norm f * sqrt (f \<bullet> (L *v f))"
    using order_trans[OF hoory_4_13 hoory_4_12] by (simp add:power2_eq_square)
  hence "\<Lambda>\<^sub>e \<le> real d * sqrt 2 * sqrt (f \<bullet> (L *v f)) / norm f"
    using norm_f_gt_0 by (simp add:ac_simps divide_simps)
  also have "... \<le> real d * sqrt 2 * sqrt ((1 - \<Lambda>\<^sub>2) * (norm f)\<^sup>2) / norm f"
    by (intro mult_left_mono divide_right_mono real_sqrt_le_mono h_part_i) auto
  also have "... = real d * sqrt 2 * sqrt (1- \<Lambda>\<^sub>2)"
    using f_nz by (simp add:real_sqrt_mult)
  also have "... = d * sqrt (2 * (1-\<Lambda>\<^sub>2))"
    by (simp add:real_sqrt_mult[symmetric])
  finally show ?thesis
    by simp
qed

end

context regular_graph
begin

lemmas (in regular_graph) cheeger_aux_1 =
  regular_graph_tts.cheeger_aux_1[OF eg_tts_1,
    internalize_sort "'n :: finite", OF _ regular_graph_axioms,
    unfolded remove_finite_premise, cancel_type_definition, OF verts_non_empty]

theorem cheeger_inequality:
  assumes "n > 1"
  shows "\<Lambda>\<^sub>e \<in> {d * (1 - \<Lambda>\<^sub>2) / 2.. d * sqrt (2 * (1 - \<Lambda>\<^sub>2))}"
  using cheeger_aux_1 cheeger_aux_2 assms by auto

unbundle no_intro_cong_syntax

end

end


(*  Title       : CLim.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 2001 University of Edinburgh
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
*)

section{*Limits, Continuity and Differentiation for Complex Functions*}

theory CLim
imports CStar
begin

(*not in simpset?*)
declare hypreal_epsilon_not_zero [simp]

(*??generalize*)
lemma lemma_complex_mult_inverse_squared [simp]:
     "x \<noteq> (0::complex) \<Longrightarrow> x * (inverse x)\<^sup>2 = inverse x"
by (simp add: numeral_2_eq_2)

text{*Changing the quantified variable. Install earlier?*}
lemma all_shift: "(\<forall>x::'a::comm_ring_1. P x) = (\<forall>x. P (x-a))"
apply auto
apply (drule_tac x="x+a" in spec)
apply (simp add: add.assoc)
done

lemma complex_add_minus_iff [simp]: "(x + - a = (0::complex)) = (x=a)"
by (simp add: diff_eq_eq)

lemma complex_add_eq_0_iff [iff]: "(x+y = (0::complex)) = (y = -x)"
apply auto
apply (drule sym [THEN diff_eq_eq [THEN iffD2]], auto)
done

subsection{*Limit of Complex to Complex Function*}

lemma NSLIM_Re: "f -- a --NS> L ==> (%x. Re(f x)) -- a --NS> Re(L)"
by (simp add: NSLIM_def starfunC_approx_Re_Im_iff
              hRe_hcomplex_of_complex)

lemma NSLIM_Im: "f -- a --NS> L ==> (%x. Im(f x)) -- a --NS> Im(L)"
by (simp add: NSLIM_def starfunC_approx_Re_Im_iff
              hIm_hcomplex_of_complex)

(** get this result easily now **)
lemma LIM_Re:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "f -- a --> L ==> (%x. Re(f x)) -- a --> Re(L)"
by (simp add: LIM_NSLIM_iff NSLIM_Re)

lemma LIM_Im:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "f -- a --> L ==> (%x. Im(f x)) -- a --> Im(L)"
by (simp add: LIM_NSLIM_iff NSLIM_Im)

lemma LIM_cnj:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "f -- a --> L ==> (%x. cnj (f x)) -- a --> cnj L"
by (simp add: LIM_eq complex_cnj_diff [symmetric] del: complex_cnj_diff)

lemma LIM_cnj_iff:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "((%x. cnj (f x)) -- a --> cnj L) = (f -- a --> L)"
by (simp add: LIM_eq complex_cnj_diff [symmetric] del: complex_cnj_diff)

lemma starfun_norm: "( *f* (\<lambda>x. norm (f x))) = (\<lambda>x. hnorm (( *f* f) x))"
by transfer (rule refl)

lemma star_of_Re [simp]: "star_of (Re x) = hRe (star_of x)"
by transfer (rule refl)

lemma star_of_Im [simp]: "star_of (Im x) = hIm (star_of x)"
by transfer (rule refl)

text""
(** another equivalence result **)
lemma NSCLIM_NSCRLIM_iff:
   "(f -- x --NS> L) = ((%y. cmod(f y - L)) -- x --NS> 0)"
by (simp add: NSLIM_def starfun_norm
    approx_approx_zero_iff [symmetric] approx_minus_iff [symmetric])

(** much, much easier standard proof **)
lemma CLIM_CRLIM_iff:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "(f -- x --> L) = ((%y. cmod(f y - L)) -- x --> 0)"
by (simp add: LIM_eq)

(* so this is nicer nonstandard proof *)
lemma NSCLIM_NSCRLIM_iff2:
     "(f -- x --NS> L) = ((%y. cmod(f y - L)) -- x --NS> 0)"
by (simp add: LIM_NSLIM_iff [symmetric] CLIM_CRLIM_iff)

lemma NSLIM_NSCRLIM_Re_Im_iff:
     "(f -- a --NS> L) = ((%x. Re(f x)) -- a --NS> Re(L) &
                            (%x. Im(f x)) -- a --NS> Im(L))"
apply (auto intro: NSLIM_Re NSLIM_Im)
apply (auto simp add: NSLIM_def starfun_Re starfun_Im)
apply (auto dest!: spec)
apply (simp add: hcomplex_approx_iff)
done

lemma LIM_CRLIM_Re_Im_iff:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "(f -- a --> L) = ((%x. Re(f x)) -- a --> Re(L) &
                         (%x. Im(f x)) -- a --> Im(L))"
by (simp add: LIM_NSLIM_iff NSLIM_NSCRLIM_Re_Im_iff)

subsection{*Continuity*}

lemma NSLIM_isContc_iff:
     "(f -- a --NS> f a) = ((%h. f(a + h)) -- 0 --NS> f a)"
by (rule NSLIM_h_iff)

subsection{*Functions from Complex to Reals*}

lemma isNSContCR_cmod [simp]: "isNSCont cmod (a)"
by (auto intro: approx_hnorm
         simp add: starfunCR_cmod hcmod_hcomplex_of_complex [symmetric]
                    isNSCont_def)

lemma isContCR_cmod [simp]: "isCont cmod (a)"
by (simp add: isNSCont_isCont_iff [symmetric])

lemma isCont_Re:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "isCont f a ==> isCont (%x. Re (f x)) a"
by (simp add: isCont_def LIM_Re)

lemma isCont_Im:
  fixes f :: "'a::real_normed_vector \<Rightarrow> complex"
  shows "isCont f a ==> isCont (%x. Im (f x)) a"
by (simp add: isCont_def LIM_Im)

subsection{* Differentiation of Natural Number Powers*}

lemma CDERIV_pow [simp]:
     "DERIV (%x. x ^ n) x :> (complex_of_real (real n)) * (x ^ (n - Suc 0))"
apply (induct n)
apply (drule_tac [2] DERIV_ident [THEN DERIV_mult])
apply (auto simp add: distrib_right real_of_nat_Suc)
apply (case_tac "n")
apply (auto simp add: ac_simps add.commute)
done

text{*Nonstandard version*}
lemma NSCDERIV_pow:
     "NSDERIV (%x. x ^ n) x :> complex_of_real (real n) * (x ^ (n - 1))"
by (simp add: NSDERIV_DERIV_iff del: of_real_real_of_nat_eq)

text{*Can't relax the premise @{term "x \<noteq> 0"}: it isn't continuous at zero*}
lemma NSCDERIV_inverse:
     "(x::complex) \<noteq> 0 ==> NSDERIV (%x. inverse(x)) x :> (- ((inverse x)\<^sup>2))"
unfolding numeral_2_eq_2
by (rule NSDERIV_inverse)

lemma CDERIV_inverse:
     "(x::complex) \<noteq> 0 ==> DERIV (%x. inverse(x)) x :> (- ((inverse x)\<^sup>2))"
unfolding numeral_2_eq_2
by (rule DERIV_inverse)

subsection{*Derivative of Reciprocals (Function @{term inverse})*}

lemma CDERIV_inverse_fun:
     "[| DERIV f x :> d; f(x) \<noteq> (0::complex) |]
      ==> DERIV (%x. inverse(f x)) x :> (- (d * inverse ((f x)\<^sup>2)))"
unfolding numeral_2_eq_2
by (rule DERIV_inverse_fun)

lemma NSCDERIV_inverse_fun:
     "[| NSDERIV f x :> d; f(x) \<noteq> (0::complex) |]
      ==> NSDERIV (%x. inverse(f x)) x :> (- (d * inverse ((f x)\<^sup>2)))"
unfolding numeral_2_eq_2
by (rule NSDERIV_inverse_fun)

subsection{* Derivative of Quotient*}

lemma CDERIV_quotient:
     "[| DERIV f x :> d; DERIV g x :> e; g(x) \<noteq> (0::complex) |]
       ==> DERIV (%y. f(y) / (g y)) x :> (d*g(x) - (e*f(x))) / ((g x)\<^sup>2)"
unfolding numeral_2_eq_2
by (rule DERIV_quotient)

lemma NSCDERIV_quotient:
     "[| NSDERIV f x :> d; NSDERIV g x :> e; g(x) \<noteq> (0::complex) |]
       ==> NSDERIV (%y. f(y) / (g y)) x :> (d*g(x) - (e*f(x))) / ((g x)\<^sup>2)"
unfolding numeral_2_eq_2
by (rule NSDERIV_quotient)

subsection{*Caratheodory Formulation of Derivative at a Point: Standard Proof*}

lemma CARAT_CDERIVD:
     "(\<forall>z. f z - f x = g z * (z - x)) & isNSCont g x & g x = l
      ==> NSDERIV f x :> l"
by clarify (rule CARAT_DERIVD)

end


(* Author: Tobias Nipkow, based on work by Daniel Somogyi *)

section \<open>Optimal BSTs: The `Cubic' Algorithm\label{sec:cubic}\<close>

theory Optimal_BST
imports Weighted_Path_Length Monad_Memo_DP.OptBST
begin

subsection \<open>Function \<open>argmin\<close>\<close>

text \<open>Function \<open>argmin\<close> was moved to \<open>Monad_Memo_DP.argmin\<close>.
It iterates over a list and returns the rightmost element that minimizes a given function:

@{thm [display] argmin.simps}
\<close>

text \<open>An optimized version that avoids repeated computation of \<open>f x\<close>:\<close>

fun argmin2 :: "('a \<Rightarrow> ('b::linorder)) \<Rightarrow> 'a list \<Rightarrow> 'a * 'b" where
"argmin2 f (x#xs) =
  (let fx = f x
   in if xs = [] then (x, fx)
      else let mfm = argmin2 f xs
           in if fx < snd mfm then (x,fx) else mfm)"

lemma argmin_argmin2[code]: "argmin f xs = (if xs = [] then undefined else fst(argmin2 f xs))"
apply(auto simp: argmin2_argmin)
apply (meson argmin.elims list.distinct(1))
done

lemma argmin_in: "xs \<noteq> [] \<Longrightarrow> argmin f xs \<in> set xs"
using argmin_forall[of xs "\<lambda>x. x\<in>set xs"] by blast

lemma argmin_pairs: "xs \<noteq> [] \<Longrightarrow>
  (argmin f xs,f (argmin f xs)) = argmin snd (map (\<lambda>x. (x,f x)) xs)"
by (induction f xs rule:argmin.induct) (auto, smt snd_conv)

lemma argmin_map: "xs \<noteq> [] \<Longrightarrow> argmin c (map f xs) = f(argmin (c o f) xs)"
by(induction xs) (simp_all add: Let_def)

subsection \<open>The `Cubic' Algorithm\<close>

text \<open>We hide the details of the access frequencies \<open>a\<close> and \<open>b\<close> by working with an abstract
version of function \<open>w\<close> definied above (summing \<open>a\<close> and \<open>b\<close>). Later we interpret \<open>w\<close> accordingly.\<close>

locale Optimal_BST =
fixes w :: "int \<Rightarrow> int \<Rightarrow> nat"
begin

subsubsection \<open>Functions \<open>wpl\<close> and \<open>min_wpl\<close>\<close>

sublocale wpl where w = w .

text \<open>Function \<open>min_wpl i j\<close> computes the minimal weighted path length of any tree \<open>t\<close>
where @{prop"inorder t = [i..j]"}. It simply tries all possible indices between \<open>i\<close> and \<open>j\<close>
as the root. Thus it implicitly constructs all possible trees.\<close>

declare conj_cong [fundef_cong]
function min_wpl :: "int \<Rightarrow> int \<Rightarrow> nat" where
"min_wpl i j =
  (if i > j then 0
   else Min ((\<lambda>k. min_wpl i (k-1) + min_wpl (k+1) j) ` {i..j}) + w i j)"
by auto
termination by (relation "measure (\<lambda>(i,j). nat(j-i+1))") auto
declare min_wpl.simps[simp del]

text \<open>Note that for efficiency reasons we have pulled \<open>+ w i j\<close> out of \<open>Min\<close>.
In the lemma below this is reversed because it simplifies the proofs.
Similar optimizations are possible in other functions below.\<close>

lemma min_wpl_simps[simp]:
  "i > j \<Longrightarrow> min_wpl i j = 0"
  "i \<le> j \<Longrightarrow> min_wpl i j =
     Min ((\<lambda>k. min_wpl i (k-1) + min_wpl (k+1) j + w i j) ` {i..j})"
by(auto simp add: min_wpl.simps[of i j] Min_add_commute)

lemma upto_split1:
  "\<lbrakk> i \<le> j;  j \<le> k \<rbrakk> \<Longrightarrow> [i..k] = [i..j-1] @ [j..k]"
proof (induction j rule: int_ge_induct)
  case base thus ?case by (simp add: upto_rec1)
next
  case step thus ?case using upto_rec1 upto_rec2 by simp
qed

text\<open>Function @{const min_wpl} returns a lower bound for all possible BSTs:\<close>

theorem min_wpl_is_optimal:
  "inorder t = [i..j] \<Longrightarrow> min_wpl i j \<le> wpl i j t"
proof(induction i j t rule: wpl.induct)
  case 1
  thus ?case by(simp add: upto.simps split: if_splits)
next
  case (2 i j l k r)
  then show ?case
  proof cases
    assume "i > j" thus ?thesis by(simp)
  next
    assume [arith]: "\<not> i > j"

    note inorder = inorder_upto_split[OF "2.prems"]

    let ?M = "(\<lambda>k. min_wpl i (k-1) + min_wpl (k+1) j + w i j) ` {i..j}"
    let ?w = "min_wpl i (k-1) + min_wpl (k+1) j + w i j"

    have aux_min:"Min ?M \<le> ?w"
    proof (rule Min_le)
      show "finite ?M" by simp
      show "?w \<in> ?M" using inorder(3,4) by simp
    qed

    have "min_wpl i j = Min ?M" by(simp)
    also have "... \<le> ?w" by (rule aux_min)
    also have "... \<le> wpl i (k-1) l + wpl (k+1) j r + w i j"
      using inorder(1,2) "2.IH" by simp
    also have "... = wpl i j \<langle>l,k,r\<rangle>" by simp
    finally show ?thesis .
  qed
qed

text \<open>Now we show that the lower bound computed by @{const min_wpl}
is the wpl of an optimal tree that can be computed in the same manner.\<close>

subsubsection \<open>Function \<open>opt_bst\<close>\<close>

text\<open>This is the functional equivalent of the standard cubic imperative algorithm.
Unless it is memoized, the complexity is again exponential.
The pattern of recursion is the same as for @{const min_wpl} but instead of the minimal weight
it computes a tree with the minimal weight:\<close>

function opt_bst :: "int \<Rightarrow> int \<Rightarrow> int tree" where
"opt_bst i j =
  (if i > j then Leaf
   else argmin (wpl i j) [\<langle>opt_bst i (k-1), k, opt_bst (k+1) j\<rangle>. k \<leftarrow> [i..j]])"
by auto
termination by (relation "measure (\<lambda>(i,j) . nat(j-i+1))") auto
declare opt_bst.simps[simp del]

corollary opt_bst_simps[simp]:
  "i > j \<Longrightarrow> opt_bst i j = Leaf"
  "i \<le> j \<Longrightarrow> opt_bst i j =
     (argmin (wpl i j) [\<langle>opt_bst i (k-1), k, opt_bst (k+1) j\<rangle>. k \<leftarrow> [i..j]])"
by(auto simp add: opt_bst.simps[of i j])

text \<open>As promised, @{const opt_bst} computes a tree with the minimal wpl:\<close>

theorem wpl_opt_bst: "wpl i j (opt_bst i j) = min_wpl i j"
proof(induction i j rule: min_wpl.induct)
  case (1 i j)
  show ?case
  proof cases
    assume "i > j"
    thus ?thesis by(simp)
  next
    assume [arith]: "\<not> i > j"
    let ?ts = "[\<langle>opt_bst i (k-1), k, opt_bst (k+1) j\<rangle>. k \<leftarrow> [i..j]]"
    let ?M = "((\<lambda>k. min_wpl i (k-1) + min_wpl (k+1) j + w i j) ` {i..j})"
    have 1: "?ts \<noteq> []" by (auto simp add: upto.simps)
    have "wpl i j (opt_bst i j) = wpl i j (argmin (wpl i j) ?ts)" by simp
    also have "\<dots> = Min (wpl i j ` (set ?ts))"
      by(rule argmin_Min[OF 1])
    also have "\<dots> = Min ?M"
    proof (rule arg_cong[where f=Min])
      show "wpl i j ` (set ?ts) = ?M" using "1.IH"
        by (force simp: Bex_def image_iff "1.IH")
    qed
    also have "\<dots> = min_wpl i j" by simp
    finally show ?thesis .
  qed
qed

corollary opt_bst_is_optimal:
  "inorder t = [i..j] \<Longrightarrow> wpl i j (opt_bst i j) \<le> wpl i j t"
by (simp add: min_wpl_is_optimal wpl_opt_bst)

subsubsection \<open>Function \<open>opt_bst_wpl\<close>\<close>

text \<open>Function @{const opt_bst} is simplistic because it computes the wpl
of each tree anew rather than returning it with the tree. That is what \<open>opt_bst_wpl\<close> does:\<close>

function opt_bst_wpl :: "int \<Rightarrow> int \<Rightarrow> int tree \<times> nat" where
"opt_bst_wpl i j =
  (if i > j then (Leaf, 0)
   else argmin snd [let (t1,c1) = opt_bst_wpl i (k-1);
                        (t2,c2) = opt_bst_wpl (k+1) j
                     in (\<langle>t1,k,t2\<rangle>, c1 + c2 + w i j). k \<leftarrow> [i..j]])"
by auto
termination
  by (relation "measure (\<lambda>(i,j). nat(j-i+1))")(auto)
declare opt_bst_wpl.simps[simp del]

text\<open>Function @{const opt_bst_wpl} returns an optimal tree and its wpl:\<close>

lemma opt_bst_wpl_eq_pair:
  "opt_bst_wpl i j = (opt_bst i j, wpl i j (opt_bst i j))"
proof(induction i j rule: opt_bst_wpl.induct)
  case (1 i j)
  note [simp] = opt_bst_wpl.simps[of i j]
  show ?case
  proof cases
    assume "i > j" thus ?thesis using "1.prems" by auto
  next
    assume "\<not> i > j"
    thus ?thesis by (simp add: argmin_pairs comp_def "1.IH" cong: list.map_cong_simp)
  qed
qed

corollary opt_bst_wpl_eq_pair': "opt_bst_wpl i j = (opt_bst i j, min_wpl i j)"
by (simp add: opt_bst_wpl_eq_pair wpl_opt_bst)

end (* locale Optimal_BST *)

end