(*  Title:      HOL/SPARK/Examples/Liseq/Longest_Increasing_Subsequence.thy
    Author:     Stefan Berghofer
    Copyright:  secunet Security Networks AG
*)

theory Longest_Increasing_Subsequence
imports "../../SPARK"
begin

text \<open>
Set of all increasing subsequences in a prefix of an array
\<close>

definition iseq :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat set set" where
  "iseq xs l = {is. (\<forall>i\<in>is. i < l) \<and>
     (\<forall>i\<in>is. \<forall>j\<in>is. i \<le> j \<longrightarrow> xs i \<le> xs j)}"

text \<open>
Length of longest increasing subsequence in a prefix of an array
\<close>

definition liseq :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat" where
  "liseq xs i = Max (card ` iseq xs i)"

text \<open>
Length of longest increasing subsequence ending at a particular position
\<close>

definition liseq' :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat" where
  "liseq' xs i = Max (card ` (iseq xs (Suc i) \<inter> {is. Max is = i}))"

lemma iseq_finite: "finite (iseq xs i)"
  apply (simp add: iseq_def)
  apply (rule finite_subset [OF _
    finite_Collect_subsets [of "{j. j < i}"]])
  apply auto
  done

lemma iseq_finite': "is \<in> iseq xs i \<Longrightarrow> finite is"
  by (auto simp add: iseq_def bounded_nat_set_is_finite)

lemma iseq_singleton: "i < l \<Longrightarrow> {i} \<in> iseq xs l"
  by (simp add: iseq_def)

lemma iseq_trivial: "{} \<in> iseq xs i"
  by (simp add: iseq_def)

lemma iseq_nonempty: "iseq xs i \<noteq> {}"
  by (auto intro: iseq_trivial)

lemma liseq'_ge1: "1 \<le> liseq' xs x"
  apply (simp add: liseq'_def)
  apply (subgoal_tac "iseq xs (Suc x) \<inter> {is. Max is = x} \<noteq> {}")
  apply (simp add: Max_ge_iff iseq_finite)
  apply (rule_tac x="{x}" in bexI)
  apply (auto intro: iseq_singleton)
  done

lemma liseq_expand:
  assumes R: "\<And>is. liseq xs i = card is \<Longrightarrow> is \<in> iseq xs i \<Longrightarrow>
    (\<And>js. js \<in> iseq xs i \<Longrightarrow> card js \<le> card is) \<Longrightarrow> P"
  shows "P"
proof -
  have "Max (card ` iseq xs i) \<in> card ` iseq xs i"
    by (rule Max_in) (simp_all add: iseq_finite iseq_nonempty)
  then obtain js where js: "liseq xs i = card js" and "js \<in> iseq xs i"
    by (rule imageE) (simp add: liseq_def)
  moreover {
    fix js'
    assume "js' \<in> iseq xs i"
    then have "card js' \<le> card js"
      by (simp add: js [symmetric] liseq_def iseq_finite iseq_trivial)
  }
  ultimately show ?thesis by (rule R)
qed

lemma liseq'_expand:
  assumes R: "\<And>is. liseq' xs i = card is \<Longrightarrow> is \<in> iseq xs (Suc i) \<Longrightarrow>
    finite is \<Longrightarrow> Max is = i \<Longrightarrow>
    (\<And>js. js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow> card js \<le> card is) \<Longrightarrow>
    is \<noteq> {} \<Longrightarrow> P"
  shows "P"
proof -
  have "Max (card ` (iseq xs (Suc i) \<inter> {is. Max is = i})) \<in>
    card ` (iseq xs (Suc i) \<inter> {is. Max is = i})"
    by (auto simp add: iseq_finite intro!: iseq_singleton Max_in)
  then obtain js where js: "liseq' xs i = card js" and "js \<in> iseq xs (Suc i)"
    and "finite js" and "Max js = i"
    by (auto simp add: liseq'_def intro: iseq_finite')
  moreover {
    fix js'
    assume "js' \<in> iseq xs (Suc i)" "Max js' = i"
    then have "card js' \<le> card js"
      by (auto simp add: js [symmetric] liseq'_def iseq_finite intro!: iseq_singleton)
  }
  note max = this
  moreover have "card {i} \<le> card js"
    by (rule max) (simp_all add: iseq_singleton)
  then have "js \<noteq> {}" by auto
  ultimately show ?thesis by (rule R)
qed

lemma liseq'_ge:
  "j = card js \<Longrightarrow> js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow>
  js \<noteq> {} \<Longrightarrow> j \<le> liseq' xs i"
  by (simp add: liseq'_def iseq_finite)

lemma liseq'_eq:
  "j = card js \<Longrightarrow> js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow>
  js \<noteq> {} \<Longrightarrow> (\<And>js'. js' \<in> iseq xs (Suc i) \<Longrightarrow> Max js' = i \<Longrightarrow> finite js' \<Longrightarrow>
    js' \<noteq> {} \<Longrightarrow> card js' \<le> card js) \<Longrightarrow>
  j = liseq' xs i"
  by (fastforce simp add: liseq'_def iseq_finite
    intro: Max_eqI [symmetric])

lemma liseq_ge:
  "j = card js \<Longrightarrow> js \<in> iseq xs i \<Longrightarrow> j \<le> liseq xs i"
  by (auto simp add: liseq_def iseq_finite)

lemma liseq_eq:
  "j = card js \<Longrightarrow> js \<in> iseq xs i \<Longrightarrow>
  (\<And>js'. js' \<in> iseq xs i \<Longrightarrow> finite js' \<Longrightarrow>
    js' \<noteq> {} \<Longrightarrow> card js' \<le> card js) \<Longrightarrow>
  j = liseq xs i"
  by (fastforce simp add: liseq_def iseq_finite
    intro: Max_eqI [symmetric])

lemma max_notin: "finite xs \<Longrightarrow> Max xs < x \<Longrightarrow> x \<notin> xs"
  by (cases "xs = {}") auto

lemma iseq_insert:
  "xs (Max is) \<le> xs i \<Longrightarrow> is \<in> iseq xs i \<Longrightarrow>
  is \<union> {i} \<in> iseq xs (Suc i)"
  apply (frule iseq_finite')
  apply (cases "is = {}")
  apply (auto simp add: iseq_def)
  apply (rule order_trans [of _ "xs (Max is)"])
  apply auto
  apply (thin_tac "\<forall>a\<in>is. a < i")
  apply (drule_tac x=ia in bspec)
  apply assumption
  apply (drule_tac x="Max is" in bspec)
  apply (auto intro: Max_in)
  done

lemma iseq_diff: "is \<in> iseq xs (Suc (Max is)) \<Longrightarrow>
  is - {Max is} \<in> iseq xs (Suc (Max (is - {Max is})))"
  apply (frule iseq_finite')
  apply (simp add: iseq_def less_Suc_eq_le)
  done

lemma iseq_butlast:
  assumes "js \<in> iseq xs (Suc i)" and "js \<noteq> {}"
  and "Max js \<noteq> i"
  shows "js \<in> iseq xs i"
proof -
  from assms have fin: "finite js"
    by (simp add: iseq_finite')
  with assms have "Max js \<in> js"
    by auto
  with assms have "Max js < i"
    by (auto simp add: iseq_def)
  with fin assms have "\<forall>j\<in>js. j < i"
    by simp
  with assms show ?thesis
    by (simp add: iseq_def)
qed

lemma iseq_mono: "is \<in> iseq xs i \<Longrightarrow> i \<le> j \<Longrightarrow> is \<in> iseq xs j"
  by (auto simp add: iseq_def)

lemma diff_nonempty:
  assumes "1 < card is"
  shows "is - {i} \<noteq> {}"
proof -
  from assms have fin: "finite is" by (auto intro: card_ge_0_finite)
  with assms fin have "card is - 1 \<le> card (is - {i})"
    by (simp add: card_Diff_singleton_if)
  with assms have "0 < card (is - {i})" by simp
  then show ?thesis by (simp add: card_gt_0_iff)
qed

lemma Max_diff:
  assumes "1 < card is"
  shows "Max (is - {Max is}) < Max is"
proof -
  from assms have "finite is" by (auto intro: card_ge_0_finite)
  moreover from assms have "is - {Max is} \<noteq> {}"
    by (rule diff_nonempty)
  ultimately show ?thesis using assms
    apply (auto simp add: not_less)
    apply (subgoal_tac "a \<le> Max is")
    apply auto
    done
qed

lemma iseq_nth: "js \<in> iseq xs l \<Longrightarrow> 1 < card js \<Longrightarrow>
  xs (Max (js - {Max js})) \<le> xs (Max js)"
  apply (auto simp add: iseq_def)
  apply (subgoal_tac "Max (js - {Max js}) \<in> js")
  apply (thin_tac "\<forall>i\<in>js. i < l")
  apply (drule_tac x="Max (js - {Max js})" in bspec)
  apply assumption
  apply (drule_tac x="Max js" in bspec)
  using card_gt_0_iff [of js]
  apply simp
  using Max_diff [of js]
  apply simp
  using Max_in [of "js - {Max js}", OF _ diff_nonempty] card_gt_0_iff [of js]
  apply auto
  done

lemma card_leq1_singleton:
  assumes "finite xs" "xs \<noteq> {}" "card xs \<le> 1"
  obtains x where "xs = {x}"
  using assms
  by induct simp_all

lemma longest_iseq1:
  "liseq' xs i =
   Max ({0} \<union> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}) + 1"
proof -
  have "Max ({0} \<union> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}) = liseq' xs i - 1"
  proof (rule Max_eqI)
    fix y
    assume "y \<in> {0} \<union> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}"
    then show "y \<le> liseq' xs i - 1"
    proof
      assume "y \<in> {liseq' xs j |j. j < i \<and> xs j \<le> xs i}"
      then obtain j where j: "j < i" "xs j \<le> xs i" "y = liseq' xs j"
        by auto
      have "liseq' xs j + 1 \<le> liseq' xs i"
      proof (rule liseq'_expand)
        fix "is"
        assume H: "liseq' xs j = card is" "is \<in> iseq xs (Suc j)"
          "finite is" "Max is = j" "is \<noteq> {}"
        from H j have "card is + 1 = card (is \<union> {i})"
          by (simp add: card_insert max_notin)
        moreover {
          from H j have "xs (Max is) \<le> xs i" by simp
          moreover from \<open>j < i\<close> have "Suc j \<le> i" by simp
          with \<open>is \<in> iseq xs (Suc j)\<close> have "is \<in> iseq xs i"
            by (rule iseq_mono)
          ultimately have "is \<union> {i} \<in> iseq xs (Suc i)"
          by (rule iseq_insert)
        } moreover from H j have "Max (is \<union> {i}) = i" by simp
        moreover have "is \<union> {i} \<noteq> {}" by simp
        ultimately have "card is + 1 \<le> liseq' xs i"
          by (rule liseq'_ge)
        with H show ?thesis by simp
      qed
      with j show "y \<le> liseq' xs i - 1"
        by simp
    qed simp
  next
    have "liseq' xs i \<le> 1 \<or>
      (\<exists>j. liseq' xs i - 1 = liseq' xs j \<and> j < i \<and> xs j \<le> xs i)"
    proof (rule liseq'_expand)
      fix "is"
      assume H: "liseq' xs i = card is" "is \<in> iseq xs (Suc i)"
        "finite is" "Max is = i" "is \<noteq> {}"
      assume R: "\<And>js. js \<in> iseq xs (Suc i) \<Longrightarrow> Max js = i \<Longrightarrow>
        card js \<le> card is"
      show ?thesis
      proof (cases "card is \<le> 1")
        case True with H show ?thesis by simp
      next
        case False
        then have "1 < card is" by simp
        then have "Max (is - {Max is}) < Max is"
          by (rule Max_diff)
        from \<open>is \<in> iseq xs (Suc i)\<close> \<open>1 < card is\<close>
        have "xs (Max (is - {Max is})) \<le> xs (Max is)"
          by (rule iseq_nth)
        have "card is - 1 = liseq' xs (Max (is - {i}))"
        proof (rule liseq'_eq)
          from \<open>Max is = i\<close> [symmetric] \<open>finite is\<close> \<open>is \<noteq> {}\<close>
          show "card is - 1 = card (is - {i})" by simp
        next
          from \<open>is \<in> iseq xs (Suc i)\<close> \<open>Max is = i\<close> [symmetric]
          show "is - {i} \<in> iseq xs (Suc (Max (is - {i})))"
            by simp (rule iseq_diff)
        next
          from \<open>1 < card is\<close>
          show "is - {i} \<noteq> {}" by (rule diff_nonempty)
        next
          fix js
          assume "js \<in> iseq xs (Suc (Max (is - {i})))"
            "Max js = Max (is - {i})" "finite js" "js \<noteq> {}"
          from \<open>xs (Max (is - {Max is})) \<le> xs (Max is)\<close>
            \<open>Max js = Max (is - {i})\<close> \<open>Max is = i\<close>
          have "xs (Max js) \<le> xs i" by simp
          moreover from \<open>Max is = i\<close> \<open>Max (is - {Max is}) < Max is\<close>
          have "Suc (Max (is - {i})) \<le> i"
            by simp
          with \<open>js \<in> iseq xs (Suc (Max (is - {i})))\<close>
          have "js \<in> iseq xs i"
            by (rule iseq_mono)
          ultimately have "js \<union> {i} \<in> iseq xs (Suc i)"
            by (rule iseq_insert)
          moreover from \<open>js \<noteq> {}\<close> \<open>finite js\<close> \<open>Max js = Max (is - {i})\<close>
            \<open>Max is = i\<close> [symmetric] \<open>Max (is - {Max is}) < Max is\<close>
          have "Max (js \<union> {i}) = i"
            by simp
          ultimately have "card (js \<union> {i}) \<le> card is" by (rule R)
          moreover from \<open>Max is = i\<close> [symmetric] \<open>finite js\<close>
            \<open>Max (is - {Max is}) < Max is\<close> \<open>Max js = Max (is - {i})\<close>
          have "i \<notin> js" by (simp add: max_notin)
          with \<open>finite js\<close>
          have "card (js \<union> {i}) = card ((js \<union> {i}) - {i}) + 1"
            by simp
          ultimately show "card js \<le> card (is - {i})"
            using \<open>i \<notin> js\<close> \<open>Max is = i\<close> [symmetric] \<open>is \<noteq> {}\<close> \<open>finite is\<close>
            by simp
        qed simp
        with H \<open>Max (is - {Max is}) < Max is\<close>
          \<open>xs (Max (is - {Max is})) \<le> xs (Max is)\<close>
        show ?thesis by auto
      qed
    qed
    then show "liseq' xs i - 1 \<in> {0} \<union>
      {liseq' xs j |j. j < i \<and> xs j \<le> xs i}" by simp
  qed simp
  moreover have "1 \<le> liseq' xs i" by (rule liseq'_ge1)
  ultimately show ?thesis by simp
qed

lemma longest_iseq2': "liseq xs i < liseq' xs i \<Longrightarrow>
  liseq xs (Suc i) = liseq' xs i"
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule liseq_eq [symmetric])
  apply (rule refl)
  apply assumption
  apply (case_tac "Max js' = i")
  apply simp
  apply (drule_tac js=js' in iseq_butlast)
  apply assumption+
  apply (drule_tac js=js' in liseq_ge [OF refl])
  apply simp
  done

lemma longest_iseq2: "liseq xs i < liseq' xs i \<Longrightarrow>
  liseq xs i + 1 = liseq' xs i"
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq_expand)
  apply (drule_tac s="Max is" in sym)
  apply simp
  apply (case_tac "card is \<le> 1")
  apply simp
  apply (drule iseq_diff)
  apply (drule_tac i="Suc (Max (is - {Max is}))" and j="Max is" in iseq_mono)
  apply (simp add: less_eq_Suc_le [symmetric])
  apply (rule Max_diff)
  apply simp
  apply (drule_tac x="is - {Max is}" in meta_spec,
    drule meta_mp, assumption)
  apply simp
  done

lemma longest_iseq3:
  "liseq xs j = liseq' xs i \<Longrightarrow> xs i \<le> xs j \<Longrightarrow> i < j \<Longrightarrow>
  liseq xs (Suc j) = liseq xs j + 1"
  apply (rule_tac xs=xs and i=j in liseq_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule_tac js="isa \<union> {j}" in liseq_eq [symmetric])
  apply (simp add: card_insert card_Diff_singleton_if max_notin)
  apply (rule iseq_insert)
  apply simp
  apply (erule iseq_mono)
  apply simp
  apply (case_tac "j = Max js'")
  apply simp
  apply (drule iseq_diff)
  apply (drule_tac x="js' - {j}" in meta_spec)
  apply (drule meta_mp)
  apply simp
  apply (case_tac "card js' \<le> 1")
  apply (erule_tac xs=js' in card_leq1_singleton)
  apply assumption+
  apply (simp add: iseq_trivial)
  apply (erule iseq_mono)
  apply (simp add: less_eq_Suc_le [symmetric])
  apply (rule Max_diff)
  apply simp
  apply (rule le_diff_iff [THEN iffD1, of 1])
  apply (simp add: card_0_eq [symmetric] del: card_0_eq)
  apply (simp add: card_insert)
  apply (subgoal_tac "card (js' - {j}) = card js' - 1")
  apply (simp add: card_insert card_Diff_singleton_if max_notin)
  apply (frule_tac A=js' in Max_in)
  apply assumption
  apply (simp add: card_Diff_singleton_if)
  apply (drule_tac js=js' in iseq_butlast)
  apply assumption
  apply (erule not_sym)
  apply (drule_tac x=js' in meta_spec)
  apply (drule meta_mp)
  apply assumption
  apply (simp add: card_insert_disjoint max_notin)
  done

lemma longest_iseq4:
  "liseq xs j = liseq' xs i \<Longrightarrow> xs i \<le> xs j \<Longrightarrow> i < j \<Longrightarrow>
  liseq' xs j = liseq' xs i + 1"
  apply (rule_tac xs=xs and i=j in liseq_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq'_expand)
  apply simp
  apply (rule_tac js="isa \<union> {j}" in liseq'_eq [symmetric])
  apply (simp add: card_insert card_Diff_singleton_if max_notin)
  apply (rule iseq_insert)
  apply simp
  apply (erule iseq_mono)
  apply simp
  apply simp
  apply simp
  apply (drule_tac s="Max js'" in sym)
  apply simp
  apply (drule iseq_diff)
  apply (drule_tac x="js' - {j}" in meta_spec)
  apply (drule meta_mp)
  apply simp
  apply (case_tac "card js' \<le> 1")
  apply (erule_tac xs=js' in card_leq1_singleton)
  apply assumption+
  apply (simp add: iseq_trivial)
  apply (erule iseq_mono)
  apply (simp add: less_eq_Suc_le [symmetric])
  apply (rule Max_diff)
  apply simp
  apply (rule le_diff_iff [THEN iffD1, of 1])
  apply (simp add: card_0_eq [symmetric] del: card_0_eq)
  apply (simp add: card_insert)
  apply (subgoal_tac "card (js' - {j}) = card js' - 1")
  apply (simp add: card_insert card_Diff_singleton_if max_notin)
  apply (frule_tac A=js' in Max_in)
  apply assumption
  apply (simp add: card_Diff_singleton_if)
  done

lemma longest_iseq5: "liseq' xs i \<le> liseq xs i \<Longrightarrow>
  liseq xs (Suc i) = liseq xs i"
  apply (rule_tac i=i and xs=xs in liseq'_expand)
  apply simp
  apply (rule_tac xs=xs and i=i in liseq_expand)
  apply simp
  apply (rule liseq_eq [symmetric])
  apply (rule refl)
  apply (erule iseq_mono)
  apply simp
  apply (case_tac "Max js' = i")
  apply (drule_tac x=js' in meta_spec)
  apply simp
  apply (drule iseq_butlast, assumption, assumption)
  apply simp
  done

lemma liseq_empty: "liseq xs 0 = 0"
  apply (rule_tac js="{}" in liseq_eq [symmetric])
  apply simp
  apply (rule iseq_trivial)
  apply (simp add: iseq_def)
  done

lemma liseq'_singleton: "liseq' xs 0 = 1"
  by (simp add: longest_iseq1 [of _ 0])

lemma liseq_singleton: "liseq xs (Suc 0) = Suc 0"
  by (simp add: longest_iseq2' liseq_empty liseq'_singleton)

lemma liseq'_Suc_unfold:
  "A j \<le> x \<Longrightarrow>
   (insert 0 {liseq' A j' |j'. j' < Suc j \<and> A j' \<le> x}) =
   (insert 0 {liseq' A j' |j'. j' < j \<and> A j' \<le> x}) \<union>
   {liseq' A j}"
  by (auto simp add: less_Suc_eq)

lemma liseq'_Suc_unfold':
  "\<not> (A j \<le> x) \<Longrightarrow>
   {liseq' A j' |j'. j' < Suc j \<and> A j' \<le> x} =
   {liseq' A j' |j'. j' < j \<and> A j' \<le> x}"
  by (auto simp add: less_Suc_eq)

lemma iseq_card_limit:
  assumes "is \<in> iseq A i"
  shows "card is \<le> i"
proof -
  from assms have "is \<subseteq> {0..<i}"
    by (auto simp add: iseq_def)
  with finite_atLeastLessThan have "card is \<le> card {0..<i}"
    by (rule card_mono)
  with card_atLeastLessThan show ?thesis by simp
qed

lemma liseq_limit: "liseq A i \<le> i"
  by (rule_tac xs=A and i=i in liseq_expand)
    (simp add: iseq_card_limit)

lemma liseq'_limit: "liseq' A i \<le> i + 1"
  by (rule_tac xs=A and i=i in liseq'_expand)
    (simp add: iseq_card_limit)

definition max_ext :: "(nat \<Rightarrow> 'a::linorder) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "max_ext A i j = Max ({0} \<union> {liseq' A j' |j'. j' < j \<and> A j' \<le> A i})"

lemma max_ext_limit: "max_ext A i j \<le> j"
  apply (auto simp add: max_ext_def)
  apply (drule Suc_leI)
  apply (cut_tac i=j' and A=A in liseq'_limit)
  apply simp
  done

text \<open>Proof functions\<close>

abbreviation (input)
  "arr_conv a \<equiv> (\<lambda>n. a (int n))"

lemma idx_conv_suc:
  "0 \<le> i \<Longrightarrow> nat (i + 1) = nat i + 1"
  by simp

abbreviation liseq_ends_at' :: "(int \<Rightarrow> 'a::linorder) \<Rightarrow> int \<Rightarrow> int" where
  "liseq_ends_at' A i \<equiv> int (liseq' (\<lambda>l. A (int l)) (nat i))"

abbreviation liseq_prfx' :: "(int \<Rightarrow> 'a::linorder) \<Rightarrow> int \<Rightarrow> int" where
  "liseq_prfx' A i \<equiv> int (liseq (\<lambda>l. A (int l)) (nat i))"

abbreviation max_ext' :: "(int \<Rightarrow> 'a::linorder) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int" where
  "max_ext' A i j \<equiv> int (max_ext (\<lambda>l. A (int l)) (nat i) (nat j))"

spark_proof_functions
  liseq_ends_at = "liseq_ends_at' :: (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int"
  liseq_prfx = "liseq_prfx' :: (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int"
  max_ext = "max_ext' :: (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int"

text \<open>The verification conditions\<close>

spark_open "liseq/liseq_length"

spark_vc procedure_liseq_length_5
  by (simp_all add: liseq_singleton liseq'_singleton)

spark_vc procedure_liseq_length_6
proof -
  from H1 H2 H3 H4
  have eq: "liseq (arr_conv a) (nat i) =
    liseq' (arr_conv a) (nat pmax)"
    by simp
  from H14 H3 H4
  have pmax1: "arr_conv a (nat pmax) \<le> arr_conv a (nat i)"
    by simp
  from H3 H4 have pmax2: "nat pmax < nat i"
    by simp
  {
    fix i2
    assume i2: "0 \<le> i2" "i2 \<le> i"
    have "(l(i := l pmax + 1)) i2 =
      int (liseq' (arr_conv a) (nat i2))"
    proof (cases "i2 = i")
      case True
      from eq pmax1 pmax2 have "liseq' (arr_conv a) (nat i) =
        liseq' (arr_conv a) (nat pmax) + 1"
        by (rule longest_iseq4)
      with True H1 H3 H4 show ?thesis
        by simp
    next
      case False
      with H1 i2 show ?thesis
        by simp
    qed
  }
  then show ?C1 by simp
  from eq pmax1 pmax2
  have "liseq (arr_conv a) (Suc (nat i)) =
    liseq (arr_conv a) (nat i) + 1"
    by (rule longest_iseq3)
 with H2 H3 H4 show ?C2
    by (simp add: idx_conv_suc)
qed

spark_vc procedure_liseq_length_7
proof -
  from H1 show ?C1
    by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
  from H6
  have m: "max_ext (arr_conv a) (nat i) (nat i) + 1 =
    liseq' (arr_conv a) (nat i)"
    by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
  with H2 H18
  have gt: "liseq (arr_conv a) (nat i) < liseq' (arr_conv a) (nat i)"
    by simp
  then have "liseq' (arr_conv a) (nat i) = liseq (arr_conv a) (nat i) + 1"
    by (rule longest_iseq2 [symmetric])
  with H2 m show ?C2 by simp
  from gt have "liseq (arr_conv a) (Suc (nat i)) = liseq' (arr_conv a) (nat i)"
    by (rule longest_iseq2')
  with m H6 show ?C3 by (simp add: idx_conv_suc)
qed

spark_vc procedure_liseq_length_8
proof -
  {
    fix i2
    assume i2: "0 \<le> i2" "i2 \<le> i"
    have "(l(i := max_ext' a i i + 1)) i2 =
      int (liseq' (arr_conv a) (nat i2))"
    proof (cases "i2 = i")
      case True
      with H1 show ?thesis
        by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
    next
      case False
      with H1 i2 show ?thesis by simp
    qed
  }
  then show ?C1 by simp
  from H2 H6 H18
  have "liseq' (arr_conv a) (nat i) \<le> liseq (arr_conv a) (nat i)"
    by (simp add: max_ext_def longest_iseq1 [of _ "nat i"])
  then have "liseq (arr_conv a) (Suc (nat i)) = liseq (arr_conv a) (nat i)"
    by (rule longest_iseq5)
  with H2 H6 show ?C2 by (simp add: idx_conv_suc)
qed

spark_vc procedure_liseq_length_12
  by (simp add: max_ext_def)

spark_vc procedure_liseq_length_13
  using H1 H6 H13 H21 H22
  by (simp add: max_ext_def
    idx_conv_suc liseq'_Suc_unfold max_def del: Max_less_iff)

spark_vc procedure_liseq_length_14
  using H1 H6 H13 H21
  by (cases "a j \<le> a i")
    (simp_all add: max_ext_def
      idx_conv_suc liseq'_Suc_unfold liseq'_Suc_unfold')

spark_vc procedure_liseq_length_19
  using H3 H4 H5 H8 H9
  apply (rule_tac y="int (nat i)" in order_trans)
  apply (cut_tac A="arr_conv a" and i="nat i" and j="nat i" in max_ext_limit)
  apply simp_all
  done

spark_vc procedure_liseq_length_23
  using H2 H3 H4 H7 H8 H11
  apply (rule_tac y="int (nat i)" in order_trans)
  apply (cut_tac A="arr_conv a" and i="nat i" in liseq_limit)
  apply simp_all
  done

spark_vc procedure_liseq_length_29
  using H2 H3 H8 H13
  by (simp add: add1_zle_eq [symmetric])

spark_end

end


(*  Title:      Fun With Functions
    Author:     Tobias Nipkow
*)

theory FunWithFunctions imports Complex_Main begin

text{* See \cite{Tao2006}. Was first brought to our attention by Herbert
Ehler who provided a similar proof. *}

theorem identity1: fixes f :: "nat \<Rightarrow> nat"
assumes fff: "\<And>n. f(f(n)) < f(Suc(n))"
shows "f(n) = n"
proof -
  { fix m n have key: "n \<le> m \<Longrightarrow> n \<le> f(m)"
    proof(induct n arbitrary: m)
      case 0 show ?case by simp
    next
      case (Suc n)
      hence "m \<noteq> 0" by simp
      then obtain k where [simp]: "m = Suc k" by (metis not0_implies_Suc)
      have "n \<le> f(k)" using Suc by simp
      hence "n \<le> f(f(k))" using Suc by simp
      also have "\<dots> < f(m)" using fff by simp
      finally show ?case by simp
    qed }
  hence "\<And>n. n \<le> f(n)" by simp
  hence "\<And>n. f(n) < f(Suc n)" by(metis fff order_le_less_trans)
  hence "f(n) < n+1" by (metis fff lift_Suc_mono_less_iff[of f] Suc_eq_plus1)
  with `n \<le> f(n)` show "f n = n" by arith
qed

text{* See \cite{Tao2006}. Possible extension:
Should also hold if the range of @{text f} is the reals!
*}

lemma identity2: fixes f :: "nat \<Rightarrow> nat"
assumes "f(k) = k" and "k \<ge> 2"
and f_times: "\<And>m n. f(m*n) = f(m)*f(n)"
and f_mono: "\<And>m n. m<n \<Longrightarrow> f m < f n"
shows "f(n) = n"
proof -
  have 0: "f(0) = 0"
    by (metis f_mono f_times mult_1_right mult_is_0 nat_less_le nat_mult_eq_cancel_disj not_less_eq)
  have 1: "f(1) = 1"
    by (metis f_mono f_times gr_implies_not0 mult_eq_self_implies_10 nat_mult_1_right zero_less_one)
  have 2: "f 2 = 2"
  proof -
    have "2 + (k - 2) = k" using `k \<ge> 2` by arith
    hence "f(2) \<le> 2"
      using mono_nat_linear_lb[of f 2 "k - 2",OF f_mono] `f k = k`
      by simp arith
    thus "f 2 = 2" using 1 f_mono[of 1 2] by arith
  qed
  show ?thesis
  proof(induct rule:less_induct)
    case (less i)
    show ?case
    proof cases
      assume "i\<le>1" thus ?case using 0 1 by (auto simp add:le_Suc_eq)
    next
      assume "~i\<le>1"
      show ?case
      proof cases
        assume "i mod 2 = 0"
        hence "EX k. i=2*k" by arith
        then obtain k where "i = 2*k" ..
        hence "0 < k" and "k<i" using `~i\<le>1` by arith+
        hence "f(k) = k" using less(1) by blast
        thus "f(i) = i" using `i = 2*k` by(simp add:f_times 2)
      next
        assume "i mod 2 \<noteq> 0"
        hence "EX k. i=2*k+1" by arith
        then obtain k where "i = 2*k+1" ..
        hence "0<k" and "k+1<i" using `~i\<le>1` by arith+
        have "2*k < f(2*k+1)"
        proof -
          have "2*k = 2*f(k)" using less(1) `i=2*k+1` by simp
          also have "\<dots> = f(2*k)" by(simp add:f_times 2)
          also have "\<dots> < f(2*k+1)" using f_mono[of "2*k" "2*k+1"] by simp
          finally show ?thesis .
        qed
        moreover
        have "f(2*k+1) < 2*(k+1)"
        proof -
          have "f(2*k+1) < f(2*k+2)" using f_mono[of "2*k+1" "2*k+2"] by simp
          also have "\<dots> = f(2*(k+1))" by simp
          also have "\<dots> = 2*f(k+1)" by(simp only:f_times 2)
          also have "f(k+1) = k+1" using less(1) `i=2*k+1` `~i\<le>1` by simp
          finally show ?thesis .
        qed
        ultimately show "f(i) = i" using `i = 2*k+1` by arith
      qed
    qed
  qed
qed

text{* One more from Tao's booklet. If @{text f} is also assumed to be
continuous, @{term"f(x::real) = x+1"} holds for all reals, not only
rationals. Extend the proof! *}

theorem plus1:
fixes f :: "real \<Rightarrow> real"
assumes 0: "f 0 = 1" and f_add: "\<And>x y. f(x+y+1) = f x + f y"

assumes "r : \<rat>" shows "f(r) = r + 1"
proof -
  { fix i :: int have "f(real i) = real i + 1"
    proof (induct i rule: int_induct [where k=0])
      case base show ?case using 0 by simp
    next
      case (step1 i)
      have "f(real(i+1)) = f(real i + 0 + 1)" by simp
      also have "\<dots> = f(real i) + f 0" by(rule f_add)
      also have "\<dots> = real(i+1) + 1" using step1 0 by simp
      finally show ?case .
    next
      case (step2 i)
      have "f(real i) = f(real(i - 1) + 0 + 1)" by simp
      also have "\<dots> = f(real(i - 1)) + f 0" by(rule f_add)
      also have "\<dots> = f(real(i - 1)) + 1 " using 0 by simp
      finally show ?case using step2 by simp
    qed }
  note f_int = this
  { fix n r have "f(real(Suc n)*r + real n) = real(Suc n) * f r"
    proof(induct n)
      case 0 show ?case by simp
    next
      case (Suc n)
      have "real(Suc(Suc n))*r + real(Suc n) =
            r + (real(Suc n)*r + real n) + 1" (is "?a = ?b")
        by(simp add:real_of_nat_Suc field_simps)
      hence "f ?a = f ?b" by simp
      also have "\<dots> = f r + f(real(Suc n)*r + real n)" by(rule f_add)
      also have "\<dots> = f r + real(Suc n) * f r" by(simp only:Suc)
      finally show ?case by(simp add:real_of_nat_Suc field_simps)
    qed }
  note 1 = this
  { fix n::nat and r assume "n\<noteq>0"
    have "f(real(n)*r + real(n - 1)) = real(n) * f r"
    proof(cases n)
      case 0 thus ?thesis using `n\<noteq>0` by simp
    next
      case Suc thus ?thesis using `n\<noteq>0` by (simp add:1)
    qed }
  note f_mult = this
  from `r:\<rat>` obtain i::int and n::nat where r: "r = real i/real n" and "n\<noteq>0"
    by(fastforce simp:Rats_eq_int_div_nat)
  have "real(n)*f(real i/real n) = f(real i + real(n - 1))"
    using `n\<noteq>0` by(simp add:f_mult[symmetric])
  also have "\<dots> = f(real(i + int n - 1))" using `n\<noteq>0`[simplified]
    by (metis One_nat_def Suc_leI int_1 add_diff_eq real_of_int_add real_of_int_of_nat_eq zdiff_int)
  also have "\<dots> = real(i + int n - 1) + 1" by(rule f_int)
  also have "\<dots> = real i + real n" by arith
  finally show ?thesis using `n\<noteq>0` unfolding r by (simp add:field_simps)
qed

text{* The only total model of a naive recursion equation of factorial on
integers is 0 for all negative arguments. Probably folklore. *}

theorem ifac_neg0: fixes ifac :: "int \<Rightarrow> int"
assumes ifac_rec: "\<And>i. ifac i = (if i=0 then 1 else i*ifac(i - 1))"
shows "i<0 \<Longrightarrow> ifac i = 0"
proof(rule ccontr)
  assume 0: "i<0" "ifac i \<noteq> 0"
  { fix j assume "j \<le> i"
    have "ifac j \<noteq> 0"
      apply(rule int_le_induct[OF `j\<le>i`])
       apply(rule `ifac i \<noteq> 0`)
      apply (metis `i<0` ifac_rec linorder_not_le mult_eq_0_iff)
      done
  } note below0 = this
  { fix j assume "j<i"
    have "1 < -j" using `j<i` `i<0` by arith
    have "ifac(j - 1) \<noteq> 0" using `j<i` by(simp add: below0)
    then have "\<bar>ifac (j - 1)\<bar> < (-j) * \<bar>ifac (j - 1)\<bar>" using `j<i`
      mult_le_less_imp_less[OF order_refl[of "abs(ifac(j - 1))"] `1 < -j`]
      by(simp add:mult.commute)
    hence "abs(ifac(j - 1)) < abs(ifac j)"
      using `1 < -j` by(simp add: ifac_rec[of "j"] abs_mult)
  } note not_wf = this
  let ?f = "%j. nat(abs(ifac(i - int(j+1))))"
  obtain k where "\<not> ?f (Suc k) < ?f k"
    using wf_no_infinite_down_chainE[OF wf_less, of "?f"] by blast
  moreover have "i - int (k + 1) - 1 = i - int (Suc k + 1)" by arith
  ultimately show False using not_wf[of "i - int(k+1)"]
    by (simp only:) arith
qed

end


(* Author: Tobias Nipkow *)

subsection \<open>Invariant\<close>

theory AVL_Set
imports
  AVL_Set_Code
  "HOL-Number_Theory.Fib"
begin

fun avl :: "'a tree_ht \<Rightarrow> bool" where
"avl Leaf = True" |
"avl (Node l (a,n) r) =
 (abs(int(height l) - int(height r)) \<le> 1 \<and>
  n = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"

subsubsection \<open>Insertion maintains AVL balance\<close>

declare Let_def [simp]

lemma ht_height[simp]: "avl t \<Longrightarrow> ht t = height t"
by (cases t rule: tree2_cases) simp_all

text \<open>First, a fast but relatively manual proof with many lemmas:\<close>

lemma height_balL:
  "\<lbrakk> avl l; avl r; height l = height r + 2 \<rbrakk> \<Longrightarrow>
   height (balL l a r) \<in> {height r + 2, height r + 3}"
by (auto simp:node_def balL_def split:tree.split)

lemma height_balR:
  "\<lbrakk> avl l; avl r; height r = height l + 2 \<rbrakk> \<Longrightarrow>
   height (balR l a r) : {height l + 2, height l + 3}"
by(auto simp add:node_def balR_def split:tree.split)

lemma height_node[simp]: "height(node l a r) = max (height l) (height r) + 1"
by (simp add: node_def)

lemma height_balL2:
  "\<lbrakk> avl l; avl r; height l \<noteq> height r + 2 \<rbrakk> \<Longrightarrow>
   height (balL l a r) = 1 + max (height l) (height r)"
by (simp_all add: balL_def)

lemma height_balR2:
  "\<lbrakk> avl l;  avl r;  height r \<noteq> height l + 2 \<rbrakk> \<Longrightarrow>
   height (balR l a r) = 1 + max (height l) (height r)"
by (simp_all add: balR_def)

lemma avl_balL:
  "\<lbrakk> avl l; avl r; height r - 1 \<le> height l \<and> height l \<le> height r + 2 \<rbrakk> \<Longrightarrow> avl(balL l a r)"
by(auto simp: balL_def node_def split!: if_split tree.split)

lemma avl_balR:
  "\<lbrakk> avl l; avl r; height l - 1 \<le> height r \<and> height r \<le> height l + 2 \<rbrakk> \<Longrightarrow> avl(balR l a r)"
by(auto simp: balR_def node_def split!: if_split tree.split)

text\<open>Insertion maintains the AVL property. Requires simultaneous proof.\<close>

theorem avl_insert:
  "avl t \<Longrightarrow> avl(insert x t)"
  "avl t \<Longrightarrow> height (insert x t) \<in> {height t, height t + 1}"
proof (induction t rule: tree2_induct)
  case (Node l a _ r)
  case 1
  show ?case
  proof(cases "x = a")
    case True with 1 show ?thesis by simp
  next
    case False
    show ?thesis
    proof(cases "x<a")
      case True with 1 Node(1,2) show ?thesis by (auto intro!:avl_balL)
    next
      case False with 1 Node(3,4) \<open>x\<noteq>a\<close> show ?thesis by (auto intro!:avl_balR)
    qed
  qed
  case 2
  show ?case
  proof(cases "x = a")
    case True with 2 show ?thesis by simp
  next
    case False
    show ?thesis
    proof(cases "x<a")
      case True
      show ?thesis
      proof(cases "height (insert x l) = height r + 2")
        case False with 2 Node(1,2) \<open>x < a\<close> show ?thesis by (auto simp: height_balL2)
      next
        case True
        hence "(height (balL (insert x l) a r) = height r + 2) \<or>
          (height (balL (insert x l) a r) = height r + 3)" (is "?A \<or> ?B")
          using 2 Node(1,2) height_balL[OF _ _ True] by simp
        thus ?thesis
        proof
          assume ?A with 2 \<open>x < a\<close> show ?thesis by (auto)
        next
          assume ?B with 2 Node(2) True \<open>x < a\<close> show ?thesis by (simp) arith
        qed
      qed
    next
      case False
      show ?thesis
      proof(cases "height (insert x r) = height l + 2")
        case False with 2 Node(3,4) \<open>\<not>x < a\<close> show ?thesis by (auto simp: height_balR2)
      next
        case True
        hence "(height (balR l a (insert x r)) = height l + 2) \<or>
          (height (balR l a (insert x r)) = height l + 3)"  (is "?A \<or> ?B")
          using 2 Node(3) height_balR[OF _ _ True] by simp
        thus ?thesis
        proof
          assume ?A with 2 \<open>\<not>x < a\<close> show ?thesis by (auto)
        next
          assume ?B with 2 Node(4) True \<open>\<not>x < a\<close> show ?thesis by (simp) arith
        qed
      qed
    qed
  qed
qed simp_all

text \<open>Now an automatic proof without lemmas:\<close>

theorem avl_insert_auto: "avl t \<Longrightarrow>
  avl(insert x t) \<and> height (insert x t) \<in> {height t, height t + 1}"
apply (induction t rule: tree2_induct)
 (* if you want to save a few secs: apply (auto split!: if_split) *)
 apply (auto simp: balL_def balR_def node_def max_absorb2 split!: if_split tree.split)
done

subsubsection \<open>Deletion maintains AVL balance\<close>

lemma avl_split_max:
  "\<lbrakk> avl t; t \<noteq> Leaf \<rbrakk> \<Longrightarrow>
  avl (fst (split_max t)) \<and>
  height t \<in> {height(fst (split_max t)), height(fst (split_max t)) + 1}"
by(induct t rule: split_max_induct)
  (auto simp: balL_def node_def max_absorb2 split!: prod.split if_split tree.split)

text\<open>Deletion maintains the AVL property:\<close>

theorem avl_delete:
  "avl t \<Longrightarrow> avl(delete x t)"
  "avl t \<Longrightarrow> height t \<in> {height (delete x t), height (delete x t) + 1}"
proof (induct t rule: tree2_induct)
  case (Node l a n r)
  case 1
  show ?case
  proof(cases "x = a")
    case True thus ?thesis
      using 1 avl_split_max[of l] by (auto intro!: avl_balR split: prod.split)
  next
    case False thus ?thesis
      using Node 1 by (auto intro!: avl_balL avl_balR)
  qed
  case 2
  show ?case
  proof(cases "x = a")
    case True thus ?thesis using 2 avl_split_max[of l]
      by(auto simp: balR_def max_absorb2 split!: if_splits prod.split tree.split)
  next
    case False
    show ?thesis
    proof(cases "x<a")
      case True
      show ?thesis
      proof(cases "height r = height (delete x l) + 2")
        case False
        thus ?thesis using 2 Node(1,2) \<open>x < a\<close> by(auto simp: balR_def)
      next
        case True
        thus ?thesis using height_balR[OF _ _ True, of a] 2 Node(1,2) \<open>x < a\<close> by simp linarith
      qed
    next
      case False
      show ?thesis
      proof(cases "height l = height (delete x r) + 2")
        case False
        thus ?thesis using 2 Node(3,4) \<open>\<not>x < a\<close> \<open>x \<noteq> a\<close> by(auto simp: balL_def)
      next
        case True
        thus ?thesis
          using height_balL[OF _ _ True, of a] 2 Node(3,4) \<open>\<not>x < a\<close> \<open>x \<noteq> a\<close> by simp linarith
      qed
    qed
  qed
qed simp_all

text \<open>A more automatic proof.
Complete automation as for insertion seems hard due to resource requirements.\<close>

theorem avl_delete_auto:
  "avl t \<Longrightarrow> avl(delete x t)"
  "avl t \<Longrightarrow> height t \<in> {height (delete x t), height (delete x t) + 1}"
proof (induct t rule: tree2_induct)
  case (Node l a n r)
  case 1
  thus ?case
    using Node avl_split_max[of l] by (auto intro!: avl_balL avl_balR split: prod.split)
  case 2
  show ?case
    using 2 Node avl_split_max[of l]
      by auto
         (auto simp: balL_def balR_def max_absorb1 max_absorb2  split!: tree.splits prod.splits if_splits)
qed simp_all

subsection "Overall correctness"

interpretation S: Set_by_Ordered
where empty = empty and isin = isin and insert = insert and delete = delete
and inorder = inorder and inv = avl
proof (standard, goal_cases)
  case 1 show ?case by (simp add: empty_def)
next
  case 2 thus ?case by(simp add: isin_set_inorder)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 thus ?case by (simp add: empty_def)
next
  case 6 thus ?case by (simp add: avl_insert(1))
next
  case 7 thus ?case by (simp add: avl_delete(1))
qed

subsection \<open>Height-Size Relation\<close>

text \<open>Any AVL tree of height \<open>n\<close> has at least \<open>fib (n+2)\<close> leaves:\<close>

theorem avl_fib_bound:
  "avl t \<Longrightarrow> fib(height t + 2) \<le> size1 t"
proof (induction rule: tree2_induct)
  case (Node l a h r)
  have 1: "height l + 1 \<le> height r + 2" and 2: "height r + 1 \<le> height l + 2"
    using Node.prems by auto
  have "fib (max (height l) (height r) + 3) \<le> size1 l + size1 r"
  proof cases
    assume "height l \<ge> height r"
    hence "fib (max (height l) (height r) + 3) = fib (height l + 3)"
      by(simp add: max_absorb1)
    also have "\<dots> = fib (height l + 2) + fib (height l + 1)"
      by (simp add: numeral_eq_Suc)
    also have "\<dots> \<le> size1 l + fib (height l + 1)"
      using Node by (simp)
    also have "\<dots> \<le> size1 r + size1 l"
      using Node fib_mono[OF 1] by auto
    also have "\<dots> = size1 (Node l (a,h) r)"
      by simp
    finally show ?thesis
      by (simp)
  next
    assume "\<not> height l \<ge> height r"
    hence "fib (max (height l) (height r) + 3) = fib (height r + 3)"
      by(simp add: max_absorb1)
    also have "\<dots> = fib (height r + 2) + fib (height r + 1)"
      by (simp add: numeral_eq_Suc)
    also have "\<dots> \<le> size1 r + fib (height r + 1)"
      using Node by (simp)
    also have "\<dots> \<le> size1 r + size1 l"
      using Node fib_mono[OF 2] by auto
    also have "\<dots> = size1 (Node l (a,h) r)"
      by simp
    finally show ?thesis
      by (simp)
  qed
  also have "\<dots> = size1 (Node l (a,h) r)"
    by simp
  finally show ?case by (simp del: fib.simps add: numeral_eq_Suc)
qed auto

lemma avl_fib_bound_auto: "avl t \<Longrightarrow> fib (height t + 2) \<le> size1 t"
proof (induction t rule: tree2_induct)
  case Leaf thus ?case by (simp)
next
  case (Node l a h r)
  have 1: "height l + 1 \<le> height r + 2" and 2: "height r + 1 \<le> height l + 2"
    using Node.prems by auto
  have left: "height l \<ge> height r \<Longrightarrow> ?case" (is "?asm \<Longrightarrow> _")
    using Node fib_mono[OF 1] by (simp add: max.absorb1)
  have right: "height l \<le> height r \<Longrightarrow> ?case"
    using Node fib_mono[OF 2] by (simp add: max.absorb2)
  show ?case using left right using Node.prems by simp linarith
qed

text \<open>An exponential lower bound for \<^const>\<open>fib\<close>:\<close>

lemma fib_lowerbound:
  defines "\<phi> \<equiv> (1 + sqrt 5) / 2"
  shows "real (fib(n+2)) \<ge> \<phi> ^ n"
proof (induction n rule: fib.induct)
  case 1
  then show ?case by simp
next
  case 2
  then show ?case by (simp add: \<phi>_def real_le_lsqrt)
next
  case (3 n)
  have "\<phi> ^ Suc (Suc n) = \<phi> ^ 2 * \<phi> ^ n"
    by (simp add: field_simps power2_eq_square)
  also have "\<dots> = (\<phi> + 1) * \<phi> ^ n"
    by (simp_all add: \<phi>_def power2_eq_square field_simps)
  also have "\<dots> = \<phi> ^ Suc n + \<phi> ^ n"
      by (simp add: field_simps)
  also have "\<dots> \<le> real (fib (Suc n + 2)) + real (fib (n + 2))"
      by (intro add_mono "3.IH")
  finally show ?case by simp
qed

text \<open>The size of an AVL tree is (at least) exponential in its height:\<close>

lemma avl_size_lowerbound:
  defines "\<phi> \<equiv> (1 + sqrt 5) / 2"
  assumes "avl t"
  shows   "\<phi> ^ (height t) \<le> size1 t"
proof -
  have "\<phi> ^ height t \<le> fib (height t + 2)"
    unfolding \<phi>_def by(rule fib_lowerbound)
  also have "\<dots> \<le> size1 t"
    using avl_fib_bound[of t] assms by simp
  finally show ?thesis .
qed

text \<open>The height of an AVL tree is most \<^term>\<open>(1/log 2 \<phi>)\<close> \<open>\<approx> 1.44\<close> times worse
than \<^term>\<open>log 2 (size1 t)\<close>:\<close>

lemma  avl_height_upperbound:
  defines "\<phi> \<equiv> (1 + sqrt 5) / 2"
  assumes "avl t"
  shows   "height t \<le> (1/log 2 \<phi>) * log 2 (size1 t)"
proof -
  have "\<phi> > 0" "\<phi> > 1" by(auto simp: \<phi>_def pos_add_strict)
  hence "height t = log \<phi> (\<phi> ^ height t)" by(simp add: log_nat_power)
  also have "\<dots> \<le> log \<phi> (size1 t)"
    using avl_size_lowerbound[OF assms(2), folded \<phi>_def] \<open>1 < \<phi>\<close>
    by (simp add: le_log_of_power)
  also have "\<dots> = (1/log 2 \<phi>) * log 2 (size1 t)"
    by(simp add: log_base_change[of 2 \<phi>])
  finally show ?thesis .
qed

end


(*  Title:      HOL/Library/Boolean_Algebra.thy
    Author:     Brian Huffman
*)

section \<open>Boolean Algebras\<close>

theory Boolean_Algebra
  imports Main
begin

locale boolean =
  fixes conj :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<sqinter>" 70)
  fixes disj :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<squnion>" 65)
  fixes compl :: "'a \<Rightarrow> 'a" ("\<sim> _" [81] 80)
  fixes zero :: "'a" ("\<zero>")
  fixes one  :: "'a" ("\<one>")
  assumes conj_assoc: "(x \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
  assumes disj_assoc: "(x \<squnion> y) \<squnion> z = x \<squnion> (y \<squnion> z)"
  assumes conj_commute: "x \<sqinter> y = y \<sqinter> x"
  assumes disj_commute: "x \<squnion> y = y \<squnion> x"
  assumes conj_disj_distrib: "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
  assumes disj_conj_distrib: "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  assumes conj_one_right [simp]: "x \<sqinter> \<one> = x"
  assumes disj_zero_right [simp]: "x \<squnion> \<zero> = x"
  assumes conj_cancel_right [simp]: "x \<sqinter> \<sim> x = \<zero>"
  assumes disj_cancel_right [simp]: "x \<squnion> \<sim> x = \<one>"
begin

sublocale conj: abel_semigroup conj
  by standard (fact conj_assoc conj_commute)+

sublocale disj: abel_semigroup disj
  by standard (fact disj_assoc disj_commute)+

lemmas conj_left_commute = conj.left_commute

lemmas disj_left_commute = disj.left_commute

lemmas conj_ac = conj.assoc conj.commute conj.left_commute
lemmas disj_ac = disj.assoc disj.commute disj.left_commute

lemma dual: "boolean disj conj compl one zero"
  apply (rule boolean.intro)
  apply (rule disj_assoc)
  apply (rule conj_assoc)
  apply (rule disj_commute)
  apply (rule conj_commute)
  apply (rule disj_conj_distrib)
  apply (rule conj_disj_distrib)
  apply (rule disj_zero_right)
  apply (rule conj_one_right)
  apply (rule disj_cancel_right)
  apply (rule conj_cancel_right)
  done

subsection \<open>Complement\<close>

lemma complement_unique:
  assumes 1: "a \<sqinter> x = \<zero>"
  assumes 2: "a \<squnion> x = \<one>"
  assumes 3: "a \<sqinter> y = \<zero>"
  assumes 4: "a \<squnion> y = \<one>"
  shows "x = y"
proof -
  have "(a \<sqinter> x) \<squnion> (x \<sqinter> y) = (a \<sqinter> y) \<squnion> (x \<sqinter> y)"
    using 1 3 by simp
  then have "(x \<sqinter> a) \<squnion> (x \<sqinter> y) = (y \<sqinter> a) \<squnion> (y \<sqinter> x)"
    using conj_commute by simp
  then have "x \<sqinter> (a \<squnion> y) = y \<sqinter> (a \<squnion> x)"
    using conj_disj_distrib by simp
  then have "x \<sqinter> \<one> = y \<sqinter> \<one>"
    using 2 4 by simp
  then show "x = y"
    using conj_one_right by simp
qed

lemma compl_unique: "x \<sqinter> y = \<zero> \<Longrightarrow> x \<squnion> y = \<one> \<Longrightarrow> \<sim> x = y"
  by (rule complement_unique [OF conj_cancel_right disj_cancel_right])

lemma double_compl [simp]: "\<sim> (\<sim> x) = x"
proof (rule compl_unique)
  from conj_cancel_right show "\<sim> x \<sqinter> x = \<zero>"
    by (simp only: conj_commute)
  from disj_cancel_right show "\<sim> x \<squnion> x = \<one>"
    by (simp only: disj_commute)
qed

lemma compl_eq_compl_iff [simp]: "\<sim> x = \<sim> y \<longleftrightarrow> x = y"
  by (rule inj_eq [OF inj_on_inverseI]) (rule double_compl)

subsection \<open>Conjunction\<close>

lemma conj_absorb [simp]: "x \<sqinter> x = x"
proof -
  have "x \<sqinter> x = (x \<sqinter> x) \<squnion> \<zero>"
    using disj_zero_right by simp
  also have "... = (x \<sqinter> x) \<squnion> (x \<sqinter> \<sim> x)"
    using conj_cancel_right by simp
  also have "... = x \<sqinter> (x \<squnion> \<sim> x)"
    using conj_disj_distrib by (simp only:)
  also have "... = x \<sqinter> \<one>"
    using disj_cancel_right by simp
  also have "... = x"
    using conj_one_right by simp
  finally show ?thesis .
qed

lemma conj_zero_right [simp]: "x \<sqinter> \<zero> = \<zero>"
proof -
  have "x \<sqinter> \<zero> = x \<sqinter> (x \<sqinter> \<sim> x)"
    using conj_cancel_right by simp
  also have "... = (x \<sqinter> x) \<sqinter> \<sim> x"
    using conj_assoc by (simp only:)
  also have "... = x \<sqinter> \<sim> x"
    using conj_absorb by simp
  also have "... = \<zero>"
    using conj_cancel_right by simp
  finally show ?thesis .
qed

lemma compl_one [simp]: "\<sim> \<one> = \<zero>"
  by (rule compl_unique [OF conj_zero_right disj_zero_right])

lemma conj_zero_left [simp]: "\<zero> \<sqinter> x = \<zero>"
  by (subst conj_commute) (rule conj_zero_right)

lemma conj_one_left [simp]: "\<one> \<sqinter> x = x"
  by (subst conj_commute) (rule conj_one_right)

lemma conj_cancel_left [simp]: "\<sim> x \<sqinter> x = \<zero>"
  by (subst conj_commute) (rule conj_cancel_right)

lemma conj_left_absorb [simp]: "x \<sqinter> (x \<sqinter> y) = x \<sqinter> y"
  by (simp only: conj_assoc [symmetric] conj_absorb)

lemma conj_disj_distrib2: "(y \<squnion> z) \<sqinter> x = (y \<sqinter> x) \<squnion> (z \<sqinter> x)"
  by (simp only: conj_commute conj_disj_distrib)

lemmas conj_disj_distribs = conj_disj_distrib conj_disj_distrib2

subsection \<open>Disjunction\<close>

lemma disj_absorb [simp]: "x \<squnion> x = x"
  by (rule boolean.conj_absorb [OF dual])

lemma disj_one_right [simp]: "x \<squnion> \<one> = \<one>"
  by (rule boolean.conj_zero_right [OF dual])

lemma compl_zero [simp]: "\<sim> \<zero> = \<one>"
  by (rule boolean.compl_one [OF dual])

lemma disj_zero_left [simp]: "\<zero> \<squnion> x = x"
  by (rule boolean.conj_one_left [OF dual])

lemma disj_one_left [simp]: "\<one> \<squnion> x = \<one>"
  by (rule boolean.conj_zero_left [OF dual])

lemma disj_cancel_left [simp]: "\<sim> x \<squnion> x = \<one>"
  by (rule boolean.conj_cancel_left [OF dual])

lemma disj_left_absorb [simp]: "x \<squnion> (x \<squnion> y) = x \<squnion> y"
  by (rule boolean.conj_left_absorb [OF dual])

lemma disj_conj_distrib2: "(y \<sqinter> z) \<squnion> x = (y \<squnion> x) \<sqinter> (z \<squnion> x)"
  by (rule boolean.conj_disj_distrib2 [OF dual])

lemmas disj_conj_distribs = disj_conj_distrib disj_conj_distrib2

subsection \<open>De Morgan's Laws\<close>

lemma de_Morgan_conj [simp]: "\<sim> (x \<sqinter> y) = \<sim> x \<squnion> \<sim> y"
proof (rule compl_unique)
  have "(x \<sqinter> y) \<sqinter> (\<sim> x \<squnion> \<sim> y) = ((x \<sqinter> y) \<sqinter> \<sim> x) \<squnion> ((x \<sqinter> y) \<sqinter> \<sim> y)"
    by (rule conj_disj_distrib)
  also have "... = (y \<sqinter> (x \<sqinter> \<sim> x)) \<squnion> (x \<sqinter> (y \<sqinter> \<sim> y))"
    by (simp only: conj_ac)
  finally show "(x \<sqinter> y) \<sqinter> (\<sim> x \<squnion> \<sim> y) = \<zero>"
    by (simp only: conj_cancel_right conj_zero_right disj_zero_right)
next
  have "(x \<sqinter> y) \<squnion> (\<sim> x \<squnion> \<sim> y) = (x \<squnion> (\<sim> x \<squnion> \<sim> y)) \<sqinter> (y \<squnion> (\<sim> x \<squnion> \<sim> y))"
    by (rule disj_conj_distrib2)
  also have "... = (\<sim> y \<squnion> (x \<squnion> \<sim> x)) \<sqinter> (\<sim> x \<squnion> (y \<squnion> \<sim> y))"
    by (simp only: disj_ac)
  finally show "(x \<sqinter> y) \<squnion> (\<sim> x \<squnion> \<sim> y) = \<one>"
    by (simp only: disj_cancel_right disj_one_right conj_one_right)
qed

lemma de_Morgan_disj [simp]: "\<sim> (x \<squnion> y) = \<sim> x \<sqinter> \<sim> y"
  by (rule boolean.de_Morgan_conj [OF dual])

end

subsection \<open>Symmetric Difference\<close>

locale boolean_xor = boolean +
  fixes xor :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixr "\<oplus>" 65)
  assumes xor_def: "x \<oplus> y = (x \<sqinter> \<sim> y) \<squnion> (\<sim> x \<sqinter> y)"
begin

sublocale xor: abel_semigroup xor
proof
  fix x y z :: 'a
  let ?t = "(x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> \<sim> y \<sqinter> \<sim> z) \<squnion>
            (\<sim> x \<sqinter> y \<sqinter> \<sim> z) \<squnion> (\<sim> x \<sqinter> \<sim> y \<sqinter> z)"
  have "?t \<squnion> (z \<sqinter> x \<sqinter> \<sim> x) \<squnion> (z \<sqinter> y \<sqinter> \<sim> y) =
        ?t \<squnion> (x \<sqinter> y \<sqinter> \<sim> y) \<squnion> (x \<sqinter> z \<sqinter> \<sim> z)"
    by (simp only: conj_cancel_right conj_zero_right)
  then show "(x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
    apply (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
    apply (simp only: conj_disj_distribs conj_ac disj_ac)
    done
  show "x \<oplus> y = y \<oplus> x"
    by (simp only: xor_def conj_commute disj_commute)
qed

lemmas xor_assoc = xor.assoc
lemmas xor_commute = xor.commute
lemmas xor_left_commute = xor.left_commute

lemmas xor_ac = xor.assoc xor.commute xor.left_commute

lemma xor_def2: "x \<oplus> y = (x \<squnion> y) \<sqinter> (\<sim> x \<squnion> \<sim> y)"
  by (simp only: xor_def conj_disj_distribs disj_ac conj_ac conj_cancel_right disj_zero_left)

lemma xor_zero_right [simp]: "x \<oplus> \<zero> = x"
  by (simp only: xor_def compl_zero conj_one_right conj_zero_right disj_zero_right)

lemma xor_zero_left [simp]: "\<zero> \<oplus> x = x"
  by (subst xor_commute) (rule xor_zero_right)

lemma xor_one_right [simp]: "x \<oplus> \<one> = \<sim> x"
  by (simp only: xor_def compl_one conj_zero_right conj_one_right disj_zero_left)

lemma xor_one_left [simp]: "\<one> \<oplus> x = \<sim> x"
  by (subst xor_commute) (rule xor_one_right)

lemma xor_self [simp]: "x \<oplus> x = \<zero>"
  by (simp only: xor_def conj_cancel_right conj_cancel_left disj_zero_right)

lemma xor_left_self [simp]: "x \<oplus> (x \<oplus> y) = y"
  by (simp only: xor_assoc [symmetric] xor_self xor_zero_left)

lemma xor_compl_left [simp]: "\<sim> x \<oplus> y = \<sim> (x \<oplus> y)"
  apply (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
  apply (simp only: conj_disj_distribs)
  apply (simp only: conj_cancel_right conj_cancel_left)
  apply (simp only: disj_zero_left disj_zero_right)
  apply (simp only: disj_ac conj_ac)
  done

lemma xor_compl_right [simp]: "x \<oplus> \<sim> y = \<sim> (x \<oplus> y)"
  apply (simp only: xor_def de_Morgan_disj de_Morgan_conj double_compl)
  apply (simp only: conj_disj_distribs)
  apply (simp only: conj_cancel_right conj_cancel_left)
  apply (simp only: disj_zero_left disj_zero_right)
  apply (simp only: disj_ac conj_ac)
  done

lemma xor_cancel_right: "x \<oplus> \<sim> x = \<one>"
  by (simp only: xor_compl_right xor_self compl_zero)

lemma xor_cancel_left: "\<sim> x \<oplus> x = \<one>"
  by (simp only: xor_compl_left xor_self compl_zero)

lemma conj_xor_distrib: "x \<sqinter> (y \<oplus> z) = (x \<sqinter> y) \<oplus> (x \<sqinter> z)"
proof -
  have *: "(x \<sqinter> y \<sqinter> \<sim> z) \<squnion> (x \<sqinter> \<sim> y \<sqinter> z) =
        (y \<sqinter> x \<sqinter> \<sim> x) \<squnion> (z \<sqinter> x \<sqinter> \<sim> x) \<squnion> (x \<sqinter> y \<sqinter> \<sim> z) \<squnion> (x \<sqinter> \<sim> y \<sqinter> z)"
    by (simp only: conj_cancel_right conj_zero_right disj_zero_left)
  then show "x \<sqinter> (y \<oplus> z) = (x \<sqinter> y) \<oplus> (x \<sqinter> z)"
    by (simp (no_asm_use) only:
        xor_def de_Morgan_disj de_Morgan_conj double_compl
        conj_disj_distribs conj_ac disj_ac)
qed

lemma conj_xor_distrib2: "(y \<oplus> z) \<sqinter> x = (y \<sqinter> x) \<oplus> (z \<sqinter> x)"
proof -
  have "x \<sqinter> (y \<oplus> z) = (x \<sqinter> y) \<oplus> (x \<sqinter> z)"
    by (rule conj_xor_distrib)
  then show "(y \<oplus> z) \<sqinter> x = (y \<sqinter> x) \<oplus> (z \<sqinter> x)"
    by (simp only: conj_commute)
qed

lemmas conj_xor_distribs = conj_xor_distrib conj_xor_distrib2

end

end


theory Lists1_8
imports Main
begin

primrec ListSum :: "nat list \<Rightarrow> nat"
where
  "ListSum [] = 0"
| "ListSum (x#xs) = x + ListSum xs"

value "ListSum []"
value "ListSum [1]"
value "ListSum [1,1,2]"

value "[0..<4]"
value "ListSum [0..<Suc 0]"

lemma listsum_append: "ListSum (xs @ ys) = ListSum xs + ListSum ys"
  apply (induct xs)
  apply simp
  apply auto
done

theorem "2 * ListSum [0..<n+1] = n * (n + 1)"
  apply (induct n)
  apply (simp add:listsum_append)+
done

value "replicate 10 (1::nat)"

theorem "ListSum (replicate n a) = n * a"
  apply (induct n)
  apply simp
  apply simp
done

fun ListSumTAux :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
where
  "ListSumTAux [] n = n"
| "ListSumTAux (x#xs) n = ListSumTAux xs (n + x)"

value "ListSumTAux [] 0"
value "ListSumTAux [1] 0"
value "ListSumTAux [1,2] 0"

fun ListSumT :: "nat list \<Rightarrow> nat"
where
  "ListSumT xs = ListSumTAux xs 0"

value "ListSumT []"
value "ListSumT [1]"
value "ListSumT [1,2]"

lemma list_sumtaux_add: "\<forall> a b. ListSumTAux xs (a + b) = a + ListSumTAux xs b"
  apply (induct xs)
  apply auto
done

(* Proving the lemma with reversed sides does not help in proving
   the main lemma proved later *)
lemma list_sumtaux_val: "a + ListSumTAux xs 0 = ListSumTAux xs a"
  apply (induct xs)
  (* using [[simp_trace=true]] *)
  apply simp
  apply (simp add:list_sumtaux_add)
done

theorem "ListSum xs = ListSumT xs"
  apply (induct xs)
  apply simp
  (* using [[simp_trace = true]] *)
  apply (simp add:list_sumtaux_val)
done

end