(*  Title:      HOL/Algebra/Order.thy
    Author:     Clemens Ballarin, started 7 November 2003
    Copyright:  Clemens Ballarin

Most congruence rules by Stephan Hohe. With additional contributions from Alasdair Armstrong
and Simon Foster.
*)

theory Order
imports
  "~~/src/HOL/Library/FuncSet"
  Congruence
begin

section \<open> Orders \<close>

subsection \<open> Partial Orders \<close>

record 'a gorder = "'a eq_object" +
  le :: "['a, 'a] => bool" (infixl "\<sqsubseteq>\<index>" 50)

abbreviation inv_gorder :: "_ \<Rightarrow> 'a gorder" where
  "inv_gorder L \<equiv> \<lparr> carrier = carrier L
                  , eq = op .=\<^bsub>L\<^esub>
                  , le = (\<lambda> x y. y \<sqsubseteq>\<^bsub>L \<^esub>x) \<rparr>"

lemma inv_gorder_inv:
  "inv_gorder (inv_gorder L) = L"
  by simp

locale weak_partial_order = equivalence L for L (structure) +
  assumes le_refl [intro, simp]:
      "x \<in> carrier L ==> x \<sqsubseteq> x"
    and weak_le_antisym [intro]:
      "[| x \<sqsubseteq> y; y \<sqsubseteq> x; x \<in> carrier L; y \<in> carrier L |] ==> x .= y"
    and le_trans [trans]:
      "[| x \<sqsubseteq> y; y \<sqsubseteq> z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L |] ==> x \<sqsubseteq> z"
    and le_cong:
      "\<lbrakk> x .= y; z .= w; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L; w \<in> carrier L \<rbrakk> \<Longrightarrow>
      x \<sqsubseteq> z \<longleftrightarrow> y \<sqsubseteq> w"

definition
  lless :: "[_, 'a, 'a] => bool" (infixl "\<sqsubset>\<index>" 50)
  where "x \<sqsubset>\<^bsub>L\<^esub> y \<longleftrightarrow> x \<sqsubseteq>\<^bsub>L\<^esub> y & x .\<noteq>\<^bsub>L\<^esub> y"

subsubsection \<open> The order relation \<close>

context weak_partial_order
begin

lemma le_cong_l [intro, trans]:
  "\<lbrakk> x .= y; y \<sqsubseteq> z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
  by (auto intro: le_cong [THEN iffD2])

lemma le_cong_r [intro, trans]:
  "\<lbrakk> x \<sqsubseteq> y; y .= z; x \<in> carrier L; y \<in> carrier L; z \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"
  by (auto intro: le_cong [THEN iffD1])

lemma weak_refl [intro, simp]: "\<lbrakk> x .= y; x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y"
  by (simp add: le_cong_l)

end

lemma weak_llessI:
  fixes R (structure)
  assumes "x \<sqsubseteq> y" and "~(x .= y)"
  shows "x \<sqsubset> y"
  using assms unfolding lless_def by simp

lemma lless_imp_le:
  fixes R (structure)
  assumes "x \<sqsubset> y"
  shows "x \<sqsubseteq> y"
  using assms unfolding lless_def by simp

lemma weak_lless_imp_not_eq:
  fixes R (structure)
  assumes "x \<sqsubset> y"
  shows "\<not> (x .= y)"
  using assms unfolding lless_def by simp

lemma weak_llessE:
  fixes R (structure)
  assumes p: "x \<sqsubset> y" and e: "\<lbrakk>x \<sqsubseteq> y; \<not> (x .= y)\<rbrakk> \<Longrightarrow> P"
  shows "P"
  using p by (blast dest: lless_imp_le weak_lless_imp_not_eq e)

lemma (in weak_partial_order) lless_cong_l [trans]:
  assumes xx': "x .= x'"
    and xy: "x' \<sqsubset> y"
    and carr: "x \<in> carrier L" "x' \<in> carrier L" "y \<in> carrier L"
  shows "x \<sqsubset> y"
  using assms unfolding lless_def by (auto intro: trans sym)

lemma (in weak_partial_order) lless_cong_r [trans]:
  assumes xy: "x \<sqsubset> y"
    and  yy': "y .= y'"
    and carr: "x \<in> carrier L" "y \<in> carrier L" "y' \<in> carrier L"
  shows "x \<sqsubset> y'"
  using assms unfolding lless_def by (auto intro: trans sym)  (*slow*)

lemma (in weak_partial_order) lless_antisym:
  assumes "a \<in> carrier L" "b \<in> carrier L"
    and "a \<sqsubset> b" "b \<sqsubset> a"
  shows "P"
  using assms
  by (elim weak_llessE) auto

lemma (in weak_partial_order) lless_trans [trans]:
  assumes "a \<sqsubset> b" "b \<sqsubset> c"
    and carr[simp]: "a \<in> carrier L" "b \<in> carrier L" "c \<in> carrier L"
  shows "a \<sqsubset> c"
  using assms unfolding lless_def by (blast dest: le_trans intro: sym)

lemma weak_partial_order_subset:
  assumes "weak_partial_order L" "A \<subseteq> carrier L"
  shows "weak_partial_order (L\<lparr> carrier := A \<rparr>)"
proof -
  interpret L: weak_partial_order L
    by (simp add: assms)
  interpret equivalence "(L\<lparr> carrier := A \<rparr>)"
    by (simp add: L.equivalence_axioms assms(2) equivalence_subset)
  show ?thesis
    apply (unfold_locales, simp_all)
    using assms(2) apply auto[1]
    using assms(2) apply auto[1]
    apply (meson L.le_trans assms(2) contra_subsetD)
    apply (meson L.le_cong assms(2) subsetCE)
  done
qed

subsubsection \<open> Upper and lower bounds of a set \<close>

definition
  Upper :: "[_, 'a set] => 'a set"
  where "Upper L A = {u. (ALL x. x \<in> A \<inter> carrier L --> x \<sqsubseteq>\<^bsub>L\<^esub> u)} \<inter> carrier L"

definition
  Lower :: "[_, 'a set] => 'a set"
  where "Lower L A = {l. (ALL x. x \<in> A \<inter> carrier L --> l \<sqsubseteq>\<^bsub>L\<^esub> x)} \<inter> carrier L"

lemma Upper_closed [intro!, simp]:
  "Upper L A \<subseteq> carrier L"
  by (unfold Upper_def) clarify

lemma Upper_memD [dest]:
  fixes L (structure)
  shows "[| u \<in> Upper L A; x \<in> A; A \<subseteq> carrier L |] ==> x \<sqsubseteq> u \<and> u \<in> carrier L"
  by (unfold Upper_def) blast

lemma (in weak_partial_order) Upper_elemD [dest]:
  "[| u .\<in> Upper L A; u \<in> carrier L; x \<in> A; A \<subseteq> carrier L |] ==> x \<sqsubseteq> u"
  unfolding Upper_def elem_def
  by (blast dest: sym)

lemma Upper_memI:
  fixes L (structure)
  shows "[| !! y. y \<in> A ==> y \<sqsubseteq> x; x \<in> carrier L |] ==> x \<in> Upper L A"
  by (unfold Upper_def) blast

lemma (in weak_partial_order) Upper_elemI:
  "[| !! y. y \<in> A ==> y \<sqsubseteq> x; x \<in> carrier L |] ==> x .\<in> Upper L A"
  unfolding Upper_def by blast

lemma Upper_antimono:
  "A \<subseteq> B ==> Upper L B \<subseteq> Upper L A"
  by (unfold Upper_def) blast

lemma (in weak_partial_order) Upper_is_closed [simp]:
  "A \<subseteq> carrier L ==> is_closed (Upper L A)"
  by (rule is_closedI) (blast intro: Upper_memI)+

lemma (in weak_partial_order) Upper_mem_cong:
  assumes a'carr: "a' \<in> carrier L" and Acarr: "A \<subseteq> carrier L"
    and aa': "a .= a'"
    and aelem: "a \<in> Upper L A"
  shows "a' \<in> Upper L A"
proof (rule Upper_memI[OF _ a'carr])
  fix y
  assume yA: "y \<in> A"
  hence "y \<sqsubseteq> a" by (intro Upper_memD[OF aelem, THEN conjunct1] Acarr)
  also note aa'
  finally
      show "y \<sqsubseteq> a'"
      by (simp add: a'carr subsetD[OF Acarr yA] subsetD[OF Upper_closed aelem])
qed

lemma (in weak_partial_order) Upper_cong:
  assumes Acarr: "A \<subseteq> carrier L" and A'carr: "A' \<subseteq> carrier L"
    and AA': "A {.=} A'"
  shows "Upper L A = Upper L A'"
unfolding Upper_def
apply rule
 apply (rule, clarsimp) defer 1
 apply (rule, clarsimp) defer 1
proof -
  fix x a'
  assume carr: "x \<in> carrier L" "a' \<in> carrier L"
    and a'A': "a' \<in> A'"
  assume aLxCond[rule_format]: "\<forall>a. a \<in> A \<and> a \<in> carrier L \<longrightarrow> a \<sqsubseteq> x"

  from AA' and a'A' have "\<exists>a\<in>A. a' .= a" by (rule set_eqD2)
  from this obtain a
      where aA: "a \<in> A"
      and a'a: "a' .= a"
      by auto
  note [simp] = subsetD[OF Acarr aA] carr

  note a'a
  also have "a \<sqsubseteq> x" by (simp add: aLxCond aA)
  finally show "a' \<sqsubseteq> x" by simp
next
  fix x a
  assume carr: "x \<in> carrier L" "a \<in> carrier L"
    and aA: "a \<in> A"
  assume a'LxCond[rule_format]: "\<forall>a'. a' \<in> A' \<and> a' \<in> carrier L \<longrightarrow> a' \<sqsubseteq> x"

  from AA' and aA have "\<exists>a'\<in>A'. a .= a'" by (rule set_eqD1)
  from this obtain a'
      where a'A': "a' \<in> A'"
      and aa': "a .= a'"
      by auto
  note [simp] = subsetD[OF A'carr a'A'] carr

  note aa'
  also have "a' \<sqsubseteq> x" by (simp add: a'LxCond a'A')
  finally show "a \<sqsubseteq> x" by simp
qed

lemma Lower_closed [intro!, simp]:
  "Lower L A \<subseteq> carrier L"
  by (unfold Lower_def) clarify

lemma Lower_memD [dest]:
  fixes L (structure)
  shows "[| l \<in> Lower L A; x \<in> A; A \<subseteq> carrier L |] ==> l \<sqsubseteq> x \<and> l \<in> carrier L"
  by (unfold Lower_def) blast

lemma Lower_memI:
  fixes L (structure)
  shows "[| !! y. y \<in> A ==> x \<sqsubseteq> y; x \<in> carrier L |] ==> x \<in> Lower L A"
  by (unfold Lower_def) blast

lemma Lower_antimono:
  "A \<subseteq> B ==> Lower L B \<subseteq> Lower L A"
  by (unfold Lower_def) blast

lemma (in weak_partial_order) Lower_is_closed [simp]:
  "A \<subseteq> carrier L \<Longrightarrow> is_closed (Lower L A)"
  by (rule is_closedI) (blast intro: Lower_memI dest: sym)+

lemma (in weak_partial_order) Lower_mem_cong:
  assumes a'carr: "a' \<in> carrier L" and Acarr: "A \<subseteq> carrier L"
    and aa': "a .= a'"
    and aelem: "a \<in> Lower L A"
  shows "a' \<in> Lower L A"
using assms Lower_closed[of L A]
by (intro Lower_memI) (blast intro: le_cong_l[OF aa'[symmetric]])

lemma (in weak_partial_order) Lower_cong:
  assumes Acarr: "A \<subseteq> carrier L" and A'carr: "A' \<subseteq> carrier L"
    and AA': "A {.=} A'"
  shows "Lower L A = Lower L A'"
unfolding Lower_def
apply rule
 apply clarsimp defer 1
 apply clarsimp defer 1
proof -
  fix x a'
  assume carr: "x \<in> carrier L" "a' \<in> carrier L"
    and a'A': "a' \<in> A'"
  assume "\<forall>a. a \<in> A \<and> a \<in> carrier L \<longrightarrow> x \<sqsubseteq> a"
  hence aLxCond: "\<And>a. \<lbrakk>a \<in> A; a \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> a" by fast

  from AA' and a'A' have "\<exists>a\<in>A. a' .= a" by (rule set_eqD2)
  from this obtain a
      where aA: "a \<in> A"
      and a'a: "a' .= a"
      by auto

  from aA and subsetD[OF Acarr aA]
      have "x \<sqsubseteq> a" by (rule aLxCond)
  also note a'a[symmetric]
  finally
      show "x \<sqsubseteq> a'" by (simp add: carr subsetD[OF Acarr aA])
next
  fix x a
  assume carr: "x \<in> carrier L" "a \<in> carrier L"
    and aA: "a \<in> A"
  assume "\<forall>a'. a' \<in> A' \<and> a' \<in> carrier L \<longrightarrow> x \<sqsubseteq> a'"
  hence a'LxCond: "\<And>a'. \<lbrakk>a' \<in> A'; a' \<in> carrier L\<rbrakk> \<Longrightarrow> x \<sqsubseteq> a'" by fast+

  from AA' and aA have "\<exists>a'\<in>A'. a .= a'" by (rule set_eqD1)
  from this obtain a'
      where a'A': "a' \<in> A'"
      and aa': "a .= a'"
      by auto
  from a'A' and subsetD[OF A'carr a'A']
      have "x \<sqsubseteq> a'" by (rule a'LxCond)
  also note aa'[symmetric]
  finally show "x \<sqsubseteq> a" by (simp add: carr subsetD[OF A'carr a'A'])
qed

text \<open> Jacobson: Theorem 8.1 \<close>

lemma Lower_empty [simp]:
  "Lower L {} = carrier L"
  by (unfold Lower_def) simp

lemma Upper_empty [simp]:
  "Upper L {} = carrier L"
  by (unfold Upper_def) simp

subsubsection \<open> Least and greatest, as predicate \<close>

definition
  least :: "[_, 'a, 'a set] => bool"
  where "least L l A \<longleftrightarrow> A \<subseteq> carrier L & l \<in> A & (ALL x : A. l \<sqsubseteq>\<^bsub>L\<^esub> x)"

definition
  greatest :: "[_, 'a, 'a set] => bool"
  where "greatest L g A \<longleftrightarrow> A \<subseteq> carrier L & g \<in> A & (ALL x : A. x \<sqsubseteq>\<^bsub>L\<^esub> g)"

text (in weak_partial_order) {* Could weaken these to @{term "l \<in> carrier L \<and> l
  .\<in> A"} and @{term "g \<in> carrier L \<and> g .\<in> A"}. *}

lemma least_closed [intro, simp]:
  "least L l A ==> l \<in> carrier L"
  by (unfold least_def) fast

lemma least_mem:
  "least L l A ==> l \<in> A"
  by (unfold least_def) fast

lemma (in weak_partial_order) weak_least_unique:
  "[| least L x A; least L y A |] ==> x .= y"
  by (unfold least_def) blast

lemma least_le:
  fixes L (structure)
  shows "[| least L x A; a \<in> A |] ==> x \<sqsubseteq> a"
  by (unfold least_def) fast

lemma (in weak_partial_order) least_cong:
  "[| x .= x'; x \<in> carrier L; x' \<in> carrier L; is_closed A |] ==> least L x A = least L x' A"
  by (unfold least_def) (auto dest: sym)

abbreviation is_lub :: "[_, 'a, 'a set] => bool"
where "is_lub L x A \<equiv> least L x (Upper L A)"

text (in weak_partial_order) {* @{const least} is not congruent in the second parameter for
  @{term "A {.=} A'"} *}

lemma (in weak_partial_order) least_Upper_cong_l:
  assumes "x .= x'"
    and "x \<in> carrier L" "x' \<in> carrier L"
    and "A \<subseteq> carrier L"
  shows "least L x (Upper L A) = least L x' (Upper L A)"
  apply (rule least_cong) using assms by auto

lemma (in weak_partial_order) least_Upper_cong_r:
  assumes Acarrs: "A \<subseteq> carrier L" "A' \<subseteq> carrier L" (* unneccessary with current Upper? *)
    and AA': "A {.=} A'"
  shows "least L x (Upper L A) = least L x (Upper L A')"
apply (subgoal_tac "Upper L A = Upper L A'", simp)
by (rule Upper_cong) fact+

lemma least_UpperI:
  fixes L (structure)
  assumes above: "!! x. x \<in> A ==> x \<sqsubseteq> s"
    and below: "!! y. y \<in> Upper L A ==> s \<sqsubseteq> y"
    and L: "A \<subseteq> carrier L"  "s \<in> carrier L"
  shows "least L s (Upper L A)"
proof -
  have "Upper L A \<subseteq> carrier L" by simp
  moreover from above L have "s \<in> Upper L A" by (simp add: Upper_def)
  moreover from below have "ALL x : Upper L A. s \<sqsubseteq> x" by fast
  ultimately show ?thesis by (simp add: least_def)
qed

lemma least_Upper_above:
  fixes L (structure)
  shows "[| least L s (Upper L A); x \<in> A; A \<subseteq> carrier L |] ==> x \<sqsubseteq> s"
  by (unfold least_def) blast

lemma greatest_closed [intro, simp]:
  "greatest L l A ==> l \<in> carrier L"
  by (unfold greatest_def) fast

lemma greatest_mem:
  "greatest L l A ==> l \<in> A"
  by (unfold greatest_def) fast

lemma (in weak_partial_order) weak_greatest_unique:
  "[| greatest L x A; greatest L y A |] ==> x .= y"
  by (unfold greatest_def) blast

lemma greatest_le:
  fixes L (structure)
  shows "[| greatest L x A; a \<in> A |] ==> a \<sqsubseteq> x"
  by (unfold greatest_def) fast

lemma (in weak_partial_order) greatest_cong:
  "[| x .= x'; x \<in> carrier L; x' \<in> carrier L; is_closed A |] ==>
  greatest L x A = greatest L x' A"
  by (unfold greatest_def) (auto dest: sym)

abbreviation is_glb :: "[_, 'a, 'a set] => bool"
where "is_glb L x A \<equiv> greatest L x (Lower L A)"

text (in weak_partial_order) {* @{const greatest} is not congruent in the second parameter for
  @{term "A {.=} A'"} *}

lemma (in weak_partial_order) greatest_Lower_cong_l:
  assumes "x .= x'"
    and "x \<in> carrier L" "x' \<in> carrier L"
    and "A \<subseteq> carrier L" (* unneccessary with current Lower *)
  shows "greatest L x (Lower L A) = greatest L x' (Lower L A)"
  apply (rule greatest_cong) using assms by auto

lemma (in weak_partial_order) greatest_Lower_cong_r:
  assumes Acarrs: "A \<subseteq> carrier L" "A' \<subseteq> carrier L"
    and AA': "A {.=} A'"
  shows "greatest L x (Lower L A) = greatest L x (Lower L A')"
apply (subgoal_tac "Lower L A = Lower L A'", simp)
by (rule Lower_cong) fact+

lemma greatest_LowerI:
  fixes L (structure)
  assumes below: "!! x. x \<in> A ==> i \<sqsubseteq> x"
    and above: "!! y. y \<in> Lower L A ==> y \<sqsubseteq> i"
    and L: "A \<subseteq> carrier L"  "i \<in> carrier L"
  shows "greatest L i (Lower L A)"
proof -
  have "Lower L A \<subseteq> carrier L" by simp
  moreover from below L have "i \<in> Lower L A" by (simp add: Lower_def)
  moreover from above have "ALL x : Lower L A. x \<sqsubseteq> i" by fast
  ultimately show ?thesis by (simp add: greatest_def)
qed

lemma greatest_Lower_below:
  fixes L (structure)
  shows "[| greatest L i (Lower L A); x \<in> A; A \<subseteq> carrier L |] ==> i \<sqsubseteq> x"
  by (unfold greatest_def) blast

lemma Lower_dual [simp]:
  "Lower (inv_gorder L) A = Upper L A"
  by (simp add:Upper_def Lower_def)

lemma Upper_dual [simp]:
  "Upper (inv_gorder L) A = Lower L A"
  by (simp add:Upper_def Lower_def)

lemma least_dual [simp]:
  "least (inv_gorder L) x A = greatest L x A"
  by (simp add:least_def greatest_def)

lemma greatest_dual [simp]:
  "greatest (inv_gorder L) x A = least L x A"
  by (simp add:least_def greatest_def)

lemma (in weak_partial_order) dual_weak_order:
  "weak_partial_order (inv_gorder L)"
  apply (unfold_locales)
  apply (simp_all)
  apply (metis sym)
  apply (metis trans)
  apply (metis weak_le_antisym)
  apply (metis le_trans)
  apply (metis le_cong_l le_cong_r sym)
done

lemma dual_weak_order_iff:
  "weak_partial_order (inv_gorder A) \<longleftrightarrow> weak_partial_order A"
proof
  assume "weak_partial_order (inv_gorder A)"
  then interpret dpo: weak_partial_order "inv_gorder A"
  rewrites "carrier (inv_gorder A) = carrier A"
  and   "le (inv_gorder A)      = (\<lambda> x y. le A y x)"
  and   "eq (inv_gorder A)      = eq A"
    by (simp_all)
  show "weak_partial_order A"
    by (unfold_locales, auto intro: dpo.sym dpo.trans dpo.le_trans)
next
  assume "weak_partial_order A"
  thus "weak_partial_order (inv_gorder A)"
    by (metis weak_partial_order.dual_weak_order)
qed

subsubsection \<open> Intervals \<close>

definition
  at_least_at_most :: "('a, 'c) gorder_scheme \<Rightarrow> 'a => 'a => 'a set" ("(1\<lbrace>_.._\<rbrace>\<index>)") where
  "\<lbrace>l..u\<rbrace>\<^bsub>A\<^esub> = {x \<in> carrier A. l \<sqsubseteq>\<^bsub>A\<^esub> x \<and> x \<sqsubseteq>\<^bsub>A\<^esub> u}"

context weak_partial_order
begin

  lemma at_least_at_most_upper [dest]:
    "x \<in> \<lbrace>a..b\<rbrace> \<Longrightarrow> x \<sqsubseteq> b"
    by (simp add: at_least_at_most_def)

  lemma at_least_at_most_lower [dest]:
    "x \<in> \<lbrace>a..b\<rbrace> \<Longrightarrow> a \<sqsubseteq> x"
    by (simp add: at_least_at_most_def)

  lemma at_least_at_most_closed: "\<lbrace>a..b\<rbrace> \<subseteq> carrier L"
    by (auto simp add: at_least_at_most_def)

  lemma at_least_at_most_member [intro]:
    "\<lbrakk> x \<in> carrier L; a \<sqsubseteq> x; x \<sqsubseteq> b \<rbrakk> \<Longrightarrow> x \<in> \<lbrace>a..b\<rbrace>"
    by (simp add: at_least_at_most_def)

end

subsubsection {* Isotone functions *}

definition isotone :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "isotone A B f \<equiv> weak_partial_order A
                 \<and> weak_partial_order B
                 \<and> (\<forall>x\<in>carrier A. \<forall>y\<in>carrier A. x \<sqsubseteq>\<^bsub>A\<^esub> y \<longrightarrow> f x \<sqsubseteq>\<^bsub>B\<^esub> f y)"

lemma isotoneI [intro?]:
  fixes f :: "'a \<Rightarrow> 'b"
  assumes "weak_partial_order L1"
          "weak_partial_order L2"
          "(\<And>x y. \<lbrakk> x \<in> carrier L1; y \<in> carrier L1; x \<sqsubseteq>\<^bsub>L1\<^esub> y \<rbrakk>
                   \<Longrightarrow> f x \<sqsubseteq>\<^bsub>L2\<^esub> f y)"
  shows "isotone L1 L2 f"
  using assms by (auto simp add:isotone_def)

abbreviation Monotone :: "('a, 'b) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" ("Mono\<index>") where
"Monotone L f \<equiv> isotone L L f"

lemma use_iso1: "\<lbrakk>isotone A A f; x \<in> carrier A; y \<in> carrier A; x \<sqsubseteq>\<^bsub>A\<^esub> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq>\<^bsub>A\<^esub> f y"
  by (simp add: isotone_def)

lemma use_iso2: "\<lbrakk>isotone A B f; x \<in> carrier A; y \<in> carrier A; x \<sqsubseteq>\<^bsub>A\<^esub> y\<rbrakk> \<Longrightarrow> f x \<sqsubseteq>\<^bsub>B\<^esub> f y"
  by (simp add: isotone_def)

lemma iso_compose: "\<lbrakk>f \<in> carrier A \<rightarrow> carrier B; isotone A B f; g \<in> carrier B \<rightarrow> carrier C; isotone B C g\<rbrakk> \<Longrightarrow> isotone A C (g \<circ> f)"
  by (simp add: isotone_def, safe, metis Pi_iff)

lemma (in weak_partial_order) inv_isotone [simp]:
  "isotone (inv_gorder A) (inv_gorder B) f = isotone A B f"
  by (auto simp add:isotone_def dual_weak_order dual_weak_order_iff)

subsubsection \<open> Idempotent functions \<close>

definition idempotent ::
  "('a, 'b) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" ("Idem\<index>") where
"idempotent L f \<equiv> \<forall>x\<in>carrier L. f (f x) .=\<^bsub>L\<^esub> f x"

lemma (in weak_partial_order) idempotent:
  "\<lbrakk> Idem f; x \<in> carrier L \<rbrakk> \<Longrightarrow> f (f x) .= f x"
  by (auto simp add: idempotent_def)

subsubsection \<open> Order embeddings \<close>

definition order_emb :: "('a, 'c) gorder_scheme \<Rightarrow> ('b, 'd) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "order_emb A B f \<equiv> weak_partial_order A
                   \<and> weak_partial_order B
                   \<and> (\<forall>x\<in>carrier A. \<forall>y\<in>carrier A. f x \<sqsubseteq>\<^bsub>B\<^esub> f y \<longleftrightarrow> x \<sqsubseteq>\<^bsub>A\<^esub> y )"

lemma order_emb_isotone: "order_emb A B f \<Longrightarrow> isotone A B f"
  by (auto simp add: isotone_def order_emb_def)

subsubsection \<open> Commuting functions \<close>

definition commuting :: "('a, 'c) gorder_scheme \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
"commuting A f g = (\<forall>x\<in>carrier A. (f \<circ> g) x .=\<^bsub>A\<^esub> (g \<circ> f) x)"

subsection \<open> Partial orders where @{text eq} is the Equality \<close>

locale partial_order = weak_partial_order +
  assumes eq_is_equal: "op .= = op ="
begin

declare weak_le_antisym [rule del]

lemma le_antisym [intro]:
  "[| x \<sqsubseteq> y; y \<sqsubseteq> x; x \<in> carrier L; y \<in> carrier L |] ==> x = y"
  using weak_le_antisym unfolding eq_is_equal .

lemma lless_eq:
  "x \<sqsubset> y \<longleftrightarrow> x \<sqsubseteq> y & x \<noteq> y"
  unfolding lless_def by (simp add: eq_is_equal)

lemma lless_asym:
  assumes "a \<in> carrier L" "b \<in> carrier L"
    and "a \<sqsubset> b" "b \<sqsubset> a"
  shows "P"
  using assms unfolding lless_eq by auto

lemma set_eq_is_eq: "A {.=} B \<longleftrightarrow> A = B"
  by (auto simp add: set_eq_def elem_def eq_is_equal)

end

lemma (in partial_order) dual_order:
  "partial_order (inv_gorder L)"
proof -
  interpret dwo: weak_partial_order "inv_gorder L"
    by (metis dual_weak_order)
  show ?thesis
    by (unfold_locales, simp add:eq_is_equal)
qed

lemma dual_order_iff:
  "partial_order (inv_gorder A) \<longleftrightarrow> partial_order A"
proof
  assume assm:"partial_order (inv_gorder A)"
  then interpret po: partial_order "inv_gorder A"
  rewrites "carrier (inv_gorder A) = carrier A"
  and   "le (inv_gorder A)      = (\<lambda> x y. le A y x)"
  and   "eq (inv_gorder A)      = eq A"
    by (simp_all)
  show "partial_order A"
    apply (unfold_locales, simp_all)
    apply (metis po.sym, metis po.trans)
    apply (metis po.weak_le_antisym, metis po.le_trans)
    apply (metis (full_types) po.eq_is_equal, metis po.eq_is_equal)
  done
next
  assume "partial_order A"
  thus "partial_order (inv_gorder A)"
    by (metis partial_order.dual_order)
qed

subsubsection \<open> Least and greatest, as predicate \<close>

lemma (in partial_order) least_unique:
  "[| least L x A; least L y A |] ==> x = y"
  using weak_least_unique unfolding eq_is_equal .

lemma (in partial_order) greatest_unique:
  "[| greatest L x A; greatest L y A |] ==> x = y"
  using weak_greatest_unique unfolding eq_is_equal .

subsection \<open> Bounded Orders \<close>

definition
  atop :: "_ => 'a" ("\<top>\<index>")
  where "\<top>\<^bsub>L\<^esub> = (SOME x. greatest L x (carrier L))"

definition
  abottom :: "_ => 'a" ("\<bottom>\<index>")
  where "\<bottom>\<^bsub>L\<^esub> = (SOME x. least L x (carrier L))"

locale weak_partial_order_bottom = weak_partial_order L for L (structure) +
  assumes bottom_exists: "\<exists> x. least L x (carrier L)"
begin

lemma bottom_least: "least L \<bottom> (carrier L)"
proof -
  obtain x where "least L x (carrier L)"
    by (metis bottom_exists)

  thus ?thesis
    by (auto intro:someI2 simp add:abottom_def)
qed

lemma bottom_closed [simp, intro]:
  "\<bottom> \<in> carrier L"
  by (metis bottom_least least_mem)

lemma bottom_lower [simp, intro]:
  "x \<in> carrier L \<Longrightarrow> \<bottom> \<sqsubseteq> x"
  by (metis bottom_least least_le)

end

locale weak_partial_order_top = weak_partial_order L for L (structure) +
  assumes top_exists: "\<exists> x. greatest L x (carrier L)"
begin

lemma top_greatest: "greatest L \<top> (carrier L)"
proof -
  obtain x where "greatest L x (carrier L)"
    by (metis top_exists)

  thus ?thesis
    by (auto intro:someI2 simp add:atop_def)
qed

lemma top_closed [simp, intro]:
  "\<top> \<in> carrier L"
  by (metis greatest_mem top_greatest)

lemma top_higher [simp, intro]:
  "x \<in> carrier L \<Longrightarrow> x \<sqsubseteq> \<top>"
  by (metis greatest_le top_greatest)

end

subsection \<open> Total Orders \<close>

locale weak_total_order = weak_partial_order +
  assumes total: "\<lbrakk> x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

text {* Introduction rule: the usual definition of total order *}

lemma (in weak_partial_order) weak_total_orderI:
  assumes total: "!!x y. \<lbrakk> x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
  shows "weak_total_order L"
  by unfold_locales (rule total)

subsection \<open> Total orders where @{text eq} is the Equality \<close>

locale total_order = partial_order +
  assumes total_order_total: "\<lbrakk> x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"

sublocale total_order < weak: weak_total_order
  by unfold_locales (rule total_order_total)

text \<open> Introduction rule: the usual definition of total order \<close>

lemma (in partial_order) total_orderI:
  assumes total: "!!x y. \<lbrakk> x \<in> carrier L; y \<in> carrier L \<rbrakk> \<Longrightarrow> x \<sqsubseteq> y \<or> y \<sqsubseteq> x"
  shows "total_order L"
  by unfold_locales (rule total)

end


theory Library_Misc
imports Probability "~~/src/HOL/Library/ContNotDenum"
begin

(* TODO: Move and merge with has_integral_lebesgue_integral *)

lemma isCont_indicator:
  fixes x :: "'a::{t2_space}"
  shows "isCont (indicator A :: 'a \<Rightarrow> real) x = (x \<notin> frontier A)"
proof -
  have *: "!! A x. (indicator A x > (0 :: real)) = (x \<in> A)"
    by (case_tac "x : A", auto)
  have **: "!! A x. (indicator A x < (1 :: real)) = (x \<notin> A)"
    by (case_tac "x : A", auto)
  show ?thesis
    apply (auto simp add: frontier_def)
    (* calling auto here produces a strange error message *)
    apply (subst (asm) continuous_at_open)
    apply (case_tac "x \<in> A", simp_all)
    apply (drule_tac x = "{0<..}" in spec, clarsimp simp add: *)
    apply (erule interiorI, assumption, force)
    apply (drule_tac x = "{..<1}" in spec, clarsimp simp add: **)
    apply (subst (asm) closure_interior, auto, erule notE)
    apply (erule interiorI, auto)
    apply (subst (asm) closure_interior, simp)
    apply (rule continuous_on_interior)
    prefer 2 apply assumption
    apply (rule continuous_on_eq [where f = "\<lambda>x. 0"], auto intro: continuous_on_const)
    apply (rule continuous_on_interior)
    prefer 2 apply assumption
    by (rule continuous_on_eq [where f = "\<lambda>x. 1"], auto intro: continuous_on_const)
qed

(* Should work for more general types than reals? *)

lemma is_real_interval:
  assumes S: "is_interval S"
  shows "\<exists>a b::real. S = {} \<or> S = UNIV \<or> S = {..<b} \<or> S = {..b} \<or> S = {a<..} \<or> S = {a..} \<or>
    S = {a<..<b} \<or> S = {a<..b} \<or> S = {a..<b} \<or> S = {a..b}"
  using S unfolding is_interval_1 by (blast intro: interval_cases)

lemma real_interval_borel_measurable:
  assumes "is_interval (S::real set)"
  shows "S \<in> sets borel"
proof -
  from assms is_real_interval have "\<exists>a b::real. S = {} \<or> S = UNIV \<or> S = {..<b} \<or> S = {..b} \<or>
    S = {a<..} \<or> S = {a..} \<or> S = {a<..<b} \<or> S = {a<..b} \<or> S = {a..<b} \<or> S = {a..b}" by auto
  then guess a ..
  then guess b ..
  thus ?thesis
    by auto
qed

lemma borel_measurable_mono:
  fixes f :: "real \<Rightarrow> real"
  assumes "mono f"
  shows "f \<in> borel_measurable borel"
proof (subst borel_measurable_iff_ge, auto simp add:)
  fix a :: real
  have "is_interval {w. a \<le> f w}" using is_interval_1 assms(1) order.trans unfolding mono_def
    by (auto simp add:,  metis)
  thus "{w. a \<le> f w} \<in> sets borel" using real_interval_borel_measurable by auto
qed

lemma continuous_within_open: "a \<in> A \<Longrightarrow> open A \<Longrightarrow> (continuous (at a within A) f) = isCont f a"
  by (simp add: continuous_within, rule Lim_within_open)

lemma has_vector_derivative_weaken:
  fixes x D and f g s t
  assumes f: "(f has_vector_derivative D) (at x within t)"
    and "x \<in> s" "s \<subseteq> t"
    and "\<And>x. x \<in> s \<Longrightarrow> f x = g x"
  shows "(g has_vector_derivative D) (at x within s)"
proof -
  have "(f has_vector_derivative D) (at x within s) \<longleftrightarrow> (g has_vector_derivative D) (at x within s)"
    unfolding has_vector_derivative_def has_derivative_iff_norm
    using assms by (intro conj_cong Lim_cong_within refl) auto
  then show ?thesis
    using has_vector_derivative_within_subset[OF f `s \<subseteq> t`] by simp
qed

lemma DERIV_image_chain': "(f has_field_derivative D) (at x within s) \<Longrightarrow>
    (g has_field_derivative E) (at (f x) within (f ` s)) \<Longrightarrow>
    ((\<lambda>x. g (f x)) has_field_derivative E * D) (at x within s)"
by (drule (1) DERIV_image_chain, simp add: comp_def)

(* This should have been in the library, like convergent_limsup_cl. *)
lemma convergent_liminf_cl:
  fixes X :: "nat \<Rightarrow> 'a::{complete_linorder,linorder_topology}"
  shows "convergent X \<Longrightarrow> liminf X = lim X"
  by (auto simp: convergent_def limI lim_imp_Liminf)

lemma bdd_below_closure:
  fixes A :: "real set"
  assumes "bdd_below A"
  shows "bdd_below (closure A)"
proof -
  from assms obtain m where "\<And>x. x \<in> A \<Longrightarrow> m \<le> x" unfolding bdd_below_def by auto
  hence "A \<subseteq> {m..}" by auto
  hence "closure A \<subseteq> {m..}" using closed_real_atLeast closure_minimal by auto
  thus ?thesis unfolding bdd_below_def by auto
qed

lemma closed_subset_contains_Inf:
  fixes A C :: "real set"
  shows "closed C \<Longrightarrow> A \<subseteq> C \<Longrightarrow> A \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> Inf A \<in> C"
  by (metis closure_contains_Inf closure_minimal subset_eq)

lemma atLeastAtMost_subset_contains_Inf:
  fixes A :: "real set" and a b :: real
  shows "A \<noteq> {} \<Longrightarrow> a \<le> b \<Longrightarrow> A \<subseteq> {a..b} \<Longrightarrow> Inf A \<in> {a..b}"
  by (rule closed_subset_contains_Inf)
     (auto intro: closed_real_atLeastAtMost intro!: bdd_belowI[of A a])

lemma convergent_real_imp_convergent_ereal:
  assumes "convergent a"
  shows "convergent (\<lambda>n. ereal (a n))" and "lim (\<lambda>n. ereal (a n)) = ereal (lim a)"
proof -
  from assms obtain L where L: "a ----> L" unfolding convergent_def ..
  hence lim: "(\<lambda>n. ereal (a n)) ----> ereal L" using lim_ereal by auto
  thus "convergent (\<lambda>n. ereal (a n))" unfolding convergent_def ..
  thus "lim (\<lambda>n. ereal (a n)) = ereal (lim a)" using lim L limI by metis
qed

lemma abs_bounds: "x \<le> y \<Longrightarrow> -x \<le> y \<Longrightarrow> abs (x :: ereal) \<le> y"
by (metis abs_ereal_ge0 abs_ereal_uminus ereal_0_le_uminus_iff linear)

lemma real_arbitrarily_close_eq:
  fixes x y :: real
  assumes "\<And>\<epsilon>. \<epsilon> > 0 \<Longrightarrow> abs (x - y) \<le> \<epsilon>"
  shows "x = y"
by (metis abs_le_zero_iff assms dense_ge eq_iff_diff_eq_0)

lemma real_interval_avoid_countable_set:
  fixes a b :: real and A :: "real set"
  assumes "a < b" and "countable A"
  shows "\<exists>x. x \<in> {a<..<b} \<and> x \<notin> A"
proof -
  from `countable A` have "countable (A \<inter> {a<..<b})" by auto
  moreover with `a < b` have "\<not> countable {a<..<b}"
    by (simp add: uncountable_open_interval)
  ultimately have "A \<inter> {a<..<b} \<noteq> {a<..<b}" by auto
  hence "A \<inter> {a<..<b} \<subset> {a<..<b}"
    by (intro psubsetI, auto)
  hence "\<exists>x. x \<in> {a<..<b} - A \<inter> {a<..<b}"
    by (rule psubset_imp_ex_mem)
  thus ?thesis by auto
qed

(* TODO: move this somewhere else *)

lemma continuous_on_vector_derivative:
  "(\<And>x. x \<in> S \<Longrightarrow> (f has_vector_derivative f' x) (at x within S)) \<Longrightarrow> continuous_on S f"
  by (auto simp: continuous_on_eq_continuous_within intro!: has_vector_derivative_continuous)

(* the dual version is in Convex_Euclidean_Space.thy *)

lemma interior_real_Iic:
  fixes a :: real
  shows "interior {..a} = {..<a}"
proof -
  {
    fix y
    assume "a > y"
    then have "y \<in> interior {..a}"
      apply (simp add: mem_interior)
      apply (rule_tac x="(a-y)" in exI)
      apply (auto simp add: dist_norm)
      done
  }
  moreover
  {
    fix y
    assume "y \<in> interior {..a}"
    then obtain e where e: "e > 0" "cball y e \<subseteq> {..a}"
      using mem_interior_cball[of y "{..a}"] by auto
    moreover from e have "y + e \<in> cball y e"
      by (auto simp add: cball_def dist_norm)
    ultimately have "a \<ge> y + e" by auto
    then have "a > y" using e by auto
  }
  ultimately show ?thesis by auto
qed

lemma frontier_real_Iic:
  fixes a :: real
  shows "frontier {..a} = {a}"
  unfolding frontier_def by (auto simp add: interior_real_Iic)

(**************************************************)

end


(*<*)
theory Nested2 imports Nested0 begin
(*>*)

lemma "trev(trev t) = t"
apply(induct_tac t rule: trev.induct)
txt{*
@{subgoals[display,indent=0]}
Both the base case and the induction step fall to simplification:
*}

by(simp_all add: rev_map sym[OF map_compose] cong: map_cong)

text{*\noindent
If the proof of the induction step mystifies you, we recommend that you go through
the chain of simplification steps in detail; you will probably need the help of
@{text"simp_trace"}. Theorem @{thm[source]map_cong} is discussed below.
%\begin{quote}
%{term[display]"trev(trev(App f ts))"}\\
%{term[display]"App f (rev(map trev (rev(map trev ts))))"}\\
%{term[display]"App f (map trev (rev(rev(map trev ts))))"}\\
%{term[display]"App f (map trev (map trev ts))"}\\
%{term[display]"App f (map (trev o trev) ts)"}\\
%{term[display]"App f (map (%x. x) ts)"}\\
%{term[display]"App f ts"}
%\end{quote}

The definition of @{term"trev"} above is superior to the one in
\S\ref{sec:nested-datatype} because it uses @{term"rev"}
and lets us use existing facts such as \hbox{@{prop"rev(rev xs) = xs"}}.
Thus this proof is a good example of an important principle:
\begin{quote}
\emph{Chose your definitions carefully\\
because they determine the complexity of your proofs.}
\end{quote}

Let us now return to the question of how \isacommand{recdef} can come up with
sensible termination conditions in the presence of higher-order functions
like @{term"map"}. For a start, if nothing were known about @{term"map"}, then
@{term"map trev ts"} might apply @{term"trev"} to arbitrary terms, and thus
\isacommand{recdef} would try to prove the unprovable @{term"size t < Suc
(size_term_list ts)"}, without any assumption about @{term"t"}.  Therefore
\isacommand{recdef} has been supplied with the congruence theorem
@{thm[source]map_cong}:
@{thm[display,margin=50]"map_cong"[no_vars]}
Its second premise expresses that in @{term"map f xs"},
function @{term"f"} is only applied to elements of list @{term"xs"}.  Congruence
rules for other higher-order functions on lists are similar.  If you get
into a situation where you need to supply \isacommand{recdef} with new
congruence rules, you can append a hint after the end of
the recursion equations:\cmmdx{hints}
*}
(*<*)
consts dummy :: "nat => nat"
recdef dummy "{}"
"dummy n = n"
(*>*)
(hints recdef_cong: map_cong)

text{*\noindent
Or you can declare them globally
by giving them the \attrdx{recdef_cong} attribute:
*}

declare map_cong[recdef_cong]

text{*
The @{text cong} and @{text recdef_cong} attributes are
intentionally kept apart because they control different activities, namely
simplification and making recursive definitions.
%The simplifier's congruence rules cannot be used by recdef.
%For example the weak congruence rules for if and case would prevent
%recdef from generating sensible termination conditions.
*}
(*<*)end(*>*)


theory Chapter10_4
imports "~~/src/HOL/IMP/Live_True" "~~/src/HOL/IMP/Vars"
begin

text{*
\exercise
In the context of ordinary live variable analysis, elimination of dead variables
(@{text bury}) is not idempotent (Exercise~\ref{exe:bury-not-idemp}).
Now define the textually identical function @{text bury} in the context
of true liveness analysis (theory @{theory Live_True})
and prove that it is idempotent.
*}

fun bury :: "com \<Rightarrow> vname set \<Rightarrow> com" where
"bury SKIP X = SKIP" |
"bury (x ::= a) X = (if x \<in> X then x ::= a else SKIP)" |
"bury (c\<^sub>1;; c\<^sub>2) X = (bury c\<^sub>1 (L c\<^sub>2 X);; bury c\<^sub>2 X)" |
"bury (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = IF b THEN bury c\<^sub>1 X ELSE bury c\<^sub>2 X" |
"bury (WHILE b DO c) X = WHILE b DO bury c (L (WHILE b DO c) X)"

text{* The following two tweaks improve proof automation: *}

declare L.simps(5)[simp]
lemmas L_mono2 = L_mono[unfolded mono_def]

text{* To show that @{const bury} is idempotent we need a key lemma: *}

lemma L_bury: "X \<subseteq> Y \<Longrightarrow> L (bury c Y) X = L c X"
(* your definition/proof here *)

text{* The proof is straightforward except for the case
\noquotes{@{term[source] "While b c"}} where reasoning about @{const lfp}
is required. Sledgehammer should help with the details.

Now we can prove idempotence of @{const bury}, again by induction on @{text c}:
*}

theorem bury_idemp: "bury (bury c X) X = bury c X"
(* your definition/proof here *)

text{*
Due to lemma @{thm[source] L_bury}, even the @{text While} case should be easy.
\endexercise
*}

end


header{* Initial Value Problems *}
theory Initial_Value_Problem
imports Bounded_Continuous_Function
begin

subsection {* Lipschitz continuity *}
text{*\label{sec:lipschitz}*}

context metric_space begin

definition lipschitz
  where "lipschitz t f L \<longleftrightarrow> (\<forall>x \<in> t. \<forall>y\<in>t. dist (f x) (f y) \<le> L * dist x y)"

lemma lipschitzI:
  assumes "\<And>x y. x \<in> t \<Longrightarrow> y \<in> t \<Longrightarrow> dist (f x) (f y) \<le> L * dist x y"
  shows "lipschitz t f L"
using assms unfolding lipschitz_def by auto

lemma lipschitzD:
  assumes "lipschitz t f L"
  assumes "x \<in> t" "y \<in> t"
  shows "dist (f x) (f y) \<le> L * dist x y"
using assms unfolding lipschitz_def by simp

lemma lipschitz_subset:
  assumes "lipschitz D f L"
  assumes "D' \<subseteq> D"
  shows "lipschitz D' f L"
  using assms by (auto intro: lipschitzI dest: lipschitzD)

end

subsection {* Solutions of IVPs *}
text{*\label{sec:solutions}*}

record 'a ivp =
  ivp_f :: "real \<times> 'a \<Rightarrow> 'a"
  ivp_t0 :: "real"
  ivp_x0 :: "'a"
  ivp_T :: "real set"
  ivp_X :: "'a set"

locale ivp =
  fixes i::"('a::ordered_euclidean_space) ivp"
  assumes iv_defined: "ivp_t0 i \<in> ivp_T i" "ivp_x0 i \<in> ivp_X i"
begin

abbreviation "t0 \<equiv> ivp_t0 i"
abbreviation "x0 \<equiv> ivp_x0 i"
abbreviation "T \<equiv> ivp_T i"
abbreviation "X \<equiv> ivp_X i"
abbreviation "f \<equiv> ivp_f i"

definition is_solution where "is_solution x \<longleftrightarrow>
  x t0 = x0 \<and>
  (\<forall>t\<in>T.
    (x has_vector_derivative f (t, x t))
      (at t within T) \<and>
     x t \<in> X)"

definition "solution = (SOME x. is_solution x)"

lemma is_solutionD:
  assumes "is_solution x"
  shows
  "x t0 = x0"
  "\<And>t. t \<in> T \<Longrightarrow> (x has_vector_derivative f (t, x t)) (at t within T)"
  "\<And>t. t \<in> T \<Longrightarrow> x t \<in> X"
  using assms
  by (auto simp: is_solution_def)

lemma solution_continuous_on[intro, simp]:
  assumes "is_solution x"
  shows "continuous_on T x"
using is_solutionD[OF assms]
by (auto intro!: differentiable_imp_continuous_on
  simp add: differentiable_on_def differentiable_def has_vector_derivative_def)
  blast

lemma is_solutionI[intro]:
  assumes "x t0 = x0"
  assumes "\<And>t. t \<in> T \<Longrightarrow>
    (x has_vector_derivative f (t, x t)) (at t within T)"
  assumes "\<And>t. t \<in> T \<Longrightarrow> x t \<in> X"
  shows "is_solution x"
  using assms
  unfolding is_solution_def by simp

lemma is_solution_solution_eq:
  assumes "\<And>t. t \<in> T \<Longrightarrow> x t = y t"
  shows "is_solution x = is_solution y"
proof -
  { fix t assume "t \<in> T"
    hence "(y has_vector_derivative f (t, y t)) (at t within T) =
      (x has_vector_derivative f (t, y t)) (at t within T)"
      using assms
      by (subst has_vector_derivative_cong) auto }
  thus ?thesis using assms iv_defined by (auto simp: is_solution_def)
qed

lemma solution_on_subset:
  assumes "t0 \<in> T'"
  assumes "T' \<subseteq> T"
  assumes "is_solution x"
  shows "ivp.is_solution (i\<lparr>ivp_T := T'\<rparr>) x"
proof -
  interpret ivp': ivp "i\<lparr>ivp_T := T'\<rparr>" using assms iv_defined
    by unfold_locales simp_all
  show ?thesis
  using assms is_solutionD[OF `is_solution x`]
  by (intro ivp'.is_solutionI) (auto intro:
    has_vector_derivative_within_subset[where s="T"])
qed

lemma is_solution_on_superset_domain:
  assumes "is_solution y"
  assumes "X \<subseteq> X'"
  shows "ivp.is_solution (i \<lparr>ivp_X := X'\<rparr>) y"
proof -
  interpret ivp': ivp "i\<lparr>ivp_X:=X'\<rparr>" using assms iv_defined
    by unfold_locales auto
  show ?thesis
  using assms
  by (auto simp: is_solution_def ivp'.is_solution_def)
qed

lemma restriction_of_solution:
  assumes "t1 \<in> T'"
  assumes "x t1 \<in> X"
  assumes "T' \<subseteq> T"
  assumes x_sol: "is_solution x"
  shows "ivp.is_solution (i\<lparr>ivp_t0:=t1, ivp_x0:=x t1, ivp_T:=T'\<rparr>) x"
proof -
  interpret ivp': ivp "i\<lparr>ivp_t0:=t1, ivp_x0:=x t1, ivp_T:=T'\<rparr>"
    using assms iv_defined is_solutionD[OF x_sol]
    by unfold_locales simp_all
  show ?thesis
    using is_solutionD[OF x_sol] assms
    by (intro ivp'.is_solutionI) (auto intro: has_vector_derivative_within_subset[where t=T' and s=T])
qed

end

locale has_solution = ivp +
  assumes exists_solution: "\<exists>x. is_solution x"
begin

lemma is_solution_solution[intro, simp]:
  shows "is_solution solution"
  using exists_solution unfolding solution_def by (rule someI_ex)

lemma solution:
  shows solution_t0: "solution t0 = x0"
    and solution_has_deriv: "\<And>t. t \<in> T \<Longrightarrow> (solution has_vector_derivative f (t, solution t)) (at t within T)"
    and solution_in_D: "\<And>t. t \<in> T \<Longrightarrow> solution t \<in> X"
  using is_solution_solution unfolding is_solution_def by auto

end

lemma (in ivp) singleton_has_solutionI:
  assumes "T = {t0}"
  shows "has_solution i"
  by unfold_locales (auto simp: has_vector_derivative_def assms
    intro!: has_derivative_singletonI bounded_linear_scaleR_left iv_defined exI[where x="\<lambda>x. x0"])

locale unique_solution = has_solution +
  assumes unique_solution: "\<And>y t. is_solution y \<Longrightarrow> t \<in> T \<Longrightarrow> y t = solution t"

lemma (in ivp) unique_solutionI:
  assumes "is_solution x"
  assumes "\<And>y t. is_solution y \<Longrightarrow> t \<in> T \<Longrightarrow> y t = x t"
  shows "unique_solution i"
proof
  show "\<exists>x. is_solution x" using assms by blast
  then interpret has_solution by unfold_locales
  fix y t
  assume "is_solution y" "t\<in>T"
  from assms(2)[OF this] assms(2)[OF is_solution_solution `t \<in> T`]
  show "y t = solution t" by simp
qed

lemma (in ivp) singleton_unique_solutionI:
  assumes "T = {t0}"
  shows "unique_solution i"
proof -
  interpret singsol: has_solution i
    using assms
    by (rule singleton_has_solutionI)
  show ?thesis
    by unfold_locales (auto dest!: is_solutionD(1) simp: assms singsol.solution_t0)
qed

locale interval = fixes a b assumes interval_notempty: "a \<le> b"

locale ivp_on_interval = ivp + interval t0 t1 for t1 +
  assumes interval: "T = {t0..t1}"
begin

lemma is_solution_ext_cont:
  assumes "continuous_on T x"
  shows "is_solution (ext_cont x t0 t1) = is_solution x"
  using assms iv_defined interval by (intro is_solution_solution_eq) simp_all

lemma solution_fixed_point:
  assumes x: "is_solution x"
  assumes t: "t \<in> T"
  shows "x0 + integral {t0..t} (\<lambda>t. f (t, x t)) = x t"
proof -
  from is_solutionD(2)[OF x] t
  have "\<forall>ta\<in>{t0..t}. (x has_vector_derivative f (ta, x ta)) (at ta within {t0..t})"
    by (auto intro!: has_vector_derivative_within_subset[where t="{t0..t}" and s="{t0..t1}"]
      simp: interval)
  hence "((\<lambda>t. f (t, x t)) has_integral x t - x t0) {t0..t}"
    using t by (intro fundamental_theorem_of_calculus) (simp add: interval)
  from this[THEN integral_unique]
  have "x t = x t0 + integral {t0..t} (\<lambda>t. f (t, x t))" by simp
  thus "x0 + integral {t0..t} (\<lambda>t. f (t, x t)) = x t"
    using solution_continuous_on[OF x] is_solutionD[OF x] by simp
qed

end

sublocale ivp_on_interval \<subseteq> interval t0 t1 by unfold_locales

subsubsection{* Connecting solutions *}
text{*\label{sec:combining-solutions}*}

locale connected_solutions =
  i1: ivp_on_interval i1 t1 + i2: ivp_on_interval i2 t2 + i: ivp_on_interval i t2
  + i1: has_solution i1 + i2: has_solution i2
  for i::"('a::ordered_euclidean_space) ivp" and i1::"'a ivp"
  and i2::"'a ivp" and t1 and t2 +
  fixes y
  assumes conn_t: "i2.t0 = t1"
  assumes sol1: "i1.is_solution y"
  assumes conn_x: "i2.x0 = y t1"
  assumes conn_f: "i1.f (t1, y t1) =
    i2.f (t1, y t1)"
  assumes initial_value: "t0 = i1.t0" "x0 = i1.x0"
  assumes f: "f = (\<lambda>(t, x). if t \<le> t1 then i1.f (t, x) else i2.f (t, x))"
  assumes interval: "T = {t0..t2}"
  assumes dom:"X = i1.X" "X = i2.X"
begin

lemma T_subsets:
  shows T1_subset: "i1.T \<subseteq> T"
  and T2_subset: "i2.T \<subseteq> T"
  using i1.iv_defined i2.iv_defined
  by (simp_all add: conn_t interval i1.interval i2.interval initial_value)

definition connection where
  "connection t = (if t \<le> t1 then y t else i2.solution t)"

lemma is_solution_connection: "is_solution connection"
proof -
  {
    fix t
    assume "t0 \<le> t" "t \<le> t2"
    hence "(connection has_vector_derivative (if t \<le> t1 then
        i1.f (t, y t) else i2.f (t, i2.solution t))) (at t within {t0..t2})"
      using initial_value interval dom conn_t conn_x conn_f
        i1.is_solutionD[OF sol1] i2.solution
      i1.iv_defined i2.iv_defined
      unfolding i1.interval i2.interval connection_def[abs_def]
      by (intro linear_continuation) auto
  } note D = this
  {
    fix t
    assume "t0 \<le> t" "t \<le> t1"
    moreover
    hence "t0 \<le> t" "t \<le> t2" using i2.interval i2.iv_defined conn_t
      by auto
    note D[OF this]
    ultimately
    have "((\<lambda>t. if t \<le> t1 then y t else i2.solution t)
      has_vector_derivative f (t, connection t))
      (at t within {t0..t2})"
      by (simp add: f connection_def[abs_def])
  } moreover {
    fix t
    assume "t \<le> t2" "\<not> t \<le> t1"
    moreover
    hence "t0 \<le> t" "t \<le> t2" using i1.interval i1.iv_defined initial_value
      by auto
    moreover
    note D[OF this]
    ultimately
    have "((\<lambda>t. if t \<le> t1 then y t else i2.solution t)
      has_vector_derivative f (t, connection t))
            (at t within {t0..t2})"
      by (simp add: f connection_def[abs_def])
  } ultimately
  show "is_solution connection" using
    i1.interval i2.interval i1.iv_defined i2.iv_defined
    i1.is_solutionD[OF sol1] i2.solution conn_f conn_t conn_x
    initial_value f interval dom
    by (intro is_solutionI) (auto simp: connection_def[abs_def])
qed

end

sublocale connected_solutions \<subseteq> has_solution using is_solution_connection
  by unfold_locales auto

locale connected_unique_solutions =
  i1: unique_solution i1 + i2: unique_solution i2 +
  connected_solutions i i1 i2 t1 t2 "i1.solution"
  for i::"('a::ordered_euclidean_space) ivp" and i1::"'a ivp"
  and i2::"'a ivp" and t1 and t2
begin

sublocale unique_solution
proof (intro unique_solutionI)
  show "is_solution connection" using is_solution_connection .
  fix y t
  assume "is_solution y" "t \<in> T"
  have "i1.is_solution y"
  proof (intro i1.is_solutionI)
    show "y (i1.t0) = i1.x0"
      using is_solutionD(1)[OF `is_solution y`] initial_value by simp
  next
    fix ta
    assume "ta \<in> i1.T"
    hence "ta \<in> T" using T1_subset by auto
    from is_solutionD(2)[OF `is_solution y` this]
    have "(y has_vector_derivative i1.f (ta, y ta)) (at ta within T)"
      using `ta \<in> i1.T` by (simp add: f i1.interval)
    thus "(y has_vector_derivative i1.f (ta, y ta)) (at ta within i1.T)"
      using T1_subset
      by (rule has_vector_derivative_within_subset)
    show "y ta \<in> i1.X" using is_solutionD(3)[OF `is_solution y` `ta \<in> T`]
      by (simp add: dom)
  qed
  have "i2.is_solution y"
  proof (intro i2.is_solutionI)
    have "i1.solution t1 = y t1"
      using i1.unique_solution[OF `i1.is_solution y`] i1.interval i1.iv_defined
      by simp
    thus "y (i2.t0) = i2.x0"
      by (simp add: conn_t conn_x)
    fix ta
    assume "ta \<in> i2.T"
    hence "ta \<in> T" using T2_subset by auto
    from is_solutionD(2)[OF `is_solution y` this]
    have "(y has_vector_derivative i2.f (ta, y ta)) (at ta within T)"
      using `ta \<in> i2.T` conn_t conn_f `i1.solution t1 = y t1`
      by (cases "ta = t1") (simp_all add: f i2.interval)
    thus "(y has_vector_derivative i2.f (ta, y ta)) (at ta within i2.T)"
      using T2_subset
      by (rule has_vector_derivative_within_subset)
    show "y ta \<in> i2.X" using is_solutionD(3)[OF `is_solution y` `ta \<in> T`]
      using dom by simp
  qed
  from i1.unique_solution[OF `i1.is_solution y`, of t]
    i2.unique_solution[OF `i2.is_solution y`, of t]
  show "y t = connection t"
    using `t \<in> T`
    by (simp add: interval i1.interval i2.interval initial_value conn_t
      connection_def)
qed

lemma connection_eq_solution: "\<And>t. t \<in> T \<Longrightarrow> connection t = solution t"
  by (rule unique_solution is_solution_connection)+

lemma solution1_eq_solution:
  assumes "t \<in> i1.T"
  shows "i1.solution t = solution t"
proof -
  from T1_subset assms have "t \<in> T" by auto
  from connection_eq_solution[OF `t \<in> T`] i1.interval assms
  show ?thesis
    by (simp add: connection_def split: split_if_asm)
qed

lemma solution2_eq_solution:
  assumes "t \<in> i2.T"
  shows "i2.solution t = solution t"
proof -
  from T2_subset assms have "t \<in> T" by auto
  from connection_eq_solution[OF `t \<in> T`] i2.interval assms conn_t conn_x i2.solution_t0
  show ?thesis
    by (simp add: connection_def split: split_if_asm)
qed

end

subsection {* Picard-Lindeloef on set of functions into closed set *}
text{*\label{sec:plclosed}*}
locale continuous = fixes T X f
  assumes continuous: "continuous_on (T \<times> X) f"

locale global_lipschitz =
  fixes T X f and L::real
  assumes lipschitz: "\<And>t. t\<in>T \<Longrightarrow> lipschitz X (\<lambda>x. f (t, x)) L" "0 \<le> L"

locale closed_domain =
  fixes X assumes closed: "closed X"

locale self_mapping = ivp_on_interval +
  assumes self_mapping:
    "\<And>x t. t \<in> T \<Longrightarrow> x t0 = x0 \<Longrightarrow> x \<in> {t0..t} \<rightarrow> X \<Longrightarrow> continuous_on {t0..t} x \<Longrightarrow>
      x0 + integral {t0..t} (\<lambda>t. f (t, x t)) \<in> X"

locale unique_on_closed = self_mapping + continuous T X f +
  closed_domain X +
  global_lipschitz T X f L for L
begin

text {* Picard Iteration *}

definition P_inner
  where
  "P_inner x t = x0 + integral {t0..t} (\<lambda>t. f (t, x t))"

definition P::"(real, 'a) bcontfun \<Rightarrow> (real, 'a) bcontfun" where
  "P x = ext_cont (P_inner x) t0 t1"

lemma
  continuous_f:
  assumes "y \<in> {t0..t} \<rightarrow> X"
  assumes "continuous_on {t0..t} y"
  assumes "t \<in> T"
  shows "continuous_on {t0..t} (\<lambda>t. f (t, y t))"
  using `y \<in> {t0..t} \<rightarrow> X` assms interval_notempty
  by (intro continuous_Sigma[of _ _ "\<lambda>_. X"])
    (auto simp: interval intro: assms continuous_on_subset continuous)

lemma P_inner_bcontfun:
  assumes "y \<in> T \<rightarrow> X"
  assumes y_cont: "continuous_on T y"
  shows "(\<lambda>x. P_inner y (clamp t0 t1 x)) \<in> bcontfun"
proof -
  show ?thesis using interval iv_defined assms
    by (auto intro!: clamp_bcontfun continuous_intros continuous_f indefinite_integral_continuous
      simp add: P_def P_inner_def)
qed

definition "iter_space = (Abs_bcontfun ` ((T \<rightarrow> X) \<inter> bcontfun \<inter> {x. x t0 = x0}))"

lemma iter_spaceI:
  "(\<And>x. x \<in> T \<Longrightarrow> Rep_bcontfun g x \<in> X) \<Longrightarrow> g t0 = x0 \<Longrightarrow> g \<in> iter_space"
  by (force simp add: assms iter_space_def Rep_bcontfun Rep_bcontfun_inverse intro!: Rep_bcontfun)

lemma const_in_subspace: "(\<lambda>_. x0) \<in> (T \<rightarrow> X) \<inter> bcontfun \<inter> {x. x t0 = x0}"
  by (auto intro: const_bcontfun iv_defined)

lemma closed_iter_space: "closed iter_space"
proof -
  have "(T \<rightarrow> X) \<inter> bcontfun \<inter> {x. x t0 = x0} = Pi T (\<lambda>i. if i = t0 then {x0} else X) \<inter> bcontfun"
    using iv_defined by (auto simp: Pi_iff split: split_if_asm)
  thus ?thesis using closed by (auto simp add: iter_space_def intro!: closed_Pi_bcontfun)
qed

lemma iter_space_notempty: "iter_space \<noteq> {}"
  using const_in_subspace by (auto simp: iter_space_def)

lemma P_self_mapping:
  assumes in_space: "g \<in> iter_space"
  shows "P g \<in> iter_space"
proof (rule iter_spaceI)
  have cont: "continuous_on {t0..t1} (P_inner (Rep_bcontfun g))"
    using assms Rep_bcontfun[of g, simplified bcontfun_def]
    by (auto simp: interval iter_space_def Abs_bcontfun_inverse P_inner_def interval_notempty
      intro!: continuous_intros indefinite_integral_continuous integrable_continuous_real continuous_f)
  from ext_cont_cancel[OF _ cont] assms
  show "Rep_bcontfun (P g) t0 = x0"
     "\<And>t. t \<in> T \<Longrightarrow> Rep_bcontfun (P g) t \<in> X"
    using assms Rep_bcontfun[of g, simplified bcontfun_def]
    by (auto intro!: self_mapping simp: interval interval_notempty P_inner_def P_def iter_space_def
      Abs_bcontfun_inverse)
qed

lemma ext_cont_solution_fixed_point:
  assumes "is_solution x"
  shows "P (ext_cont x t0 t1) = ext_cont x t0 t1"
  unfolding P_def
proof (rule ext_cont_cong)
  show "\<And>t. t \<in> {t0..t1} \<Longrightarrow> P_inner (Rep_bcontfun (ext_cont x t0 t1)) t = x t"
    unfolding P_inner_def
    using solution_fixed_point solution_continuous_on assms is_solutionD
    by (subst integral_spike[OF negligible_empty])
       (auto simp: interval P_inner_def integral_spike[OF negligible_empty])
qed (insert iv_defined solution_continuous_on assms is_solutionD,
  auto simp: interval P_inner_def continuous_intros indefinite_integral_continuous continuous_f)

lemma
  solution_in_iter_space:
  assumes "is_solution z"
  shows "ext_cont z t0 t1 \<in> iter_space"
proof -
  let ?z = "ext_cont z t0 t1"
  have "is_solution ?z"
    using is_solution_ext_cont interval `is_solution z` solution_continuous_on by simp
  hence "\<And>t. t \<in> T \<Longrightarrow> ext_cont z t0 t1 t \<in> X" by (auto simp add: is_solution_def)
  thus "?z \<in> iter_space" using is_solutionD[OF `is_solution z`]
    solution_continuous_on[OF `is_solution z`]
    by (auto simp: interval interval_notempty intro!: iter_spaceI)
qed

end

locale unique_on_bounded_closed = unique_on_closed +
  assumes lipschitz_bound: "(t1 - t0) * L < 1"
begin

lemma lipschitz_P:
  shows "lipschitz iter_space P ((t1 - t0) * L)"
proof (rule lipschitzI)
  fix y z
  assume "y \<in> iter_space" and "z \<in> iter_space"
  hence y_defined: "Rep_bcontfun y \<in> (T \<rightarrow> X)" and z_defined: "Rep_bcontfun z \<in> (T \<rightarrow> X)"
    by (auto simp: Abs_bcontfun_inverse iter_space_def)
  {
    fix y z::"real\<Rightarrow>'a"
    assume "y \<in> bcontfun" and y_defined: "y \<in> (T \<rightarrow> X)"
    assume "z \<in> bcontfun" and z_defined: "z \<in> (T \<rightarrow> X)"
    from bcontfunE[OF `y \<in> bcontfun`] have y: "continuous_on UNIV y" by auto
    from bcontfunE[OF `z \<in> bcontfun`] have z: "continuous_on UNIV z" by auto
    {
      fix t
      assume t_bounds: "t0 \<le> t" "t \<le> t1"
        --{* Instances of @{text continuous_on_subset} *}
      have y_cont: "continuous_on {t0..t} (\<lambda>t. y t)" using y
        by (auto intro:continuous_on_subset)
      have "continuous_on {t0..t1} (\<lambda>t. f (t, y t))"
        using continuous interval interval_notempty y strip y_defined
        by (auto intro!:continuous_f intro: continuous_on_subset)
      hence fy_cont[intro, simp]:
        "continuous_on {t0..t} (\<lambda>t. f (t, y t))"
        by (rule continuous_on_subset) (simp add: t_bounds)
      have z_cont: "continuous_on {t0..t} (\<lambda>t. z t)" using z
        by (auto intro:continuous_on_subset)
      have "continuous_on {t0..t1} (\<lambda>t. f (t, z t))" using z
        continuous strip interval z_defined
        by (auto intro!: continuous_Sigma intro: continuous_on_subset)
      hence fz_cont[intro, simp]:
        "continuous_on {t0..t} (\<lambda>t. f (t, z t))"
        by (rule continuous_on_subset) (simp add: t_bounds)

      have "norm (P_inner y t - P_inner z t) =
        norm (integral {t0..t} (\<lambda>t. f (t, y t) - f (t, z t)))"
        using y
        by (auto simp add: integral_sub P_inner_def)
      also have "... \<le> integral {t0..t} (\<lambda>t. norm (f (t, y t) - f (t, z t)))"
        by (auto intro!: integral_norm_bound_integral continuous_intros)
      also have "... \<le> integral {t0..t} (\<lambda>t. L * norm (y t - z t))"
        using y_cont z_cont lipschitz t_bounds interval y_defined z_defined
        by (auto intro!: integral_le continuous_intros
          simp add: dist_norm lipschitz_def Pi_iff)
      also have "... \<le> integral {t0..t} (\<lambda>t. L *
        norm (Abs_bcontfun y - Abs_bcontfun  z))"
        using norm_bounded[of "Abs_bcontfun y - Abs_bcontfun z"]
          y_cont z_cont lipschitz
        by (intro integral_le) (auto intro!: continuous_intros mult_left_mono
          simp add: Abs_bcontfun_inverse[OF `y \<in> bcontfun`]
          Abs_bcontfun_inverse[OF `z \<in> bcontfun`])
      also have "... =
        L * (t - t0) * norm (Abs_bcontfun y - Abs_bcontfun z)"
        using t_bounds by simp
      also have "... \<le> L * (t1 - t0) * norm (Abs_bcontfun y - Abs_bcontfun z)"
        using t_bounds zero_le_dist lipschitz
        by (auto intro!: mult_right_mono mult_left_mono)
      finally
      have "norm (P_inner y t - P_inner z t)
        \<le> L * (t1 - t0) * norm (Abs_bcontfun y - Abs_bcontfun z)" .
    } note * = this
    have "dist (P (Abs_bcontfun y)) (P (Abs_bcontfun z)) \<le>
      L * (t1 - t0) * dist (Abs_bcontfun y) (Abs_bcontfun z)"
      unfolding P_def dist_norm ext_cont_def Abs_bcontfun_inverse[OF `y \<in> bcontfun`]
        Abs_bcontfun_inverse[OF `z \<in> bcontfun`]
      using interval iv_defined `y \<in> bcontfun` `z \<in> bcontfun` y_defined z_defined
        clamp_in_interval[OF interval_notempty]
      apply (intro norm_bound)
      unfolding Rep_bcontfun_minus
      apply (subst Abs_bcontfun_inverse)
       defer
       apply (subst Abs_bcontfun_inverse)
        defer
        apply (auto intro!: P_inner_bcontfun * elim!: bcontfunE intro: continuous_on_subset)
      done
  }
  from this[OF Rep_bcontfun y_defined Rep_bcontfun z_defined]
  show "dist (P y) (P z) \<le> (t1 - t0) * L * dist y z"
    unfolding Rep_bcontfun_inverse by (simp add: field_simps)
qed

lemma fixed_point_unique: "\<exists>!x\<in>iter_space. P x = x"
  using lipschitz lipschitz_bound lipschitz_P interval
      complete_UNIV iv_defined
  by (intro banach_fix) (auto intro: P_self_mapping split_mult_pos_le
    intro!: closed_iter_space iter_space_notempty simp: lipschitz_def complete_eq_closed)

definition fixed_point where
  "fixed_point = (THE x. x \<in> iter_space \<and> P x = x)"

lemma fixed_point':
  "fixed_point \<in> iter_space \<and> P fixed_point = fixed_point"
  unfolding fixed_point_def using fixed_point_unique
  by (rule theI')

lemma fixed_point:
  "fixed_point \<in> iter_space" "P fixed_point = fixed_point"
  using fixed_point' by simp_all

lemma fixed_point_equality': "x \<in> iter_space \<and> P x = x \<Longrightarrow> fixed_point = x"
  unfolding fixed_point_def using fixed_point_unique assms by (rule the1_equality)

lemma fixed_point_equality: "x \<in> iter_space \<Longrightarrow> P x = x \<Longrightarrow> fixed_point = x"
  using fixed_point_equality'[of x] by auto

lemma fixed_point_continuous: "\<And>t. continuous_on I fixed_point"
  using bcontfunE[OF Rep_bcontfun[of fixed_point]]
  by (auto intro: continuous_on_subset)

lemma fixed_point_solution:
  shows "is_solution fixed_point"
proof
  have "fixed_point t0 = P fixed_point t0"
    unfolding fixed_point ..
  also have "... = x0"
    using interval iv_defined continuous fixed_point_continuous fixed_point
    unfolding P_def P_inner_def[abs_def]
    by (subst ext_cont_cancel) (auto simp add: iter_space_def Abs_bcontfun_inverse
      intro!: continuous_intros indefinite_integral_continuous integrable_continuous_real
      continuous_f intro: continuous_on_subset)
  finally show "fixed_point t0 = x0" .
next
  fix t
  have U: "Rep_bcontfun fixed_point \<in> Pi T (\<lambda>_. X)"
    using fixed_point by (auto simp add: iter_space_def Abs_bcontfun_inverse)
  assume "t \<in> T" hence t_range: "t \<in> {t0..t1}" by (simp add: interval)
  from has_vector_derivative_const
    integral_has_vector_derivative[
    OF continuous_Sigma[OF U continuous fixed_point_continuous, simplified interval] t_range]
  have "((\<lambda>u. x0 + integral {t0..u}
         (\<lambda>x. f (x, fixed_point x))) has_vector_derivative
   0 + f (t, fixed_point t))
   (at t within {t0..t1})"
    by (rule has_vector_derivative_add)
  hence "((P fixed_point) has_vector_derivative
    f (t, fixed_point t)) (at t within {t0..t1})"
    unfolding P_def P_inner_def[abs_def]
    using t_range
    apply (subst has_vector_derivative_cong)
    apply (simp_all)
    using fixed_point fixed_point_continuous continuous interval
    by (subst ext_cont_cancel) (auto simp add: iter_space_def Abs_bcontfun_inverse
      intro!: continuous_intros indefinite_integral_continuous integrable_continuous_real
      continuous_f intro: continuous_on_subset)
  moreover
  have "fixed_point t \<in> X"
    using fixed_point `t \<in> T` by (auto simp add: iter_space_def Abs_bcontfun_inverse)
  ultimately
  show "(fixed_point has_vector_derivative
      f (t, fixed_point t)) (at t within T)"
    "fixed_point t \<in> X" unfolding fixed_point interval
    by simp_all
qed

end

subsubsection {* Existence of solution *}

sublocale unique_on_bounded_closed \<subseteq> has_solution
proof
  from fixed_point_solution
  show "\<exists>x. is_solution x" by blast
qed

subsubsection {* Unique solution *}
text{*\label{sec:ivp-ubs}*}

sublocale unique_on_bounded_closed \<subseteq> unique_solution
proof
  fix z t
  assume "is_solution z"
  with ext_cont_solution_fixed_point `is_solution z` is_solution_solution
    solution_in_iter_space fixed_point_equality
  have "ext_cont solution t0 t1 t = ext_cont z t0 t1 t" by metis
  moreover assume "t \<in> T"
  ultimately
  show "z t = solution t"
    using solution_continuous_on[OF `is_solution z`] solution_continuous_on[OF is_solution_solution]
    by (auto simp: interval)
qed

sublocale unique_on_closed \<subseteq> unique_solution
proof (cases "t1 = t0")
  assume "t1 = t0"
  then interpret has_solution
    using is_solution_def interval iv_defined
    by unfold_locales (auto intro!: exI[where x="(\<lambda>t. x0)"]
      simp add: has_vector_derivative_def
      has_derivative_within_alt bounded_linear_scaleR_left)
  show "unique_solution i"
    using `t1=t0` interval solution_t0
    by unfold_locales (simp add: is_solution_def)
next
  assume "t1 \<noteq> t0" with interval iv_defined have interval: "T = {t0..t1}" "t0 < t1"
    by auto
  obtain n::nat and b where b: "b = (t1 - t0) / (Suc n)" and bL: "L * b < 1"
    by (rule, rule) (auto intro: order_le_less_trans real_natceiling_ge
    simp: natceiling_def)
  then interpret i': ivp_on_interval i "t0 + (Suc n) * b"
    using interval by unfold_locales simp_all
  from b have "b > 0" using interval iv_defined
    by auto
  hence "b \<ge> 0" by simp
  from interval have "t0 * (real (Suc n) - 1) \<le> t1 * (real (Suc n) - 1)" by (cases n) auto
  hence ble: "t0 + b \<le> t1" unfolding b by (auto simp add: field_simps)
  have subsetbase: "t0 + (Suc n) * b \<le> t1" using i'.interval interval by auto

  interpret i': unique_solution "i\<lparr>ivp_T := {t0..t0 + real (Suc n) * b}\<rparr>"
    using subsetbase
  proof (induct n)
    case 0
    then interpret sol: unique_on_bounded_closed "i\<lparr>ivp_T:={t0..t0+b}\<rparr>" "t0 + b"
      using interval iv_defined `b > 0` bL continuous lipschitz closed self_mapping
      by unfold_locales (auto intro: continuous_on_subset simp: ac_simps Pi_iff)
    show ?case by simp unfold_locales
  next
    case (Suc n)
    def nb \<equiv> "real (Suc n) * b"
    def snb \<equiv> "real (Suc (Suc n)) * b"
    note Suc = Suc[simplified nb_def[symmetric] snb_def[symmetric]]
    from `b > 0` nb_def snb_def have nbs_nonneg: "0 < snb" "0 < nb"
      by (simp_all add: zero_less_mult_iff)
    with `b>0` have nb_le_snb: "nb < snb" using nb_def snb_def
      by auto
    have [simp]: "snb - nb = b"
    proof -
      have "snb + - (nb) = b * real (Suc (Suc n)) + - (b * real (Suc n))"
        by (simp add: ac_simps snb_def nb_def)
      thus ?thesis by (simp add: field_simps real_of_nat_Suc)
    qed
    def i1 \<equiv> "i\<lparr>ivp_T := {t0..t0 + nb}\<rparr>"
    def T1 \<equiv> "t0 + nb"
    interpret ivp1: ivp_on_interval i1 T1
      using iv_defined `nb > 0` by unfold_locales (auto simp: i1_def T1_def)
    interpret ivp1: unique_solution i1
      using nb_le_snb nbs_nonneg Suc continuous lipschitz by (simp add: i1_def)
    interpret ivp1_cl: unique_on_closed i1 "t0 + nb"
      using nb_le_snb nbs_nonneg Suc continuous lipschitz closed self_mapping
      by unfold_locales (auto simp: i1_def interval intro: continuous_on_subset)
    def i2 \<equiv> "i\<lparr>ivp_t0:=t0+nb, ivp_T:={t0 + nb..t0+snb},
      ivp_x0:=ivp1.solution (t0 + nb)\<rparr>"
    def T2 \<equiv> "t0 + snb"
    interpret ivp2: ivp_on_interval i2 T2
      using nbs_nonneg `nb < snb` ivp1.solution_in_D
      by unfold_locales (auto simp: i1_def i2_def T2_def)
    interpret ivp2: self_mapping i2 T2
    proof unfold_locales
      fix x t assume t: "t \<in> ivp2.T" and x: "x ivp2.t0 = ivp2.x0" "x \<in> {ivp2.t0 .. t} \<rightarrow> ivp2.X"
        and cont: "continuous_on {ivp2.t0 .. t} x"
      hence "t \<in> T"
        using Suc(2) nbs_nonneg interval
        by (simp add: i2_def)
      let ?un = "(\<lambda>t. if t \<le> nb + t0 then ivp1.solution t else x t)"
      let ?fun = "(\<lambda>t. f (t, ?un t))"
      have decomp: "{t0..t} = {t0..nb + t0} \<union> {nb + t0..t}" using interval_notempty t nbs_nonneg
        by (auto simp: i2_def)
      have un_space: "?un \<in> {t0..t} \<rightarrow> X"
        using x ivp1.solution_in_D
        by (auto simp: i1_def i2_def Pi_iff)
      have cont_un: "continuous_on {t0..t} ?un"
        using x cont ivp1.solution_continuous_on[OF ivp1.is_solution_solution, simplified i1_def]
        unfolding decomp
        by (intro continuous_on_If) (auto intro: continuous_on_subset simp: i1_def i2_def ac_simps)
      have cont_fun: "continuous_on {t0..t} ?fun"
        using un_space cont_un `t \<in> T` by (rule continuous_f)
      have "ivp.solution i1 (nb + t0) + integral {nb + t0..t} (\<lambda>xa. f (xa, x xa)) =
        x0 + (integral {t0..nb + t0} (\<lambda>t. f (t, ivp1.solution t)) + integral {nb + t0..t} (\<lambda>xa. f (xa, x xa)))"
        using ivp1_cl.solution_fixed_point[OF ivp1.is_solution_solution] nbs_nonneg
          ivp1_cl.P_inner_def
        by (auto simp: i1_def ac_simps)
      also have "integral {t0..nb + t0} (\<lambda>t. f (t, ivp1.solution t)) = integral {t0..nb + t0} ?fun"
        by (rule integral_spike[OF negligible_empty]) auto
      also have fun2: "integral {nb + t0..t} (\<lambda>t. f (t, x t)) = integral {nb + t0..t} ?fun"
        using x
        by (intro integral_spike[OF negligible_empty]) (auto simp: i1_def i2_def ac_simps)
      also have "integral {t0..nb + t0} ?fun + integral {nb + t0..t} ?fun = integral {t0..t} ?fun"
        using t nbs_nonneg
        by (intro integral_combine) (auto simp: i2_def less_imp_le intro!: cont_fun)
      also have "x0 + \<dots> \<in> X"
        using `t \<in> T` `nb > 0` ivp1.is_solutionD[OF ivp1.is_solution_solution]
        by (intro self_mapping[OF _ _ un_space cont_un]) (auto simp: ivp1.iv_defined i1_def)
      also note fun2[symmetric]
      finally show "ivp2.x0 + integral {ivp2.t0 .. t} (\<lambda>t. ivp2.f (t, x t)) \<in> ivp2.X"
        by (simp add: i1_def i2_def ac_simps)
    qed
    interpret ivp2: unique_on_bounded_closed i2 T2
      using bL Suc(2) nbs_nonneg interval continuous lipschitz closed
      by unfold_locales (auto intro: continuous_on_subset simp:ac_simps i1_def i2_def T2_def)
    def i \<equiv> "i\<lparr>ivp_T := {t0..t0 + real (Suc (Suc n)) * b}\<rparr>"
    def T \<equiv> "t0 + real (Suc (Suc n)) * b"
    interpret ivp_c: connected_unique_solutions i i1 i2 T1 T2
      using `b > 0` iv_defined ivp1.is_solution_solution
      by unfold_locales (auto simp: i1_def i2_def i_def T1_def T2_def T_def snb_def)
    show ?case unfolding i_def[symmetric] by unfold_locales
  qed
  show "unique_solution i"
    using i'.solution i'.unique_solution interval(1)[symmetric] i'.interval[symmetric]
    by unfold_locales auto
qed

subsection {* Picard-Lindeloef for @{term "X=(\<lambda>_. UNIV)"} *}
text{*\label{sec:pl-us}*}

locale unique_on_strip = ivp_on_interval + continuous T X f +
  global_lipschitz T X f L for L +
  assumes strip: "X = UNIV"

sublocale unique_on_strip < unique_on_closed
  using strip by unfold_locales auto

subsection {* Picard-Lindeloef on rectangular domain *}
text{*\label{sec:pl-rect}*}
locale rectangle = ivp_on_interval +
  fixes b
  assumes b_pos: "b > 0"
  assumes rectangle: "X = {x0 - b *\<^sub>R One..x0 + b *\<^sub>R One}"

lemma dist_component_le:
  fixes x y::"'a::euclidean_space"
  assumes "i \<in> Basis"
  shows "dist (x \<bullet> i) (y \<bullet> i) \<le> dist x y"
  using assms
  by (auto simp: euclidean_dist_l2[of x y] intro: member_le_setL2)

lemma setsum_inner_Basis_one: "i \<in> Basis \<Longrightarrow> (\<Sum>x\<in>Basis. x \<bullet> i) = 1"
  by (subst setsum.mono_neutral_right [of _ "{i}"]) (auto simp: inner_not_same_Basis)

lemma cball_in_cube:
  fixes y::"'a::ordered_euclidean_space"
  shows "cball y r \<subseteq> {y - r *\<^sub>R One..y + r *\<^sub>R One}"
  unfolding scaleR_setsum_right interval_cbox cbox_def
proof safe
  fix x i::'a assume "i \<in> Basis" "x \<in> cball y r"
  with dist_component_le[OF `i \<in> Basis`, of y x]
  have "dist (y \<bullet> i) (x \<bullet> i) \<le> r" by simp
  thus "(y - setsum (op *\<^sub>R r) Basis) \<bullet> i \<le> x \<bullet> i" "x \<bullet> i \<le> (y + setsum (op *\<^sub>R r) Basis) \<bullet> i"
    by (auto simp add: inner_diff_left inner_add_left inner_setsum_left setsum_right_distrib[symmetric]
      setsum_inner_Basis_one `i\<in>Basis` dist_real_def)
qed

lemma centered_cube_in_cball:
  shows "{- r *\<^sub>R One..r *\<^sub>R One::'a::ordered_euclidean_space} \<subseteq> cball 0 (sqrt(DIM('a)) * r)"
proof
  fix x::'a
  have "norm x \<le> sqrt(DIM('a)) * infnorm x"
  by (rule norm_le_infnorm)
  also
  assume "x \<in> {- r *\<^sub>R One..r *\<^sub>R One}"
  hence "infnorm x \<le> r"
    using assms
    by (auto simp: infnorm_def eucl_le[where 'a='a] intro!: cSup_least)
      (simp add: abs_real_def minus_le_iff)
  finally show "x \<in> cball 0 (sqrt(DIM('a)) * r)"
    by (auto simp: dist_norm mult_left_mono)
qed

locale solution_in_rectangle = rectangle + continuous T X f +
  fixes B
  assumes norm_f: "\<And>x t. t \<in> T \<Longrightarrow> x \<in> X \<Longrightarrow> norm (f (t, x)) \<le> B"
  assumes t1_bounded: "t1 \<le> t0 + b / B"
begin

lemma B_nonneg: "B \<ge> 0"
proof -
  have "0 \<le> norm (f (t0, x0))" by simp
  also from iv_defined norm_f have "... \<le> B" by simp
  finally show ?thesis by simp
qed

lemma in_bounds_derivativeI:
  assumes "t \<in> T"
  assumes init: "x t0 = x0"
  assumes cont: "continuous_on {t0..t} x"
  assumes solves: "\<And>s. s \<in> {t0..t} \<Longrightarrow> (x has_vector_derivative f (s, y s)) (at s within {t0..t})"
  assumes y_bounded: "\<And>\<xi>. \<xi>\<in>{t0..t} \<Longrightarrow> x \<xi> \<in> X \<Longrightarrow> y \<xi> \<in> X"
  shows "x t \<in> X"
proof cases
  assume "b = 0 \<or> B = 0" with assms t1_bounded interval interval_notempty have "t = t0"
    by auto
  thus ?thesis using iv_defined init by simp
next
  assume "\<not>(b = 0 \<or> B = 0)"
  hence "b > 0" "B > 0" using B_nonneg b_pos by auto
  show ?thesis
  proof -
    from cont have closed: "closed {s \<in> {t0..t}. norm (x s - x t0) \<in> {b..}}"
      by (intro continuous_closed_preimage continuous_intros) auto
    have exceeding: "{s \<in> {t0..t}. norm (x s - x t0) \<in> {b..}} \<subseteq> {t}"
    proof (rule ccontr)
      assume "\<not>{s \<in> {t0..t}. norm (x s - x t0) \<in> {b..}} \<subseteq> {t}"
      hence notempty: "{s \<in> {t0..t}. norm (x s - x t0) \<in> {b..}} \<noteq> {}"
        and not_max: "{s \<in> {t0..t}. norm (x s - x t0) \<in> {b..}} \<noteq> {t}" by auto
      from distance_attains_inf[OF closed notempty, of t0]
      obtain s where s_bound: "s \<in> {t0..t}" and exceeds: "norm (x s - x t0) \<in> {b..}"
        and min: "\<forall>t2\<in>{t0..t}. norm (x t2 - x t0) \<in> {b..} \<longrightarrow> dist t0 s \<le> dist t0 t2"
        by blast
      hence "s \<le> t" by simp
      have lt: "t0 < s"
        using s_bound exceeds min
          eucl_le[of x0] eucl_le[where y=x0] diff_self `b>0`
        by (auto simp add: less_le)
      have deriv:
        "\<forall>t\<in>{t0<..<s}. (x has_derivative (\<lambda>h. h *\<^sub>R f (t, y t))) (at t)"
      proof
        fix ss
        assume int:"ss \<in> {t0<..<s}"
        hence "{t0..t} \<supseteq> {t0<..<s}" "t0 \<le> ss" "ss \<le> t" using s_bound by auto
        with solves[of ss]
        show "(x has_derivative (\<lambda>h. h *\<^sub>R f (ss, y ss))) (at ss)"
          unfolding has_vector_derivative_def
          by (subst has_derivative_within_open[OF int, symmetric])
            (auto intro!: has_derivative_within_subset[where s="{t0..t}" and t = "{t0<..<s}"]
             simp add: interval)
      qed
      from cont have cont: "continuous_on {t0..s} x"
        by (rule continuous_on_subset) (simp add: `s \<le> t`)
      from mvt_general[OF lt cont deriv] obtain \<xi> where \<xi>: "\<xi> \<in> {t0<..<s}"
        "norm (x s - x t0) \<le> norm ((s - t0) *\<^sub>R f (\<xi>, y \<xi>))" by auto
      have "\<xi> \<in> {t0..t}" using \<xi> `s \<le> t` by auto
      hence "\<xi> \<in> {t0..t1}" using assms by (auto simp: interval)
      have "norm (x s - x t0) < b"
      proof cases
        assume "f (\<xi>, y \<xi>) = 0"
        with \<xi>(2) have "norm (x s - x t0) \<le> 0" by simp
        with `b > 0` show ?thesis by simp
      next
        assume f'_nonzero: "f (\<xi>, y \<xi>) \<noteq> 0"
        note \<xi>(2)
        also
        have "s \<noteq> t"
          using s_bound exceeds min not_max by (auto simp: dist_norm)
        hence "norm ((s - t0) *\<^sub>R f (\<xi>, y \<xi>)) < \<bar>t1 - t0\<bar> * norm (f (\<xi>, y \<xi>))"
          using s_bound f'_nonzero `t \<in> T` by (simp add: interval less_le)
        also
        have "\<xi> \<notin> {s \<in> {t0..t}. norm (x s - x t0) \<in> {b..}}"
        proof
          assume "\<xi> \<in> {s \<in> {t0..t}. norm (x s - x t0) \<in> {b..}}"
          with min have "dist t0 s \<le> dist t0 \<xi>" by simp
          thus "False" using s_bound \<xi> by (simp add: dist_real_def)
        qed
        with `\<xi> \<in> {t0..t}` have norm_lt: "norm (x \<xi> - x t0) < b"
          by auto
        hence "x \<xi> \<in> cball x0 b" by (auto simp: dist_norm[symmetric] dist_commute init)
        with cball_in_cube[of "x0" b]
        have "x \<xi> \<in> X" unfolding rectangle[symmetric] by (auto simp: scaleR_setsum_left)
        with \<xi> have "\<bar>t1 - t0\<bar> * norm (f (\<xi>, y \<xi>)) \<le> \<bar>t1 - t0\<bar> * B"
          using `\<xi> \<in> {t0..t1}`
          using norm_f y_bounded interval s_bound by (auto simp: interval)
        also
        have "... \<le> b" using `b>0` norm_f t1_bounded interval iv_defined `B>0`
          by (simp add: field_simps abs_real_def)
        finally
        show "norm (x s - x t0) < b" .
      qed
      moreover
      from exceeds have "norm (x s - x t0) \<ge> b" by simp
      ultimately show False by simp
    qed note mvt_result = this
    from cont assms have cont_diff: "continuous_on {t0..t} (\<lambda>xa. x xa - x t0)"
      by (auto intro!: continuous_intros continuous_on_subset[where t="{t0..t}"] simp: interval)
    have "norm (x t - x t0) \<le> b"
    proof (rule ccontr)
      assume H: "\<not> norm (x t - x t0) \<le> b"
      hence "norm (x t - x t0) \<ge> b" "t0 \<le> t" using assms interval by simp_all
      from IVT'[of "\<lambda>t. norm (x t - x t0)" t0 b t, OF _ this continuous_on_norm[OF cont_diff]]
      obtain s where s: "s\<ge>t0" "s \<le> t" "norm (x s - x t0) = b"
        using b_pos by auto
      have "s \<in> {s \<in> {t0..t}. norm (x s - x t0) \<in> {b..}}"
        using s `t \<in> T` by (auto simp: interval)
      with mvt_result have "s = t" by blast
      hence "s = t" using s `t \<in> T` by (auto simp: interval)
      with s H show False by simp
    qed
    hence "x t \<in> cball x0 b" using init
      by (auto simp: dist_commute dist_norm[symmetric])
    also note cball_in_cube
    finally show "x t \<in> X" unfolding rectangle .
  qed
qed

lemma integral_in_bounds:
  assumes "t \<in> T" "x t0 = x0" "x \<in> {t0..t} \<rightarrow> X"
  assumes cont: "continuous_on {t0..t} x"
  shows "x0 + integral {t0..t} (\<lambda>t. f (t, x t)) \<in> X" (is "x0 + ?ix t \<in> X")
proof -
  have cont_f:"continuous_on {t0..t} (\<lambda>t. f (t, x t))"
    using assms
    by (intro continuous_Sigma)
      (auto intro: cont continuous_on_subset[OF continuous] simp: interval)
  show ?thesis
    using assms
    by (intro in_bounds_derivativeI[where y=x and x="\<lambda>t. x0 + ?ix t"])
      (auto simp: interval intro!: cont_f integral_has_vector_derivative
      has_vector_derivative_const has_vector_derivative_add[THEN vector_derivative_eq_rhs]
      continuous_intros indefinite_integral_continuous)
qed

lemma solution_in_bounds:
  assumes "t \<in> T"
  assumes init: "x t0 = x0"
  assumes cont: "continuous_on {t0..t} x"
  assumes solves: "\<And>s. s \<in> {t0..t} \<Longrightarrow> (x has_vector_derivative f (s, x s)) (at s within {t0..t})"
  shows "x t \<in> X"
  using assms by (rule in_bounds_derivativeI)

lemma is_solution_eq_is_solution_on_supersetdomain:
  assumes "X \<subseteq> X'"
  shows "is_solution = ivp.is_solution (i\<lparr>ivp_X:=X'\<rparr>)"
proof -
  interpret ivp': ivp "i\<lparr>ivp_X:=X'\<rparr>" using iv_defined assms by unfold_locales auto
  show ?thesis using assms
  proof (safe intro!: ext)
   fix x assume "ivp'.is_solution x"
    moreover
    from ivp'.is_solutionD[OF this] ivp'.solution_continuous_on[OF this]
    have "\<And>t. t \<in> T \<Longrightarrow> x t \<in> X" using assms
      by (intro solution_in_bounds) (force simp: interval
        intro: continuous_on_subset has_vector_derivative_within_subset)+
    ultimately show "is_solution x"
      by (auto intro!: is_solutionI dest: ivp'.is_solutionD simp add: interval)
  qed (intro is_solution_on_superset_domain)
qed

end

text {* For the numerical approximation, it is necessary that f is
lipschitz-continuous outside the actual domain - therefore D'. *}

locale unique_on_rectangle =
  solution_in_rectangle + global_lipschitz!: global_lipschitz T X' f L for L X' +
  assumes lipschitz_on_domain: "X \<subseteq> X'"
begin

lemma lipschitz': "t \<in> T \<Longrightarrow> lipschitz X (\<lambda>x. f (t, x)) L" "0 \<le> L"
  using global_lipschitz.lipschitz lipschitz_on_domain
  by (auto intro: lipschitz_subset)

end

sublocale unique_on_rectangle \<subseteq> unique_on_closed
proof
  show "0 \<le> L" "closed X" using lipschitz' by (simp_all add: rectangle)
  fix t assume "t \<in> T" with lipschitz' show "lipschitz X (\<lambda>x. f (t, x)) L" by simp
qed (rule integral_in_bounds)

lemma (in unique_on_rectangle) unique_on_rectangle_subset:
  assumes "t0 \<le> t1'" "t1' \<le> t1"
  shows "unique_on_rectangle (i\<lparr>ivp_T:={t0..t1'}\<rparr>) t1' b B L X'"
  using iv_defined rectangle interval assms b_pos
    continuous_on_subset[OF continuous, of "{t0..t1'} \<times> X"]
    norm_f t1_bounded global_lipschitz.lipschitz lipschitz_on_domain
  by unfold_locales (fastforce simp: Times_subset_cancel2 order.trans[OF assms])+

locale unique_on_rectangle_superset = subset: unique_on_rectangle + fixes X'' assumes superset: "X' \<subseteq> X''"
begin

sublocale superset_domain: has_solution "i\<lparr>ivp_X:=X''\<rparr>"
  using iv_defined lipschitz_on_domain superset
  by unfold_locales (auto intro!: exI[where x=solution] is_solution_on_superset_domain)

lemma sup_solution_is_solution: "is_solution x \<Longrightarrow> subset.is_solution x"
  using assms lipschitz_on_domain superset
  by (subst is_solution_eq_is_solution_on_supersetdomain[of X'']) auto

lemma solutions_eq:
  "t \<in> T \<Longrightarrow> solution t = subset.solution t"
  using sup_solution_is_solution
  by (auto intro!: subset.unique_solution)

sublocale unique_solution "i\<lparr>ivp_X:=X''\<rparr>"
proof
  fix y t
  assume "t \<in> T" hence t: "t \<in> subset.T" by simp
  assume sol': "is_solution y"
  hence sol: "subset.is_solution y"
    by (rule sup_solution_is_solution)
  from unique_solution[OF sol t] have "y t = subset.solution t" .
  also
  note solutions_eq[OF `t \<in> T`, symmetric]
  finally show "y t = ivp.solution (i\<lparr>ivp_X := X''\<rparr>) t" .
qed

end

locale unique_of_superset =
  sub: has_solution +
  super: unique_solution "i\<lparr>ivp_X:=X'\<rparr>" for X' +
  assumes subset: "sub.X \<subseteq> X'"
begin

lemma sub_is_solution: "super.is_solution sub.solution"
  using sub.is_solutionD[OF sub.is_solution_solution] subset
  by (intro is_solutionI) auto

lemma sub_eq_sup_solution: "\<And>t. t \<in> T \<Longrightarrow> sub.solution t = super.solution t"
  by (auto intro!: super.unique_solution sub_is_solution)

sublocale unique_solution
proof
  fix y t
  assume "sub.is_solution y"
    and "t \<in> sub.T"
  from this have t: "t \<in> super.T"
    and y: "super.is_solution y"
    by (auto intro!: sub.is_solution_on_superset_domain[OF _ subset])
  show "y t = sub.solution t"
    using y
    unfolding sub_eq_sup_solution[OF t]
    by (rule super.unique_solution[OF _ t])
qed

end

locale derivative_on_convex =
  fixes T X and f::"(real \<times> 'a::ordered_euclidean_space) \<Rightarrow> 'a" and f'
  assumes convex: "convex T" "convex X"
  assumes nonempty: "T \<noteq> {}" "X \<noteq> {}"
  assumes f': "\<And>t x. t \<in> T \<Longrightarrow> x \<in> X \<Longrightarrow> (f has_derivative f' (t, x)) (at (t, x) within (T \<times> X))"

locale compact_domain =
  fixes X assumes compact: "compact X"

lemma norm_scale_inverse_self: "norm (x /\<^sub>R norm x) \<le> 1"
  by (auto simp: inverse_eq_divide)

locale continuously_diff =
  fixes f'::"(real \<times> 'a::ordered_euclidean_space) \<Rightarrow> (real \<times> 'a::ordered_euclidean_space) \<Rightarrow> 'a"
  assumes cont_diff: "continuous_on ((T\<times>X)\<times>cball 0 1) (\<lambda>(tx, dtdx). f' tx dtdx)"

locale compact_continuously_diff =
  compact_domain X +
  derivative_on_convex T X f f' +
  continuously_diff f' for T X f f' +
  assumes compact_domain1: "compact T"
  assumes nonempty_domains: "T \<noteq> {}" "X \<noteq> {}"
begin

lemma ex_onorm_bound:
  "\<exists>B. \<forall>t x. t \<in> T \<longrightarrow> x \<in> X \<longrightarrow> onorm (f' (t, x)) \<le> B"
proof -
  have "compact ((\<lambda>(tx, dtdx). f' tx dtdx) ` ((T \<times> X) \<times> cball 0 1))" (is "compact ?F'")
    by (rule compact_continuous_image[OF cont_diff])
      (auto intro!: compact_Times compact_domain1 compact)
  hence "bounded ?F'"
    by (rule compact_imp_bounded)
  then obtain B where B: "\<And>x. x\<in>?F' \<Longrightarrow> norm x \<le> B" unfolding bounded_iff by blast
  show ?thesis
  proof (rule exI[where x= B], safe)
    fix t x assume "t \<in> T" "x \<in> X"
    interpret bounded_linear "f' (t, x)"
      by (auto simp: algebra_simps intro!: has_derivative_bounded_linear[OF f'[OF `t \<in> T` `x \<in> X`]])
    show "onorm (f' (t, x)) \<le> B"
    proof (rule onorm_le, safe)
      fix a b
      from scaleR[of "inverse (norm (a, b))" "(a, b)"]
      have "norm (f' (t, x) (a, b)) =
          norm (f' (t, x) (inverse (norm (a, b)) *\<^sub>R (a, b))) * norm (a, b)" (is "_ = ?f * _")
        by (auto simp: field_simps) (simp add: zero_prod_def)
      also
      have uball: "(a, b) /\<^sub>R norm (a, b) \<in> cball 0 1"
        unfolding cball_def
        apply rule
        apply (subst dist_commute)
        apply (subst norm_conv_dist[symmetric])
        apply (rule norm_scale_inverse_self)
        done
      hence "?f \<le> B"
        using `t \<in> T` `x \<in> X` by (safe intro!: pair_imageI B)
      finally show "norm (f' (t, x) (a, b)) \<le> B * norm (a, b)" by (auto simp: mult_right_mono)
    qed
  qed
qed

definition "onorm_bound = (SOME B. \<forall>t x. t \<in> T \<longrightarrow> x \<in> X \<longrightarrow> onorm (f' (t, x)) \<le> B)"

lemma onorm_bound: assumes "t \<in> T" "x \<in> X" shows "onorm (f' (t, x)) \<le> onorm_bound"
  unfolding onorm_bound_def
  using someI_ex[OF ex_onorm_bound] assms
  by blast

sublocale closed_domain X
  using compact by (unfold_locales) (rule compact_imp_closed)

sublocale global_lipschitz T X f onorm_bound
proof (unfold_locales, rule lipschitzI)
  fix t x y
  assume txy: "t \<in> T" "x \<in> X" "y \<in> X"
  from onorm_bound have "norm (f (t, x) - f (t, y)) \<le> onorm_bound * norm ((t, x) - (t, y))"
    using txy
    by (intro differentiable_bound) (auto intro!: f' convex_Times[OF convex])
  thus "dist (f (t, x)) (f (t, y)) \<le> onorm_bound * dist x y"
    by (auto simp: dist_norm norm_Pair)
next
  from nonempty_domains obtain t x where t: "t \<in> T" and x: "x \<in> X" by auto
  show "0 \<le> onorm_bound"
    apply (rule order_trans)
    apply (rule onorm_pos_le)
    apply (rule has_derivative_bounded_linear[OF f'[OF t x]])
    apply (rule onorm_bound[OF t x])
    done
qed

end

locale unique_on_closed_cont_diff =
  self_mapping +
  continuous T X f +
  compact_domain X +
  derivative_on_convex T X f +
  continuously_diff f'
begin

sublocale compact_continuously_diff T X f f'
  using iv_defined
  by unfold_locales (auto simp: interval)

sublocale unique_on_closed i t1 onorm_bound
  by unfold_locales

end

end


(*
  File: Interval_Tree.thy
  Author: Bohua Zhan
*)

section \<open>Interval tree\<close>

theory Interval_Tree
  imports Lists_Ex Interval
begin

text \<open>
  Functional version of interval tree. This is an augmented data
  structure on top of regular binary search trees (see BST.thy).
  See \<^cite>\<open>\<open>Section 14.3\<close> in "cormen2009introduction"\<close> for a reference.
\<close>

subsection \<open>Definition of an interval tree\<close>

datatype interval_tree =
   Tip
 | Node (lsub: interval_tree) (val: "nat idx_interval") (tmax: nat) (rsub: interval_tree)
where
  "tmax Tip = 0"

setup \<open>add_resolve_prfstep @{thm interval_tree.distinct(1)}\<close>
setup \<open>fold add_rewrite_rule @{thms interval_tree.sel}\<close>
setup \<open>add_forward_prfstep @{thm interval_tree.collapse}\<close>
setup \<open>add_var_induct_rule @{thm interval_tree.induct}\<close>

subsection \<open>Inorder traversal, and set of elements of a tree\<close>

fun in_traverse :: "interval_tree \<Rightarrow> nat idx_interval list" where
  "in_traverse Tip = []"
| "in_traverse (Node l it m r) = in_traverse l @ it # in_traverse r"
setup \<open>fold add_rewrite_rule @{thms in_traverse.simps}\<close>

fun tree_set :: "interval_tree \<Rightarrow> nat idx_interval set" where
  "tree_set Tip = {}"
| "tree_set (Node l it m r) = {it} \<union> tree_set l \<union> tree_set r"
setup \<open>fold add_rewrite_rule @{thms tree_set.simps}\<close>

fun tree_sorted :: "interval_tree \<Rightarrow> bool" where
  "tree_sorted Tip = True"
| "tree_sorted (Node l it m r) = ((\<forall>x\<in>tree_set l. x < it) \<and> (\<forall>x\<in>tree_set r. it < x)
                                   \<and> tree_sorted l \<and> tree_sorted r)"
setup \<open>fold add_rewrite_rule @{thms tree_sorted.simps}\<close>

lemma tree_sorted_lr [forward]:
  "tree_sorted (Node l it m r) \<Longrightarrow> tree_sorted l \<and> tree_sorted r" by auto2

lemma tree_sortedD1 [forward]:
  "tree_sorted (Node l it m r) \<Longrightarrow> x \<in> tree_set l \<Longrightarrow> x < it" by auto2

lemma tree_sortedD2 [forward]:
  "tree_sorted (Node l it m r) \<Longrightarrow> x \<in> tree_set r \<Longrightarrow> x > it" by auto2

lemma inorder_preserve_set [rewrite]:
  "tree_set t = set (in_traverse t)"
@proof @induct t @qed

lemma inorder_sorted [rewrite]:
  "tree_sorted t \<longleftrightarrow> strict_sorted (in_traverse t)"
@proof @induct t @qed

text \<open>Use definition in terms of in\_traverse from now on.\<close>
setup \<open>fold del_prfstep_thm (@{thms tree_set.simps} @ @{thms tree_sorted.simps})\<close>

subsection \<open>Invariant on the maximum\<close>

definition max3 :: "nat idx_interval \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where [rewrite]:
  "max3 it b c = max (high (int it)) (max b c)"

fun tree_max_inv :: "interval_tree \<Rightarrow> bool" where
  "tree_max_inv Tip = True"
| "tree_max_inv (Node l it m r) \<longleftrightarrow> (tree_max_inv l \<and> tree_max_inv r \<and> m = max3 it (tmax l) (tmax r))"
setup \<open>fold add_rewrite_rule @{thms tree_max_inv.simps}\<close>

lemma tree_max_is_max [resolve]:
  "tree_max_inv t \<Longrightarrow> it \<in> tree_set t \<Longrightarrow> high (int it) \<le> tmax t"
@proof @induct t @qed

lemma tmax_exists [backward]:
  "tree_max_inv t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> \<exists>p\<in>tree_set t. high (int p) = tmax t"
@proof @induct t @with
  @subgoal "t = Node l it m r"
    @case "l = Tip" @with @case "r = Tip" @end
    @case "r = Tip"
  @endgoal @end
@qed

text \<open>For insertion\<close>
lemma max3_insert [rewrite]: "max3 it 0 0 = high (int it)" by auto2

setup \<open>del_prfstep_thm @{thm max3_def}\<close>

subsection \<open>Condition on the values\<close>

definition tree_interval_inv :: "interval_tree \<Rightarrow> bool" where [rewrite]:
  "tree_interval_inv t \<longleftrightarrow> (\<forall>p\<in>tree_set t. is_interval (int p))"

definition is_interval_tree :: "interval_tree \<Rightarrow> bool" where [rewrite]:
  "is_interval_tree t \<longleftrightarrow> (tree_sorted t \<and> tree_max_inv t \<and> tree_interval_inv t)"

lemma is_interval_tree_lr [forward]:
  "is_interval_tree (Node l x m r) \<Longrightarrow> is_interval_tree l \<and> is_interval_tree r" by auto2

subsection \<open>Insertion on trees\<close>

fun insert :: "nat idx_interval \<Rightarrow> interval_tree \<Rightarrow> interval_tree" where
  "insert x Tip = Node Tip x (high (int x)) Tip"
| "insert x (Node l y m r) =
    (if x = y then Node l y m r
     else if x < y then
       let l' = insert x l in
           Node l' y (max3 y (tmax l') (tmax r)) r
     else
       let r' = insert x r in
           Node l y (max3 y (tmax l) (tmax r')) r')"
setup \<open>fold add_rewrite_rule @{thms insert.simps}\<close>

lemma tree_insert_in_traverse [rewrite]:
  "tree_sorted t \<Longrightarrow> in_traverse (insert x t) = ordered_insert x (in_traverse t)"
@proof @induct t @qed

lemma tree_insert_max_inv [forward]:
  "tree_max_inv t \<Longrightarrow> tree_max_inv (insert x t)"
@proof @induct t @qed

text \<open>Correctness of insertion.\<close>

theorem tree_insert_on_set [rewrite]:
  "tree_sorted t \<Longrightarrow> tree_set (insert it t) = {it} \<union> tree_set t" by auto2

subsection \<open>Deletion on trees\<close>

fun del_min :: "interval_tree \<Rightarrow> nat idx_interval \<times> interval_tree" where
  "del_min Tip = undefined"
| "del_min (Node lt v m rt) =
   (if lt = Tip then (v, rt) else
    let lt' = snd (del_min lt) in
    (fst (del_min lt), Node lt' v (max3 v (tmax lt') (tmax rt)) rt))"
setup \<open>add_rewrite_rule @{thm del_min.simps(2)}\<close>
setup \<open>register_wellform_data ("del_min t", ["t \<noteq> Tip"])\<close>

lemma delete_min_del_hd:
  "t \<noteq> Tip \<Longrightarrow> fst (del_min t) # in_traverse (snd (del_min t)) = in_traverse t"
@proof @induct t @qed
setup \<open>add_forward_prfstep_cond @{thm delete_min_del_hd} [with_term "in_traverse (snd (del_min ?t))"]\<close>

lemma delete_min_max_inv [forward_arg]:
  "tree_max_inv t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> tree_max_inv (snd (del_min t))"
@proof @induct t @qed

lemma delete_min_on_set:
  "t \<noteq> Tip \<Longrightarrow> {fst (del_min t)} \<union> tree_set (snd (del_min t)) = tree_set t" by auto2
setup \<open>add_forward_prfstep_cond @{thm delete_min_on_set} [with_term "tree_set (snd (del_min ?t))"]\<close>

lemma delete_min_interval_inv [forward_arg]:
  "tree_interval_inv t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> tree_interval_inv (snd (del_min t))" by auto2

lemma delete_min_all_inv [forward_arg]:
  "is_interval_tree t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> is_interval_tree (snd (del_min t))" by auto2

fun delete_elt_tree :: "interval_tree \<Rightarrow> interval_tree" where
  "delete_elt_tree Tip = undefined"
| "delete_elt_tree (Node lt x m rt) =
    (if lt = Tip then rt else if rt = Tip then lt else
     let x' = fst (del_min rt);
         rt' = snd (del_min rt);
         m' = max3 x' (tmax lt) (tmax rt') in
       Node lt (fst (del_min rt)) m' rt')"
setup \<open>add_rewrite_rule @{thm delete_elt_tree.simps(2)}\<close>

lemma delete_elt_in_traverse [rewrite]:
  "in_traverse (delete_elt_tree (Node lt x m rt)) = in_traverse lt @ in_traverse rt" by auto2

lemma delete_elt_max_inv [forward_arg]:
  "tree_max_inv t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> tree_max_inv (delete_elt_tree t)" by auto2

lemma delete_elt_on_set [rewrite]:
  "t \<noteq> Tip \<Longrightarrow> tree_set (delete_elt_tree (Node lt x m rt)) = tree_set lt \<union> tree_set rt" by auto2

lemma delete_elt_interval_inv [forward_arg]:
  "tree_interval_inv t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> tree_interval_inv (delete_elt_tree t)" by auto2

lemma delete_elt_all_inv [forward_arg]:
  "is_interval_tree t \<Longrightarrow> t \<noteq> Tip \<Longrightarrow> is_interval_tree (delete_elt_tree t)" by auto2

fun delete :: "nat idx_interval \<Rightarrow> interval_tree \<Rightarrow> interval_tree" where
  "delete x Tip = Tip"
| "delete x (Node l y m r) =
    (if x = y then delete_elt_tree (Node l y m r)
     else if x < y then
       let l' = delete x l;
           m' = max3 y (tmax l') (tmax r) in Node l' y m' r
     else
       let r' = delete x r;
           m' = max3 y (tmax l) (tmax r') in Node l y m' r')"
setup \<open>fold add_rewrite_rule @{thms delete.simps}\<close>

lemma tree_delete_in_traverse [rewrite]:
  "tree_sorted t \<Longrightarrow> in_traverse (delete x t) = remove_elt_list x (in_traverse t)"
@proof @induct t @qed

lemma tree_delete_max_inv [forward]:
  "tree_max_inv t \<Longrightarrow> tree_max_inv (delete x t)"
@proof @induct t @qed

text \<open>Correctness of deletion.\<close>
theorem tree_delete_all_inv [forward]:
  "is_interval_tree t \<Longrightarrow> is_interval_tree (delete x t)"
@proof @have "tree_set (delete x t) \<subseteq> tree_set t" @qed

theorem tree_delete_on_set [rewrite]:
  "tree_sorted t \<Longrightarrow> tree_set (delete x t) = tree_set t - {x}" by auto2

subsection \<open>Search on interval trees\<close>

fun search :: "interval_tree \<Rightarrow> nat interval \<Rightarrow> bool" where
  "search Tip x = False"
| "search (Node l y m r) x =
   (if is_overlap (int y) x then True
    else if l \<noteq> Tip \<and> tmax l \<ge> low x then search l x
    else search r x)"
setup \<open>fold add_rewrite_rule @{thms search.simps}\<close>

text \<open>Correctness of search\<close>
theorem search_correct [rewrite]:
  "is_interval_tree t \<Longrightarrow> is_interval x \<Longrightarrow> search t x \<longleftrightarrow> has_overlap (tree_set t) x"
@proof
  @induct t @with
    @subgoal "t = Node l y m r"
      @let "t = Node l y m r"
      @case "is_overlap (int y) x"
      @case "l \<noteq> Tip \<and> tmax l \<ge> low x" @with
        @obtain "p\<in>tree_set l" where "high (int p) = tmax l"
        @case "is_overlap (int p) x"
      @end
      @case "l = Tip"
    @endgoal
  @end
@qed

end


(*  Title:      HOL/Nitpick_Examples/Hotel_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2010-2011

Nitpick example based on Tobias Nipkow's hotel key card formalization.
*)

section \<open>Nitpick Example Based on Tobias Nipkow's Hotel Key Card
          Formalization\<close>

theory Hotel_Nits
imports Main
begin

nitpick_params [verbose, max_potential = 0, sat_solver = MiniSat_JNI,
                max_threads = 1, timeout = 240]

typedecl guest
typedecl key
typedecl room

type_synonym keycard = "key \<times> key"

record state =
  owns :: "room \<Rightarrow> guest option"
  currk :: "room \<Rightarrow> key"
  issued :: "key set"
  cards :: "guest \<Rightarrow> keycard set"
  roomk :: "room \<Rightarrow> key"
  isin :: "room \<Rightarrow> guest set"
  safe :: "room \<Rightarrow> bool"

inductive_set reach :: "state set" where
init:
"inj initk \<Longrightarrow>
 \<lparr>owns = (\<lambda>r. None), currk = initk, issued = range initk, cards = (\<lambda>g. {}),
  roomk = initk, isin = (\<lambda>r. {}), safe = (\<lambda>r. True)\<rparr> \<in> reach" |
check_in:
"\<lbrakk>s \<in> reach; k \<notin> issued s\<rbrakk> \<Longrightarrow>
 s\<lparr>currk := (currk s)(r := k), issued := issued s \<union> {k},
   cards := (cards s)(g := cards s g \<union> {(currk s r, k)}),
   owns :=  (owns s)(r := Some g), safe := (safe s)(r := False)\<rparr> \<in> reach" |
enter_room:
"\<lbrakk>s \<in> reach; (k,k') \<in> cards s g; roomk s r \<in> {k,k'}\<rbrakk> \<Longrightarrow>
 s\<lparr>isin := (isin s)(r := isin s r \<union> {g}),
   roomk := (roomk s)(r := k'),
   safe := (safe s)(r := owns s r = Some g \<and> isin s r = {} \<^cancel>\<open>\<and> k' = currk s r\<close>
                         \<or> safe s r)\<rparr> \<in> reach" |
exit_room:
"\<lbrakk>s \<in> reach; g \<in> isin s r\<rbrakk> \<Longrightarrow> s\<lparr>isin := (isin s)(r := isin s r - {g})\<rparr> \<in> reach"

theorem safe: "s \<in> reach \<Longrightarrow> safe s r \<Longrightarrow> g \<in> isin s r \<Longrightarrow> owns s r = Some g"
nitpick [card room = 1, card guest = 2, card "guest option" = 3,
         card key = 4, card state = 6, show_consts, format = 2,
         expect = genuine]
(* nitpick [card room = 1, card guest = 2, expect = genuine] *) (* slow *)
oops

end