theory Analysis_More
  imports Ordinary_Differential_Equations.Flow
begin

subsection \<open>Some results about derivatives\<close>

text \<open>Projection of has_vector_derivative onto components.\<close>
lemma has_vector_derivative_proj:
  assumes "(p has_vector_derivative q t) (at t within D)"
  shows "((\<lambda>t. p t $ i) has_vector_derivative q t $ i) (at t within D)"
  using assms unfolding has_vector_derivative_def has_derivative_def
  apply (simp add: bounded_linear_scaleR_left)
  using tendsto_vec_nth by fastforce

lemma has_vderiv_on_proj:
  assumes "(p has_vderiv_on q) D"
  shows "((\<lambda>t. p t $ i) has_vderiv_on (\<lambda>t. q t $ i)) D"
  using assms unfolding has_vderiv_on_def
  by (simp add: has_vector_derivative_proj)

lemma has_vector_derivative_projI:
  assumes "\<forall>i. ((\<lambda>t. p t $ i) has_vector_derivative q t $ i) (at t within D)"
  shows "(p has_vector_derivative q t) (at t within D)"
  using assms unfolding has_vector_derivative_def has_derivative_def
  apply (auto simp add: bounded_linear_scaleR_left)
  by (auto intro: vec_tendstoI)

lemma has_derivative_coords [simp,derivative_intros]:
  "((\<lambda>t. t$i) has_derivative (\<lambda>t. t$i)) (at x)"
  unfolding has_derivative_def by auto

lemma has_vector_derivative_divide[derivative_intros]:
  fixes a:: "'a::real_normed_field"
  shows "(f has_vector_derivative x) F \<Longrightarrow> ((\<lambda>x. f x / a) has_vector_derivative (x/a)) F"
  unfolding divide_inverse by(fact has_vector_derivative_mult_left)

lemma has_derivative_divide[derivative_intros]:
  fixes a:: "'a::real_normed_field"
  shows "(f has_derivative g) F \<Longrightarrow> ((\<lambda>x. f x / a) has_derivative (\<lambda>x. g x / a)) F"
  unfolding divide_inverse by(fact has_derivative_mult_left)

text \<open>If the derivative is always 0, then the function is always 0.\<close>
lemma mvt_real_eq:
  fixes p :: "real \<Rightarrow> real"
  assumes "\<forall>t\<in>{0 .. d}. (p has_derivative q t) (at t within {0 .. d}) "
    and "d \<ge> 0"
    and "\<forall>t\<in>{0 ..<d}. \<forall>s. q t s = 0"
    and "x \<in> {0 .. d}"
  shows "p 0 = p x"
proof -
  have "\<forall>t\<in>{0 .. x}. (p has_derivative q t) (at t within {0 .. x})"
    using assms
    by (metis atLeastAtMost_iff atLeastatMost_subset_iff has_derivative_subset less_eq_real_def order_less_le_trans)
    then show ?thesis
  using assms
  using mvt_simple[of 0 x p q]
  by force
qed

text \<open>If the derivative is always non-negative, then the function is increasing.\<close>
lemma mvt_real_ge:
  fixes p :: "real \<Rightarrow>real"
 assumes "\<forall>t\<in>{0 .. d}. (p has_derivative q t) (at t within {0 .. d}) "
  and "d \<ge> 0"
  and "\<forall>t\<in>{0 ..<d}. \<forall>s\<ge>0. q t s \<ge> 0"
  and "x \<in> {0 .. d}"
  shows "p 0 \<le> p x"
proof -
  have "\<forall>t\<in>{0 .. x}. (p has_derivative q t) (at t within {0 .. x})"
    using assms
    by (meson atLeastAtMost_iff atLeastatMost_subset_iff has_derivative_subset in_mono order_refl)
  then show ?thesis
  using assms
  using mvt_simple[of 0 x p q]
  by (smt atLeastAtMost_iff atLeastLessThan_iff greaterThanLessThan_iff)
qed

text \<open>If the derivative is always non-positive, then the function is decreasing.\<close>
lemma mvt_real_le:
  fixes p :: "real \<Rightarrow>real"
  assumes "\<forall>t\<in>{0 .. d}. (p has_derivative q t) (at t within {0 .. d}) "
    and "d \<ge> 0"
    and "\<forall>t\<in>{0 ..<d}. \<forall>s\<ge>0 . q t s \<le> 0"
    and "x \<in> {0 .. d}"
  shows "p 0 \<ge> p x"
proof -
  have "\<forall>t\<in>{0 .. x}. (p has_derivative q t) (at t within {0 .. x})"
    using assms
    by (meson atLeastAtMost_iff atLeastatMost_subset_iff has_derivative_subset in_mono order_refl)
  then obtain xa where "xa\<in>{0<..<x}" " p x - p 0 = q xa (x - 0)" if "x>0"
    using  mvt_simple[of 0 x p q]
    using atLeastAtMost_iff by blast
  then have "p x \<le> p 0" if "x>0"
  using assms
  by (smt atLeastAtMost_iff atLeastLessThan_iff greaterThanLessThan_iff)
  then show ?thesis
    using assms  by fastforce

qed

lemma real_inv_le:
  fixes p :: "real \<Rightarrow> real" and con :: real
  assumes "\<forall>t\<in>{-e..d+e}. (p has_derivative q t) (at t within {-e..d+e})"
    and "d \<ge> 0"
    and "\<forall>t\<in>{0 ..<d}. (p t = con \<longrightarrow> q t 1 < 0)"
    and "p 0 \<le> con "
    and "x \<in> {0 .. d}"
    and "e > 0"
  shows "p x \<le> con"
proof (rule ccontr)
  assume a:" \<not> p x \<le> con"
  have 1:"p x > con"
    using a by auto
  have 2:"\<forall>t\<in>{0 .. d}. continuous (at t within {-e<..<d+e}) p"
    using assms has_derivative_subset
    using has_derivative_continuous
    by (smt atLeastAtMost_iff continuous_within_subset greaterThanLessThan_subseteq_atLeastAtMost_iff greaterThan_iff)
  have 3:"\<forall>t\<in>{0 .. d}. isCont p t"
    apply auto subgoal for t
      using continuous_within_open[of t "{-e<..<d+e}" p]
      using 2 assms(5) assms(6) by auto
    done
  have 4:"{y. p y = con \<and> y \<in> {0 .. x}} \<noteq> {}"
    using IVT[of p 0 con x] using 3 1 assms
    by auto
  have 5: "{y. p y = con \<and> y \<in> {0 .. x}} = ({0 .. x} \<inter> p -` {con})"
    by auto
  have 6: "closed ({0 .. x} \<inter> p -` {con})"
    using 3 assms(5) apply simp
    apply (rule continuous_closed_preimage)
      apply auto
    by (simp add: continuous_at_imp_continuous_on)
  have 7: "compact {0 .. x}"
    using assms
    by blast
  have 8: "compact {y. p y = con \<and> y \<in> {0 .. x}}"
    apply auto
    using 4 5 6 7
    by (smt Collect_cong Int_left_absorb atLeastAtMost_iff compact_Int_closed)
  obtain t where t1:"t \<in> {y. p y = con \<and> y \<in> {0 .. x}}" and t2:"\<forall> tt\<in> {y. p y = con \<and> y \<in> {0 .. x}}. tt \<le>t"
    using compact_attains_sup[of "{y. p y = con \<and> y \<in> {0 .. x}}"] 4 8
    by blast
  have 9:"t<x"
    using t1 1
    using leI by fastforce
  have 10:"p tt > con" if "tt\<in>{t<..x}" for tt
  proof(rule ccontr)
    assume "\<not> con < p tt"
    then have not:"p tt \<le>con" by auto
    have "\<exists> t' \<in> {t<..x}. p t' = con"
    proof(cases "p tt = con")
      case True
      then show ?thesis using that by auto
    next
      case False
      then have "p tt < con"
        using not by auto
      then have "{y. p y = con \<and> y \<in> {tt .. x}} \<noteq> {}"
        using IVT[of p tt con x] using 3 1 assms that t1
        by auto
      then show ?thesis using that by auto
    qed
    then show False using t1 t2 9
      using atLeastAtMost_iff greaterThanAtMost_iff by auto
  qed
  have 11:"(p has_derivative q t) (at t within {-e..d+e})"
    using assms t1 by auto
  then have 12:"\<forall>s . q t s = q t 1 * s"
    using has_derivative_bounded_linear[of p "q t" "(at t within {-e..d+e})"]
    using real_bounded_linear by auto
  have 13:"(p has_real_derivative q t 1) (at t within {-e..d+e})"
    using 11 12
    by (metis has_derivative_imp_has_field_derivative mult.commute)
  have 14:"q t 1 < 0" using t1 assms 9 by auto
  have 15:"\<exists>dd>0. \<forall>h>0. t + h \<in> {-e..d+e} \<longrightarrow> h < dd \<longrightarrow> p (t + h) < p t"
    using has_real_derivative_neg_dec_right[of p "q t 1" t "{-e..d+e}"] 13 14
    by auto
  then obtain dd where d1:"\<forall>h>0. t + h \<in> {-e..d+e} \<longrightarrow> h < dd \<longrightarrow> p (t + h) < p t" and d2:"dd>0" by auto
  then have 16:"min (dd/2) (x-t)/2 < dd" and "min (dd/2) (x-t)/2 > 0"
    using 9 by auto
  then have 17:"(t + min (dd/2) (x-t)/2)> t" "(t + min (dd/2) (x-t)/2) < x"
    apply auto
    using d2 9
     by (smt field_sum_of_halves)
   then have 18:"p (t + min (dd/2) (x-t)/2) < p t"
    using d1 t1 16 assms(5) assms(6) by auto
  have 19:"p (t + min (dd/2) (x-t)/2)>con" using 10 17 by auto
  show False using 18 19 t1
    by auto
  qed

lemma real_inv_ge:
  fixes p :: "real \<Rightarrow> real" and con :: real
  assumes "\<forall>t\<in>{-e..d+e}. (p has_derivative q t) (at t within {-e..d+e})"
    and "d \<ge> 0"
    and "\<forall>t\<in>{0 ..<d}. (p t = con \<longrightarrow> q t 1 > 0)"
    and "p 0 \<ge> con "
    and "x \<in> {0 .. d}"
    and "e > 0"
  shows "p x \<ge> con"
proof (rule ccontr)
  assume a:" \<not> p x \<ge> con"
  have 1:"p x < con"
    using a by auto
  have " \<forall>t\<in>{- e..d + e}. (p has_derivative q t) (at t within {- e<..<d + e})"
    using assms has_derivative_subset
    by (smt greaterThanLessThan_subseteq_atLeastAtMost_iff)
  then have " \<forall>t\<in>{0..d}. (p has_derivative q t) (at t within {- e<..<d + e})"
    using assms by auto
  then have 2:"\<forall>t\<in>{0 .. d}. continuous (at t within {-e<..<d+e}) p"
    using has_derivative_continuous
    by blast
  have 3:"\<forall>t\<in>{0 .. d}. isCont p t"
    apply auto subgoal for t
      using continuous_within_open[of t "{-e<..<d+e}" p]
      using 2 assms(5) assms(6) by auto
    done
  have 4:"{y. p y = con \<and> y \<in> {0 .. x}} \<noteq> {}"
    using IVT2[of p x con 0] using 3 1 assms
    by auto
  have 5: "{y. p y = con \<and> y \<in> {0 .. x}} = ({0 .. x} \<inter> p -` {con})"
    by auto
  have 6: "closed ({0 .. x} \<inter> p -` {con})"
    using 3 assms(5) apply simp
    apply (rule continuous_closed_preimage)
      apply auto
    by (simp add: continuous_at_imp_continuous_on)
  have 7: "compact {0 .. x}"
    using assms
    by blast
  have 8: "compact {y. p y = con \<and> y \<in> {0 .. x}}"
    apply auto
    using 4 5 6 7
    by (smt Collect_cong Int_left_absorb atLeastAtMost_iff compact_Int_closed)
  obtain t where t1:"t \<in> {y. p y = con \<and> y \<in> {0 .. x}}" and t2:"\<forall> tt\<in> {y. p y = con \<and> y \<in> {0 .. x}}. tt \<le>t"
    using compact_attains_sup[of "{y. p y = con \<and> y \<in> {0 .. x}}"] 4 8
    by blast
  have 9:"t<x"
    using t1 1
    using leI by fastforce
  have 10:"p tt < con" if "tt\<in>{t<..x}" for tt
  proof(rule ccontr)
    assume "\<not> con > p tt"
    then have not:"p tt \<ge> con" by auto
    have "\<exists> t' \<in> {t<..x}. p t' = con"
    proof(cases "p tt = con")
      case True
      then show ?thesis using that by auto
    next
      case False
      then have "p tt > con"
        using not by auto
      then have "{y. p y = con \<and> y \<in> {tt .. x}} \<noteq> {}"
        using IVT2[of p x con tt] using 3 1 assms that t1
        by auto
      then show ?thesis using that by auto
    qed
    then show False using t1 t2 9
      using atLeastAtMost_iff greaterThanAtMost_iff by auto
  qed
  have 11:"(p has_derivative q t) (at t within {-e..d+e})"
    using assms t1 by auto
  then have 12:"\<forall>s . q t s = q t 1 * s"
    using has_derivative_bounded_linear[of p "q t" "(at t within {-e..d+e})"]
    using real_bounded_linear by auto
  have 13:"(p has_real_derivative q t 1) (at t within {-e..d+e})"
    using 11 12
    by (metis has_derivative_imp_has_field_derivative mult.commute)
  have 14:"q t 1 > 0" using t1 assms 9 by auto
  have 15:"\<exists>dd>0. \<forall>h>0. t + h \<in> {-e..d+e} \<longrightarrow> h < dd \<longrightarrow> p (t + h) > p t"
    using has_real_derivative_pos_inc_right[of p "q t 1" t "{-e..d+e}"] 13 14
    by auto
  then obtain dd where d1:"\<forall>h>0. t + h \<in> {-e..d+e} \<longrightarrow> h < dd \<longrightarrow> p (t + h) > p t" and d2:"dd>0" by auto
  then have 16:"min (dd/2) (x-t)/2 < dd" and "min (dd/2) (x-t)/2 > 0"
    using 9 by auto
  then have 17:"(t + min (dd/2) (x-t)/2)> t" "(t + min (dd/2) (x-t)/2) < x"
    apply auto
    using d2 9
     by (smt field_sum_of_halves)
   then have 18:"p (t + min (dd/2) (x-t)/2) > p t"
    using d1 t1 16 assms(5) assms(6) by auto
  have 19:"p (t + min (dd/2) (x-t)/2)< con" using 10 17 by auto
  show False using 18 19 t1
    by auto
qed

lemma real_inv_l:
  fixes p :: "real \<Rightarrow> real" and con :: real
  assumes "\<forall>t\<in>{-e..d+e}. (p has_derivative q t) (at t within {-e..d+e})"
    and "d \<ge> 0"
    and "\<forall>t\<in>{0 ..<d}. (p t \<le> con \<longrightarrow> q t 1 < 0)"
    and "p 0 < con "
    and "x \<in> {0 .. d}"
    and "e > 0"
  shows "p x < con"
proof (rule ccontr)
  assume a:" \<not> p x < con"
  have 1:"p x \<ge> con"
    using a by auto
  have 2:"\<forall>t\<in>{0 .. d}. continuous (at t within {-e<..<d+e}) p"
    using assms has_derivative_subset
    using has_derivative_continuous
    by (smt atLeastAtMost_iff continuous_within_subset greaterThanLessThan_subseteq_atLeastAtMost_iff greaterThan_iff)
  have 3:"\<forall>t\<in>{0 .. d}. isCont p t"
    apply auto subgoal for t
      using continuous_within_open[of t "{-e<..<d+e}" p]
      using 2 assms(5) assms(6) by auto
    done
  have 4:"{y. p y = con \<and> y \<in> {0 .. x}} \<noteq> {}"
    using IVT[of p 0 con x] using 3 1 assms
    by auto
  have 5: "{y. p y = con \<and> y \<in> {0 .. x}} = ({0 .. x} \<inter> p -` {con})"
    by auto
  have 6: "closed ({0 .. x} \<inter> p -` {con})"
    using 3 assms(5) apply simp
    apply (rule continuous_closed_preimage)
      apply auto
    by (simp add: continuous_at_imp_continuous_on)
  have 7: "compact {0 .. x}"
    using assms
    by blast
  have 8: "compact {y. p y = con \<and> y \<in> {0 .. x}}"
    apply auto
    using 4 5 6 7
    by (smt Collect_cong Int_left_absorb atLeastAtMost_iff compact_Int_closed)
  obtain t where t1:"t \<in> {y. p y = con \<and> y \<in> {0 .. x}}" and t2:"\<forall> tt\<in> {y. p y = con \<and> y \<in> {0 .. x}}. tt \<ge> t"
    using compact_attains_inf[of "{y. p y = con \<and> y \<in> {0 .. x}}"] 4 8
    by blast
  have 9:"t > 0"
    using t1 1 assms(4)
    using less_eq_real_def by auto
  have 10:"p tt < con" if "tt\<in>{0..<t}" for tt
  proof(rule ccontr)
    assume "\<not> p tt < con"
    then have not:"p tt \<ge> con" by auto
    have "\<exists> t' \<in> {0..<t}. p t' = con"
    proof(cases "p tt = con")
      case True
      then show ?thesis using that by auto
    next
      case False
      then have "p tt > con"
        using not by auto
      then have "{y. p y = con \<and> y \<in> {0 .. tt}} \<noteq> {}"
        using IVT[of p 0 con tt] using 3 1 assms that t1
        by auto
      then show ?thesis using that by auto
    qed
    then show False using t1 t2 9
      using atLeastAtMost_iff greaterThanAtMost_iff by auto
  qed
  have 11:"(p has_derivative q y) (at y within {0..t})" if "y \<in> {0 ..t}"for y
    apply(rule has_derivative_subset [where s = "{-e<..<d+e}"])
    using assms that t1
    apply auto
    by (smt atLeastAtMost_iff at_within_Icc_at has_derivative_at_withinI)
  have 12:"\<exists> tt \<in> {0<..<t} . p t - p 0 = q tt t "
    using mvt_simple[of 0 t p q] 9 11
    by auto
  obtain tt where tt1:"p t - p 0 = q tt t" and tt2:"tt \<in> {0<..<t}"
    using 12 by auto
  have 13:"\<forall>s . q tt s = q tt 1 * s"
    using has_derivative_bounded_linear[of p "q tt" "(at tt within {0..t})"]
    using real_bounded_linear 11 tt2 by auto
  have 14:"p t - p 0 = q tt 1 * t" using tt1 13
    by metis
  have 15:"q tt 1 > 0" using 14 assms(4) t1 9
    by (metis (mono_tags, lifting) diff_gt_0_iff_gt mem_Collect_eq zero_less_mult_pos2)
  then show False using assms(3) 10[of tt] tt2
    by (smt "10" a assms(5) atLeastAtMost_iff atLeastLessThan_iff greaterThanLessThan_iff)
qed

lemma real_inv_g:
  fixes p :: "real \<Rightarrow> real" and con :: real
  assumes "\<forall>t\<in>{-e..d+e}. (p has_derivative q t) (at t within {-e..d+e})"
    and "d \<ge> 0"
    and "\<forall>t\<in>{0 ..<d}. (p t \<ge> con \<longrightarrow> q t 1 \<ge> 0)"
    and "p 0 > con "
    and "x \<in> {0 .. d}"
    and "e > 0"
  shows "p x > con"
proof (rule ccontr)
  assume a:" \<not> p x > con"
  have 1:"p x \<le> con"
    using a by auto
  have 2:"\<forall>t\<in>{0 .. d}. continuous (at t within {-e<..<d+e}) p"
    using assms has_derivative_subset
    using has_derivative_continuous
    by (smt atLeastAtMost_iff continuous_within_subset greaterThanLessThan_subseteq_atLeastAtMost_iff greaterThan_iff)
  have 3:"\<forall>t\<in>{0 .. d}. isCont p t"
    apply auto subgoal for t
      using continuous_within_open[of t "{-e<..<d+e}" p]
      using 2 assms(5) assms(6) by auto
    done
  have 4:"{y. p y = con \<and> y \<in> {0 .. x}} \<noteq> {}"
    using IVT2[of p x con 0] using 3 1 assms
    by auto
  have 5: "{y. p y = con \<and> y \<in> {0 .. x}} = ({0 .. x} \<inter> p -` {con})"
    by auto
  have 6: "closed ({0 .. x} \<inter> p -` {con})"
    using 3 assms(5) apply simp
    apply (rule continuous_closed_preimage)
      apply auto
    by (simp add: continuous_at_imp_continuous_on)
  have 7: "compact {0 .. x}"
    using assms
    by blast
  have 8: "compact {y. p y = con \<and> y \<in> {0 .. x}}"
    apply auto
    using 4 5 6 7
    by (smt Collect_cong Int_left_absorb atLeastAtMost_iff compact_Int_closed)
  obtain t where t1:"t \<in> {y. p y = con \<and> y \<in> {0 .. x}}" and t2:"\<forall> tt\<in> {y. p y = con \<and> y \<in> {0 .. x}}. tt \<ge> t"
    using compact_attains_inf[of "{y. p y = con \<and> y \<in> {0 .. x}}"] 4 8
    by blast
  have 9:"t > 0"
    using t1 1 assms(4)
    using less_eq_real_def by auto
  have 10:"p tt > con" if "tt\<in>{0..<t}" for tt
  proof(rule ccontr)
    assume "\<not> p tt > con"
    then have not:"p tt \<le> con" by auto
    have "\<exists> t' \<in> {0..<t}. p t' = con"
    proof(cases "p tt = con")
      case True
      then show ?thesis using that by auto
    next
      case False
      then have "p tt < con"
        using not by auto
      then have "{y. p y = con \<and> y \<in> {0 .. tt}} \<noteq> {}"
        using IVT2[of p tt con 0] using 3 1 assms that t1
        by auto
      then show ?thesis using that by auto
    qed
    then show False using t1 t2 9
      using atLeastAtMost_iff greaterThanAtMost_iff by auto
  qed
  have 11:"(p has_derivative q y) (at y within {0..t})" if "y \<in> {0 ..t}"for y
    apply(rule has_derivative_subset [where s = "{-e<..<d+e}"])
    using assms that t1
    apply auto
    by (smt atLeastAtMost_iff at_within_Icc_at has_derivative_at_withinI)
  have 12:"\<exists> tt \<in> {0<..<t} . p t - p 0 = q tt t "
    using mvt_simple[of 0 t p q] 9 11
    by auto
  obtain tt where tt1:"p t - p 0 = q tt t" and tt2:"tt \<in> {0<..<t}"
    using 12 by auto
  have 13:"\<forall>s . q tt s = q tt 1 * s"
    using has_derivative_bounded_linear[of p "q tt" "(at tt within {0..t})"]
    using real_bounded_linear 11 tt2 by auto
  have 14:"p t - p 0 = q tt 1 * t" using tt1 13
    by metis
  have 15:"q tt 1 < 0" using 14 assms(4) t1 9
    by (metis (mono_tags, lifting) less_iff_diff_less_0 mem_Collect_eq mult_less_0_iff not_less_iff_gr_or_eq)
  then show False using assms(3) 10[of tt] tt2
    by (smt "1" "10" assms(5) atLeastAtMost_iff atLeastLessThan_iff greaterThanLessThan_iff)
qed

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

text \<open>Variable names\<close>
type_synonym var = char

text \<open>State\<close>
type_synonym state = "var \<Rightarrow> real"

text \<open>Expressions\<close>
type_synonym exp = "state \<Rightarrow> real"

text \<open>Predicates\<close>
type_synonym fform = "state \<Rightarrow> bool"

text \<open>States as a vector\<close>
type_synonym vec = "real^(var)"

text \<open>Conversion between state and vector\<close>
definition state2vec :: "state \<Rightarrow> vec" where
  "state2vec s = (\<chi> x. s x)"

definition vec2state :: "vec \<Rightarrow> state" where
  "(vec2state v) x = v $ x"

lemma vec_state_map1[simp]: "vec2state (state2vec s) = s"
  unfolding vec2state_def state2vec_def by auto

lemma vec_state_map2[simp]: "state2vec (vec2state s) = s"
  unfolding vec2state_def state2vec_def by auto

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

datatype ODE =
  ODE "var \<Rightarrow> exp"

text \<open>Given ODE and a state, find the derivative vector.\<close>
fun ODE2Vec :: "ODE \<Rightarrow> state \<Rightarrow> vec" where
  "ODE2Vec (ODE f) s = state2vec (\<lambda>a. f a s)"

text \<open>History p on time {0 .. d} is a solution to ode.\<close>
definition ODEsol :: "ODE \<Rightarrow> (real \<Rightarrow> state) \<Rightarrow> real \<Rightarrow> bool" where
  "ODEsol ode p d = (d \<ge> 0 \<and> (\<exists>\<epsilon>>0. ((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {-\<epsilon> .. d+\<epsilon>}))"

text \<open>History p on time {0 ..} is a solution to ode.\<close>
definition ODEsolInf :: "ODE \<Rightarrow> (real \<Rightarrow> state) \<Rightarrow> bool" where
  "ODEsolInf ode p = (\<exists>\<epsilon>>0. ((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {-\<epsilon> ..})"

subsection \<open>Further results in analysis\<close>

lemma ODEsol_old:
  assumes "ODEsol ode p d"
  shows "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {0 .. d}"
proof-
  obtain e where e: "e > 0" "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {-e .. d+e}"
    using assms(1) unfolding ODEsol_def by blast
  then show ?thesis
    using e(1) has_vderiv_on_subset[OF e(2)] by auto
qed

lemma ODEsolInf_old:
   assumes "ODEsolInf  ode p"
   shows "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {0 ..}"
proof-
  obtain e where e: "e > 0" "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {-e ..}"
    using assms(1) unfolding ODEsolInf_def by blast
  then show ?thesis
    using e(1) has_vderiv_on_subset[OF e(2)] by auto
qed

lemma ODEsol_merge:
  assumes "ODEsol ode p d"
    and "ODEsol ode p2 d2"
    and "p2 0 = p d"
  shows "ODEsol ode (\<lambda>\<tau>. if \<tau> < d then p \<tau> else p2 (\<tau> - d)) (d + d2)"
  unfolding ODEsol_def
  apply auto
  subgoal
    using assms(1,2) unfolding ODEsol_def by auto
  subgoal
  proof-
    have step1:"d\<ge>0 \<and> d2\<ge>0"
      using assms unfolding ODEsol_def by auto
    then have step2:"{0 .. d+d2} = {0 .. d}\<union>{d .. d+d2}"
      by auto
    have step3:"({0..d} \<union> closure {d..d + d2} \<inter> closure {0..d}) = {0..d}"
      using step1 by auto
    have step4:"({d..d + d2} \<union> closure {d..d + d2} \<inter> closure {0..d}) = {d..d+d2}"
      using step1 by auto
    obtain e1 where e1: "e1 > 0" "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {-e1 .. d+e1}"
      using assms(1) unfolding ODEsol_def by blast
    obtain e2 where e2: "e2 > 0" "((\<lambda>t. state2vec (p2 t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p2 t))) {-e2 .. d2+e2}"
      using assms(2) unfolding ODEsol_def by blast
    obtain e where e: "e > 0" "e < e1" "e < e2"
      using e1(1) e2(1) field_lbound_gt_zero by auto
    then have stepe:"{0 .. d2+e}\<subseteq>{- e2..d2 + e2}" "{-e .. d}\<subseteq>{- e1..d + e1}" "{- e..d + d2 + e} = {- e..d} \<union> {d..d + d2 + e}"
      using step1  by auto
    have stepclo1:"({- e..d} \<union> closure {d..d + d2 + e} \<inter> closure {- e..d}) = {- e..d}"
      using e step1 by auto
    have stepclo2:" ({d..d + d2 + e} \<union> closure {d..d + d2 + e} \<inter> closure {- e..d}) = {d..d + d2 + e}"
      using e step1 by auto
    have stepclo3: "x \<in> closure {d..d + d2 + e} \<Longrightarrow>
          x \<in> closure {- e..d} \<Longrightarrow> x = d" for x
      using e step1  by auto
    have step5: "((\<lambda>t. t - d) has_vderiv_on (\<lambda>t. 1)) {d .. d+d2+e}"
      by (auto intro!: derivative_intros)
    then have step6: "((\<lambda>t. state2vec (p2 (t-d))) has_vderiv_on (\<lambda>t. ODE2Vec ode (p2 (t-d)))) {d .. d+d2+e}"
      using has_vderiv_on_compose2[of "(\<lambda>t. state2vec (p2 t))" "(\<lambda>t. ODE2Vec ode (p2 (t)))" "{0 .. d2+e}" "(\<lambda>t. (t-d))" "(\<lambda>t. 1)" "{d .. d+d2+e}"]
      using e2 e unfolding ODEsol_def
      using has_vderiv_on_subset[OF e2(2) stepe(1)] by auto
     have step7:" ((\<lambda>t. if t \<in> {-e..d} then state2vec (p t) else state2vec (p2 (t - d))) has_vderiv_on
     (\<lambda>t. if t \<in> {-e..d} then ODE2Vec ode (p t) else ODE2Vec ode (p2 (t - d)))){-e..d + d2+e}"
      using has_vderiv_on_If[of "{-e .. d+d2+e}" "{-e .. d}" "{d .. d+d2+e}" "(\<lambda>t. state2vec (p t))" "(\<lambda>t. ODE2Vec ode (p t))" "(\<lambda>t. state2vec (p2 (t-d)))" "(\<lambda>t. ODE2Vec ode (p2 (t-d)))"]
      using step1 step2 step3 step4 step6 stepclo1 stepclo2 stepclo3
      using has_vderiv_on_subset[OF e1(2) stepe(2)] e stepe assms(3)
      by auto
    show ?thesis
      apply(rule exI[where x=e])
      using has_vderiv_eq[of "(\<lambda>t. if t \<in> {-e..d} then state2vec (p t) else state2vec (p2 (t - d)))" "(\<lambda>t. if t \<in> {-e..d} then ODE2Vec ode (p t) else ODE2Vec ode (p2 (t - d)))" "{-e..d + d2+e}" "(\<lambda>t. state2vec (if t < d then p t else p2 (t - d)))" "(\<lambda>t. ODE2Vec ode (if t < d then p t else p2 (t - d)))" "{-e..d + d2+e}"]
      using step7
      using assms(3) step1 e
      by auto
  qed
  done

lemma ODEsol_split:
  assumes "ODEsol ode p d"
    and "0 < t1" and "t1 < d"
  shows "ODEsol ode p t1"
        "ODEsol ode (\<lambda>t. p (t + t1)) (d - t1)"
  subgoal
  proof-
    obtain e where e: "e > 0" "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {-e .. d+e}"
      using assms(1) unfolding ODEsol_def by blast
    then show ?thesis unfolding ODEsol_def
    using has_vderiv_on_subset[of "(\<lambda>t. state2vec (p t))" " (\<lambda>t. ODE2Vec ode (p t))" "{-e .. d+e}" "{-e..t1+e}"]
    using assms unfolding ODEsol_def by auto
qed
  subgoal
    unfolding ODEsol_def apply auto
    subgoal using assms by auto
    subgoal
    proof-
      obtain e where e: "e > 0" "((\<lambda>t. state2vec (p t)) has_vderiv_on (\<lambda>t. ODE2Vec ode (p t))) {-e .. d+e}"
        using assms(1) unfolding ODEsol_def by blast
      have step1:"((\<lambda>t. state2vec (p (t))) has_vderiv_on (\<lambda>t. ODE2Vec ode (p (t)))) {t1-e..d+e}"
        using has_vderiv_on_subset[of "(\<lambda>t. state2vec (p t))" " (\<lambda>t. ODE2Vec ode (p t))" "{-e..d+e}" "{t1-e..d+e}"]
        using e assms  by auto
      have step2:"((\<lambda>t.(t+t1)) has_vderiv_on (\<lambda>t. 1)) {-e..d-t1+e}"
        by (auto intro!: derivative_intros)
      have step3:"t \<in> {- e..d - t1 + e} \<Longrightarrow> t + t1 \<in> {t1 - e..d + e}" for t
        using e assms by auto
      show ?thesis
        apply (rule exI[where x=e])
        apply auto
        subgoal using e by auto
        using has_vderiv_on_compose2[of "(\<lambda>t. state2vec (p (t)))" "(\<lambda>t. ODE2Vec ode (p (t)))" "{t1-e..d+e}" "(\<lambda>t.(t+t1))" "(\<lambda>t. 1)" " {-e..d-t1+e}"]
        using step1 step2 step3 by auto
    qed
    done
  done

end


(*  Title:       Computing Square Roots using the Babylonian Method
    Author:      René Thiemann       <rene.thiemann@uibk.ac.at>
    Maintainer:  René Thiemann
    License:     LGPL
*)
section \<open>A Fast Logarithm Algorithm\<close>

theory Log_Impl
imports
  Sqrt_Babylonian_Auxiliary
begin

text \<open>We implement the discrete logarithm function in a manner similar to
  a repeated squaring exponentiation algorithm.\<close>

text \<open>In order to prove termination of the algorithm without intermediate checks
  we need to ensure that we only use proper bases,
  i.e., values of at least 2. This will be encoded into a separate type.\<close>

typedef proper_base = "{x :: int. x \<ge> 2}" by auto

setup_lifting type_definition_proper_base

lift_definition get_base :: "proper_base \<Rightarrow> int" is "\<lambda> x. x" .

lift_definition square_base :: "proper_base \<Rightarrow> proper_base" is "\<lambda> x. x * x"
proof -
  fix i :: int
  assume i: "2 \<le> i"
  have "2 * 2 \<le> i * i"
    by (rule mult_mono[OF i i], insert i, auto)
  thus "2 \<le> i * i" by auto
qed

lift_definition into_base :: "int \<Rightarrow> proper_base" is "\<lambda> x. if x \<ge> 2 then x else 2" by auto

lemma square_base: "get_base (square_base b) = get_base b * get_base b"
  by (transfer, auto)

lemma get_base_2: "get_base b \<ge> 2"
  by (transfer, auto)

lemma b_less_square_base_b: "get_base b < get_base (square_base b)"
  unfolding square_base using get_base_2[of b] by simp

lemma b_less_div_base_b: assumes xb: "\<not> x < get_base b"
  shows "x div get_base b < x"
proof -
  from get_base_2[of b] have b: "get_base b \<ge> 2" .
  with xb have x2: "x \<ge> 2" by auto
  with b int_div_less_self[of x "(get_base b)"]
  show ?thesis by auto
qed

text \<open>We now state the main algorithm.\<close>

function log_main :: "proper_base \<Rightarrow> int \<Rightarrow> nat \<times> int" where
  "log_main b x = (if x < get_base b then (0,1) else
    case log_main (square_base b) x of
      (z, bz) \<Rightarrow>
    let l = 2 * z; bz1 = bz * get_base b
      in if x < bz1 then (l,bz) else (Suc l,bz1))"
  by pat_completeness auto

termination by (relation "measure (\<lambda> (b,x). nat (1 + x - get_base b))",
  insert b_less_square_base_b, auto)

lemma log_main: "x > 0 \<Longrightarrow> log_main b x = (y,by) \<Longrightarrow> by = (get_base b)^y \<and> (get_base b)^y \<le> x \<and> x < (get_base b)^(Suc y)"
proof (induct b x arbitrary: y "by" rule: log_main.induct)
  case (1 b x y "by")
  note x = 1(2)
  note y = 1(3)
  note IH = 1(1)
  let ?b = "get_base b"
  show ?case
  proof (cases "x < ?b")
    case True
    with x y show ?thesis by auto
  next
    case False
    obtain z bz where zz: "log_main (square_base b) x = (z,bz)"
      by (cases "log_main (square_base b) x", auto)
    have id: "get_base (square_base b) ^ k = ?b ^ (2 * k)" for k unfolding square_base
      by (simp add: power_mult semiring_normalization_rules(29))
    from IH[OF False x zz, unfolded id]
    have z: "?b ^ (2 * z) \<le> x" "x < ?b ^ (2 * Suc z)" and bz: "bz = get_base b ^ (2 * z)" by auto
    from y[unfolded log_main.simps[of b x] Let_def zz split] bz False
    have yy: "(if x < bz * ?b then (2 * z, bz) else (Suc (2 * z), bz * ?b)) =
      (y, by)" by auto
    show ?thesis
    proof (cases "x < bz * ?b")
      case True
      with yy have yz: "y = 2 * z" "by = bz" by auto
      from True z(1) bz show ?thesis unfolding yz by (auto simp: ac_simps)
    next
      case False
      with yy have yz: "y = Suc (2 * z)" "by = ?b * bz" by auto
      from False have "?b ^ Suc (2 * z) \<le> x" by (auto simp: bz ac_simps)
      with z(2) bz show ?thesis unfolding yz by auto
    qed
  qed
qed

text \<open>We then derive the floor- and ceiling-log functions.\<close>

definition log_floor :: "int \<Rightarrow> int \<Rightarrow> nat" where
  "log_floor b x = fst (log_main (into_base b) x)"

definition log_ceiling :: "int \<Rightarrow> int \<Rightarrow> nat" where
  "log_ceiling b x = (case log_main (into_base b) x of
     (y,by) \<Rightarrow> if x = by then y else Suc y)"

lemma log_floor_sound: assumes "b > 1" "x > 0" "log_floor b x = y"
  shows "b^y \<le> x" "x < b^(Suc y)"
proof -
  from assms(1,3) have id: "get_base (into_base b) = b" by transfer auto
  obtain yy bb where log: "log_main (into_base b) x = (yy,bb)"
    by (cases "log_main (into_base b) x", auto)
  from log_main[OF assms(2) log] assms(3)[unfolded log_floor_def log] id
  show "b^y \<le> x" "x < b^(Suc y)" by auto
qed

lemma log_ceiling_sound: assumes "b > 1" "x > 0" "log_ceiling b x = y"
  shows "x \<le> b^y" "y \<noteq> 0 \<Longrightarrow> b^(y - 1) < x"
proof -
  from assms(1,3) have id: "get_base (into_base b) = b" by transfer auto
  obtain yy bb where log: "log_main (into_base b) x = (yy,bb)"
    by (cases "log_main (into_base b) x", auto)
  from log_main[OF assms(2) log, unfolded id] assms(3)[unfolded log_ceiling_def log split]
  have bnd: "b ^ yy \<le> x" "x < b ^ Suc yy" and
    y: "y = (if x = b ^ yy then yy else Suc yy)" by auto
  have "x \<le> b^y \<and> (y \<noteq> 0 \<longrightarrow> b^(y - 1) < x)"
  proof (cases "x = b ^ yy")
    case True
    with y bnd assms(1) show ?thesis by (cases yy, auto)
  next
    case False
    with y bnd show ?thesis by auto
  qed
  thus "x \<le> b^y" "y \<noteq> 0 \<Longrightarrow> b^(y - 1) < x" by auto
qed

text \<open>Finally, we connect it to the @{const log} function working on real numbers.\<close>

lemma log_floor[simp]: assumes b: "b > 1" and x: "x > 0"
  shows "log_floor b x = \<lfloor>log b x\<rfloor>"
proof -
  obtain y where y: "log_floor b x = y" by auto
  note main = log_floor_sound[OF assms y]
  from b x have *: "1 < real_of_int b" "0 < real_of_int (b ^ y)" "0 < real_of_int x"
    and **: "1 < real_of_int b" "0 < real_of_int x" "0 < real_of_int (b ^ Suc y)"
    by auto
  show ?thesis unfolding y
  proof (rule sym, rule floor_unique)
    show "real_of_int (int y) \<le> log (real_of_int b) (real_of_int x)"
      using main(1)[folded log_le_cancel_iff[OF *, unfolded of_int_le_iff]]
      using log_pow_cancel[of b y] b by auto
    show "log (real_of_int b) (real_of_int x) < real_of_int (int y) + 1"
      using main(2)[folded log_less_cancel_iff[OF **, unfolded of_int_less_iff]]
      using log_pow_cancel[of b "Suc y"] b by auto
  qed
qed

lemma log_ceiling[simp]: assumes b: "b > 1" and x: "x > 0"
  shows "log_ceiling b x = \<lceil>log b x\<rceil>"
proof -
  obtain y where y: "log_ceiling b x = y" by auto
  note main = log_ceiling_sound[OF assms y]
  from b x have *: "1 < real_of_int b" "0 < real_of_int (b ^ (y - 1))" "0 < real_of_int x"
    and **: "1 < real_of_int b" "0 < real_of_int x" "0 < real_of_int (b ^ y)"
    by auto
  show ?thesis unfolding y
  proof (rule sym, rule ceiling_unique)
    show "log (real_of_int b) (real_of_int x) \<le> real_of_int (int y)"
      using main(1)[folded log_le_cancel_iff[OF **, unfolded of_int_le_iff]]
      using log_pow_cancel[of b y] b by auto
    from x have x: "x \<ge> 1" by auto
    show "real_of_int (int y) - 1 < log (real_of_int b) (real_of_int x)"
    proof (cases "y = 0")
      case False
      thus ?thesis
        using main(2)[folded log_less_cancel_iff[OF *, unfolded of_int_less_iff]]
        using log_pow_cancel[of b "y - 1"] b x by auto
    next
      case True
      have "real_of_int (int y) - 1 = log b (1/b)" using True b
        by (subst log_divide, auto)
      also have "\<dots> < log b 1"
        by (subst log_less_cancel_iff, insert b, auto)
      also have "\<dots> \<le> log b x"
        by (subst log_le_cancel_iff, insert b x, auto)
      finally show "real_of_int (int y) - 1 < log (real_of_int b) (real_of_int x)" .
    qed
  qed
qed

end


(*  Title:      HOL/Library/Countable_Set_Type.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Type of (at most) countable sets.
*)

section {* Type of (at Most) Countable Sets *}

theory Countable_Set_Type
imports Countable_Set Cardinal_Notations
begin

abbreviation "Grp \<equiv> BNF_Def.Grp"

subsection{* Cardinal stuff *}

lemma countable_card_of_nat: "countable A \<longleftrightarrow> |A| \<le>o |UNIV::nat set|"
  unfolding countable_def card_of_ordLeq[symmetric] by auto

lemma countable_card_le_natLeq: "countable A \<longleftrightarrow> |A| \<le>o natLeq"
  unfolding countable_card_of_nat using card_of_nat ordLeq_ordIso_trans ordIso_symmetric by blast

lemma countable_or_card_of:
assumes "countable A"
shows "(finite A \<and> |A| <o |UNIV::nat set| ) \<or>
       (infinite A  \<and> |A| =o |UNIV::nat set| )"
by (metis assms countable_card_of_nat infinite_iff_card_of_nat ordIso_iff_ordLeq
      ordLeq_iff_ordLess_or_ordIso)

lemma countable_cases_card_of[elim]:
  assumes "countable A"
  obtains (Fin) "finite A" "|A| <o |UNIV::nat set|"
        | (Inf) "infinite A" "|A| =o |UNIV::nat set|"
  using assms countable_or_card_of by blast

lemma countable_or:
  "countable A \<Longrightarrow> (\<exists> f::'a\<Rightarrow>nat. finite A \<and> inj_on f A) \<or> (\<exists> f::'a\<Rightarrow>nat. infinite A \<and> bij_betw f A UNIV)"
  by (elim countable_enum_cases) fastforce+

lemma countable_cases[elim]:
  assumes "countable A"
  obtains (Fin) f :: "'a\<Rightarrow>nat" where "finite A" "inj_on f A"
        | (Inf) f :: "'a\<Rightarrow>nat" where "infinite A" "bij_betw f A UNIV"
  using assms countable_or by metis

lemma countable_ordLeq:
assumes "|A| \<le>o |B|" and "countable B"
shows "countable A"
using assms unfolding countable_card_of_nat by(rule ordLeq_transitive)

lemma countable_ordLess:
assumes AB: "|A| <o |B|" and B: "countable B"
shows "countable A"
using countable_ordLeq[OF ordLess_imp_ordLeq[OF AB] B] .

subsection {* The type of countable sets *}

typedef 'a cset = "{A :: 'a set. countable A}" morphisms rcset acset
  by (rule exI[of _ "{}"]) simp

setup_lifting type_definition_cset

declare
  rcset_inverse[simp]
  acset_inverse[Transfer.transferred, unfolded mem_Collect_eq, simp]
  acset_inject[Transfer.transferred, unfolded mem_Collect_eq, simp]
  rcset[Transfer.transferred, unfolded mem_Collect_eq, simp]

lift_definition cin :: "'a \<Rightarrow> 'a cset \<Rightarrow> bool" is "op \<in>" parametric member_transfer
  .
lift_definition cempty :: "'a cset" is "{}" parametric empty_transfer
  by (rule countable_empty)
lift_definition cinsert :: "'a \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is insert parametric Lifting_Set.insert_transfer
  by (rule countable_insert)
lift_definition csingle :: "'a \<Rightarrow> 'a cset" is "\<lambda>x. {x}"
  by (rule countable_insert[OF countable_empty])
lift_definition cUn :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op \<union>" parametric union_transfer
  by (rule countable_Un)
lift_definition cInt :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op \<inter>" parametric inter_transfer
  by (rule countable_Int1)
lift_definition cDiff :: "'a cset \<Rightarrow> 'a cset \<Rightarrow> 'a cset" is "op -" parametric Diff_transfer
  by (rule countable_Diff)
lift_definition cimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a cset \<Rightarrow> 'b cset" is "op `" parametric image_transfer
  by (rule countable_image)

subsection {* Registration as BNF *}

lemma card_of_countable_sets_range:
fixes A :: "'a set"
shows "|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |{f::nat \<Rightarrow> 'a. range f \<subseteq> A}|"
apply(rule card_of_ordLeqI[of from_nat_into]) using inj_on_from_nat_into
unfolding inj_on_def by auto

lemma card_of_countable_sets_Func:
"|{X. X \<subseteq> A \<and> countable X \<and> X \<noteq> {}}| \<le>o |A| ^c natLeq"
using card_of_countable_sets_range card_of_Func_UNIV[THEN ordIso_symmetric]
unfolding cexp_def Field_natLeq Field_card_of
by (rule ordLeq_ordIso_trans)

lemma ordLeq_countable_subsets:
"|A| \<le>o |{X. X \<subseteq> A \<and> countable X}|"
apply (rule card_of_ordLeqI[of "\<lambda> a. {a}"]) unfolding inj_on_def by auto

lemma finite_countable_subset:
"finite {X. X \<subseteq> A \<and> countable X} \<longleftrightarrow> finite A"
apply default
 apply (erule contrapos_pp)
 apply (rule card_of_ordLeq_infinite)
 apply (rule ordLeq_countable_subsets)
 apply assumption
apply (rule finite_Collect_conjI)
apply (rule disjI1)
by (erule finite_Collect_subsets)

lemma rcset_to_rcset: "countable A \<Longrightarrow> rcset (the_inv rcset A) = A"
  apply (rule f_the_inv_into_f[unfolded inj_on_def image_iff])
   apply transfer' apply simp
  apply transfer' apply simp
  done

lemma Collect_Int_Times:
"{(x, y). R x y} \<inter> A \<times> B = {(x, y). R x y \<and> x \<in> A \<and> y \<in> B}"
by auto

definition rel_cset :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a cset \<Rightarrow> 'b cset \<Rightarrow> bool" where
"rel_cset R a b \<longleftrightarrow>
 (\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and>
 (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t)"

lemma rel_cset_aux:
"(\<forall>t \<in> rcset a. \<exists>u \<in> rcset b. R t u) \<and> (\<forall>t \<in> rcset b. \<exists>u \<in> rcset a. R u t) \<longleftrightarrow>
 ((Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage fst))\<inverse>\<inverse> OO
          Grp {x. rcset x \<subseteq> {(a, b). R a b}} (cimage snd)) a b" (is "?L = ?R")
proof
  assume ?L
  def R' \<equiv> "the_inv rcset (Collect (split R) \<inter> (rcset a \<times> rcset b))"
  (is "the_inv rcset ?L'")
  have L: "countable ?L'" by auto
  hence *: "rcset R' = ?L'" unfolding R'_def by (intro rcset_to_rcset)
  thus ?R unfolding Grp_def relcompp.simps conversep.simps
  proof (intro CollectI case_prodI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
    from * `?L` show "a = cimage fst R'" by transfer (auto simp: image_def Collect_Int_Times)
  next
    from * `?L` show "b = cimage snd R'" by transfer (auto simp: image_def Collect_Int_Times)
  qed simp_all
next
  assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
    by transfer force
qed

bnf "'a cset"
  map: cimage
  sets: rcset
  bd: natLeq
  wits: "cempty"
  rel: rel_cset
proof -
  show "cimage id = id" by transfer' simp
next
  fix f g show "cimage (g \<circ> f) = cimage g \<circ> cimage f" by transfer' fastforce
next
  fix C f g assume eq: "\<And>a. a \<in> rcset C \<Longrightarrow> f a = g a"
  thus "cimage f C = cimage g C" by transfer force
next
  fix f show "rcset \<circ> cimage f = op ` f \<circ> rcset" by transfer' fastforce
next
  show "card_order natLeq" by (rule natLeq_card_order)
next
  show "cinfinite natLeq" by (rule natLeq_cinfinite)
next
  fix C show "|rcset C| \<le>o natLeq" by transfer (unfold countable_card_le_natLeq)
next
  fix R S
  show "rel_cset R OO rel_cset S \<le> rel_cset (R OO S)"
    unfolding rel_cset_def[abs_def] by fast
next
  fix R
  show "rel_cset R =
        (Grp {x. rcset x \<subseteq> Collect (split R)} (cimage fst))\<inverse>\<inverse> OO
         Grp {x. rcset x \<subseteq> Collect (split R)} (cimage snd)"
  unfolding rel_cset_def[abs_def] rel_cset_aux by simp
qed (transfer, simp)

end


(*  Title:      HOL/Library/Subseq_Order.thy
    Author:     Peter Lammich, Uni Muenster <peter.lammich@uni-muenster.de>
    Author:     Florian Haftmann, TU Muenchen
    Author:     Tobias Nipkow, TU Muenchen
*)

section \<open>Subsequence Ordering\<close>

theory Subseq_Order
imports Sublist
begin

text \<open>
  This theory defines subsequence ordering on lists. A list \<open>ys\<close> is a subsequence of a
  list \<open>xs\<close>, iff one obtains \<open>ys\<close> by erasing some elements from \<open>xs\<close>.
\<close>

subsection \<open>Definitions and basic lemmas\<close>

instantiation list :: (type) ord
begin

definition "xs \<le> ys \<longleftrightarrow> subseq xs ys" for xs ys :: "'a list"
definition "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs" for xs ys :: "'a list"

instance ..

end

instance list :: (type) order
proof
  fix xs ys zs :: "'a list"
  show "xs < ys \<longleftrightarrow> xs \<le> ys \<and> \<not> ys \<le> xs"
    unfolding less_list_def ..
  show "xs \<le> xs"
    by (simp add: less_eq_list_def)
  show "xs = ys" if "xs \<le> ys" and "ys \<le> xs"
    using that unfolding less_eq_list_def
    by (rule subseq_order.antisym)
  show "xs \<le> zs" if "xs \<le> ys" and "ys \<le> zs"
    using that unfolding less_eq_list_def
    by (rule subseq_order.order_trans)
qed

lemmas less_eq_list_induct [consumes 1, case_names empty drop take] =
  list_emb.induct [of "(=)", folded less_eq_list_def]
lemmas less_eq_list_drop = list_emb.list_emb_Cons [of "(=)", folded less_eq_list_def]
lemmas le_list_Cons2_iff [simp, code] = subseq_Cons2_iff [folded less_eq_list_def]
lemmas le_list_map = subseq_map [folded less_eq_list_def]
lemmas le_list_filter = subseq_filter [folded less_eq_list_def]
lemmas le_list_length = list_emb_length [of "(=)", folded less_eq_list_def]

lemma less_list_length: "xs < ys \<Longrightarrow> length xs < length ys"
  by (metis list_emb_length subseq_same_length le_neq_implies_less less_list_def less_eq_list_def)

lemma less_list_empty [simp]: "[] < xs \<longleftrightarrow> xs \<noteq> []"
  by (metis less_eq_list_def list_emb_Nil order_less_le)

lemma less_list_below_empty [simp]: "xs < [] \<longleftrightarrow> False"
  by (metis list_emb_Nil less_eq_list_def less_list_def)

lemma less_list_drop: "xs < ys \<Longrightarrow> xs < x # ys"
  by (unfold less_le less_eq_list_def) (auto)

lemma less_list_take_iff: "x # xs < x # ys \<longleftrightarrow> xs < ys"
  by (metis subseq_Cons2_iff less_list_def less_eq_list_def)

lemma less_list_drop_many: "xs < ys \<Longrightarrow> xs < zs @ ys"
  by (metis subseq_append_le_same_iff subseq_drop_many order_less_le
      self_append_conv2 less_eq_list_def)

lemma less_list_take_many_iff: "zs @ xs < zs @ ys \<longleftrightarrow> xs < ys"
  by (metis less_list_def less_eq_list_def subseq_append')

lemma less_list_rev_take: "xs @ zs < ys @ zs \<longleftrightarrow> xs < ys"
  by (unfold less_le less_eq_list_def) auto

end


theory "HOLCF-Meet"
imports HOLCF
begin

text \<open>
This theory defines the $\sqcap$ operator on HOLCF domains, and introduces a type class for domains
where all finite meets exist.
\<close>

subsubsection \<open>Towards meets: Lower bounds\<close>

context po
begin
definition is_lb :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix ">|" 55) where
  "S >| x \<longleftrightarrow> (\<forall>y\<in>S. x \<sqsubseteq> y)"

lemma is_lbI: "(!!x. x \<in> S ==> l \<sqsubseteq> x) ==> S >| l"
  by (simp add: is_lb_def)

lemma is_lbD: "[|S >| l; x \<in> S|] ==> l \<sqsubseteq> x"
  by (simp add: is_lb_def)

lemma is_lb_empty [simp]: "{} >| l"
  unfolding is_lb_def by fast

lemma is_lb_insert [simp]: "(insert x A) >| y = (y \<sqsubseteq> x \<and> A >| y)"
  unfolding is_lb_def by fast

lemma is_lb_downward: "[|S >| l; y \<sqsubseteq> l|] ==> S >| y"
  unfolding is_lb_def by (fast intro: below_trans)

subsubsection \<open>Greatest lower bounds\<close>

definition is_glb :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" (infix ">>|" 55) where
  "S >>| x \<longleftrightarrow> S >| x \<and> (\<forall>u. S >| u --> u \<sqsubseteq> x)"

definition glb :: "'a set \<Rightarrow> 'a" ("\<Sqinter>_" [60]60) where
  "glb S = (THE x. S >>| x)"

text \<open>Access to the definition as inference rule\<close>

lemma is_glbD1: "S >>| x ==> S >| x"
  unfolding is_glb_def by fast

lemma is_glbD2: "[|S >>| x; S >| u|] ==> u \<sqsubseteq> x"
  unfolding is_glb_def by fast

lemma (in po) is_glbI: "[|S >| x; !!u. S >| u ==> u \<sqsubseteq> x|] ==> S >>| x"
  unfolding is_glb_def by fast

lemma is_glb_above_iff: "S >>| x ==> u \<sqsubseteq> x \<longleftrightarrow> S >| u"
  unfolding is_glb_def is_lb_def by (metis below_trans)

text \<open>glbs are unique\<close>

lemma is_glb_unique: "[|S >>| x; S >>| y|] ==> x = y"
  unfolding is_glb_def is_lb_def by (blast intro: below_antisym)

text \<open>technical lemmas about @{term glb} and @{term is_glb}\<close>

lemma is_glb_glb: "M >>| x ==> M >>| glb M"
  unfolding glb_def by (rule theI [OF _ is_glb_unique])

lemma glb_eqI: "M >>| l ==> glb M = l"
  by (rule is_glb_unique [OF is_glb_glb])

lemma is_glb_singleton: "{x} >>| x"
  by (simp add: is_glb_def)

lemma glb_singleton [simp]: "glb {x} = x"
  by (rule is_glb_singleton [THEN glb_eqI])

lemma is_glb_bin: "x \<sqsubseteq> y ==> {x, y} >>| x"
  by (simp add: is_glb_def)

lemma glb_bin: "x \<sqsubseteq> y ==> glb {x, y} = x"
  by (rule is_glb_bin [THEN glb_eqI])

lemma is_glb_maximal: "[|S >| x; x \<in> S|] ==> S >>| x"
  by (erule is_glbI, erule (1) is_lbD)

lemma glb_maximal: "[|S >| x; x \<in> S|] ==> glb S = x"
  by (rule is_glb_maximal [THEN glb_eqI])

lemma glb_above: "S >>| z \<Longrightarrow> x \<sqsubseteq> glb S \<longleftrightarrow> S >| x"
  by (metis glb_eqI is_glb_above_iff)
end

lemma (in cpo) Meet_insert: "S >>| l \<Longrightarrow> {x, l} >>| l2 \<Longrightarrow> insert x S >>| l2"
  apply (rule is_glbI)
  apply (metis is_glb_above_iff is_glb_def is_lb_insert)
  by (metis is_glb_above_iff is_glb_def is_glb_singleton is_lb_insert)

text \<open>Binary, hence finite meets.\<close>

class Finite_Meet_cpo = cpo +
  assumes binary_meet_exists: "\<exists> l. l \<sqsubseteq> x \<and> l \<sqsubseteq> y \<and> (\<forall> z. z \<sqsubseteq> x \<longrightarrow> z \<sqsubseteq> y \<longrightarrow> z \<sqsubseteq> l)"
begin

  lemma binary_meet_exists': "\<exists>l. {x, y} >>| l"
    using binary_meet_exists[of x y]
    unfolding is_glb_def is_lb_def
    by auto

  lemma finite_meet_exists:
    assumes "S \<noteq> {}"
    and "finite S"
    shows "\<exists>x. S >>| x"
  using \<open>S \<noteq> {}\<close>
  apply (induct rule: finite_induct[OF \<open>finite S\<close>])
  apply (erule notE, rule refl)[1]
  apply (case_tac "F = {}")
  apply (metis is_glb_singleton)
  apply (metis Meet_insert binary_meet_exists')
  done
end

definition meet :: "'a::cpo \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<sqinter>" 80) where
  "x \<sqinter> y = (if \<exists> z. {x, y} >>| z then glb {x, y} else x)"

lemma meet_def': "(x::'a::Finite_Meet_cpo) \<sqinter> y = glb {x, y}"
  unfolding meet_def by (metis binary_meet_exists')

lemma meet_bot1[simp]:
  fixes y :: "'a :: {Finite_Meet_cpo,pcpo}"
  shows "(\<bottom> \<sqinter> y) = \<bottom>" unfolding meet_def' by (metis minimal po_class.glb_bin)
lemma meet_bot2[simp]:
  fixes x :: "'a :: {Finite_Meet_cpo,pcpo}"
  shows "(x \<sqinter> \<bottom>) = \<bottom>" by (metis meet_bot1 meet_comm)

lemma meet_below1[intro]:
  fixes x y :: "'a :: Finite_Meet_cpo"
  assumes "x \<sqsubseteq> z"
  shows "(x \<sqinter> y) \<sqsubseteq> z" unfolding meet_def' by (metis assms binary_meet_exists' below_trans glb_eqI is_glbD1 is_lb_insert)
lemma meet_below2[intro]:
  fixes x y :: "'a :: Finite_Meet_cpo"
  assumes "y \<sqsubseteq> z"
  shows "(x \<sqinter> y) \<sqsubseteq> z" unfolding meet_def' by (metis assms binary_meet_exists' below_trans glb_eqI is_glbD1 is_lb_insert)

lemma meet_above_iff:
  fixes x y z :: "'a :: Finite_Meet_cpo"
  shows "z \<sqsubseteq> x \<sqinter> y \<longleftrightarrow> z \<sqsubseteq> x \<and> z \<sqsubseteq> y"
proof-
  obtain g where "{x,y} >>| g" by (metis binary_meet_exists')
  thus ?thesis
  unfolding meet_def' by (simp add: glb_above)
qed

lemma below_meet[simp]:
  fixes x y :: "'a :: Finite_Meet_cpo"
  assumes "x \<sqsubseteq> z"
  shows "(x \<sqinter> z) = x" by (metis assms glb_bin meet_def')

lemma meet_aboveI:
  fixes x y z :: "'a :: Finite_Meet_cpo"
  shows "z \<sqsubseteq> x \<Longrightarrow> z \<sqsubseteq> y \<Longrightarrow> z \<sqsubseteq> x \<sqinter> y" by (simp add: meet_above_iff)

lemma is_meetI:
  fixes x y z :: "'a :: Finite_Meet_cpo"
  assumes "z \<sqsubseteq> x"
  assumes "z \<sqsubseteq> y"
  assumes "\<And> a. \<lbrakk> a \<sqsubseteq> x ; a \<sqsubseteq> y \<rbrakk> \<Longrightarrow> a \<sqsubseteq> z"
  shows "x \<sqinter> y = z"
by (metis assms below_antisym meet_above_iff below_refl)

lemma meet_assoc[simp]: "((x::'a::Finite_Meet_cpo) \<sqinter> y) \<sqinter> z = x \<sqinter> (y \<sqinter> z)"
  apply (rule is_meetI)
  apply (metis below_refl meet_above_iff)
  apply (metis below_refl meet_below2)
  apply (metis meet_above_iff)
  done

lemma meet_self[simp]: "r \<sqinter> r = (r::'a::Finite_Meet_cpo)"
  by (metis below_refl is_meetI)

lemma meet_monofun1:
  fixes y :: "'a :: Finite_Meet_cpo"
  shows "monofun (\<lambda>x. (x \<sqinter> y))"
  by (rule monofunI)(auto simp add: meet_above_iff)

lemma chain_meet1:
  fixes y :: "'a :: Finite_Meet_cpo"
  assumes "chain Y"
  shows "chain (\<lambda> i. Y i \<sqinter> y)"
by (rule chainI) (auto simp add: meet_above_iff intro: chainI chainE[OF assms])

class cont_binary_meet = Finite_Meet_cpo +
  assumes meet_cont': "chain Y \<Longrightarrow> (\<Squnion> i. Y i) \<sqinter> y = (\<Squnion> i. Y i \<sqinter> y)"

lemma meet_cont1:
  fixes y :: "'a :: cont_binary_meet"
  shows "cont (\<lambda>x. (x \<sqinter> y))"
  by (rule contI2[OF meet_monofun1]) (simp add: meet_cont')

lemma meet_cont2:
  fixes x :: "'a :: cont_binary_meet"
  shows "cont (\<lambda>y. (x \<sqinter> y))" by (subst meet_comm, rule meet_cont1)

lemma meet_cont[cont2cont,simp]:"cont f \<Longrightarrow> cont g \<Longrightarrow> cont (\<lambda>x. (f x \<sqinter> (g x::'a::cont_binary_meet)))"
  apply (rule cont2cont_case_prod[where g = "\<lambda> x. (f x, g x)" and f = "\<lambda> p x y . x \<sqinter> y", simplified])
  apply (rule meet_cont1)
  apply (rule meet_cont2)
  apply (metis cont2cont_Pair)
  done

end


(*<*)
(*:maxLineLen=78:*)
theory RecursiveVDMExamples
imports VDMToolkit
begin

(********************************************************)
section \<open>Constructive type (\<^typ>\<open>\<nat>\<close>) recursion primitive and function\<close>

\<comment> \<open>Automatic with pattern matching only, if-then-else fails\<close>
primrec factN :: \<open>\<nat> \<Rightarrow> \<nat>\<close> where
\<open>factN n = (if n = 0 then 1 else n * (factN (n - 1)))\<close>

\<comment> \<open>Automatic but forces \<^typ>\<open>\<nat>\<close> constructors\<close>
primrec factN :: \<open>\<nat> \<Rightarrow> \<nat>\<close> where
  \<open>factN       0 = 1\<close>
| \<open>factN (Suc n) = (n * (factN n))\<close>

\<comment> \<open>Pattern completeness missed is allowed as a warning\<close>
primrec factNmissingConstructors :: \<open>\<nat> \<Rightarrow> \<nat>\<close> where
  \<open>factNmissingConstructors 0 = 1\<close>

\<comment> \<open>Automatic termination with pattern matching\<close>
fun factN' :: \<open>\<nat> \<Rightarrow> \<nat>\<close> where
\<open>factN' n = (if n = 0 then 1 else n * (factN' (n - 1)))\<close>

\<comment> \<open>Pattern completeness missed is provided as undefined\<close>
fun factNincmplete' :: \<open>\<nat> \<Rightarrow> \<nat>\<close> where
\<open>factNincmplete' (Suc n) = (factNincmplete' n)\<close>

(********************************************************)
section \<open>Algebraic type  (\<^typ>\<open>\<int>\<close>) recursion primitive and function\<close>

\<comment> \<open>Primitive recursion doesn't work for non-constructive types\<close>
primrec factZ :: \<open>VDMNat \<Rightarrow> VDMNat\<close> where
  \<open>factZ 0 = 1\<close>

\<comment> \<open>Function works but can't find termination proof automatically\<close>
fun factZ :: \<open>VDMNat \<Rightarrow> VDMNat\<close> where
\<open>factZ n = (if n = 0 then 1 else n * (factZ (n - 1)))\<close>

\<comment> \<open>User must provide termination argument\<close>
function (domintros) factZ :: \<open>VDMNat \<Rightarrow> VDMNat\<close> where
\<open>factZ n = (if n = 0 then 1 else n * (factZ (n - 1)))\<close>
  \<comment> \<open>pattern consistency goal\<close>
   apply simp
  \<comment> \<open>pattern completeness goal\<close>
  by simp

  \<comment> \<open>Recursive termination goal\<close>
  termination
    oops

  \<comment> \<open>Various theorems about recursion\<close>
    find_theorems name:"factZ"

(********************************************************)
section \<open>Simple recursion catering for VDM specification\<close>

\<comment> \<open>Automatically generated: implicitly inferred input type invariant check\<close>
definition pre_factV :: \<open>VDMNat \<Rightarrow> \<bool>\<close> where
\<open>pre_factV n \<equiv> inv_VDMNat n\<close>

\<comment> \<open>VDM only operates if precondition is satisfied\<close>
function (domintros) factV :: \<open>VDMNat \<Rightarrow> VDMNat\<close> where
\<open>factV n = (if pre_factV n then (if n = 0 then 1 else n * (factV (n - 1))) else undefined)\<close>
  by (pat_completeness, auto) \<^marker>\<open>tag sledgehammer\<close>

  \<comment> \<open>Well formedness expression relating conditions for every recursive and original calls\<close>
  abbreviation factV_wf :: \<open>(VDMNat \<times> VDMNat) set\<close> where
    \<open>factV_wf \<equiv> { (n - 1, n) | n . pre_factV n \<and> n \<noteq> 0 }\<close>

  \<comment> \<open>Notice the psimps (partial function) simplification rules and guarding domain predicates\<close>
  find_theorems name:"factV"

  \<comment> \<open>For VDM nat and int, we have proved general well formedness relations theorem\<close>
  termination
    apply (relation \<open>(gen_VDMNat_term factV_wf)\<close>)
    \<comment> \<open>This enables sledgehammer to find the well-formedness part of the proof\<close>
    using l_gen_VDMNat_term_wf apply blast \<^marker>\<open>tag sledgehammer\<close>
    \<comment> \<open>Remains to be shown that the local recursive relation is within the general relation space\<close>
    (*Sledgehammering... No proof found *)
    oops

  termination
    apply (relation \<open>(gen_VDMNat_term factV_wf)\<close>)
    using l_gen_VDMNat_term_wf apply blast \<^marker>\<open>tag sledgehammer\<close>
    \<comment> \<open>Even though sledgehammer struggles, the proof is in fact trivial\<close>
    by (simp add: pre_factV_def int_ge_less_than_def)

  \<comment> \<open>Notice the psimps (partial function) simplification rules are gone, and simps (total function) are in place instead\<close>
  find_theorems name:factV

definition largest_wf_int_rel :: "\<int> \<Rightarrow> (\<int> \<times> \<int>) set" where
"largest_wf_int_rel d = {(z', z). d \<le> z' \<and> z' < z}"

\<comment> \<open>Flag can also generate this lemma (and proof sketch) to ensure the recursive relation is a fix-point\<close>
\<comment> \<open>This is useful when recursive relation is not within largest upper bound to discover how to prove it well formed\<close>
lemma l_fact_term_valid: \<open>(gen_VDMNat_term factV_wf) = factV_wf\<close>
  apply (simp )
  apply (intro equalityI subsetI)
  apply (simp_all add: pre_factV_def int_ge_less_than_def case_prod_beta)
  by auto

(********************************************************)
section \<open>VDM recursion over sets\<close>

\<comment> \<open>
  sumset: set of nat -> nat
  sumset(s) == if s = {} then 0 else let e in set s in sumset(s - {e}) + e
  pre (forall n in set s & n > 5)
  --@IsaMeasure({(x - { let e in set x in e }, x) | x : set of nat & x <> {}})
  --@Witness(sumset({ 1 }))
  measure card s;
\<close>

\<comment> \<open>Automatically generated: implicitly inferred type invariant check + user defined pre\<close>
definition pre_sumset :: \<open>VDMNat VDMSet \<Rightarrow> \<bool>\<close> where
  \<open>pre_sumset s \<equiv> inv_VDMSet' inv_VDMNat s \<and> (\<forall> n \<in> s . n > 5)\<close>

\<comment> \<open>Automatically generated def set: inferred from function AST + signature\<close>
\<comment> \<open>Notice the unfolding is staggered and deep into the AST term\<close>
lemmas pre_sumset_defs = pre_sumset_def inv_VDMSet'_defs inv_VDMNat_def

\<comment> \<open>Mostly verbatim translation from VDM; let-in-set becomes Isabelle's Hilbert Choice binder (\<some>)\<close>
function (domintros) sumset :: \<open>VDMNat VDMSet \<Rightarrow> VDMNat\<close> where
  \<open>sumset s = (if pre_sumset s then
                  (if s = {} then 0 else
                      let e = (\<some> x . x \<in> s) in sumset (s - {e}) + e)
                   else undefined)\<close>
  \<comment> \<open>Automatically generated proof for pattern compatibility and completeness\<close>
  \<comment> \<open>Users will have to finish this before proceeding if proof suggestion fails!\<close>
  by (pat_completeness, auto)

  \<comment> \<open>Recursive definitions available, yet as partial functions (psimps + dom predicate)\<close>
  find_theorems name:"sumset"

  \<comment> \<open>Well founded recursive relation translated from user defined @IsaMeasure\<close>
  \<comment> \<open>We automatically infer recursive relations for this specific (commonly used) kind of set recursion\<close>
  \<comment> \<open>It is crucial for termination proof that pre condition is included, which translator does automatically\<close>
  abbreviation sumset_wf_rel :: \<open>(VDMNat VDMSet \<times> VDMNat VDMSet) set\<close> where
    \<open>sumset_wf_rel \<equiv> { (s - {(\<some> e . e \<in> s)}, s)| s . pre_sumset s \<and> s \<noteq> {}}\<close>

  \<comment> \<open>Translator infers recursive relation well formedness lemma being about sets\<close>
  lemma l_sumset_rel_wf: \<open>wf (gen_set_term sumset_wf_rel)\<close>
    \<comment> \<open>Proof in this case is discovered by sledgehammer\<close>
    using l_gen_set_term_wf by blast \<^marker>\<open>tag sledgehammer\<close>

  \<comment> \<open>Termination proof setup is automatically generated\<close>
  termination
    apply (relation \<open>(gen_set_term sumset_wf_rel)\<close>)
    using l_sumset_rel_wf apply blast \<^marker>\<open>tag sledgehammer\<close>
    oops

  \<comment> \<open>Verbatim copy of failed goal. Perhaps could be auto generated? (Problem it might be spurious)\<close>
  lemma l_pre_sumset_sumset_wf_rel:
     \<open>pre_sumset s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> (s - {(\<some> x. x \<in> s)}, s) \<in> (gen_set_term sumset_wf_rel)\<close>
    unfolding gen_set_term_def apply (simp add: pre_sumset_defs)\<^marker>\<open>tag manual\<close>
    by (metis Diff_subset member_remove psubsetI remove_def some_in_eq)\<^marker>\<open>tag sledgehammer\<close>

  \<comment> \<open>Lemma enables sledgehammer to find the termination proof\<close>
  termination
    apply (relation \<open>(gen_set_term sumset_wf_rel)\<close>)
    using l_sumset_rel_wf apply blast \<^marker>\<open>tag sledgehammer\<close>
    using l_pre_sumset_sumset_wf_rel by presburger \<^marker>\<open>tag sledgehammer\<close>

  \<comment> \<open>Recursive definitions available as total functions (simps)\<close>
  find_theorems name:"sumset"

  \<comment> \<open>Recursion over maps is similar, if more involved; see paper source\<close>

  \<comment> \<open>VDM measures are not expressive enough for non-functional measures?\<close>

(********************************************************)
section \<open>Complex recursion example with automation support\<close>

\<comment> \<open>ack: nat * nat -> nat
    ack(m,n) == if m = 0 then n+1
           else if n = 0 then ack(m-1, 1)
           else               ack(m-1, ack(m, (n-1)))
    --@IsaMeasure( pair_less_VDMNat )
    measure is not yet specified;
  \<close>

definition pre_ack :: \<open>VDMNat \<Rightarrow> VDMNat \<Rightarrow> \<bool>\<close> where
  \<open>pre_ack m n \<equiv> inv_VDMNat m \<and> inv_VDMNat n\<close>
lemmas pre_ack_defs = pre_ack_def

function (domintros) ack :: \<open>VDMNat \<Rightarrow> VDMNat \<Rightarrow> VDMNat\<close> where
  \<open>ack m n = (if pre_ack m n then
                       if m = 0 then n+1
                  else if n = 0 then ack (m-1) 1
                  else               ack (m-1) (ack m (n-1))
                  else               undefined)\<close>
  by (pat_completeness, auto) \<^marker>\<open>tag sledgehammer\<close>

  \<comment> \<open>User defined well formed relation, yet as part of Isabelle's high levels of automation armoury \<close>
  abbreviation ack_wf :: \<open>((VDMNat \<times> VDMNat) \<times> (VDMNat \<times> VDMNat)) VDMSet\<close>
    where \<open>ack_wf \<equiv> pair_less_VDMNat\<close>

  \<comment> \<open>Proof is manual, but mostly discovered by sledgehammer\<close>
  termination
    apply (relation ack_wf)\<^marker>\<open>tag manual\<close>
    using wf_pair_less_VDMNat apply blast \<^marker>\<open>tag sledgehammer\<close>
    apply (simp add: l_pair_less_VDMNat_I1 pre_ack_def) \<^marker>\<open>tag sledgehammer\<close>
    apply (simp add:  pre_ack_defs) \<^marker>\<open>tag sledgehammer\<close>
    by (simp add: pair_less_VDMNat_def pre_ack_def) \<^marker>\<open>tag sledgehammer\<close>

(********************************************************)
section \<open>Complex recursion where Isabelle proof discovers missing VDM specification!\<close>

\<comment> \<open>perm: int * int * int -> int
    perm(m,n,r) == if 0 < r then perm(m, r-1, n)
              else if 0 < n then perm(r, n-1, m) else m
    measure is not yet specified;\<close>

definition pre_perm :: \<open>VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt \<Rightarrow> \<bool>\<close> where
  \<open>pre_perm m n r \<equiv> inv_VDMInt m \<and> inv_VDMInt n \<and> inv_VDMInt r\<close>
lemmas pre_perm_defs = pre_perm_def inv_VDMInt_def inv_True_def

function (domintros) perm :: \<open>VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt\<close> where
  \<open>perm m n r = (if pre_perm m n r then
                         if 0 < r then perm m (r-1) n
                    else if 0 < n then perm r (n-1) m else m
                 else undefined)\<close>
  by (pat_completeness, auto) \<^marker>\<open>tag sledgehammer\<close>

  \<comment> \<open>Inferred recursive relation based on recursive call patterns and VDM AST\<close>
  definition perm_wf_rel :: \<open>((VDMInt \<times> VDMInt \<times> VDMInt) \<times>
                              (VDMInt \<times> VDMInt \<times> VDMInt)) VDMSet\<close>
    where \<open>perm_wf_rel \<equiv>
     { ((m, r-1, n), (m, n, r)) | m r n . pre_perm m n r \<and> 0 < r } \<union>
     { ((r, n-1, m), (m, n, r)) | m r n . pre_perm m n r \<and> \<not> 0 < r \<and> 0 < n }\<close>

  \<comment> \<open>Automatically generated lemma left for the user to discharge\<close>
  \<comment> \<open>This will force the user to think of a VDM measure to use, which can be
      expressed in this case using the measure method\<close>
  lemma l_perm_wf_rel: \<open>wf perm_wf_rel\<close>
    sorry

  termination
    apply (relation \<open>perm_wf_rel\<close>)
      apply (simp add: l_perm_wf_rel) \<^marker>\<open>tag sledgehammer\<close>
    \<comment> \<open>Sledgehammer fails here, yet the proof is "easy" \<close>
    by (simp_all add: perm_wf_rel_def)  \<^marker>\<open>tag manual\<close>

  (*----------------------------------------------------------------*)
  subsection \<open>Distilling missing proof: take 1\<close>

  \<comment> \<open>Suggests a VDM measure as max(m+n+r, 0)\<close>
  lemma l_perm_wf_rel_VDM_measure:
    \<open>perm_wf_rel \<subseteq> measure (\<lambda> (m, r, n) . nat (max 0 (m+r+n)))\<close>
    apply (intro subsetI, case_tac x)
      apply (simp add: pre_perm_defs perm_wf_rel_def case_prod_beta max_def)
       apply (elim disjE conjE, simp_all)
       nitpick
       \<comment> \<open>Counter example shows the recursion would fail for certain inputs!\<close>
       \<comment> \<open>It suggests a precondition is needed.\<close>
       \<comment> \<open>@NB would quickcheck find it?\<close>
       sorry

  \<comment> \<open>If measure lemma is proved, sledgehammer can find the missing proof\<close>
  lemma l_perm_wf_rel': \<open>wf perm_wf_rel\<close>
    using l_perm_wf_rel_VDM_measure wf_subset by blast

  (*----------------------------------------------------------------*)
  subsection \<open>Distilling missing proof: take 2\<close>

  \<comment> \<open>Reviewed VDM specification must include:
      * pre ((0 < r or 0 < n) => m+n+r > 0)
      * measure maxs({m+n+r, 0});
     \<close>
  definition pre_perm' :: \<open>VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt \<Rightarrow> \<bool>\<close> where
    \<open>pre_perm' m n r \<equiv> pre_perm m n r \<and> ((0 < r \<or> 0 < n) \<longrightarrow> m+n+r > 0)\<close>
  lemmas pre_perm'_defs = pre_perm'_def pre_perm_defs

  definition perm_wf_rel' :: \<open>((VDMInt \<times> VDMInt \<times> VDMInt) \<times>
                              (VDMInt \<times> VDMInt \<times> VDMInt)) VDMSet\<close>
    where \<open>perm_wf_rel' \<equiv>
     { ((m, r-1, n), (m, n, r)) | m r n . pre_perm' m n r \<and> 0 < r } \<union>
     { ((r, n-1, m), (m, n, r)) | m r n . pre_perm' m n r \<and> \<not> 0 < r \<and> 0 < n }\<close>

function (domintros) perm' :: \<open>VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt \<Rightarrow> VDMInt\<close> where
  \<open>perm' m n r = (if pre_perm' m n r then
                         if 0 < r then perm' m (r-1) n
                    else if 0 < n then perm' r (n-1) m else m
                 else undefined)\<close>
  by (pat_completeness, auto) \<^marker>\<open>tag sledgehammer\<close>

  lemma l_perm_wf_rel_VDM_measure':
    \<open>perm_wf_rel' \<subseteq> measure (\<lambda> (m, r, n) . nat (max 0 (m+r+n)))\<close>
    apply (intro subsetI, case_tac x)
      apply (simp add: pre_perm'_defs perm_wf_rel'_def case_prod_beta max_def)
       apply (elim disjE conjE, simp_all)
  done

  \<comment> \<open>With the lemma proved, sledgehammer can find the missing proof on updated spec\<close>
  lemma l_perm_wf_rel'': \<open>wf perm_wf_rel'\<close>
    using l_perm_wf_rel_VDM_measure' wf_subset by blast

  termination
    apply (relation \<open>perm_wf_rel'\<close>)
      apply (simp add: l_perm_wf_rel'') \<^marker>\<open>tag sledgehammer\<close>
    \<comment> \<open>Sledgehammer fails here, yet the proof is "easy" \<close>
    by (simp_all add: perm_wf_rel'_def)  \<^marker>\<open>tag manual\<close>

end
(*>*)