(* Title:  Digraph_Component.thy
   Author: Lars Noschinski, TU München
*)

theory Digraph_Component
imports
  Digraph
  Arc_Walk
  Pair_Digraph
begin

section {* Components of (Symmetric) Digraphs *}

definition compatible :: "('a,'b) pre_digraph \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> bool" where
  "compatible G H \<equiv> tail G = tail H \<and> head G = head H"

(* Require @{term "wf_digraph G"}? *)
definition subgraph :: "('a,'b) pre_digraph \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> bool" where
  "subgraph H G \<equiv> verts H \<subseteq> verts G \<and> arcs H \<subseteq> arcs G \<and> wf_digraph G \<and> wf_digraph H \<and> compatible G H"

definition induced_subgraph :: "('a,'b) pre_digraph \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> bool" where
  "induced_subgraph H G \<equiv> subgraph H G \<and> arcs H = {e \<in> arcs G. tail G e \<in> verts H \<and> head G e \<in> verts H}"

definition spanning :: "('a,'b) pre_digraph \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> bool" where
  "spanning H G \<equiv> subgraph H G \<and> verts G = verts H"

definition strongly_connected :: "('a,'b) pre_digraph \<Rightarrow> bool" where
  "strongly_connected G \<equiv> verts G \<noteq> {} \<and> (\<forall>u \<in> verts G. \<forall>v \<in> verts G. u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v)"

text {*
  The following function computes underlying symmetric graph of a digraph
  and removes parallel arcs.
*}

definition mk_symmetric :: "('a,'b) pre_digraph \<Rightarrow> 'a pair_pre_digraph" where
  "mk_symmetric G \<equiv> \<lparr> pverts = verts G, parcs = \<Union>e\<in>arcs G. {(tail G e, head G e), (head G e, tail G e)}\<rparr>"

definition connected :: "('a,'b) pre_digraph \<Rightarrow> bool" where
  "connected G \<equiv> strongly_connected (mk_symmetric G)"

definition forest :: "('a,'b) pre_digraph \<Rightarrow> bool" where
  "forest G \<equiv> \<not>(\<exists>p. pre_digraph.cycle G p)"

definition tree :: "('a,'b) pre_digraph \<Rightarrow> bool" where
  "tree G \<equiv> connected G \<and> forest G"

definition spanning_tree :: "('a,'b) pre_digraph \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> bool" where
  "spanning_tree H G \<equiv> tree H \<and> spanning H G"

definition (in pre_digraph) sccs :: "('a,'b) pre_digraph set" where
  "sccs \<equiv> {H. induced_subgraph H G \<and> strongly_connected H \<and> \<not>(\<exists>H'. induced_subgraph H' G
      \<and> strongly_connected H' \<and> verts H \<subset> verts H')}"

definition union :: "('a,'b) pre_digraph \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> ('a,'b) pre_digraph" where
  "union G H \<equiv> \<lparr> verts = verts G \<union> verts H, arcs = arcs G \<union> arcs H, tail = tail G, head = head G\<rparr>"

definition (in pre_digraph) Union :: "('a,'b) pre_digraph set \<Rightarrow> ('a,'b) pre_digraph" where
  "Union gs = \<lparr> verts = (\<Union>G \<in> gs. verts G), arcs = (\<Union>G \<in> gs. arcs G),
    tail = tail G , head = head G  \<rparr>"

subsection {* Compatible Graphs *}

lemma compatible_tail:
  assumes "compatible G H" shows "tail G = tail H"
  using assms by (simp add: fun_eq_iff compatible_def)

lemma compatible_head:
  assumes "compatible G H" shows "head G = head H"
  using assms by (simp add: fun_eq_iff compatible_def)

lemma compatible_cas:
  assumes "compatible G H" shows "pre_digraph.cas G = pre_digraph.cas H"
proof (unfold fun_eq_iff, intro allI)
  fix u es v show "pre_digraph.cas G u es v = pre_digraph.cas H u es v"
    using assms
    by (induct es arbitrary: u)
       (simp_all add: pre_digraph.cas.simps compatible_head compatible_tail)
qed

lemma compatible_awalk_verts:
  assumes "compatible G H" shows "pre_digraph.awalk_verts G = pre_digraph.awalk_verts H"
proof (unfold fun_eq_iff, intro allI)
  fix u es show "pre_digraph.awalk_verts G u es = pre_digraph.awalk_verts H u es"
    using assms
    by (induct es arbitrary: u)
       (simp_all add: pre_digraph.awalk_verts.simps compatible_head compatible_tail)
qed

lemma compatibleI_with_proj[intro]:
  shows "compatible (with_proj G) (with_proj H)"
  by (auto simp: compatible_def)

subsection {* Basic lemmas *}

lemma (in sym_digraph) graph_symmetric:
  shows "(u,v) \<in> arcs_ends G \<Longrightarrow> (v,u) \<in> arcs_ends G"
  using assms sym_arcs by (auto simp add: symmetric_def sym_def)

lemma strongly_connectedI[intro]:
  assumes "verts G \<noteq> {}" "\<And>u v. u \<in> verts G \<Longrightarrow> v \<in> verts G \<Longrightarrow> u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
  shows "strongly_connected G"
using assms by (simp add: strongly_connected_def)

lemma strongly_connectedE[elim]:
  assumes "strongly_connected G"
  assumes "(\<And>u v. u \<in> verts G \<and> v \<in> verts G \<Longrightarrow> u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v) \<Longrightarrow> P"
  shows "P"
using assms by (auto simp add: strongly_connected_def)

lemma subgraph_imp_subverts:
  assumes "subgraph H G"
  shows "verts H \<subseteq> verts G"
using assms by (simp add: subgraph_def)

lemma induced_imp_subgraph:
  assumes "induced_subgraph H G"
  shows "subgraph H G"
using assms by (simp add: induced_subgraph_def)

lemma (in pre_digraph) in_sccs_imp_induced:
  assumes "c \<in> sccs"
  shows "induced_subgraph c G"
using assms by (auto simp: sccs_def)

lemma spanning_tree_imp_tree[dest]:
  assumes "spanning_tree H G"
  shows "tree H"
using assms by (simp add: spanning_tree_def)

lemma tree_imp_connected[dest]:
  assumes "tree G"
  shows "connected G"
using assms by (simp add: tree_def)

lemma spanning_treeI[intro]:
  assumes "spanning H G"
  assumes "tree H"
  shows "spanning_tree H G"
using assms by (simp add: spanning_tree_def)

lemma spanning_treeE[elim]:
  assumes "spanning_tree H G"
  assumes "tree H \<and> spanning H G \<Longrightarrow> P"
  shows "P"
using assms by (simp add: spanning_tree_def)

lemma spanningE[elim]:
  assumes "spanning H G"
  assumes "subgraph H G \<and> verts G = verts H \<Longrightarrow> P"
  shows "P"
using assms by (simp add: spanning_def)

lemma (in pre_digraph) in_sccsI[intro]:
  assumes "induced_subgraph c G"
  assumes "strongly_connected c"
  assumes "\<not>(\<exists>c'. induced_subgraph c' G \<and> strongly_connected c' \<and>
    verts c \<subset> verts c')"
  shows "c \<in> sccs"
using assms by (auto simp add: sccs_def)

lemma (in pre_digraph) in_sccsE[elim]:
  assumes "c \<in> sccs"
  assumes "induced_subgraph c G \<Longrightarrow> strongly_connected c \<Longrightarrow> \<not> (\<exists>d.
    induced_subgraph d G \<and> strongly_connected d \<and> verts c \<subset> verts d) \<Longrightarrow> P"
  shows "P"
using assms by (simp add: sccs_def)

lemma subgraphI:
  assumes "verts H \<subseteq> verts G"
  assumes "arcs H \<subseteq> arcs G"
  assumes "compatible G H"
  assumes "wf_digraph H"
  assumes "wf_digraph G"
  shows "subgraph H G"
using assms by (auto simp add: subgraph_def)

lemma subgraphE[elim]:
  assumes "subgraph H G"
  obtains "verts H \<subseteq> verts G" "arcs H \<subseteq> arcs G" "compatible G H" "wf_digraph H" "wf_digraph G"
using assms by (simp add: subgraph_def)

lemma induced_subgraphI[intro]:
  assumes "subgraph H G"
  assumes "arcs H = {e \<in> arcs G. tail G e \<in> verts H \<and> head G e \<in> verts H}"
  shows "induced_subgraph H G"
using assms unfolding induced_subgraph_def by safe

lemma induced_subgraphE[elim]:
  assumes "induced_subgraph H G"
  assumes "\<lbrakk>subgraph H G; arcs H = {e \<in> arcs G. tail G e \<in> verts H \<and> head G e \<in> verts H}\<rbrakk> \<Longrightarrow> P"
  shows "P"
using assms by (auto simp add: induced_subgraph_def)

lemma pverts_mk_symmetric[simp]: "pverts (mk_symmetric G) = verts G"
  and parcs_mk_symmetric:
    "parcs (mk_symmetric G) = (\<Union>e\<in>arcs G. {(tail G e, head G e), (head G e, tail G e)})"
  by (auto simp: mk_symmetric_def arcs_ends_conv image_UN)

lemma arcs_ends_mono:
  assumes "subgraph H G"
  shows "arcs_ends H \<subseteq> arcs_ends G"
  using assms by (auto simp add: subgraph_def arcs_ends_conv compatible_tail compatible_head)

lemma (in wf_digraph) subgraph_refl: "subgraph G G"
  by (auto simp: subgraph_def compatible_def) unfold_locales

subsection {* The underlying symmetric graph of a digraph *}

lemma (in wf_digraph) wellformed_mk_symmetric[intro]: "pair_wf_digraph (mk_symmetric G)"
  by unfold_locales (auto simp: parcs_mk_symmetric)

lemma (in fin_digraph) pair_fin_digraph_mk_symmetric[intro]: "pair_fin_digraph (mk_symmetric G)"
proof -
  have "finite ((\<lambda>(a,b). (b,a)) ` arcs_ends G)" (is "finite ?X") by (auto simp: arcs_ends_conv)
  also have "?X = {(a, b). (b, a) \<in> arcs_ends G}" by auto
  finally have X: "finite ..." .
  then show ?thesis
    by unfold_locales (auto simp: mk_symmetric_def arcs_ends_conv)
qed

lemma (in digraph) digraph_mk_symmetric[intro]: "pair_digraph (mk_symmetric G)"
proof -
  have "finite ((\<lambda>(a,b). (b,a)) ` arcs_ends G)" (is "finite ?X") by (auto simp: arcs_ends_conv)
  also have "?X = {(a, b). (b, a) \<in> arcs_ends G}" by auto
  finally have "finite ..." .
  then show ?thesis
    by unfold_locales (auto simp: mk_symmetric_def arc_to_ends_def dest: no_loops)
qed

lemma (in wf_digraph) reachable_mk_symmetricI:
  assumes "u \<rightarrow>\<^sup>* v" shows "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> v"
proof -
  have "arcs_ends G \<subseteq> parcs (mk_symmetric G)"
       "(u, v) \<in> rtrancl_on (pverts (mk_symmetric G)) (arcs_ends G)"
    using assms unfolding reachable_def by (auto simp: parcs_mk_symmetric)
  then show ?thesis unfolding reachable_def by (auto intro: rtrancl_on_mono)
qed

lemma (in wf_digraph) adj_mk_symmetric_eq:
  "symmetric G \<Longrightarrow> parcs (mk_symmetric G) = arcs_ends G"
  by (auto simp: parcs_mk_symmetric in_arcs_imp_in_arcs_ends arcs_ends_symmetric)

lemma (in wf_digraph) reachable_mk_symmetric_eq:
  assumes "symmetric G" shows "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> v \<longleftrightarrow> u \<rightarrow>\<^sup>* v" (is "?L \<longleftrightarrow> ?R")
  using adj_mk_symmetric_eq[OF assms] unfolding reachable_def by auto

lemma (in wf_digraph) mk_symmetric_awalk_imp_awalk:
  assumes sym: "symmetric G"
  assumes walk: "pre_digraph.awalk (mk_symmetric G) u p v"
  obtains q where "awalk u q v"
proof -
  interpret S: pair_wf_digraph "mk_symmetric G" ..
  from walk have "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> v"
    by (simp only: S.reachable_awalk) rule
  then have "u \<rightarrow>\<^sup>* v" by (simp only: reachable_mk_symmetric_eq[OF sym])
  then show ?thesis by (auto simp: reachable_awalk intro: that)
qed

lemma symmetric_mk_symmetric:
  "symmetric (mk_symmetric G)"
  by (auto simp: symmetric_def parcs_mk_symmetric intro: symI)

subsection {* Subgraphs and Induced Subgraphs *}

lemma subgraph_trans:
  assumes "subgraph G H" "subgraph H I" shows "subgraph G I"
  using assms by (auto simp: subgraph_def compatible_def)

text {*
  The @{term digraph} and @{term fin_digraph} properties are preserved under
  the (inverse) subgraph relation
*}
lemma (in fin_digraph) fin_digraph_subgraph:
  assumes "subgraph H G" shows "fin_digraph H"
proof (intro_locales)
  from assms show "wf_digraph H" by auto

  have HG: "arcs H \<subseteq> arcs G" "verts H \<subseteq> verts G"
    using assms by auto
  then have "finite (verts H)" "finite (arcs H)"
    using finite_verts finite_arcs by (blast intro: finite_subset)+
  then show "fin_digraph_axioms H"
    by unfold_locales
qed

lemma (in digraph) digraph_subgraph:
  assumes "subgraph H G" shows "digraph H"
proof
  fix e assume e: "e \<in> arcs H"
  with assms show "tail H e \<in> verts H" "head H e \<in> verts H"
    by (auto simp: subgraph_def intro: wf_digraph.wellformed)
  from e and assms have "e \<in> arcs H \<inter> arcs G" by auto
  with assms show "tail H e \<noteq> head H e"
    using no_loops by (auto simp: subgraph_def compatible_def arc_to_ends_def)
next
  have "arcs H \<subseteq> arcs G" "verts H \<subseteq> verts G" using assms by auto
  then show "finite (arcs H)" "finite (verts H)"
    using finite_verts finite_arcs by (blast intro: finite_subset)+
next
  fix e1 e2 assume "e1 \<in> arcs H" "e2 \<in> arcs H"
    and eq: "arc_to_ends H e1 = arc_to_ends H e2"
  with assms have "e1 \<in> arcs H \<inter> arcs G" "e2 \<in> arcs H \<inter> arcs G"
    by auto
  with eq show "e1 = e2"
    using no_multi_arcs assms
    by (auto simp: subgraph_def compatible_def arc_to_ends_def)
qed

lemma (in pre_digraph) adj_mono:
  assumes "u \<rightarrow>\<^bsub>H\<^esub> v" "subgraph H G"
  shows "u \<rightarrow> v"
  using assms by (blast dest: arcs_ends_mono)

lemma (in pre_digraph) reachable_mono:
  assumes walk: "u \<rightarrow>\<^sup>*\<^bsub>H\<^esub> v" and sub: "subgraph H G"
  shows "u \<rightarrow>\<^sup>* v"
proof -
  have "verts H \<subseteq> verts G" using sub by auto
  with assms show ?thesis
    unfolding reachable_def by (metis arcs_ends_mono rtrancl_on_mono)
qed

text {*
  Arc walks and paths are preserved under the subgraph relation.
*}
lemma (in wf_digraph) subgraph_awalk_imp_awalk:
  assumes walk: "pre_digraph.awalk H u p v"
  assumes sub: "subgraph H G"
  shows "awalk u p v"
  using assms by (auto simp: pre_digraph.awalk_def compatible_cas)

lemma (in wf_digraph) subgraph_apath_imp_apath:
  assumes path: "pre_digraph.apath H u p v"
  assumes sub: "subgraph H G"
  shows "apath u p v"
  using assms unfolding pre_digraph.apath_def
  by (auto intro: subgraph_awalk_imp_awalk simp: compatible_awalk_verts)

lemma subgraph_mk_symmetric:
  assumes "subgraph H G"
  shows "subgraph (mk_symmetric H) (mk_symmetric G)"
proof (rule subgraphI)
  let ?wpms = "\<lambda>G. mk_symmetric G"
  from assms have "compatible G H" by auto
  with assms
  show "verts (?wpms H)  \<subseteq> verts (?wpms G)"
    and "arcs (?wpms H) \<subseteq> arcs (?wpms G)"
    by (auto simp: parcs_mk_symmetric compatible_head compatible_tail)
  show "compatible (?wpms G) (?wpms H)" by rule
  interpret H: pair_wf_digraph "mk_symmetric H"
    using assms by (auto intro: wf_digraph.wellformed_mk_symmetric)
  interpret G: pair_wf_digraph "mk_symmetric G"
    using assms by (auto intro: wf_digraph.wellformed_mk_symmetric)
  show "wf_digraph (?wpms H)"
    by unfold_locales
  show "wf_digraph (?wpms G)" by unfold_locales
qed

lemma (in fin_digraph) subgraph_in_degree:
  assumes "subgraph H G"
  shows "in_degree H v \<le> in_degree G v"
proof -
  have "finite (in_arcs G v)" by auto
  moreover
  have "in_arcs H v \<subseteq> in_arcs G v"
    using assms by (auto simp: subgraph_def in_arcs_def compatible_head compatible_tail)
  ultimately
  show ?thesis unfolding in_degree_def by (rule card_mono)
qed

lemma (in wf_digraph) subgraph_cycle:
  assumes "subgraph H G" "pre_digraph.cycle H p " shows "cycle p"
proof -
  from assms have "compatible G H" by auto
  with assms show ?thesis
    by (auto simp: pre_digraph.cycle_def compatible_awalk_verts intro: subgraph_awalk_imp_awalk)
qed

subsection {* Induced subgraphs *}

lemma wf_digraphI_induced:
  assumes "induced_subgraph H G"
  shows "wf_digraph H"
proof -
  from assms have "compatible G H" by auto
  with assms show ?thesis by unfold_locales (auto simp: compatible_tail compatible_head)
qed

lemma (in digraph) digraphI_induced:
  assumes "induced_subgraph H G"
  shows "digraph H"
proof -
  interpret W: wf_digraph H using assms by (rule wf_digraphI_induced)
  from assms have "compatible G H" by auto
  from assms have arcs: "arcs H \<subseteq> arcs G" by blast
  show ?thesis
  proof
    from assms have "verts H \<subseteq> verts G" by blast
    then show "finite (verts H)" using finite_verts by (rule finite_subset)
  next
    from arcs show "finite (arcs H)" using finite_arcs by (rule finite_subset)
  next
    fix e assume "e \<in> arcs H"
    with arcs `compatible G H` show "tail H e \<noteq> head H e"
      by (auto dest: no_loops simp: compatible_tail[symmetric] compatible_head[symmetric])
  next
    fix e1 e2 assume "e1 \<in> arcs H" "e2 \<in> arcs H" and ate: "arc_to_ends H e1 = arc_to_ends H e2"
    with arcs `compatible G H` show "e1 = e2" using ate
      by (auto intro: no_multi_arcs simp: compatible_tail[symmetric] compatible_head[symmetric] arc_to_ends_def)
  qed
qed

text {* Computes the subgraph of @{term G} induced by @{term vs} *}
definition induce_subgraph :: "('a,'b) pre_digraph \<Rightarrow> 'a set \<Rightarrow> ('a,'b) pre_digraph" (infix "\<restriction>" 67) where
  "G \<restriction> vs = \<lparr> verts = vs, arcs = {e \<in> arcs G. tail G e \<in> vs \<and> head G e \<in> vs},
    tail = tail G, head = head G \<rparr>"

lemma induce_subgraph_verts[simp]:
 "verts (G \<restriction> vs) = vs"
by (auto simp add: induce_subgraph_def)

lemma induce_subgraph_arcs[simp]:
 "arcs (G \<restriction> vs) = {e \<in> arcs G. tail G e \<in> vs \<and> head G e \<in> vs}"
by (auto simp add: induce_subgraph_def)

lemma induce_subgraph_tail[simp]:
  "tail (G \<restriction> vs) = tail G"
by (auto simp: induce_subgraph_def)

lemma induce_subgraph_head[simp]:
  "head (G \<restriction> vs) = head G"
by (auto simp: induce_subgraph_def)

lemma (in wf_digraph) induced_induce[intro]:
  assumes "vs \<subseteq> verts G"
  shows "induced_subgraph (G \<restriction> vs) G"
using assms
by (intro subgraphI induced_subgraphI)
   (auto simp: arc_to_ends_def induce_subgraph_def wf_digraph_def compatible_def)

lemma (in wf_digraph) wellformed_induce_subgraph[intro]:
  "wf_digraph (G \<restriction> vs)"
  by unfold_locales auto

lemma induced_graph_imp_symmetric:
  assumes "symmetric G"
  assumes "induced_subgraph H G"
  shows "symmetric H"
proof (unfold symmetric_conv, safe)
  from assms have "compatible G H" by auto

  fix e1 assume "e1 \<in> arcs H"
  then obtain e2 where "tail G e1 = head G e2"  "head G e1 = tail G e2" "e2 \<in> arcs G"
    using assms by (auto simp add: symmetric_conv)
  moreover
  then have "e2 \<in> arcs H"
    using assms and `e1 \<in> arcs H` by auto
  ultimately
  show "\<exists>e2\<in>arcs H. tail H e1 = head H e2 \<and> head H e1 = tail H e2"
    using assms `e1 \<in> arcs H` `compatible G H`
    by (auto simp: compatible_head compatible_tail)
qed

lemma (in sym_digraph) induced_graph_imp_graph:
  assumes "induced_subgraph H G"
  shows "sym_digraph H"
proof (rule wf_digraph.sym_digraphI)
  from assms show "wf_digraph H" by (rule wf_digraphI_induced)
next
  show "symmetric H"
    using assms sym_arcs by (auto intro: induced_graph_imp_symmetric)
qed

lemma (in wf_digraph) induce_reachable_preserves_paths:
  assumes "u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> v"
  shows "u \<rightarrow>\<^sup>*\<^bsub>G \<restriction> {w. u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> w}\<^esub> v"
  using assms
proof induct
  case base then show ?case by (auto simp: reachable_def)
next
  case (step u w)
  interpret iG: wf_digraph "G \<restriction> {w. u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> w}"
    by (rule wellformed_induce_subgraph)
  from `u \<rightarrow> w` have "u \<rightarrow>\<^bsub>G \<restriction> {wa. u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> wa}\<^esub> w"
    by (auto simp: arcs_ends_conv reachable_def intro: wellformed rtrancl_on_into_rtrancl_on)
  then have "u \<rightarrow>\<^sup>*\<^bsub>G \<restriction> {wa. u \<rightarrow>\<^sup>*\<^bsub>G\<^esub> wa}\<^esub> w"
    by (rule iG.reachable_adjI)
  moreover
  from step have "{x. w \<rightarrow>\<^sup>* x} \<subseteq> {x. u \<rightarrow>\<^sup>* x}"
    by (auto intro: adj_reachable_trans)
  then have "subgraph (G \<restriction> {wa. w \<rightarrow>\<^sup>* wa}) (G \<restriction> {wa. u \<rightarrow>\<^sup>* wa})"
    by (intro subgraphI) (auto simp: arcs_ends_conv compatible_def)
  then have "w \<rightarrow>\<^sup>*\<^bsub>G \<restriction> {wa. u \<rightarrow>\<^sup>* wa}\<^esub> v"
    by (rule iG.reachable_mono[rotated]) fact
  ultimately show ?case by (rule iG.reachable_trans)
qed

subsection {* Unions of Graphs *}

lemma
  verts_union[simp]: "verts (union G H) = verts G \<union> verts H" and
  arcs_union[simp]: "arcs (union G H) = arcs G \<union> arcs H" and
  tail_union[simp]: "tail (union G H) = tail G" and
  head_union[simp]: "head (union G H) = head G"
  by (auto simp: union_def)

lemma wellformed_union:
  assumes "wf_digraph G" "wf_digraph H" "compatible G H"
  shows "wf_digraph (union G H)"
  using assms
  by unfold_locales
     (auto simp: union_def compatible_tail compatible_head dest: wf_digraph.wellformed)

lemma subgraph_union_iff:
  assumes "wf_digraph H1" "wf_digraph H2" "compatible H1 H2"
  shows "subgraph (union H1 H2) G \<longleftrightarrow> subgraph H1 G \<and> subgraph H2 G"
  using assms by (fastforce simp: compatible_def intro!: subgraphI wellformed_union)

lemma subgraph_union[intro]:
  assumes "subgraph H1 G" "compatible H1 G"
  assumes "subgraph H2 G" "compatible H2 G"
  shows "subgraph (union H1 H2) G"
proof -
  from assms have "wf_digraph (union H1 H2)"
    by (auto intro: wellformed_union simp: compatible_def)
  with assms show ?thesis
    by (auto simp add: subgraph_def union_def arc_to_ends_def compatible_def)
qed

lemma union_fin_digraph:
  assumes "fin_digraph G" "fin_digraph H" "compatible G H"
  shows "fin_digraph (union G H)"
proof intro_locales
  interpret G: fin_digraph G by (rule assms)
  interpret H: fin_digraph H by (rule assms)
  show "wf_digraph (union G H)" using assms
    by (intro wellformed_union) intro_locales
  show "fin_digraph_axioms (union G H)"
    using assms by unfold_locales (auto simp: union_def)
qed

lemma subgraphs_of_union:
  assumes "wf_digraph G" "wf_digraph G'" "compatible G G'"
  shows "subgraph G (union G G')"
    and "subgraph G' (union G G')"
  using assms by (auto intro!: subgraphI wellformed_union simp: compatible_def)

subsection {* Connected and Strongly Connected Graphs*}

lemma connected_conv:
  shows "connected G \<longleftrightarrow> verts G \<noteq> {} \<and> (\<forall>u \<in> verts G. \<forall>v \<in> verts G. (u,v) \<in> rtrancl_on (verts G) ((arcs_ends G)\<^sup>s))"
proof -
  have "symcl (arcs_ends G) = parcs (mk_symmetric G)"
    by (auto simp: parcs_mk_symmetric symcl_def arcs_ends_conv)
  then show ?thesis by (auto simp: connected_def strongly_connected_def reachable_def)
qed

lemma (in wf_digraph) strongly_connected_spanning_imp_strongly_connected:
  assumes "spanning H G"
  assumes "strongly_connected H"
  shows "strongly_connected G"
proof (unfold strongly_connected_def, intro ballI conjI)
  from assms show "verts G \<noteq> {}" unfolding strongly_connected_def spanning_def by auto
next
  fix u v assume "u \<in> verts G" and "v \<in> verts G"
  then have "u \<rightarrow>\<^sup>*\<^bsub>H\<^esub> v" "subgraph H G"
    using assms by (auto simp add: strongly_connected_def)
  then show "u \<rightarrow>\<^sup>* v" by (rule reachable_mono)
qed

lemma (in wf_digraph) symmetric_connected_imp_strongly_connected:
  assumes "symmetric G" "connected G"
  shows "strongly_connected G"
proof
  from `connected G` show "verts G \<noteq> {}" unfolding connected_def strongly_connected_def by auto
next
  from `connected G`
  have sc_mks: "strongly_connected (mk_symmetric G)"
    unfolding connected_def by simp

  fix u v assume "u \<in> verts G" "v \<in> verts G"
  with sc_mks have "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> v"
    unfolding strongly_connected_def by auto
  then show "u \<rightarrow>\<^sup>* v" using assms by (simp only: reachable_mk_symmetric_eq)
qed

lemma (in wf_digraph) connected_spanning_imp_connected:
  assumes "spanning H G"
  assumes "connected H"
  shows "connected G"
proof (unfold connected_def strongly_connected_def, intro conjI ballI)
  from assms show "verts (mk_symmetric G )\<noteq> {}"
    unfolding spanning_def connected_def strongly_connected_def by auto
next
  fix u v
  assume "u \<in> verts (mk_symmetric G)" and "v \<in> verts (mk_symmetric G)"
  then have "u \<in> pverts (mk_symmetric H)" and "v \<in> pverts (mk_symmetric H)"
    using `spanning H G` by (auto simp: mk_symmetric_def)
  with `connected H`
  have "u \<rightarrow>\<^sup>*\<^bsub>with_proj (mk_symmetric H)\<^esub> v" "subgraph (mk_symmetric H) (mk_symmetric G)"
    using `spanning H G` unfolding connected_def
    by (auto simp: spanning_def dest: subgraph_mk_symmetric)
  then show "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> v" by (rule pre_digraph.reachable_mono)
qed

lemma (in wf_digraph) spanning_tree_imp_connected:
  assumes "spanning_tree H G"
  shows "connected G"
using assms by (auto intro: connected_spanning_imp_connected)

lemma (in sym_digraph) induce_reachable_is_in_sccs:
  assumes "u \<in> verts G"
  shows "(G \<restriction> {v. u \<rightarrow>\<^sup>* v}) \<in> sccs"
proof -
  let ?c = "(G \<restriction> {v. u \<rightarrow>\<^sup>* v})"
  have isub_c: "induced_subgraph ?c G"
    by (auto elim: reachable_in_vertsE)
  then interpret c: wf_digraph ?c by (rule wf_digraphI_induced)

  have sym_c: "symmetric (G \<restriction> {v. u \<rightarrow>\<^sup>* v})"
    using sym_arcs isub_c by (rule induced_graph_imp_symmetric)

  note `induced_subgraph ?c G`
  moreover
  have "strongly_connected ?c"
  proof (rule strongly_connectedI)
    show "verts ?c \<noteq> {}" using assms by auto
  next
    fix v w assume l_assms: "v \<in> verts ?c" "w \<in> verts ?c"
    have "u \<rightarrow>\<^sup>*\<^bsub>G \<restriction> {v. u \<rightarrow>\<^sup>* v}\<^esub> v"
      using l_assms by (intro induce_reachable_preserves_paths) auto
    then have "v \<rightarrow>\<^sup>*\<^bsub>G \<restriction> {v. u \<rightarrow>\<^sup>* v}\<^esub> u" by (rule symmetric_reachable[OF sym_c])
    also have "u \<rightarrow>\<^sup>*\<^bsub>G \<restriction> {v. u \<rightarrow>\<^sup>* v}\<^esub> w"
      using l_assms by (intro induce_reachable_preserves_paths) auto
    finally show "v \<rightarrow>\<^sup>*\<^bsub>G \<restriction> {v. u \<rightarrow>\<^sup>* v}\<^esub> w" .
  qed
  moreover
  have "\<not>(\<exists>d. induced_subgraph d G \<and> strongly_connected d \<and>
    verts ?c \<subset> verts d)"
  proof
    assume "\<exists>d. induced_subgraph d G \<and> strongly_connected d \<and>
      verts ?c \<subset> verts d"
    then obtain d where "induced_subgraph d G" "strongly_connected d"
      "verts ?c \<subset> verts d" by auto
    then obtain v where "v \<in> verts d" and "v \<notin> verts ?c"
      by auto

    have "u \<in> verts ?c" using `u \<in> verts G` by auto
    then have "u \<in> verts d" using `verts ?c \<subset> verts d` by auto
    then have "u \<rightarrow>\<^sup>*\<^bsub>d\<^esub> v"
      using `strongly_connected d` `u \<in> verts d` `v \<in> verts d` by auto
    then have "u \<rightarrow>\<^sup>* v"
      using `induced_subgraph d G`
      by (auto intro: pre_digraph.reachable_mono)
    then have "v \<in> verts ?c" by (auto simp: reachable_awalk)
    then show False using `v \<notin> verts ?c` by auto
  qed
  ultimately show ?thesis unfolding sccs_def by auto
qed

lemma induced_eq_verts_imp_eq:
  assumes "induced_subgraph G H"
  assumes "induced_subgraph G' H"
  assumes "verts G = verts G'"
  shows "G = G'"
  using assms by (auto simp: induced_subgraph_def subgraph_def compatible_def)

lemma (in pre_digraph) in_sccs_subset_imp_eq:
  assumes "c \<in> sccs"
  assumes "d \<in> sccs"
  assumes "verts c \<subseteq> verts d"
  shows "c = d"
using assms by (blast intro: induced_eq_verts_imp_eq)

lemma (in wf_digraph) strongly_connected_imp_induce_subgraph_strongly_connected:
  assumes subg: "subgraph H G"
  assumes sc: "strongly_connected H"
  shows "strongly_connected (G \<restriction> (verts H))"
proof -
  let ?is_H = "G \<restriction> (verts H)"

  interpret H: wf_digraph H
    using subg by (rule subgraphE)
  interpret GrH: wf_digraph "?is_H"
    by (rule wellformed_induce_subgraph)

  have "verts H \<subseteq> verts G" using assms by auto

  have "subgraph H (G \<restriction> verts H)"
    using subg by (intro subgraphI) (auto simp: compatible_def)
  then show ?thesis
    using induced_induce[OF `verts H \<subseteq> verts G`]
      and sc GrH.strongly_connected_spanning_imp_strongly_connected
    unfolding spanning_def by auto
qed

lemma (in wf_digraph) connectedI:
  assumes "verts G \<noteq> {}" "\<And>u v. u \<in> verts G \<Longrightarrow> v \<in> verts G \<Longrightarrow> u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> v"
  shows "connected G"
  using assms by (auto simp: connected_def)

lemma (in wf_digraph) connected_awalkE:
  assumes "connected G" "u \<in> verts G" "v \<in> verts G"
  obtains p where "pre_digraph.awalk (mk_symmetric G) u p v"
proof -
  interpret sG: pair_wf_digraph "mk_symmetric G" ..
  from assms have "u \<rightarrow>\<^sup>*\<^bsub>mk_symmetric G\<^esub> v" by (auto simp: connected_def)
  then obtain p where "sG.awalk u p v" by (auto simp: sG.reachable_awalk)
  then show ?thesis ..
qed

subsection {* Components *}

lemma (in sym_digraph) exists_scc:
  assumes "verts G \<noteq> {}" shows "\<exists>c. c \<in> sccs"
proof -
  from assms obtain u where "u \<in> verts G" by auto
  then show ?thesis by (blast dest: induce_reachable_is_in_sccs)
qed

theorem (in sym_digraph) graph_is_union_sccs:
  shows "Union sccs = G"
proof -
  have "(\<Union>c \<in> sccs. verts c) = verts G"
    by (auto intro: induce_reachable_is_in_sccs)
  moreover
  have "(\<Union>c \<in> sccs. arcs c) = arcs G"
  proof
    show "(\<Union>c \<in> sccs. arcs c) \<subseteq> arcs G"
      by safe (metis in_sccsE induced_imp_subgraph subgraphE subsetD)
    show "arcs G \<subseteq> (\<Union>c \<in> sccs. arcs c)"
    proof (safe)
      fix e assume "e \<in> arcs G"
      def a \<equiv> "tail G e" and b \<equiv> "head G e"
      note a_def[simp] b_def[simp]

      have "e \<in> (\<Union>x \<in> sccs. arcs x)"
      proof cases
        assume "\<exists>x\<in>sccs. {a,b } \<subseteq> verts x"
        then obtain c where "c \<in> sccs" and "{a,b} \<subseteq> verts c"
          by auto
        then have "e \<in> {e \<in> arcs G. tail G e \<in> verts c
          \<and> head G e \<in> verts c}" using `e \<in> arcs G` by auto
        then have "e \<in> arcs c" using `c \<in> sccs` by blast
        then show ?thesis using `c \<in> sccs` by auto
      next
        assume l_assm: "\<not>(\<exists>x\<in>sccs. {a,b} \<subseteq> verts x)"

        have "a \<rightarrow>\<^sup>* b" using `e \<in> arcs G`
          by (metis a_def b_def reachable_adjI in_arcs_imp_in_arcs_ends)
        then have "{a,b} \<subseteq> verts (G \<restriction> {v. a \<rightarrow>\<^sup>* v})" "a \<in> verts G"
          by (auto elim: reachable_in_vertsE)
        moreover
        have "(G \<restriction> {v. a \<rightarrow>\<^sup>* v}) \<in> sccs"
          using `a \<in> verts G` by (auto intro: induce_reachable_is_in_sccs)
        ultimately
        have False using l_assm by blast
        then show ?thesis by simp
      qed
      then show "e \<in> (\<Union>c \<in> sccs. arcs c)" by auto
    qed
  qed
  ultimately show ?thesis
    by (auto simp add: Union_def)
qed

lemma (in sym_digraph) scc_for_vert_ex:
  assumes "u \<in> verts G"
  shows "\<exists>c. c\<in>sccs \<and> u \<in> verts c"
using assms by (auto intro: induce_reachable_is_in_sccs)

lemma strongly_connected_non_disj:
  assumes wf: "wf_digraph G" "wf_digraph H" "compatible G H"
  assumes sc: "strongly_connected G" "strongly_connected H"
  assumes not_disj: "verts G \<inter> verts H \<noteq> {}"
  shows "strongly_connected (union G H)"
proof
  from sc show "verts (union G H) \<noteq> {}"
    unfolding strongly_connected_def by simp
next
  let ?x = "union G H"
  fix u v w assume "u \<in> verts ?x" and "v \<in> verts ?x"
  obtain w where w_in_both: "w \<in> verts G" "w \<in> verts H"
    using not_disj by auto

  interpret x: wf_digraph ?x
    by (rule wellformed_union) fact+
  have subg: "subgraph G ?x" "subgraph H ?x"
    by (rule subgraphs_of_union[OF _ _ ], fact+)+
  have reach_uw: "u \<rightarrow>\<^sup>*\<^bsub>?x\<^esub> w"
    using `u \<in> verts ?x` subg w_in_both sc
    by (auto intro: pre_digraph.reachable_mono)
  also have reach_wv: "w \<rightarrow>\<^sup>*\<^bsub>?x\<^esub> v"
    using `v \<in> verts ?x` subg w_in_both sc
    by (auto intro: pre_digraph.reachable_mono)
  finally (x.reachable_trans) show "u \<rightarrow>\<^sup>*\<^bsub>?x\<^esub> v" .
qed

lemma (in wf_digraph) scc_disj:
  assumes scc: "c \<in> sccs" "d \<in> sccs"
  assumes "c \<noteq> d"
  shows "verts c \<inter> verts d = {}"
proof (rule ccontr)
  assume contr: "\<not>?thesis"

  let ?x = "union c d"

  have comp1: "compatible G c" "compatible G d"
    using scc by (auto simp: sccs_def)
  then have comp: "compatible c d" by (auto simp: compatible_def)

  have wf: "wf_digraph c" "wf_digraph d"
    and sc: "strongly_connected c" "strongly_connected d"
    using scc by (auto intro: in_sccs_imp_induced)
  have "compatible c d"
    using comp by (auto simp: sccs_def compatible_def)
  from wf comp sc have union_conn: "strongly_connected ?x"
    using contr by (rule strongly_connected_non_disj)

  have sg: "subgraph ?x G"
    using scc comp1 by (intro subgraph_union) (auto simp: compatible_def)
  then have v_cd: "verts c \<subseteq> verts G"  "verts d \<subseteq> verts G" by (auto elim!: subgraphE)
  have "wf_digraph ?x" by (rule wellformed_union) fact+
  with v_cd sg union_conn
  have induce_subgraph_conn: "strongly_connected (G \<restriction> verts ?x)"
      "induced_subgraph (G \<restriction> verts ?x) G"
    by - (intro strongly_connected_imp_induce_subgraph_strongly_connected,
      auto simp: subgraph_union_iff)

  from assms have "\<not>verts c \<subseteq> verts d" and "\<not> verts d \<subseteq> verts c"
    by (metis in_sccs_subset_imp_eq)+
  then have psub: "verts c \<subset> verts ?x"
    by (auto simp: union_def)
  then show False using induce_subgraph_conn
    by (metis `c \<in> sccs` in_sccsE induce_subgraph_verts)
qed

lemma (in sym_digraph) scc_decomp_unique:
  assumes "S \<subseteq> sccs" "Union S = G" shows "S = sccs"
proof (rule ccontr)
  assume "S \<noteq> sccs"
  with assms obtain c where "c \<in> sccs" and "c \<notin> S" by auto
  with assms have "\<And>d. d \<in> S \<Longrightarrow> verts c \<inter> verts d = {}"
    by (intro scc_disj) auto
  then have "verts c \<inter> verts (Union S) = {}"
    by (auto simp: Union_def)
  with assms have "verts c \<inter> verts G = {}" by auto
  moreover from `c \<in> sccs` obtain u where "u \<in> verts c \<inter> verts G"
    by (auto simp: sccs_def strongly_connected_def)
  ultimately show False by blast
qed

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_49
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun butlast :: "'a list => 'a list" where
  "butlast (nil2) = nil2"
| "butlast (cons2 z (nil2)) = nil2"
| "butlast (cons2 z (cons2 x2 x3)) =
     cons2 z (butlast (cons2 x2 x3))"

fun butlastConcat :: "'a list => 'a list => 'a list" where
  "butlastConcat y (nil2) = butlast y"
| "butlastConcat y (cons2 z2 x2) = x y (butlast (cons2 z2 x2))"

theorem property0 :
  "((butlast (x xs ys)) = (butlastConcat xs ys))"
  (*Why on "xs"?
    Because "x" is defined recursively on the first parameter, which is "xs" in this case,
    and "x" is the innermost recursive function.
    and we can apply "butlast.simps" to the left-hand side if we can apply "x.simps" to "x xs ys".
   *)
  (*Why "rule:butlast.induct"?
    Because "butlast"'s pattern-matching seems to be powerful(?)
    Because we want to simplify "x xs ys" and "x xs ys" is a sub-term of "butlast (x xs ys)"(?)
   *)
  apply(induct xs rule:butlast.induct)
    apply(cases ys)
     apply fastforce+
   apply(cases ys)
    apply fastforce+
  apply(cases ys)
   apply fastforce+
  done

theorem property0' :
  "((butlast (x xs ys)) = (butlastConcat xs ys))"
  apply(induct xs rule:butlast.induct)
    apply(induct ys)
     apply fastforce+
   apply(induct ys)
    apply fastforce+
  apply(induct ys)
   apply fastforce+
  done

theorem "((butlast (x xs ys)) = (butlastConcat xs ys))"
  apply(induct ys rule:butlastConcat.induct)
  nitpick
  oops

theorem "((butlast (x xs ys)) = (butlastConcat xs ys))"
  apply(induct xs rule:butlastConcat.induct)
  nitpick
  oops

theorem "((butlast (x xs ys)) = (butlastConcat xs ys))"
(*TODO: find alternative proofs without "butlast.induct".*)
  oops

end


(*  Title:      ZF/OrdQuant.thy
    Authors:    Krzysztof Grabczewski and L C Paulson
*)

section {*Special quantifiers*}

theory OrdQuant imports Ordinal begin

subsection {*Quantifiers and union operator for ordinals*}

definition
  (* Ordinal Quantifiers *)
  oall :: "[i, i => o] => o"  where
    "oall(A, P) == \<forall>x. x<A \<longrightarrow> P(x)"

definition
  oex :: "[i, i => o] => o"  where
    "oex(A, P)  == \<exists>x. x<A & P(x)"

definition
  (* Ordinal Union *)
  OUnion :: "[i, i => i] => i"  where
    "OUnion(i,B) == {z: \<Union>x\<in>i. B(x). Ord(i)}"

syntax
  "_oall"     :: "[idt, i, o] => o"        ("(3ALL _<_./ _)" 10)
  "_oex"      :: "[idt, i, o] => o"        ("(3EX _<_./ _)" 10)
  "_OUNION"   :: "[idt, i, i] => i"        ("(3UN _<_./ _)" 10)

translations
  "ALL x<a. P"  == "CONST oall(a, %x. P)"
  "EX x<a. P"   == "CONST oex(a, %x. P)"
  "UN x<a. B"   == "CONST OUnion(a, %x. B)"

syntax (xsymbols)
  "_oall"     :: "[idt, i, o] => o"        ("(3\<forall>_<_./ _)" 10)
  "_oex"      :: "[idt, i, o] => o"        ("(3\<exists>_<_./ _)" 10)
  "_OUNION"   :: "[idt, i, i] => i"        ("(3\<Union>_<_./ _)" 10)
syntax (HTML output)
  "_oall"     :: "[idt, i, o] => o"        ("(3\<forall>_<_./ _)" 10)
  "_oex"      :: "[idt, i, o] => o"        ("(3\<exists>_<_./ _)" 10)
  "_OUNION"   :: "[idt, i, i] => i"        ("(3\<Union>_<_./ _)" 10)

subsubsection {*simplification of the new quantifiers*}

(*MOST IMPORTANT that this is added to the simpset BEFORE Ord_atomize
  is proved.  Ord_atomize would convert this rule to
    x < 0 ==> P(x) == True, which causes dire effects!*)

lemma [simp]: "~(\<exists>x<0. P(x))"
by (simp add: oex_def)

lemma [simp]: "(\<forall>x<succ(i). P(x)) <-> (Ord(i) \<longrightarrow> P(i) & (\<forall>x<i. P(x)))"
apply (simp add: oall_def le_iff)
apply (blast intro: lt_Ord2)
done

lemma [simp]: "(\<exists>x<succ(i). P(x)) <-> (Ord(i) & (P(i) | (\<exists>x<i. P(x))))"
apply (simp add: oex_def le_iff)
apply (blast intro: lt_Ord2)
done

subsubsection {*Union over ordinals*}

lemma Ord_OUN [intro,simp]:
     "[| !!x. x<A ==> Ord(B(x)) |] ==> Ord(\<Union>x<A. B(x))"
by (simp add: OUnion_def ltI Ord_UN)

lemma OUN_upper_lt:
     "[| a<A;  i < b(a);  Ord(\<Union>x<A. b(x)) |] ==> i < (\<Union>x<A. b(x))"
by (unfold OUnion_def lt_def, blast )

lemma OUN_upper_le:
     "[| a<A;  i\<le>b(a);  Ord(\<Union>x<A. b(x)) |] ==> i \<le> (\<Union>x<A. b(x))"
apply (unfold OUnion_def, auto)
apply (rule UN_upper_le )
apply (auto simp add: lt_def)
done

lemma Limit_OUN_eq: "Limit(i) ==> (\<Union>x<i. x) = i"
by (simp add: OUnion_def Limit_Union_eq Limit_is_Ord)

(* No < version of this theorem: consider that @{term"(\<Union>i\<in>nat.i)=nat"}! *)
lemma OUN_least:
     "(!!x. x<A ==> B(x) \<subseteq> C) ==> (\<Union>x<A. B(x)) \<subseteq> C"
by (simp add: OUnion_def UN_least ltI)

lemma OUN_least_le:
     "[| Ord(i);  !!x. x<A ==> b(x) \<le> i |] ==> (\<Union>x<A. b(x)) \<le> i"
by (simp add: OUnion_def UN_least_le ltI Ord_0_le)

lemma le_implies_OUN_le_OUN:
     "[| !!x. x<A ==> c(x) \<le> d(x) |] ==> (\<Union>x<A. c(x)) \<le> (\<Union>x<A. d(x))"
by (blast intro: OUN_least_le OUN_upper_le le_Ord2 Ord_OUN)

lemma OUN_UN_eq:
     "(!!x. x \<in> A ==> Ord(B(x)))
      ==> (\<Union>z < (\<Union>x\<in>A. B(x)). C(z)) = (\<Union>x\<in>A. \<Union>z < B(x). C(z))"
by (simp add: OUnion_def)

lemma OUN_Union_eq:
     "(!!x. x \<in> X ==> Ord(x))
      ==> (\<Union>z < \<Union>(X). C(z)) = (\<Union>x\<in>X. \<Union>z < x. C(z))"
by (simp add: OUnion_def)

(*So that rule_format will get rid of this quantifier...*)
lemma atomize_oall [symmetric, rulify]:
     "(!!x. x<A ==> P(x)) == Trueprop (\<forall>x<A. P(x))"
by (simp add: oall_def atomize_all atomize_imp)

subsubsection {*universal quantifier for ordinals*}

lemma oallI [intro!]:
    "[| !!x. x<A ==> P(x) |] ==> \<forall>x<A. P(x)"
by (simp add: oall_def)

lemma ospec: "[| \<forall>x<A. P(x);  x<A |] ==> P(x)"
by (simp add: oall_def)

lemma oallE:
    "[| \<forall>x<A. P(x);  P(x) ==> Q;  ~x<A ==> Q |] ==> Q"
by (simp add: oall_def, blast)

lemma rev_oallE [elim]:
    "[| \<forall>x<A. P(x);  ~x<A ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: oall_def, blast)

(*Trival rewrite rule.  @{term"(\<forall>x<a.P)<->P"} holds only if a is not 0!*)
lemma oall_simp [simp]: "(\<forall>x<a. True) <-> True"
by blast

(*Congruence rule for rewriting*)
lemma oall_cong [cong]:
    "[| a=a';  !!x. x<a' ==> P(x) <-> P'(x) |]
     ==> oall(a, %x. P(x)) <-> oall(a', %x. P'(x))"
by (simp add: oall_def)

subsubsection {*existential quantifier for ordinals*}

lemma oexI [intro]:
    "[| P(x);  x<A |] ==> \<exists>x<A. P(x)"
apply (simp add: oex_def, blast)
done

(*Not of the general form for such rules... *)
lemma oexCI:
   "[| \<forall>x<A. ~P(x) ==> P(a);  a<A |] ==> \<exists>x<A. P(x)"
apply (simp add: oex_def, blast)
done

lemma oexE [elim!]:
    "[| \<exists>x<A. P(x);  !!x. [| x<A; P(x) |] ==> Q |] ==> Q"
apply (simp add: oex_def, blast)
done

lemma oex_cong [cong]:
    "[| a=a';  !!x. x<a' ==> P(x) <-> P'(x) |]
     ==> oex(a, %x. P(x)) <-> oex(a', %x. P'(x))"
apply (simp add: oex_def cong add: conj_cong)
done

subsubsection {*Rules for Ordinal-Indexed Unions*}

lemma OUN_I [intro]: "[| a<i;  b \<in> B(a) |] ==> b: (\<Union>z<i. B(z))"
by (unfold OUnion_def lt_def, blast)

lemma OUN_E [elim!]:
    "[| b \<in> (\<Union>z<i. B(z));  !!a.[| b \<in> B(a);  a<i |] ==> R |] ==> R"
apply (unfold OUnion_def lt_def, blast)
done

lemma OUN_iff: "b \<in> (\<Union>x<i. B(x)) <-> (\<exists>x<i. b \<in> B(x))"
by (unfold OUnion_def oex_def lt_def, blast)

lemma OUN_cong [cong]:
    "[| i=j;  !!x. x<j ==> C(x)=D(x) |] ==> (\<Union>x<i. C(x)) = (\<Union>x<j. D(x))"
by (simp add: OUnion_def lt_def OUN_iff)

lemma lt_induct:
    "[| i<k;  !!x.[| x<k;  \<forall>y<x. P(y) |] ==> P(x) |]  ==>  P(i)"
apply (simp add: lt_def oall_def)
apply (erule conjE)
apply (erule Ord_induct, assumption, blast)
done

subsection {*Quantification over a class*}

definition
  "rall"     :: "[i=>o, i=>o] => o"  where
    "rall(M, P) == \<forall>x. M(x) \<longrightarrow> P(x)"

definition
  "rex"      :: "[i=>o, i=>o] => o"  where
    "rex(M, P) == \<exists>x. M(x) & P(x)"

syntax
  "_rall"     :: "[pttrn, i=>o, o] => o"        ("(3ALL _[_]./ _)" 10)
  "_rex"      :: "[pttrn, i=>o, o] => o"        ("(3EX _[_]./ _)" 10)

syntax (xsymbols)
  "_rall"     :: "[pttrn, i=>o, o] => o"        ("(3\<forall>_[_]./ _)" 10)
  "_rex"      :: "[pttrn, i=>o, o] => o"        ("(3\<exists>_[_]./ _)" 10)
syntax (HTML output)
  "_rall"     :: "[pttrn, i=>o, o] => o"        ("(3\<forall>_[_]./ _)" 10)
  "_rex"      :: "[pttrn, i=>o, o] => o"        ("(3\<exists>_[_]./ _)" 10)

translations
  "ALL x[M]. P"  == "CONST rall(M, %x. P)"
  "EX x[M]. P"   == "CONST rex(M, %x. P)"

subsubsection{*Relativized universal quantifier*}

lemma rallI [intro!]: "[| !!x. M(x) ==> P(x) |] ==> \<forall>x[M]. P(x)"
by (simp add: rall_def)

lemma rspec: "[| \<forall>x[M]. P(x); M(x) |] ==> P(x)"
by (simp add: rall_def)

(*Instantiates x first: better for automatic theorem proving?*)
lemma rev_rallE [elim]:
    "[| \<forall>x[M]. P(x);  ~ M(x) ==> Q;  P(x) ==> Q |] ==> Q"
by (simp add: rall_def, blast)

lemma rallE: "[| \<forall>x[M]. P(x);  P(x) ==> Q;  ~ M(x) ==> Q |] ==> Q"
by blast

(*Trival rewrite rule;   (ALL x[M].P)<->P holds only if A is nonempty!*)
lemma rall_triv [simp]: "(ALL x[M]. P) <-> ((EX x. M(x)) --> P)"
by (simp add: rall_def)

(*Congruence rule for rewriting*)
lemma rall_cong [cong]:
    "(!!x. M(x) ==> P(x) <-> P'(x)) ==> (\<forall>x[M]. P(x)) <-> (\<forall>x[M]. P'(x))"
by (simp add: rall_def)

subsubsection{*Relativized existential quantifier*}

lemma rexI [intro]: "[| P(x); M(x) |] ==> \<exists>x[M]. P(x)"
by (simp add: rex_def, blast)

(*The best argument order when there is only one M(x)*)
lemma rev_rexI: "[| M(x);  P(x) |] ==> \<exists>x[M]. P(x)"
by blast

(*Not of the general form for such rules... *)
lemma rexCI: "[| \<forall>x[M]. ~P(x) ==> P(a); M(a) |] ==> \<exists>x[M]. P(x)"
by blast

lemma rexE [elim!]: "[| \<exists>x[M]. P(x);  !!x. [| M(x); P(x) |] ==> Q |] ==> Q"
by (simp add: rex_def, blast)

(*We do not even have (EX x[M]. True) <-> True unless A is nonempty!!*)
lemma rex_triv [simp]: "(EX x[M]. P) <-> ((EX x. M(x)) & P)"
by (simp add: rex_def)

lemma rex_cong [cong]:
    "(!!x. M(x) ==> P(x) <-> P'(x)) ==> (\<exists>x[M]. P(x)) <-> (\<exists>x[M]. P'(x))"
by (simp add: rex_def cong: conj_cong)

lemma rall_is_ball [simp]: "(\<forall>x[%z. z\<in>A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
by blast

lemma rex_is_bex [simp]: "(\<exists>x[%z. z\<in>A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
by blast

lemma atomize_rall: "(!!x. M(x) ==> P(x)) == Trueprop (\<forall>x[M]. P(x))"
by (simp add: rall_def atomize_all atomize_imp)

declare atomize_rall [symmetric, rulify]

lemma rall_simps1:
     "(\<forall>x[M]. P(x) & Q)   <-> (\<forall>x[M]. P(x)) & ((\<forall>x[M]. False) | Q)"
     "(\<forall>x[M]. P(x) | Q)   <-> ((\<forall>x[M]. P(x)) | Q)"
     "(\<forall>x[M]. P(x) \<longrightarrow> Q) <-> ((\<exists>x[M]. P(x)) \<longrightarrow> Q)"
     "(~(\<forall>x[M]. P(x))) <-> (\<exists>x[M]. ~P(x))"
by blast+

lemma rall_simps2:
     "(\<forall>x[M]. P & Q(x))   <-> ((\<forall>x[M]. False) | P) & (\<forall>x[M]. Q(x))"
     "(\<forall>x[M]. P | Q(x))   <-> (P | (\<forall>x[M]. Q(x)))"
     "(\<forall>x[M]. P \<longrightarrow> Q(x)) <-> (P \<longrightarrow> (\<forall>x[M]. Q(x)))"
by blast+

lemmas rall_simps [simp] = rall_simps1 rall_simps2

lemma rall_conj_distrib:
    "(\<forall>x[M]. P(x) & Q(x)) <-> ((\<forall>x[M]. P(x)) & (\<forall>x[M]. Q(x)))"
by blast

lemma rex_simps1:
     "(\<exists>x[M]. P(x) & Q) <-> ((\<exists>x[M]. P(x)) & Q)"
     "(\<exists>x[M]. P(x) | Q) <-> (\<exists>x[M]. P(x)) | ((\<exists>x[M]. True) & Q)"
     "(\<exists>x[M]. P(x) \<longrightarrow> Q) <-> ((\<forall>x[M]. P(x)) \<longrightarrow> ((\<exists>x[M]. True) & Q))"
     "(~(\<exists>x[M]. P(x))) <-> (\<forall>x[M]. ~P(x))"
by blast+

lemma rex_simps2:
     "(\<exists>x[M]. P & Q(x)) <-> (P & (\<exists>x[M]. Q(x)))"
     "(\<exists>x[M]. P | Q(x)) <-> ((\<exists>x[M]. True) & P) | (\<exists>x[M]. Q(x))"
     "(\<exists>x[M]. P \<longrightarrow> Q(x)) <-> (((\<forall>x[M]. False) | P) \<longrightarrow> (\<exists>x[M]. Q(x)))"
by blast+

lemmas rex_simps [simp] = rex_simps1 rex_simps2

lemma rex_disj_distrib:
    "(\<exists>x[M]. P(x) | Q(x)) <-> ((\<exists>x[M]. P(x)) | (\<exists>x[M]. Q(x)))"
by blast

subsubsection{*One-point rule for bounded quantifiers*}

lemma rex_triv_one_point1 [simp]: "(\<exists>x[M]. x=a) <-> ( M(a))"
by blast

lemma rex_triv_one_point2 [simp]: "(\<exists>x[M]. a=x) <-> ( M(a))"
by blast

lemma rex_one_point1 [simp]: "(\<exists>x[M]. x=a & P(x)) <-> ( M(a) & P(a))"
by blast

lemma rex_one_point2 [simp]: "(\<exists>x[M]. a=x & P(x)) <-> ( M(a) & P(a))"
by blast

lemma rall_one_point1 [simp]: "(\<forall>x[M]. x=a \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
by blast

lemma rall_one_point2 [simp]: "(\<forall>x[M]. a=x \<longrightarrow> P(x)) <-> ( M(a) \<longrightarrow> P(a))"
by blast

subsubsection{*Sets as Classes*}

definition
  setclass :: "[i,i] => o"       ("##_" [40] 40)  where
   "setclass(A) == %x. x \<in> A"

lemma setclass_iff [simp]: "setclass(A,x) <-> x \<in> A"
by (simp add: setclass_def)

lemma rall_setclass_is_ball [simp]: "(\<forall>x[##A]. P(x)) <-> (\<forall>x\<in>A. P(x))"
by auto

lemma rex_setclass_is_bex [simp]: "(\<exists>x[##A]. P(x)) <-> (\<exists>x\<in>A. P(x))"
by auto

ML
{*
val Ord_atomize =
  atomize ([(@{const_name oall}, @{thms ospec}), (@{const_name rall}, @{thms rspec})] @
    ZF_conn_pairs, ZF_mem_pairs);
*}
declaration {* fn _ =>
  Simplifier.map_ss (Simplifier.set_mksimps (K (map mk_eq o Ord_atomize o gen_all)))
*}

text {* Setting up the one-point-rule simproc *}

simproc_setup defined_rex ("\<exists>x[M]. P(x) & Q(x)") = {*
  fn _ => Quantifier1.rearrange_bex
    (fn ctxt =>
      unfold_tac ctxt @{thms rex_def} THEN
      Quantifier1.prove_one_point_ex_tac)
*}

simproc_setup defined_rall ("\<forall>x[M]. P(x) \<longrightarrow> Q(x)") = {*
  fn _ => Quantifier1.rearrange_ball
    (fn ctxt =>
      unfold_tac ctxt @{thms rall_def} THEN
      Quantifier1.prove_one_point_all_tac)
*}

end


(*  Title:       Square Matrices
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jjhuertaymunive1@sheffield.ac.uk>
*)

section \<open> Square Matrices \<close>

text\<open> The general solution for affine systems of ODEs involves the exponential function.
Unfortunately, this operation is only available in Isabelle for the type class ``banach''.
Hence, we define a type of square matrices and prove that it is an instance of this class.\<close>

theory SQ_MTX
  imports MTX_Norms

begin

subsection \<open> Definition \<close>

typedef 'm sq_mtx = "UNIV::(real^'m^'m) set"
  morphisms to_vec to_mtx by simp

declare to_mtx_inverse [simp]
    and to_vec_inverse [simp]

setup_lifting type_definition_sq_mtx

lift_definition sq_mtx_ith :: "'m sq_mtx \<Rightarrow> 'm \<Rightarrow> (real^'m)" (infixl "$$" 90) is "($)" .

lift_definition sq_mtx_vec_mult :: "'m sq_mtx \<Rightarrow> (real^'m) \<Rightarrow> (real^'m)" (infixl "*\<^sub>V" 90) is "(*v)" .

lift_definition vec_sq_mtx_prod :: "(real^'m) \<Rightarrow> 'm sq_mtx \<Rightarrow> (real^'m)" is "(v*)" .

lift_definition sq_mtx_diag :: "(('m::finite) \<Rightarrow> real) \<Rightarrow> ('m::finite) sq_mtx" (binder "\<d>\<i>\<a>\<g> " 10)
  is diag_mat .

lift_definition sq_mtx_transpose :: "('m::finite) sq_mtx \<Rightarrow> 'm sq_mtx" ("_\<^sup>\<dagger>") is transpose .

lift_definition sq_mtx_inv :: "('m::finite) sq_mtx \<Rightarrow> 'm sq_mtx" ("_\<^sup>-\<^sup>1" [90]) is matrix_inv .

lift_definition sq_mtx_row :: "'m \<Rightarrow> ('m::finite) sq_mtx \<Rightarrow> real^'m" ("\<r>\<o>\<w>") is row .

lift_definition sq_mtx_col :: "'m \<Rightarrow> ('m::finite) sq_mtx \<Rightarrow> real^'m" ("\<c>\<o>\<l>")  is column .

lemma to_vec_eq_ith: "(to_vec A) $ i = A $$ i"
  by transfer simp

lemma to_mtx_ith[simp]:
  "(to_mtx A) $$ i1 = A $ i1"
  "(to_mtx A) $$ i1 $ i2 = A $ i1 $ i2"
  by (transfer, simp)+

lemma to_mtx_vec_lambda_ith[simp]: "to_mtx (\<chi> i j. x i j) $$ i1 $ i2 = x i1 i2"
  by (simp add: sq_mtx_ith_def)

lemma sq_mtx_eq_iff:
  shows "A = B = (\<forall>i j. A $$ i $ j = B $$ i $ j)"
    and "A = B = (\<forall>i. A $$ i = B $$ i)"
  by (transfer, simp add: vec_eq_iff)+

lemma sq_mtx_diag_simps[simp]:
  "i = j \<Longrightarrow> sq_mtx_diag f $$ i $ j = f i"
  "i \<noteq> j \<Longrightarrow> sq_mtx_diag f $$ i $ j = 0"
  "sq_mtx_diag f $$ i = axis i (f i)"
  unfolding sq_mtx_diag_def by (simp_all add: axis_def vec_eq_iff)

lemma sq_mtx_vec_mult_diag_axis: "(\<d>\<i>\<a>\<g> i. f i) *\<^sub>V (axis i k) = axis i (f i * k)"
  unfolding sq_mtx_diag_vec_mult axis_def by auto

lemma sq_mtx_vec_mult_eq: "m *\<^sub>V x = (\<chi> i. sum (\<lambda>j. (m $$ i $ j) * (x $ j)) UNIV)"
  by (transfer, simp add: matrix_vector_mult_def)

lemma sq_mtx_transpose_transpose[simp]: "(A\<^sup>\<dagger>)\<^sup>\<dagger> = A"
  by (transfer, simp)

lemma transpose_mult_vec_canon_row[simp]: "(A\<^sup>\<dagger>) *\<^sub>V (\<e> i) = \<r>\<o>\<w> i A"
  by transfer (simp add: row_def transpose_def axis_def matrix_vector_mult_def)

lemma row_ith[simp]: "\<r>\<o>\<w> i A = A $$ i"
  by transfer (simp add: row_def)

lemma mtx_vec_mult_canon: "A *\<^sub>V (\<e> i) = \<c>\<o>\<l> i A"
  by (transfer, simp add: matrix_vector_mult_basis)

subsection \<open> Ring of square matrices \<close>

instantiation sq_mtx :: (finite) ring
begin

lift_definition plus_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is "(+)" .

lift_definition zero_sq_mtx :: "'a sq_mtx" is "0" .

lift_definition uminus_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx" is "uminus" .

lift_definition minus_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is "(-)" .

lift_definition times_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is "(**)" .

declare plus_sq_mtx.rep_eq [simp]
    and minus_sq_mtx.rep_eq [simp]

instance apply intro_classes
  by(transfer, simp add: algebra_simps matrix_mul_assoc matrix_add_rdistrib matrix_add_ldistrib)+

end

lemma sq_mtx_zero_ith[simp]: "0 $$ i = 0"
  by (transfer, simp)

lemma sq_mtx_zero_nth[simp]: "0 $$ i $ j = 0"
  by transfer simp

lemma sq_mtx_plus_eq: "A + B = to_mtx (\<chi> i j. A$$i$j + B$$i$j)"
  by transfer (simp add: vec_eq_iff)

lemma sq_mtx_plus_ith[simp]:"(A + B) $$ i = A $$ i + B $$ i"
  unfolding sq_mtx_plus_eq by (simp add: vec_eq_iff)

lemma sq_mtx_minus_eq: "A - B = to_mtx (\<chi> i j. A$$i$j - B$$i$j)"
  by transfer (simp add: vec_eq_iff)

lemma sq_mtx_minus_ith[simp]:"(A - B) $$ i = A $$ i - B $$ i"
  unfolding sq_mtx_minus_eq by (simp add: vec_eq_iff)

lemma sq_mtx_times_eq: "A * B = to_mtx (\<chi> i j. sum (\<lambda>k. A$$i$k * B$$k$j) UNIV)"
  by transfer (simp add: matrix_matrix_mult_def)

lemma sq_mtx_plus_diag_diag[simp]: "sq_mtx_diag f + sq_mtx_diag g = (\<d>\<i>\<a>\<g> i. f i + g i)"
  by (subst sq_mtx_eq_iff) (simp add: axis_def)

lemma sq_mtx_minus_diag_diag[simp]: "sq_mtx_diag f - sq_mtx_diag g = (\<d>\<i>\<a>\<g> i. f i - g i)"
  by (subst sq_mtx_eq_iff) (simp add: axis_def)

lemma sum_sq_mtx_diag[simp]: "(\<Sum>n<m. sq_mtx_diag (g n)) = (\<d>\<i>\<a>\<g> i. \<Sum>n<m. (g n i))" for m::nat
  by (induct m, simp, subst sq_mtx_eq_iff, simp_all)

lemma sq_mtx_mult_diag_diag[simp]: "sq_mtx_diag f * sq_mtx_diag g = (\<d>\<i>\<a>\<g> i. f i * g i)"
  by (simp add: matrix_mul_diag_diag sq_mtx_diag.abs_eq times_sq_mtx.abs_eq)

lemma sq_mtx_mult_diagl: "(\<d>\<i>\<a>\<g> i. f i) * A = to_mtx (\<chi> i j. f i * A $$ i $ j)"
  by transfer (simp add: matrix_mul_diag_matl)

lemma sq_mtx_mult_diagr: "A * (\<d>\<i>\<a>\<g> i. f i) = to_mtx (\<chi> i j. A $$ i $ j * f j)"
  by transfer (simp add: matrix_matrix_mul_diag_matr)

lemma mtx_vec_mult_0l[simp]: "0 *\<^sub>V x = 0"
  by (simp add: sq_mtx_vec_mult.abs_eq zero_sq_mtx_def)

lemma mtx_vec_mult_0r[simp]: "A *\<^sub>V 0 = 0"
  by (transfer, simp)

lemma mtx_vec_mult_add_rdistr: "(A + B) *\<^sub>V x = A *\<^sub>V x + B *\<^sub>V x"
  unfolding plus_sq_mtx_def
  apply(transfer)
  by (simp add: matrix_vector_mult_add_rdistrib)

lemma mtx_vec_mult_add_rdistl: "A *\<^sub>V (x + y) = A *\<^sub>V x + A *\<^sub>V y"
  unfolding plus_sq_mtx_def
  apply transfer
  by (simp add: matrix_vector_right_distrib)

lemma mtx_vec_mult_minus_rdistrib: "(A - B) *\<^sub>V x = A *\<^sub>V x - B *\<^sub>V x"
  unfolding minus_sq_mtx_def by(transfer, simp add: matrix_vector_mult_diff_rdistrib)

lemma mtx_vec_mult_minus_ldistrib: "A *\<^sub>V (x - y) =  A *\<^sub>V x -  A *\<^sub>V y"
  by (metis (no_types, lifting) add_diff_cancel diff_add_cancel
      matrix_vector_right_distrib sq_mtx_vec_mult.rep_eq)

lemma sq_mtx_times_vec_assoc: "(A * B) *\<^sub>V x = A *\<^sub>V (B *\<^sub>V x)"
  by (transfer, simp add: matrix_vector_mul_assoc)

lemma sq_mtx_vec_mult_sum_cols: "A *\<^sub>V x = sum (\<lambda>i. x $ i *\<^sub>R \<c>\<o>\<l> i A) UNIV"
  by(transfer) (simp add: matrix_mult_sum scalar_mult_eq_scaleR)

subsection \<open> Real normed vector space of square matrices \<close>

instantiation sq_mtx :: (finite) real_normed_vector
begin

definition norm_sq_mtx :: "'a sq_mtx \<Rightarrow> real" where "\<parallel>A\<parallel> = \<parallel>to_vec A\<parallel>\<^sub>o\<^sub>p"

lift_definition scaleR_sq_mtx :: "real \<Rightarrow> 'a sq_mtx \<Rightarrow> 'a sq_mtx" is scaleR .

definition sgn_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx"
  where "sgn_sq_mtx A = (inverse (\<parallel>A\<parallel>)) *\<^sub>R A"

definition dist_sq_mtx :: "'a sq_mtx \<Rightarrow> 'a sq_mtx \<Rightarrow> real"
  where "dist_sq_mtx A B = \<parallel>A - B\<parallel>"

definition uniformity_sq_mtx :: "('a sq_mtx \<times> 'a sq_mtx) filter"
  where "uniformity_sq_mtx = (INF e\<in>{0<..}. principal {(x, y). dist x y < e})"

definition open_sq_mtx :: "'a sq_mtx set \<Rightarrow> bool"
  where "open_sq_mtx U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> U)"

instance apply intro_classes
  unfolding sgn_sq_mtx_def open_sq_mtx_def dist_sq_mtx_def uniformity_sq_mtx_def
            prefer 10
            apply(transfer, simp add: norm_sq_mtx_def op_norm_triangle)
           prefer 9
           apply(simp_all add: norm_sq_mtx_def zero_sq_mtx_def op_norm_eq_0)
  by (transfer, simp add: norm_sq_mtx_def op_norm_scaleR algebra_simps)+

end

lemma sq_mtx_scaleR_eq: "c *\<^sub>R A = to_mtx (\<chi> i j. c *\<^sub>R A $$ i $ j)"
  by transfer (simp add: vec_eq_iff)

lemma scaleR_to_mtx_ith[simp]: "c *\<^sub>R (to_mtx A) $$ i1 $ i2 = c * A $ i1 $ i2"
  by transfer (simp add: scaleR_vec_def)

lemma sq_mtx_scaleR_ith[simp]: "(c *\<^sub>R A) $$ i = (c  *\<^sub>R (A $$ i))"
  by (unfold scaleR_sq_mtx_def, transfer, simp)

lemma scaleR_sq_mtx_diag: "c *\<^sub>R sq_mtx_diag f = (\<d>\<i>\<a>\<g> i. c * f i)"
  by (subst sq_mtx_eq_iff, simp add: axis_def)

lemma scaleR_mtx_vec_assoc: "(c *\<^sub>R A) *\<^sub>V x = c *\<^sub>R (A *\<^sub>V x)"
  unfolding scaleR_sq_mtx_def sq_mtx_vec_mult_def apply simp
  by (simp add: scaleR_matrix_vector_assoc)

lemma mtx_vec_scaleR_commute: "A *\<^sub>V (c *\<^sub>R x) = c *\<^sub>R (A *\<^sub>V x)"
  unfolding scaleR_sq_mtx_def sq_mtx_vec_mult_def apply(simp, transfer)
  by (simp add: vector_scaleR_commute)

lemma mtx_times_scaleR_commute: "A * (c *\<^sub>R B) = c *\<^sub>R (A * B)" for A::"('n::finite) sq_mtx"
  unfolding sq_mtx_scaleR_eq sq_mtx_times_eq
  apply(simp add: to_mtx_inject)
  apply(simp add: vec_eq_iff fun_eq_iff)
  by (simp add: semiring_normalization_rules(19) vector_space_over_itself.scale_sum_right)

lemma le_mtx_norm: "m \<in> {\<parallel>A *\<^sub>V x\<parallel> |x. \<parallel>x\<parallel> = 1} \<Longrightarrow> m \<le> \<parallel>A\<parallel>"
  using cSup_upper[of _ "{\<parallel>(to_vec A) *v x\<parallel> | x. \<parallel>x\<parallel> = 1}"]
  by (simp add: op_norm_set_proptys(2) op_norm_def norm_sq_mtx_def sq_mtx_vec_mult.rep_eq)

lemma norm_vec_mult_le: "\<parallel>A *\<^sub>V x\<parallel> \<le> (\<parallel>A\<parallel>) * (\<parallel>x\<parallel>)"
  by (simp add: norm_matrix_le_mult_op_norm norm_sq_mtx_def sq_mtx_vec_mult.rep_eq)

lemma bounded_bilinear_sq_mtx_vec_mult: "bounded_bilinear (\<lambda>A s. A *\<^sub>V s)"
  apply (rule bounded_bilinear.intro, simp_all add: mtx_vec_mult_add_rdistr
      mtx_vec_mult_add_rdistl scaleR_mtx_vec_assoc mtx_vec_scaleR_commute)
  by (rule_tac x=1 in exI, auto intro!: norm_vec_mult_le)

lemma norm_sq_mtx_def2: "\<parallel>A\<parallel> = Sup {\<parallel>A *\<^sub>V x\<parallel> |x. \<parallel>x\<parallel> = 1}"
  unfolding norm_sq_mtx_def op_norm_def sq_mtx_vec_mult_def by simp

lemma norm_sq_mtx_def3: "\<parallel>A\<parallel> = (SUP x. (\<parallel>A *\<^sub>V x\<parallel>) / (\<parallel>x\<parallel>))"
  unfolding norm_sq_mtx_def onorm_def sq_mtx_vec_mult_def by simp

lemma norm_sq_mtx_diag: "\<parallel>sq_mtx_diag f\<parallel> = Max {\<bar>f i\<bar> |i. i \<in> UNIV}"
  unfolding norm_sq_mtx_def apply transfer
  by (rule op_norm_diag_mat_eq)

lemma sq_mtx_norm_le_sum_col: "\<parallel>A\<parallel> \<le> (\<Sum>i\<in>UNIV. \<parallel>\<c>\<o>\<l> i A\<parallel>)"
  using op_norm_le_sum_column[of "to_vec A"]
  apply(simp add: norm_sq_mtx_def)
  by(transfer, simp add: op_norm_le_sum_column)

lemma norm_le_transpose: "\<parallel>A\<parallel> \<le> \<parallel>A\<^sup>\<dagger>\<parallel>"
  unfolding norm_sq_mtx_def by transfer (rule op_norm_le_transpose)

lemma norm_eq_norm_transpose[simp]: "\<parallel>A\<^sup>\<dagger>\<parallel> = \<parallel>A\<parallel>"
  using norm_le_transpose[of A] and norm_le_transpose[of "A\<^sup>\<dagger>"] by simp

lemma norm_column_le_norm: "\<parallel>A $$ i\<parallel> \<le> \<parallel>A\<parallel>"
  using norm_vec_mult_le[of "A\<^sup>\<dagger>" "\<e> i"] by simp

subsection \<open> Real normed algebra of square matrices \<close>

instantiation sq_mtx :: (finite) real_normed_algebra_1
begin

lift_definition one_sq_mtx :: "'a sq_mtx" is "to_mtx (mat 1)" .

lemma sq_mtx_one_idty: "1 * A = A" "A * 1 = A" for A :: "'a sq_mtx"
  by(transfer, transfer, unfold mat_def matrix_matrix_mult_def, simp add: vec_eq_iff)+

lemma sq_mtx_norm_1: "\<parallel>(1::'a sq_mtx)\<parallel> = 1"
  unfolding one_sq_mtx_def norm_sq_mtx_def
  apply(simp add: op_norm_def)
  apply(subst cSup_eq[of _ 1])
  using ex_norm_eq_1 by auto

lemma sq_mtx_norm_times: "\<parallel>A * B\<parallel> \<le> (\<parallel>A\<parallel>) * (\<parallel>B\<parallel>)" for A :: "'a sq_mtx"
  unfolding norm_sq_mtx_def times_sq_mtx_def by(simp add: op_norm_matrix_matrix_mult_le)

instance
  apply intro_classes
  apply(simp_all add: sq_mtx_one_idty sq_mtx_norm_1 sq_mtx_norm_times)
  apply(simp_all add: to_mtx_inject vec_eq_iff one_sq_mtx_def zero_sq_mtx_def mat_def)
  by(transfer, simp add: scalar_matrix_assoc matrix_scalar_ac)+

end

lemma sq_mtx_one_ith_simps[simp]: "1 $$ i $ i = 1" "i \<noteq> j \<Longrightarrow> 1 $$ i $ j = 0"
  unfolding one_sq_mtx_def mat_def by simp_all

lemma of_nat_eq_sq_mtx_diag[simp]: "of_nat m = (\<d>\<i>\<a>\<g> i. m)"
  by (induct m) (simp, subst sq_mtx_eq_iff, simp add: axis_def)+

lemma mtx_vec_mult_1[simp]: "1 *\<^sub>V s = s"
  by (auto simp: sq_mtx_vec_mult_def one_sq_mtx_def
      mat_def vec_eq_iff matrix_vector_mult_def)

lemma sq_mtx_diag_one[simp]: "(\<d>\<i>\<a>\<g> i. 1) = 1"
  by (subst sq_mtx_eq_iff, simp add: one_sq_mtx_def mat_def axis_def)

abbreviation "mtx_invertible A \<equiv> invertible (to_vec A)"

lemma mtx_invertible_def: "mtx_invertible A \<longleftrightarrow> (\<exists>A'. A' * A = 1 \<and> A * A' = 1)"
  apply (unfold sq_mtx_inv_def times_sq_mtx_def one_sq_mtx_def invertible_def, clarsimp, safe)
   apply(rule_tac x="to_mtx A'" in exI, simp)
  by (rule_tac x="to_vec A'" in exI, simp add: to_mtx_inject)

lemma mtx_invertibleD[simp]:
  assumes "mtx_invertible A"
  shows "A\<^sup>-\<^sup>1 * A = 1" and "A * A\<^sup>-\<^sup>1 = 1"
  apply (unfold sq_mtx_inv_def times_sq_mtx_def one_sq_mtx_def)
  using assms by simp_all

lemma mtx_invertible_inv[simp]: "mtx_invertible A \<Longrightarrow> mtx_invertible (A\<^sup>-\<^sup>1)"
  using mtx_invertibleD mtx_invertibleI by blast

lemma mtx_invertible_one[simp]: "mtx_invertible 1"
  by (simp add: one_sq_mtx.rep_eq)

lemma sq_mtx_inv_unique:
  assumes "A * B = 1" and "B * A = 1"
  shows "A\<^sup>-\<^sup>1 = B"
  by (metis (no_types, lifting) assms mtx_invertibleD(2)
      mtx_invertibleI mult.assoc sq_mtx_one_idty(1))

lemma sq_mtx_inv_idempotent[simp]: "mtx_invertible A \<Longrightarrow> A\<^sup>-\<^sup>1\<^sup>-\<^sup>1 = A"
  using mtx_invertibleD sq_mtx_inv_unique by blast

lemma sq_mtx_inv_mult:
  assumes "mtx_invertible A" and "mtx_invertible B"
  shows "(A * B)\<^sup>-\<^sup>1 = B\<^sup>-\<^sup>1 * A\<^sup>-\<^sup>1"
  by (simp add: assms matrix_inv_matrix_mul sq_mtx_inv_def times_sq_mtx_def)

lemma sq_mtx_inv_one[simp]: "1\<^sup>-\<^sup>1 = 1"
  by (simp add: sq_mtx_inv_unique)

definition similar_sq_mtx :: "('n::finite) sq_mtx \<Rightarrow> 'n sq_mtx \<Rightarrow> bool" (infixr "\<sim>" 25)
  where "(A \<sim> B) \<longleftrightarrow> (\<exists> P. mtx_invertible P \<and> A = P\<^sup>-\<^sup>1 * B * P)"

lemma similar_sq_mtx_matrix: "(A \<sim> B) = similar_matrix (to_vec A) (to_vec B)"
  apply(unfold similar_matrix_def similar_sq_mtx_def, safe)
   apply (metis sq_mtx_inv.rep_eq times_sq_mtx.rep_eq)
  by (metis UNIV_I sq_mtx_inv.abs_eq times_sq_mtx.abs_eq to_mtx_inverse to_vec_inverse)

lemma similar_sq_mtx_refl[simp]: "A \<sim> A"
  by (unfold similar_sq_mtx_def, rule_tac x="1" in exI, simp)

lemma similar_sq_mtx_simm: "A \<sim> B \<Longrightarrow> B \<sim> A"
  apply(unfold similar_sq_mtx_def, clarsimp)
  apply(rule_tac x="P\<^sup>-\<^sup>1" in exI, simp add: mult.assoc)
  by (metis mtx_invertibleD(2) mult.assoc mult.left_neutral)

lemma similar_sq_mtx_trans: "A \<sim> B \<Longrightarrow> B \<sim> C \<Longrightarrow> A \<sim> C"
  unfolding similar_sq_mtx_matrix using similar_matrix_trans by blast

lemma power_similiar_sq_mtx_diag_eq:
  assumes "mtx_invertible P"
      and "A = P\<^sup>-\<^sup>1 * (sq_mtx_diag f) * P"
    shows "A^n = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i^n) * P"
proof(induct n, simp_all add: assms)
  fix n::nat
  have "P\<^sup>-\<^sup>1 * sq_mtx_diag f * P * (P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P) =
  P\<^sup>-\<^sup>1 * sq_mtx_diag f * (\<d>\<i>\<a>\<g> i. f i ^ n) * P"
    by (metis (no_types, lifting) assms(1) mtx_invertibleD(2) mult.assoc mult.right_neutral)
  also have "... = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i * f i ^ n) * P"
    by (simp add: mult.assoc)
  finally show "P\<^sup>-\<^sup>1 * sq_mtx_diag f * P * (P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P) =
  P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i * f i ^ n) * P" .
qed

lemma power_similar_sq_mtx_diag:
  assumes "A \<sim> (sq_mtx_diag f)"
  shows "A^n \<sim> (\<d>\<i>\<a>\<g> i. f i^n)"
  using assms power_similiar_sq_mtx_diag_eq
  unfolding similar_sq_mtx_def by blast

subsection \<open> Banach space of square matrices \<close>

lemma Cauchy_cols:
  fixes X :: "nat \<Rightarrow> ('a::finite) sq_mtx"
  assumes "Cauchy X"
  shows "Cauchy (\<lambda>n. \<c>\<o>\<l> i (X n))"
proof(unfold Cauchy_def dist_norm, clarsimp)
  fix \<epsilon>::real assume "\<epsilon> > 0"
  then obtain M where M_def:"\<forall>m\<ge>M. \<forall>n\<ge>M. \<parallel>X m - X n\<parallel> < \<epsilon>"
    using \<open>Cauchy X\<close> unfolding Cauchy_def by(simp add: dist_sq_mtx_def) metis
  {fix m n assume "m \<ge> M" and "n \<ge> M"
    hence "\<epsilon> > \<parallel>X m - X n\<parallel>"
      using M_def by blast
    moreover have "\<parallel>X m - X n\<parallel> \<ge> \<parallel>(X m - X n) *\<^sub>V \<e> i\<parallel>"
      by(rule le_mtx_norm[of _ "X m - X n"], force)
    moreover have "\<parallel>(X m - X n) *\<^sub>V \<e> i\<parallel> = \<parallel>X m *\<^sub>V \<e> i - X n *\<^sub>V \<e> i\<parallel>"
      by (simp add: mtx_vec_mult_minus_rdistrib)
    moreover have "... = \<parallel>\<c>\<o>\<l> i (X m) - \<c>\<o>\<l> i (X n)\<parallel>"
      by (simp add: mtx_vec_mult_minus_rdistrib mtx_vec_mult_canon)
    ultimately have "\<parallel>\<c>\<o>\<l> i (X m) - \<c>\<o>\<l> i (X n)\<parallel> < \<epsilon>"
      by linarith}
  thus "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. \<parallel>\<c>\<o>\<l> i (X m) - \<c>\<o>\<l> i (X n)\<parallel> < \<epsilon>"
    by blast
qed

lemma col_convergence:
  assumes "\<forall>i. (\<lambda>n. \<c>\<o>\<l> i (X n)) \<longlonglongrightarrow> L $ i"
  shows "X \<longlonglongrightarrow> to_mtx (transpose L)"
proof(unfold LIMSEQ_def dist_norm, clarsimp)
  let ?L = "to_mtx (transpose L)"
  let ?a = "CARD('a)" fix \<epsilon>::real assume "\<epsilon> > 0"
  hence "\<epsilon> / ?a > 0" by simp
  hence "\<forall>i. \<exists> N. \<forall>n\<ge>N. \<parallel>\<c>\<o>\<l> i (X n) - L $ i\<parallel> < \<epsilon>/?a"
    using assms unfolding LIMSEQ_def dist_norm convergent_def by blast
  then obtain N where "\<forall>i. \<forall>n\<ge>N. \<parallel>\<c>\<o>\<l> i (X n) - L $ i\<parallel> < \<epsilon>/?a"
    using finite_nat_minimal_witness[of "\<lambda> i n. \<parallel>\<c>\<o>\<l> i (X n) - L $ i\<parallel> < \<epsilon>/?a"] by blast
  also have "\<And>i n. (\<c>\<o>\<l> i (X n) - L $ i) = (\<c>\<o>\<l> i (X n - ?L))"
    unfolding minus_sq_mtx_def by(transfer, simp add: transpose_def vec_eq_iff column_def)
  ultimately have N_def:"\<forall>i. \<forall>n\<ge>N. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel> < \<epsilon>/?a"
    by auto
  have "\<forall>n\<ge>N. \<parallel>X n - ?L\<parallel> < \<epsilon>"
  proof(rule allI, rule impI)
    fix n::nat assume "N \<le> n"
    hence "\<forall> i. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel> < \<epsilon>/?a"
      using N_def by blast
    hence "(\<Sum>i\<in>UNIV. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel>) < (\<Sum>(i::'a)\<in>UNIV. \<epsilon>/?a)"
      using sum_strict_mono[of _ "\<lambda>i. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel>"] by force
    moreover have "\<parallel>X n - ?L\<parallel> \<le> (\<Sum>i\<in>UNIV. \<parallel>\<c>\<o>\<l> i (X n - ?L)\<parallel>)"
      using sq_mtx_norm_le_sum_col by blast
    moreover have "(\<Sum>(i::'a)\<in>UNIV. \<epsilon>/?a) = \<epsilon>"
      by force
    ultimately show "\<parallel>X n - ?L\<parallel> < \<epsilon>"
      by linarith
  qed
  thus "\<exists>no. \<forall>n\<ge>no. \<parallel>X n - ?L\<parallel> < \<epsilon>"
    by blast
qed

instance sq_mtx :: (finite) banach
proof(standard)
  fix X :: "nat \<Rightarrow> 'a sq_mtx"
  assume "Cauchy X"
  hence "\<And>i. Cauchy (\<lambda>n. \<c>\<o>\<l> i (X n))"
    using Cauchy_cols by blast
  hence obs: "\<forall>i. \<exists>! L. (\<lambda>n. \<c>\<o>\<l> i (X n)) \<longlonglongrightarrow> L"
    using Cauchy_convergent convergent_def LIMSEQ_unique by fastforce
  define L where "L = (\<chi> i. lim (\<lambda>n. \<c>\<o>\<l> i (X n)))"
  hence "\<forall>i. (\<lambda>n. \<c>\<o>\<l> i (X n)) \<longlonglongrightarrow> L $ i"
    using obs theI_unique[of "\<lambda>L. (\<lambda>n. \<c>\<o>\<l> _ (X n)) \<longlonglongrightarrow> L" "L $ _"] by (simp add: lim_def)
  thus "convergent X"
    using col_convergence unfolding convergent_def by blast
qed

lemma exp_similiar_sq_mtx_diag_eq:
  assumes "mtx_invertible P"
      and "A = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i) * P"
    shows "exp A = P\<^sup>-\<^sup>1 * exp (\<d>\<i>\<a>\<g> i. f i) * P"
proof(unfold exp_def power_similiar_sq_mtx_diag_eq[OF assms])
  have "(\<Sum>n. P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P /\<^sub>R fact n) =
  (\<Sum>n. P\<^sup>-\<^sup>1 * ((\<d>\<i>\<a>\<g> i. f i ^ n) /\<^sub>R fact n) * P)"
    by simp
  also have "... = (\<Sum>n. P\<^sup>-\<^sup>1 * ((\<d>\<i>\<a>\<g> i. f i ^ n) /\<^sub>R fact n)) * P"
    apply(subst suminf_multr[OF bounded_linear.summable[OF bounded_linear_mult_right]])
    unfolding power_sq_mtx_diag[symmetric] by (simp_all add: summable_exp_generic)
  also have "... = P\<^sup>-\<^sup>1 * (\<Sum>n. (\<d>\<i>\<a>\<g> i. f i ^ n) /\<^sub>R fact n) * P"
    apply(subst suminf_mult[of _ "P\<^sup>-\<^sup>1"])
    unfolding power_sq_mtx_diag[symmetric]
    by (simp_all add: summable_exp_generic)
  finally show "(\<Sum>n. P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i ^ n) * P /\<^sub>R fact n) =
  P\<^sup>-\<^sup>1 * (\<Sum>n. sq_mtx_diag f ^ n /\<^sub>R fact n) * P"
    unfolding power_sq_mtx_diag by simp
qed

lemma exp_similiar_sq_mtx_diag:
  assumes "A \<sim> sq_mtx_diag f"
  shows "exp A \<sim> exp (sq_mtx_diag f)"
  using assms exp_similiar_sq_mtx_diag_eq
  unfolding similar_sq_mtx_def by blast

lemma suminf_sq_mtx_diag:
  assumes "\<forall>i. (\<lambda>n. f n i) sums (suminf (\<lambda>n. f n i))"
  shows "(\<Sum>n. (\<d>\<i>\<a>\<g> i. f n i)) = (\<d>\<i>\<a>\<g> i. \<Sum>n. f n i)"
proof(rule suminfI, unfold sums_def LIMSEQ_iff, clarsimp simp: norm_sq_mtx_diag)
  let ?g = "\<lambda>n i. \<bar>(\<Sum>n<n. f n i) - (\<Sum>n. f n i)\<bar>"
  fix r::real assume "r > 0"
  have "\<forall>i. \<exists>no. \<forall>n\<ge>no. ?g n i < r"
    using assms \<open>r > 0\<close> unfolding sums_def LIMSEQ_iff by clarsimp
  then obtain N where key: "\<forall>i. \<forall>n\<ge>N. ?g n i < r"
    using finite_nat_minimal_witness[of "\<lambda>i n. ?g n i < r"] by blast
  {fix n::nat
    assume "n \<ge> N"
    obtain i where i_def: "Max {x. \<exists>i. x = ?g n i} = ?g n i"
      using cMax_finite_ex[of "{x. \<exists>i. x = ?g n i}"] by auto
    hence "?g n i < r"
      using key \<open>n \<ge> N\<close> by blast
    hence "Max {x. \<exists>i. x = ?g n i} < r"
      unfolding i_def[symmetric] .}
  thus "\<exists>N. \<forall>n\<ge>N. Max {x. \<exists>i. x = ?g n i} < r"
    by blast
qed

lemma exp_sq_mtx_diag: "exp (sq_mtx_diag f) = (\<d>\<i>\<a>\<g> i. exp (f i))"
  apply(unfold exp_def, simp add: power_sq_mtx_diag scaleR_sq_mtx_diag)
  apply(rule suminf_sq_mtx_diag)
  using exp_converges[of "f _"]
  unfolding sums_def LIMSEQ_iff exp_def by force

lemma exp_scaleR_diagonal1:
  assumes "mtx_invertible P" and "A = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. f i) * P"
    shows "exp (t *\<^sub>R A) = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P"
proof-
  have "exp (t *\<^sub>R A) = exp (P\<^sup>-\<^sup>1 * (t *\<^sub>R sq_mtx_diag f) * P)"
    using assms by simp
  also have "... = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P"
    by (metis assms(1) exp_similiar_sq_mtx_diag_eq exp_sq_mtx_diag scaleR_sq_mtx_diag)
  finally show "exp (t *\<^sub>R A) = P\<^sup>-\<^sup>1 * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P" .
qed

lemma exp_scaleR_diagonal2:
  assumes "mtx_invertible P" and "A = P * (\<d>\<i>\<a>\<g> i. f i) * P\<^sup>-\<^sup>1"
    shows "exp (t *\<^sub>R A) = P * (\<d>\<i>\<a>\<g> i. exp (t * f i)) * P\<^sup>-\<^sup>1"
  apply(subst sq_mtx_inv_idempotent[OF assms(1), symmetric])
  apply(rule exp_scaleR_diagonal1)
  by (simp_all add: assms)

subsection \<open> Examples \<close>

definition "mtx A = to_mtx (vector (map vector A))"

lemma vector_nth_eq: "(vector A) $ i = foldr (\<lambda>x f n. (f (n + 1))(n := x)) A (\<lambda>n x. 0) 1 i"
  unfolding vector_def by simp

lemma mtx_ith_eq[simp]: "mtx A $$ i $ j = foldr (\<lambda>x f n. (f (n + 1))(n := x))
  (map (\<lambda>l. vec_lambda (foldr (\<lambda>x f n. (f (n + 1))(n := x)) l (\<lambda>n x. 0) 1)) A) (\<lambda>n x. 0) 1 i $ j"
  unfolding mtx_def vector_def by (simp add: vector_nth_eq)

subsubsection \<open> 2x2 matrices \<close>

lemma mtx2_eq_iff: "(mtx
  ([a1, b1] #
   [c1, d1] # []) :: 2 sq_mtx) = mtx
  ([a2, b2] #
   [c2, d2] # []) \<longleftrightarrow> a1 = a2 \<and> b1 = b2 \<and> c1 = c2 \<and> d1 = d2"
  apply(simp add: sq_mtx_eq_iff, safe)
  using exhaust_2 by force+

lemma mtx2_to_mtx: "mtx
  ([a, b] #
   [c, d] # []) =
  to_mtx (\<chi> i j::2. if i=1 \<and> j=1 then a
  else (if i=1 \<and> j=2 then b
  else (if i=2 \<and> j=1 then c
  else d)))"
  apply(subst sq_mtx_eq_iff)
  using exhaust_2 by force

abbreviation diag2 :: "real \<Rightarrow> real \<Rightarrow> 2 sq_mtx"
  where "diag2 \<iota>\<^sub>1 \<iota>\<^sub>2 \<equiv> mtx
   ([\<iota>\<^sub>1, 0] #
    [0, \<iota>\<^sub>2] # [])"

lemma diag2_eq: "diag2 (\<iota> 1) (\<iota> 2) = (\<d>\<i>\<a>\<g> i. \<iota> i)"
  apply(simp add: sq_mtx_eq_iff)
  using exhaust_2 by (force simp: axis_def)

lemma one_mtx2: "(1::2 sq_mtx) = diag2 1 1"
  apply(subst sq_mtx_eq_iff)
  using exhaust_2 by force

lemma zero_mtx2: "(0::2 sq_mtx) = diag2 0 0"
  by (simp add: sq_mtx_eq_iff)

lemma scaleR_mtx2: "k *\<^sub>R mtx
  ([a, b] #
   [c, d] # []) = mtx
  ([k*a, k*b] #
   [k*c, k*d] # [])"
  by (simp add: sq_mtx_eq_iff)

lemma uminus_mtx2: "-mtx
  ([a, b] #
   [c, d] # []) = (mtx
  ([-a, -b] #
   [-c, -d] # [])::2 sq_mtx)"
  by (simp add: sq_mtx_uminus_eq sq_mtx_eq_iff)

lemma plus_mtx2: "mtx
  ([a1, b1] #
   [c1, d1] # []) + mtx
  ([a2, b2] #
   [c2, d2] # []) = ((mtx
  ([a1+a2, b1+b2] #
   [c1+c2, d1+d2] # []))::2 sq_mtx)"
  by (simp add: sq_mtx_eq_iff)

lemma minus_mtx2: "mtx
  ([a1, b1] #
   [c1, d1] # []) - mtx
  ([a2, b2] #
   [c2, d2] # []) = ((mtx
  ([a1-a2, b1-b2] #
   [c1-c2, d1-d2] # []))::2 sq_mtx)"
  by (simp add: sq_mtx_eq_iff)

lemma times_mtx2: "mtx
  ([a1, b1] #
   [c1, d1] # []) * mtx
  ([a2, b2] #
   [c2, d2] # []) = ((mtx
  ([a1*a2+b1*c2, a1*b2+b1*d2] #
   [c1*a2+d1*c2, c1*b2+d1*d2] # []))::2 sq_mtx)"
  unfolding sq_mtx_times_eq UNIV_2
  by (simp add: sq_mtx_eq_iff)

subsubsection \<open> 3x3 matrices \<close>

lemma mtx3_to_mtx: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) =
  to_mtx (\<chi> i j::3. if i=1 \<and> j=1 then a\<^sub>1\<^sub>1
  else (if i=1 \<and> j=2 then a\<^sub>1\<^sub>2
  else (if i=1 \<and> j=3 then a\<^sub>1\<^sub>3
  else (if i=2 \<and> j=1 then a\<^sub>2\<^sub>1
  else (if i=2 \<and> j=2 then a\<^sub>2\<^sub>2
  else (if i=2 \<and> j=3 then a\<^sub>2\<^sub>3
  else (if i=3 \<and> j=1 then a\<^sub>3\<^sub>1
  else (if i=3 \<and> j=2 then a\<^sub>3\<^sub>2
  else a\<^sub>3\<^sub>3))))))))"
  apply(simp add: sq_mtx_eq_iff)
  using exhaust_3 by force

abbreviation diag3 :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 3 sq_mtx"
  where "diag3 \<iota>\<^sub>1 \<iota>\<^sub>2 \<iota>\<^sub>3 \<equiv> mtx
  ([\<iota>\<^sub>1, 0, 0] #
   [0, \<iota>\<^sub>2, 0] #
   [0, 0, \<iota>\<^sub>3] # [])"

lemma diag3_eq: "diag3 (\<iota> 1) (\<iota> 2) (\<iota> 3) = (\<d>\<i>\<a>\<g> i. \<iota> i)"
  apply(simp add: sq_mtx_eq_iff)
  using exhaust_3 by (force simp: axis_def)

lemma one_mtx3: "(1::3 sq_mtx) = diag3 1 1 1"
  apply(subst sq_mtx_eq_iff)
  using exhaust_3 by force

lemma zero_mtx3: "(0::3 sq_mtx) = diag3 0 0 0"
  by (simp add: sq_mtx_eq_iff)

lemma scaleR_mtx3: "k *\<^sub>R mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) = mtx
  ([k*a\<^sub>1\<^sub>1, k*a\<^sub>1\<^sub>2, k*a\<^sub>1\<^sub>3] #
   [k*a\<^sub>2\<^sub>1, k*a\<^sub>2\<^sub>2, k*a\<^sub>2\<^sub>3] #
   [k*a\<^sub>3\<^sub>1, k*a\<^sub>3\<^sub>2, k*a\<^sub>3\<^sub>3] # [])"
  by (simp add: sq_mtx_eq_iff)

lemma plus_mtx3: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) + mtx
  ([b\<^sub>1\<^sub>1, b\<^sub>1\<^sub>2, b\<^sub>1\<^sub>3] #
   [b\<^sub>2\<^sub>1, b\<^sub>2\<^sub>2, b\<^sub>2\<^sub>3] #
   [b\<^sub>3\<^sub>1, b\<^sub>3\<^sub>2, b\<^sub>3\<^sub>3] # []) = (mtx
  ([a\<^sub>1\<^sub>1+b\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2+b\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3+b\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1+b\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2+b\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3+b\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1+b\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2+b\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3+b\<^sub>3\<^sub>3] # [])::3 sq_mtx)"
  by (subst sq_mtx_eq_iff) simp

lemma minus_mtx3: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) - mtx
  ([b\<^sub>1\<^sub>1, b\<^sub>1\<^sub>2, b\<^sub>1\<^sub>3] #
   [b\<^sub>2\<^sub>1, b\<^sub>2\<^sub>2, b\<^sub>2\<^sub>3] #
   [b\<^sub>3\<^sub>1, b\<^sub>3\<^sub>2, b\<^sub>3\<^sub>3] # []) = (mtx
  ([a\<^sub>1\<^sub>1-b\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2-b\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3-b\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1-b\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2-b\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3-b\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1-b\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2-b\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3-b\<^sub>3\<^sub>3] # [])::3 sq_mtx)"
  by (simp add: sq_mtx_eq_iff)

lemma times_mtx3: "mtx
  ([a\<^sub>1\<^sub>1, a\<^sub>1\<^sub>2, a\<^sub>1\<^sub>3] #
   [a\<^sub>2\<^sub>1, a\<^sub>2\<^sub>2, a\<^sub>2\<^sub>3] #
   [a\<^sub>3\<^sub>1, a\<^sub>3\<^sub>2, a\<^sub>3\<^sub>3] # []) * mtx
  ([b\<^sub>1\<^sub>1, b\<^sub>1\<^sub>2, b\<^sub>1\<^sub>3] #
   [b\<^sub>2\<^sub>1, b\<^sub>2\<^sub>2, b\<^sub>2\<^sub>3] #
   [b\<^sub>3\<^sub>1, b\<^sub>3\<^sub>2, b\<^sub>3\<^sub>3] # []) = (mtx
  ([a\<^sub>1\<^sub>1*b\<^sub>1\<^sub>1+a\<^sub>1\<^sub>2*b\<^sub>2\<^sub>1+a\<^sub>1\<^sub>3*b\<^sub>3\<^sub>1, a\<^sub>1\<^sub>1*b\<^sub>1\<^sub>2+a\<^sub>1\<^sub>2*b\<^sub>2\<^sub>2+a\<^sub>1\<^sub>3*b\<^sub>3\<^sub>2, a\<^sub>1\<^sub>1*b\<^sub>1\<^sub>3+a\<^sub>1\<^sub>2*b\<^sub>2\<^sub>3+a\<^sub>1\<^sub>3*b\<^sub>3\<^sub>3] #
   [a\<^sub>2\<^sub>1*b\<^sub>1\<^sub>1+a\<^sub>2\<^sub>2*b\<^sub>2\<^sub>1+a\<^sub>2\<^sub>3*b\<^sub>3\<^sub>1, a\<^sub>2\<^sub>1*b\<^sub>1\<^sub>2+a\<^sub>2\<^sub>2*b\<^sub>2\<^sub>2+a\<^sub>2\<^sub>3*b\<^sub>3\<^sub>2, a\<^sub>2\<^sub>1*b\<^sub>1\<^sub>3+a\<^sub>2\<^sub>2*b\<^sub>2\<^sub>3+a\<^sub>2\<^sub>3*b\<^sub>3\<^sub>3] #
   [a\<^sub>3\<^sub>1*b\<^sub>1\<^sub>1+a\<^sub>3\<^sub>2*b\<^sub>2\<^sub>1+a\<^sub>3\<^sub>3*b\<^sub>3\<^sub>1, a\<^sub>3\<^sub>1*b\<^sub>1\<^sub>2+a\<^sub>3\<^sub>2*b\<^sub>2\<^sub>2+a\<^sub>3\<^sub>3*b\<^sub>3\<^sub>2, a\<^sub>3\<^sub>1*b\<^sub>1\<^sub>3+a\<^sub>3\<^sub>2*b\<^sub>2\<^sub>3+a\<^sub>3\<^sub>3*b\<^sub>3\<^sub>3] # [])::3 sq_mtx)"
  unfolding sq_mtx_times_eq
  unfolding UNIV_3 by (simp add: sq_mtx_eq_iff)

end


theory Poly_Monotonicity
imports "~~/src/HOL/Library/Poly_Deriv" "Lib/Misc_Polynomial"
begin

section {* Additional monotonicity notions *}

subsection{* Monotonicity on a set *}

definition mono_on where
  "mono_on f A  \<longleftrightarrow> (\<forall>x y. x \<in> A \<longrightarrow> y \<in> A \<longrightarrow> x \<le> y \<longrightarrow> f x \<le> f y)"

lemma mono_onI:
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  shows "mono_on f A"
  using assms unfolding mono_on_def by simp

lemma mono_onD:
  assumes "mono_on f A"
  shows "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
  using assms unfolding mono_on_def by simp

lemma mono_on_subset: "mono_on f B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> mono_on f A"
  by (blast intro: mono_onI dest: mono_onD)

lemma mono_on_UNIV[simp]: "mono_on f UNIV = mono f"
  unfolding mono_on_def mono_def by simp

subsection{* Strict monotonicity on a set *}

definition strict_mono_on where
  "strict_mono_on f A  \<longleftrightarrow> (\<forall>x y. x \<in> A \<longrightarrow> y \<in> A \<longrightarrow> x < y \<longrightarrow> f x < f y)"

lemma strict_mono_onI:
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x < y \<Longrightarrow> f x < f y"
  shows "strict_mono_on f A"
  using assms unfolding strict_mono_on_def by simp

lemma strict_mono_onD:
  assumes "strict_mono_on f A"
  shows "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x < y \<Longrightarrow> f x < f y"
  using assms unfolding strict_mono_on_def by simp

lemma strict_mono_on_subset: "strict_mono_on f B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> strict_mono_on f A"
  by (blast intro: strict_mono_onI dest: strict_mono_onD)

lemma strict_mono_on_UNIV[simp]: "strict_mono_on f UNIV = strict_mono f"
  unfolding strict_mono_on_def strict_mono_def by simp

subsection{* Monotonically decreasing *}

definition mono_dec where
  "mono_dec f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<ge> f y)"

definition strict_mono_dec where
  "strict_mono_dec f \<longleftrightarrow> (\<forall>x y. x < y \<longrightarrow> f x > f y)"

lemma mono_dec_mono_conv:
  fixes f :: "_ \<Rightarrow> ('a :: ordered_ab_group_add)"
  shows "mono_dec f \<longleftrightarrow> mono (\<lambda>x. -f x)"
  unfolding mono_def mono_dec_def by simp

lemma strict_mono_dec_strict_mono_conv:
  fixes f :: "_ \<Rightarrow> ('a :: ordered_ab_group_add)"
  shows "strict_mono_dec f \<longleftrightarrow> strict_mono (\<lambda>x. -f x)"
  unfolding strict_mono_def strict_mono_dec_def by simp

subsection{* Monotonically decreasing on a set *}

definition mono_dec_on where
  "mono_dec_on f A  \<longleftrightarrow> (\<forall>x y. x \<in> A \<longrightarrow> y \<in> A \<longrightarrow> x \<le> y \<longrightarrow> f x \<ge> f y)"

lemma mono_dec_onI:
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
  shows "mono_dec_on f A"
  using assms unfolding mono_dec_on_def by simp

lemma mono_dec_onD:
  assumes "mono_dec_on f A"
  shows "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
  using assms unfolding mono_dec_on_def by simp

lemma mono_dec_on_subset: "mono_dec_on f B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> mono_dec_on f A"
  by (blast intro: mono_dec_onI dest: mono_dec_onD)

lemma mono_dec_on_mono_on_conv:
  fixes f :: "_ \<Rightarrow> ('a :: ordered_ab_group_add)"
  shows "mono_dec_on f A \<longleftrightarrow> mono_on (\<lambda>x. -f x) A"
  unfolding mono_on_def mono_dec_on_def by simp

lemma mono_dec_on_UNIV[simp]:
    "mono_dec_on f UNIV = mono_dec f"
  unfolding mono_dec_on_def mono_dec_def by simp

subsection {* Strictly monotonically decreasing on a set *}

definition strict_mono_dec_on where
  "strict_mono_dec_on f A  \<longleftrightarrow> (\<forall>x y. x \<in> A \<longrightarrow> y \<in> A \<longrightarrow> x < y \<longrightarrow> f x > f y)"

lemma strict_mono_dec_onI:
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x < y \<Longrightarrow> f x > f y"
  shows "strict_mono_dec_on f A"
  using assms unfolding strict_mono_dec_on_def by simp

lemma strict_mono_dec_onD:
  assumes "strict_mono_dec_on f A"
  shows "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x < y \<Longrightarrow> f x > f y"
  using assms unfolding strict_mono_dec_on_def by simp

lemma strict_mono_dec_on_subset: "strict_mono_dec_on f B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> strict_mono_dec_on f A"
  by (blast intro: strict_mono_dec_onI dest: strict_mono_dec_onD)

lemma strict_mono_dec_on_strict_mono_on_conv:
  fixes f :: "_ \<Rightarrow> ('a :: ordered_ab_group_add)"
  shows "strict_mono_dec_on f A \<longleftrightarrow> strict_mono_on (\<lambda>x. -f x) A"
  unfolding strict_mono_on_def strict_mono_dec_on_def by simp

lemma strict_mono_dec_on_UNIV[simp]: "strict_mono_dec_on f UNIV = strict_mono_dec f"
  unfolding strict_mono_dec_on_def strict_mono_dec_def by simp

section {* Monotonicity of polynomials *}

lemma poly_deriv_ge_0:
  fixes p :: "real poly"
  defines "p' \<equiv> pderiv p"
  assumes "a \<le> b" and "\<And>x. x \<in> {a<..<b} \<Longrightarrow> poly p' x \<ge> 0"
  shows "poly p a \<le> poly p b"
proof (cases "a < b")
  assume "a < b"
  from poly_MVT[OF this] obtain \<xi>
    where "\<xi> \<in> {a<..<b}" and "poly p b - poly p a = (b - a) * poly p' \<xi>"
    by (auto simp: p'_def)
  with assms have "poly p b - poly p a \<ge> 0" by simp
  thus ?thesis by simp
qed (insert assms, simp)

lemma poly_deriv_ge_0':
  fixes p :: "real poly"
  defines "p' \<equiv> pderiv p"
  assumes "a < b" and "p' \<noteq> 0" and "\<And>x. x \<in> {a<..<b} \<Longrightarrow> poly p' x \<ge> 0"
  shows "poly p a < poly p b"
proof (rule ccontr)
  assume "\<not>(poly p a < poly p b)"
  moreover from assms have "poly p a \<le> poly p b" using poly_deriv_ge_0 by simp
  ultimately have eq: "poly p a = poly p b" by simp
  have interval_const: "\<And>x. x \<in> {a..b} \<Longrightarrow> poly p x = poly p a"
  proof-
    fix x assume x: "x \<in> {a..b}"
    with assms(4) have "poly p x \<ge> poly p a" "poly p x \<le> poly  p b"
      by (intro poly_deriv_ge_0, simp, simp add: p'_def)+
    with eq show "poly p x = poly p a" by auto
  qed

  have deriv_0: "\<And>x. x \<in> {a<..<b} \<Longrightarrow> poly p' x = 0"
  proof (intro ballI DERIV_local_const)
    fix x assume x: "x \<in> {a<..<b}"
    hence px: "poly p x = poly p a" by (intro interval_const) simp
    show "(poly p has_real_derivative poly p' x) (at x)" unfolding p'_def by (rule poly_DERIV)
    let ?m = "(a + b) / 2" and ?d = "(b - a) / 2"
    from x and `a < b` show "?d - abs (x - ?m) > 0" by (simp add: field_simps abs_real_def)
    show "\<forall>y. \<bar>x - y\<bar> < ?d - \<bar>x - ?m\<bar> \<longrightarrow> poly p x = poly p y"
    proof (intro allI impI)
      fix y assume "\<bar>x - y\<bar> < ?d - \<bar>x - ?m\<bar>"
      hence "y \<in> {a<..<b}" by (simp add: field_simps abs_real_def split: split_if_asm)
      hence "poly p y = poly p a" by (intro interval_const) simp
      with px show "poly p x = poly p y" by simp
    qed
  qed
  from `a < b` have "\<not>finite {a<..<b}" by (rule dense_linorder_class.infinite_Ioo)
  moreover from deriv_0 have "{a<..<b} \<subseteq> {x. poly p' x = 0}" by blast
  ultimately have "\<not>finite {x. poly p' x = 0}" using finite_subset by blast
  hence "p' = 0" using poly_roots_finite by blast
  with `p' \<noteq> 0` show False by contradiction
qed

lemma pderiv_ge_0_imp_mono_on:
  assumes "connected A" "\<forall>x\<in>A. poly (pderiv p) x \<ge> (0::real)"
  shows "mono_on (poly p) A"
proof (rule mono_onI)
  fix x y assume "x \<in> A" "y \<in> A" "x \<le> y"
  with `connected A` have "{x<..<y} \<subseteq> A" by (intro connected_contains_Ioo)
  with `x \<le> y` and assms(2) show "poly p x \<le> poly p y"
    by (intro poly_deriv_ge_0) auto
qed

lemma pderiv_ge_0_imp_strict_mono_on:
  assumes "connected A" "pderiv p \<noteq> 0" "\<forall>x\<in>A. poly (pderiv p) x \<ge> (0::real)"
  shows "strict_mono_on (poly p) A"
proof (rule strict_mono_onI)
  fix x y assume "x \<in> A" "y \<in> A" "x < y"
  with `connected A` have "{x<..<y} \<subseteq> A" by (intro connected_contains_Ioo)
  with `x < y` and assms(2,3) show "poly p x < poly p y"
    by (intro poly_deriv_ge_0') auto
qed

lemma pderiv_ge_0_imp_mono:
    "(\<forall>x. poly (pderiv p) x \<ge> (0::real)) \<Longrightarrow> mono (poly p) "
  by (intro monoI poly_deriv_ge_0) auto

lemma pderiv_ge_0_imp_strict_mono:
    "pderiv p \<noteq> 0 \<Longrightarrow> (\<forall>x. poly (pderiv p) x \<ge> (0::real)) \<Longrightarrow> strict_mono (poly p) "
  by (intro strict_monoI poly_deriv_ge_0') auto

lemma pderiv_le_0_imp_mono_dec_on:
    "connected A \<Longrightarrow> (\<forall>x\<in>A. poly (pderiv p) x \<le> (0::real)) \<Longrightarrow> mono_dec_on (poly p) A"
  apply (subst mono_dec_on_mono_on_conv, subst poly_minus[symmetric])
  apply (intro pderiv_ge_0_imp_mono_on)
  apply (simp_all add: pderiv_minus)
  done

lemma pderiv_ge_0_imp_strict_mono_dec_on:
    "connected A \<Longrightarrow> pderiv p \<noteq> 0 \<Longrightarrow> (\<forall>x\<in>A. poly (pderiv p) x \<le> (0::real)) \<Longrightarrow> strict_mono_dec_on (poly p) A"
  apply (subst strict_mono_dec_on_strict_mono_on_conv, subst poly_minus[symmetric])
  apply (intro pderiv_ge_0_imp_strict_mono_on)
  apply (simp_all add: pderiv_minus)
  done

lemma pderiv_le_0_imp_mono_dec:
    "(\<forall>x. poly (pderiv p) x \<le> (0::real)) \<Longrightarrow> mono_dec (poly p) "
  apply (subst mono_dec_mono_conv, subst poly_minus[symmetric])
  apply (intro pderiv_ge_0_imp_mono)
  apply (simp add: pderiv_minus)
  done

lemma pderiv_ge_0_imp_strict_mono_dec:
    "pderiv p \<noteq> 0 \<Longrightarrow> (\<forall>x. poly (pderiv p) x \<le> (0::real)) \<Longrightarrow> strict_mono_dec (poly p) "
  apply (subst strict_mono_dec_strict_mono_conv, subst poly_minus[symmetric])
  apply (intro pderiv_ge_0_imp_strict_mono)
  apply (simp_all add: pderiv_minus)
  done

end


theory Fun_Semantics
imports Main
begin

datatype exp = T | F | Zero | Succ exp | IF exp exp exp | EQ exp exp

inductive Eval :: "exp \<Rightarrow> exp \<Rightarrow> bool" (infix "\<Rrightarrow>" 50) where
    IF_T:    "IF T x y \<Rrightarrow> x"
  | IF_F:    "IF F x y \<Rrightarrow> y"
  | IF_Eval: "p \<Rrightarrow> q \<Longrightarrow> IF p x y \<Rrightarrow> IF q x y"
  | Succ_Eval: "x \<Rrightarrow> y \<Longrightarrow> Succ x \<Rrightarrow> Succ y"
  | EQ_same: "EQ x x \<Rrightarrow> T"
  | EQ_S0:   "EQ (Succ x) Zero \<Rrightarrow> F"
  | EQ_0S:   "EQ Zero (Succ y) \<Rrightarrow> F"
  | EQ_SS:   "EQ (Succ x) (Succ y) \<Rrightarrow> EQ x y"
  | EQ_Eval1: "x \<Rrightarrow> z \<Longrightarrow> EQ x y \<Rrightarrow> EQ z y"
  | EQ_Eval2: "y \<Rrightarrow> z \<Longrightarrow> EQ x y \<Rrightarrow> EQ x z"

inductive_simps T_simp [simp]: "T \<Rrightarrow> z"
inductive_simps F_simp [simp]: "F \<Rrightarrow> z"
inductive_simps Zero_simp [simp]: "Zero \<Rrightarrow> z"
inductive_simps Succ_simp [simp]: "Succ x \<Rrightarrow> z"
inductive_simps IF_simp [simp]: "IF p x y \<Rrightarrow>  z"
inductive_simps EQ_simp [simp]: "EQ x y \<Rrightarrow> z"

datatype tp = bool | num

inductive TP :: "exp \<Rightarrow> tp \<Rightarrow> bool" where
  T:    "TP T bool"
| F:    "TP F bool"
| Zero: "TP Zero num"
| IF:   "\<lbrakk>TP p bool; TP x t; TP y t\<rbrakk> \<Longrightarrow> TP (IF p x y) t"
| Succ: "TP x num \<Longrightarrow> TP (Succ x) num"
| EQ:   "\<lbrakk>TP x t; TP y t\<rbrakk> \<Longrightarrow> TP (EQ x y) bool"

inductive_simps TP_IF [simp]: "TP (IF p x y) t"
inductive_simps TP_Succ [simp]: "TP (Succ x) t"
inductive_simps TP_EQ [simp]: "TP (EQ x y) t"

proposition type_preservation:
  assumes "x \<Rrightarrow> y" "TP x t" shows "TP y t"
  using assms
  by (induction x y arbitrary: t rule: Eval.induct) (auto simp: TP.intros)

fun evl :: "exp \<Rightarrow> nat"
  where
    "evl T = 1"
  | "evl F = 0"
  | "evl Zero = 0"
  | "evl (Succ x) = evl x + 1"
  | "evl (IF x y z) = (if evl x = 1 then evl y else evl z)"
  | "evl (EQ x y) = (if evl x = evl y then 1 else 0)"

lemma
  assumes "TP x t" "t = bool" shows "evl x < 2"
  using assms by (induction x t; force)

proposition value_preservation:
  assumes "x \<Rrightarrow> y" shows "evl x = evl y"
  using assms by (induction x y; force)

text \<open>This doesn't hold\<close>
lemma
  assumes "x \<Rrightarrow> y" "x \<Rrightarrow> z" shows "\<exists>u. y \<Rrightarrow> u \<and> z \<Rrightarrow> u"
  nitpick
  oops

inductive EvalStar :: "exp \<Rightarrow> exp \<Rightarrow> bool" (infix "\<Rrightarrow>*" 50) where
    Id: "x \<Rrightarrow>* x"
  | Step: "x \<Rrightarrow> y \<Longrightarrow> y \<Rrightarrow>* z \<Longrightarrow> x \<Rrightarrow>* z"

proposition type_preservation_Star:
  assumes "x \<Rrightarrow>* y" "TP x t" shows "TP y t"
  using assms by (induction x y) (auto simp: type_preservation)

lemma Succ_EvalStar:
  assumes "x \<Rrightarrow>* y" shows "Succ x \<Rrightarrow>* Succ y"
  using assms by induction (auto intro: Succ_Eval EvalStar.intros)

lemma IF_EvalStar:
  assumes "p \<Rrightarrow>* q" shows "IF p x y \<Rrightarrow>* IF q x y"
  using assms by induction (auto intro: IF_Eval EvalStar.intros)

lemma EQ_EvalStar1:
  assumes "x \<Rrightarrow>* z" shows "EQ x y \<Rrightarrow>* EQ z y"
  using assms by induction (auto intro: EQ_Eval1 EvalStar.intros)

lemma EQ_EvalStar2:
  assumes "y \<Rrightarrow>* z" shows "EQ x y \<Rrightarrow>* EQ x z "
  using assms by induction (auto intro: EQ_Eval2 EvalStar.intros)

proposition diamond:
  assumes "x \<Rrightarrow> y" "x \<Rrightarrow> z" shows "\<exists>u. y \<Rrightarrow>* u \<and> z \<Rrightarrow>* u"
  using assms
proof (induction x y arbitrary: z)
  case (IF_Eval p q x y)
  then show ?case
    by (simp; meson F_simp IF_EvalStar T_simp)
next
  case (EQ_SS x y)
  then show ?case
    by (simp; meson Eval.intros EvalStar.intros)
next
  case (EQ_Eval1 x u y)
  then show ?case
    by (auto; meson EQ_EvalStar1 Eval.intros EvalStar.intros)+
next
    case (EQ_Eval2 y u x)
    then show ?case
    by (auto; meson EQ_EvalStar2 Eval.intros EvalStar.intros)+
qed (force intro: Succ_EvalStar Eval.intros EvalStar.intros)+

end