(*  Author: Tobias Nipkow, Alex Krauss, Christian Urban  *)

section "Regular sets"

theory Regular_Set
imports Main
begin

type_synonym 'a lang = "'a list set"

definition conc :: "'a lang \<Rightarrow> 'a lang \<Rightarrow> 'a lang" (infixr "@@" 75) where
"A @@ B = {xs@ys | xs ys. xs:A & ys:B}"

text \<open>checks the code preprocessor for set comprehensions\<close>
export_code conc checking SML

overloading lang_pow == "compow :: nat \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
begin
  primrec lang_pow :: "nat \<Rightarrow> 'a lang \<Rightarrow> 'a lang" where
  "lang_pow 0 A = {[]}" |
  "lang_pow (Suc n) A = A @@ (lang_pow n A)"
end

text \<open>for code generation\<close>

definition lang_pow :: "nat \<Rightarrow> 'a lang \<Rightarrow> 'a lang" where
  lang_pow_code_def [code_abbrev]: "lang_pow = compow"

hide_const (open) lang_pow

definition star :: "'a lang \<Rightarrow> 'a lang" where
"star A = (\<Union>n. A ^^ n)"

subsection\<open>@{term "(@@)"}\<close>

lemma concI[simp,intro]: "u : A \<Longrightarrow> v : B \<Longrightarrow> u@v : A @@ B"
by (auto simp add: conc_def)

lemma concE[elim]:
assumes "w \<in> A @@ B"
obtains u v where "u \<in> A" "v \<in> B" "w = u@v"
using assms by (auto simp: conc_def)

lemma conc_mono: "A \<subseteq> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> A @@ B \<subseteq> C @@ D"
by (auto simp: conc_def)

lemma conc_empty[simp]: shows "{} @@ A = {}" and "A @@ {} = {}"
by auto

lemma conc_epsilon[simp]: shows "{[]} @@ A = A" and "A @@ {[]} = A"
by (simp_all add:conc_def)

lemma conc_assoc: "(A @@ B) @@ C = A @@ (B @@ C)"
by (auto elim!: concE) (simp only: append_assoc[symmetric] concI)

lemma conc_Un_distrib:
shows "A @@ (B \<union> C) = A @@ B \<union> A @@ C"
and   "(A \<union> B) @@ C = A @@ C \<union> B @@ C"
by auto

lemma conc_UNION_distrib:
shows "A @@ \<Union>(M ` I) = \<Union>((%i. A @@ M i) ` I)"
and   "\<Union>(M ` I) @@ A = \<Union>((%i. M i @@ A) ` I)"
by auto

lemma conc_subset_lists: "A \<subseteq> lists S \<Longrightarrow> B \<subseteq> lists S \<Longrightarrow> A @@ B \<subseteq> lists S"
by(fastforce simp: conc_def in_lists_conv_set)

lemma Nil_in_conc[simp]: "[] \<in> A @@ B \<longleftrightarrow> [] \<in> A \<and> [] \<in> B"
by (metis append_is_Nil_conv concE concI)

lemma concI_if_Nil1: "[] \<in> A \<Longrightarrow> xs : B \<Longrightarrow> xs \<in> A @@ B"
by (metis append_Nil concI)

lemma conc_Diff_if_Nil1: "[] \<in> A \<Longrightarrow> A @@ B = (A - {[]}) @@ B \<union> B"
by (fastforce elim: concI_if_Nil1)

lemma concI_if_Nil2: "[] \<in> B \<Longrightarrow> xs : A \<Longrightarrow> xs \<in> A @@ B"
by (metis append_Nil2 concI)

lemma conc_Diff_if_Nil2: "[] \<in> B \<Longrightarrow> A @@ B = A @@ (B - {[]}) \<union> A"
by (fastforce elim: concI_if_Nil2)

lemma singleton_in_conc:
  "[x] : A @@ B \<longleftrightarrow> [x] : A \<and> [] : B \<or> [] : A \<and> [x] : B"
by (fastforce simp: Cons_eq_append_conv append_eq_Cons_conv
       conc_Diff_if_Nil1 conc_Diff_if_Nil2)

subsection\<open>@{term "A ^^ n"}\<close>

lemma lang_pow_add: "A ^^ (n + m) = A ^^ n @@ A ^^ m"
by (induct n) (auto simp: conc_assoc)

lemma lang_pow_empty: "{} ^^ n = (if n = 0 then {[]} else {})"
by (induct n) auto

lemma lang_pow_empty_Suc[simp]: "({}::'a lang) ^^ Suc n = {}"
by (simp add: lang_pow_empty)

lemma length_lang_pow_ub:
  "\<forall>w \<in> A. length w \<le> k \<Longrightarrow> w : A^^n \<Longrightarrow> length w \<le> k*n"
by(induct n arbitrary: w) (fastforce simp: conc_def)+

lemma length_lang_pow_lb:
  "\<forall>w \<in> A. length w \<ge> k \<Longrightarrow> w : A^^n \<Longrightarrow> length w \<ge> k*n"
by(induct n arbitrary: w) (fastforce simp: conc_def)+

lemma lang_pow_subset_lists: "A \<subseteq> lists S \<Longrightarrow> A ^^ n \<subseteq> lists S"
by(induct n)(auto simp: conc_subset_lists)

subsection\<open>@{const star}\<close>

lemma star_subset_lists: "A \<subseteq> lists S \<Longrightarrow> star A \<subseteq> lists S"
unfolding star_def by(blast dest: lang_pow_subset_lists)

lemma star_if_lang_pow[simp]: "w : A ^^ n \<Longrightarrow> w : star A"
by (auto simp: star_def)

lemma Nil_in_star[iff]: "[] : star A"
proof (rule star_if_lang_pow)
  show "[] : A ^^ 0" by simp
qed

lemma star_if_lang[simp]: assumes "w : A" shows "w : star A"
proof (rule star_if_lang_pow)
  show "w : A ^^ 1" using \<open>w : A\<close> by simp
qed

lemma append_in_starI[simp]:
assumes "u : star A" and "v : star A" shows "u@v : star A"
proof -
  from \<open>u : star A\<close> obtain m where "u : A ^^ m" by (auto simp: star_def)
  moreover
  from \<open>v : star A\<close> obtain n where "v : A ^^ n" by (auto simp: star_def)
  ultimately have "u@v : A ^^ (m+n)" by (simp add: lang_pow_add)
  thus ?thesis by simp
qed

lemma conc_star_star: "star A @@ star A = star A"
by (auto simp: conc_def)

lemma conc_star_comm:
  shows "A @@ star A = star A @@ A"
unfolding star_def conc_pow_comm conc_UNION_distrib
by simp

lemma star_induct[consumes 1, case_names Nil append, induct set: star]:
assumes "w : star A"
  and "P []"
  and step: "!!u v. u : A \<Longrightarrow> v : star A \<Longrightarrow> P v \<Longrightarrow> P (u@v)"
shows "P w"
proof -
  { fix n have "w : A ^^ n \<Longrightarrow> P w"
    by (induct n arbitrary: w) (auto intro: \<open>P []\<close> step star_if_lang_pow) }
  with \<open>w : star A\<close> show "P w" by (auto simp: star_def)
qed

lemma star_empty[simp]: "star {} = {[]}"
by (auto elim: star_induct)

lemma star_epsilon[simp]: "star {[]} = {[]}"
by (auto elim: star_induct)

lemma star_idemp[simp]: "star (star A) = star A"
by (auto elim: star_induct)

lemma star_unfold_left: "star A = A @@ star A \<union> {[]}" (is "?L = ?R")
proof
  show "?L \<subseteq> ?R" by (rule, erule star_induct) auto
qed auto

lemma concat_in_star: "set ws \<subseteq> A \<Longrightarrow> concat ws : star A"
by (induct ws) simp_all

lemma in_star_iff_concat:
  "w \<in> star A = (\<exists>ws. set ws \<subseteq> A \<and> w = concat ws)"
  (is "_ = (\<exists>ws. ?R w ws)")
proof
  assume "w : star A" thus "\<exists>ws. ?R w ws"
  proof induct
    case Nil have "?R [] []" by simp
    thus ?case ..
  next
    case (append u v)
    then obtain ws where "set ws \<subseteq> A \<and> v = concat ws" by blast
    with append have "?R (u@v) (u#ws)" by auto
    thus ?case ..
  qed
next
  assume "\<exists>us. ?R w us" thus "w : star A"
  by (auto simp: concat_in_star)
qed

lemma star_conv_concat: "star A = {concat ws|ws. set ws \<subseteq> A}"
by (fastforce simp: in_star_iff_concat)

lemma star_insert_eps[simp]: "star (insert [] A) = star(A)"
proof-
  { fix us
    have "set us \<subseteq> insert [] A \<Longrightarrow> \<exists>vs. concat us = concat vs \<and> set vs \<subseteq> A"
      (is "?P \<Longrightarrow> \<exists>vs. ?Q vs")
    proof
      let ?vs = "filter (%u. u \<noteq> []) us"
      show "?P \<Longrightarrow> ?Q ?vs" by (induct us) auto
    qed
  } thus ?thesis by (auto simp: star_conv_concat)
qed

lemma star_unfold_left_Nil: "star A = (A - {[]}) @@ (star A) \<union> {[]}"
by (metis insert_Diff_single star_insert_eps star_unfold_left)

lemma star_Diff_Nil_fold: "(A - {[]}) @@ star A = star A - {[]}"
proof -
  have "[] \<notin> (A - {[]}) @@ star A" by simp
  thus ?thesis using star_unfold_left_Nil by blast
qed

lemma star_decom:
  assumes a: "x \<in> star A" "x \<noteq> []"
  shows "\<exists>a b. x = a @ b \<and> a \<noteq> [] \<and> a \<in> A \<and> b \<in> star A"
using a by (induct rule: star_induct) (blast)+

subsection \<open>Left-Quotients of languages\<close>

definition Deriv :: "'a \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
  where "Deriv x A = { xs. x#xs \<in> A }"

definition Derivs :: "'a list \<Rightarrow> 'a lang \<Rightarrow> 'a lang"
where "Derivs xs A = { ys. xs @ ys \<in> A }"

abbreviation
  Derivss :: "'a list \<Rightarrow> 'a lang set \<Rightarrow> 'a lang"
where
  "Derivss s As \<equiv> \<Union> (Derivs s ` As)"

lemma Deriv_empty[simp]:   "Deriv a {} = {}"
  and Deriv_epsilon[simp]: "Deriv a {[]} = {}"
  and Deriv_char[simp]:    "Deriv a {[b]} = (if a = b then {[]} else {})"
  and Deriv_union[simp]:   "Deriv a (A \<union> B) = Deriv a A \<union> Deriv a B"
  and Deriv_inter[simp]:   "Deriv a (A \<inter> B) = Deriv a A \<inter> Deriv a B"
  and Deriv_compl[simp]:   "Deriv a (-A) = - Deriv a A"
  and Deriv_Union[simp]:   "Deriv a (Union M) = Union(Deriv a ` M)"
  and Deriv_UN[simp]:      "Deriv a (UN x:I. S x) = (UN x:I. Deriv a (S x))"
by (auto simp: Deriv_def)

lemma Der_conc [simp]:
  shows "Deriv c (A @@ B) = (Deriv c A) @@ B \<union> (if [] \<in> A then Deriv c B else {})"
unfolding Deriv_def conc_def
by (auto simp add: Cons_eq_append_conv)

lemma Deriv_star [simp]:
  shows "Deriv c (star A) = (Deriv c A) @@ star A"
proof -
  have "Deriv c (star A) = Deriv c ({[]} \<union> A @@ star A)"
    by (metis star_unfold_left sup.commute)
  also have "... = Deriv c (A @@ star A)"
    unfolding Deriv_union by (simp)
  also have "... = (Deriv c A) @@ (star A) \<union> (if [] \<in> A then Deriv c (star A) else {})"
    by simp
  also have "... =  (Deriv c A) @@ star A"
    unfolding conc_def Deriv_def
    using star_decom by (force simp add: Cons_eq_append_conv)
  finally show "Deriv c (star A) = (Deriv c A) @@ star A" .
qed

lemma Deriv_diff[simp]:
  shows "Deriv c (A - B) = Deriv c A - Deriv c B"
by(auto simp add: Deriv_def)

lemma Deriv_lists[simp]: "c : S \<Longrightarrow> Deriv c (lists S) = lists S"
by(auto simp add: Deriv_def)

lemma Derivs_simps [simp]:
  shows "Derivs [] A = A"
  and   "Derivs (c # s) A = Derivs s (Deriv c A)"
  and   "Derivs (s1 @ s2) A = Derivs s2 (Derivs s1 A)"
unfolding Derivs_def Deriv_def by auto

lemma in_fold_Deriv: "v \<in> fold Deriv w L \<longleftrightarrow> w @ v \<in> L"
  by (induct w arbitrary: L) (simp_all add: Deriv_def)

lemma Derivs_alt_def [code]: "Derivs w L = fold Deriv w L"
  by (induct w arbitrary: L) simp_all

lemma Deriv_code [code]:
  "Deriv x A = tl ` Set.filter (\<lambda>xs. case xs of x' # _ \<Rightarrow> x = x' | _ \<Rightarrow> False) A"
  by (auto simp: Deriv_def Set.filter_def image_iff tl_def split: list.splits)

subsection \<open>Shuffle product\<close>

definition Shuffle (infixr "\<parallel>" 80) where
  "Shuffle A B = \<Union>{shuffles xs ys | xs ys. xs \<in> A \<and> ys \<in> B}"

lemma Deriv_Shuffle[simp]:
  "Deriv a (A \<parallel> B) = Deriv a A \<parallel> B \<union> A \<parallel> Deriv a B"
  unfolding Shuffle_def Deriv_def by (fastforce simp: Cons_in_shuffles_iff neq_Nil_conv)

lemma shuffle_subset_lists:
  assumes "A \<subseteq> lists S" "B \<subseteq> lists S"
  shows "A \<parallel> B \<subseteq> lists S"
unfolding Shuffle_def proof safe
  fix x and zs xs ys :: "'a list"
  assume zs: "zs \<in> shuffles xs ys" "x \<in> set zs" and "xs \<in> A" "ys \<in> B"
  with assms have "xs \<in> lists S" "ys \<in> lists S" by auto
  with zs show "x \<in> S" by (induct xs ys arbitrary: zs rule: shuffles.induct) auto
qed

lemma Nil_in_Shuffle[simp]: "[] \<in> A \<parallel> B \<longleftrightarrow> [] \<in> A \<and> [] \<in> B"
  unfolding Shuffle_def by force

lemma shuffle_UNION_distrib:
shows "A \<parallel> \<Union>(M ` I) = \<Union>((%i. A \<parallel> M i) ` I)"
and   "\<Union>(M ` I) \<parallel> A = \<Union>((%i. M i \<parallel> A) ` I)"
unfolding Shuffle_def by fast+

lemma Shuffle_empty[simp]:
  "A \<parallel> {} = {}"
  "{} \<parallel> B = {}"
  unfolding Shuffle_def by auto

subsection \<open>Arden's Lemma\<close>

lemma arden_helper:
  assumes eq: "X = A @@ X \<union> B"
  shows "X = (A ^^ Suc n) @@ X \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)"
proof (induct n)
  case 0
  show "X = (A ^^ Suc 0) @@ X \<union> (\<Union>m\<le>0. (A ^^ m) @@ B)"
    using eq by simp
next
  case (Suc n)
  have ih: "X = (A ^^ Suc n) @@ X \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)" by fact
  also have "\<dots> = (A ^^ Suc n) @@ (A @@ X \<union> B) \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)" using eq by simp
  also have "\<dots> = (A ^^ Suc (Suc n)) @@ X \<union> ((A ^^ Suc n) @@ B) \<union> (\<Union>m\<le>n. (A ^^ m) @@ B)"
    by (simp add: conc_Un_distrib conc_assoc[symmetric] conc_pow_comm)
  also have "\<dots> = (A ^^ Suc (Suc n)) @@ X \<union> (\<Union>m\<le>Suc n. (A ^^ m) @@ B)"
    by (auto simp add: atMost_Suc)
  finally show "X = (A ^^ Suc (Suc n)) @@ X \<union> (\<Union>m\<le>Suc n. (A ^^ m) @@ B)" .
qed

lemma Arden:
  assumes "[] \<notin> A"
  shows "X = A @@ X \<union> B \<longleftrightarrow> X = star A @@ B"
proof
  assume eq: "X = A @@ X \<union> B"
  { fix w assume "w : X"
    let ?n = "size w"
    from \<open>[] \<notin> A\<close> have "\<forall>u \<in> A. length u \<ge> 1"
      by (metis Suc_eq_plus1 add_leD2 le_0_eq length_0_conv not_less_eq_eq)
    hence "\<forall>u \<in> A^^(?n+1). length u \<ge> ?n+1"
      by (metis length_lang_pow_lb nat_mult_1)
    hence "\<forall>u \<in> A^^(?n+1)@@X. length u \<ge> ?n+1"
      by(auto simp only: conc_def length_append)
    hence "w \<notin> A^^(?n+1)@@X" by auto
    hence "w : star A @@ B" using \<open>w : X\<close> using arden_helper[OF eq, where n="?n"]
      by (auto simp add: star_def conc_UNION_distrib)
  } moreover
  { fix w assume "w : star A @@ B"
    hence "\<exists>n. w \<in> A^^n @@ B" by(auto simp: conc_def star_def)
    hence "w : X" using arden_helper[OF eq] by blast
  } ultimately show "X = star A @@ B" by blast
next
  assume eq: "X = star A @@ B"
  have "star A = A @@ star A \<union> {[]}"
    by (rule star_unfold_left)
  then have "star A @@ B = (A @@ star A \<union> {[]}) @@ B"
    by metis
  also have "\<dots> = (A @@ star A) @@ B \<union> B"
    unfolding conc_Un_distrib by simp
  also have "\<dots> = A @@ (star A @@ B) \<union> B"
    by (simp only: conc_assoc)
  finally show "X = A @@ X \<union> B"
    using eq by blast
qed

lemma reversed_arden_helper:
  assumes eq: "X = X @@ A \<union> B"
  shows "X = X @@ (A ^^ Suc n) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))"
proof (induct n)
  case 0
  show "X = X @@ (A ^^ Suc 0) \<union> (\<Union>m\<le>0. B @@ (A ^^ m))"
    using eq by simp
next
  case (Suc n)
  have ih: "X = X @@ (A ^^ Suc n) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))" by fact
  also have "\<dots> = (X @@ A \<union> B) @@ (A ^^ Suc n) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))" using eq by simp
  also have "\<dots> = X @@ (A ^^ Suc (Suc n)) \<union> (B @@ (A ^^ Suc n)) \<union> (\<Union>m\<le>n. B @@ (A ^^ m))"
    by (simp add: conc_Un_distrib conc_assoc)
  also have "\<dots> = X @@ (A ^^ Suc (Suc n)) \<union> (\<Union>m\<le>Suc n. B @@ (A ^^ m))"
    by (auto simp add: atMost_Suc)
  finally show "X = X @@ (A ^^ Suc (Suc n)) \<union> (\<Union>m\<le>Suc n. B @@ (A ^^ m))" .
qed

theorem reversed_Arden:
  assumes nemp: "[] \<notin> A"
  shows "X = X @@ A \<union> B \<longleftrightarrow> X = B @@ star A"
proof
 assume eq: "X = X @@ A \<union> B"
  { fix w assume "w : X"
    let ?n = "size w"
    from \<open>[] \<notin> A\<close> have "\<forall>u \<in> A. length u \<ge> 1"
      by (metis Suc_eq_plus1 add_leD2 le_0_eq length_0_conv not_less_eq_eq)
    hence "\<forall>u \<in> A^^(?n+1). length u \<ge> ?n+1"
      by (metis length_lang_pow_lb nat_mult_1)
    hence "\<forall>u \<in> X @@ A^^(?n+1). length u \<ge> ?n+1"
      by(auto simp only: conc_def length_append)
    hence "w \<notin> X @@ A^^(?n+1)" by auto
    hence "w : B @@ star A" using \<open>w : X\<close> using reversed_arden_helper[OF eq, where n="?n"]
      by (auto simp add: star_def conc_UNION_distrib)
  } moreover
  { fix w assume "w : B @@ star A"
    hence "\<exists>n. w \<in> B @@ A^^n" by (auto simp: conc_def star_def)
    hence "w : X" using reversed_arden_helper[OF eq] by blast
  } ultimately show "X = B @@ star A" by blast
next
  assume eq: "X = B @@ star A"
  have "star A = {[]} \<union> star A @@ A"
    unfolding conc_star_comm[symmetric]
    by(metis Un_commute star_unfold_left)
  then have "B @@ star A = B @@ ({[]} \<union> star A @@ A)"
    by metis
  also have "\<dots> = B \<union> B @@ (star A @@ A)"
    unfolding conc_Un_distrib by simp
  also have "\<dots> = B \<union> (B @@ star A) @@ A"
    by (simp only: conc_assoc)
  finally show "X = X @@ A \<union> B"
    using eq by blast
qed

end


theory "Frechet_Correctness"
imports
  Ordinary_Differential_Equations.ODE_Analysis
  "Lib"
  "Syntax"
  "Denotational_Semantics"
  "Ids"
begin
section \<open>Characterization of Term Derivatives\<close>

text \<open>
 This section builds up to a proof that in well-formed interpretations, all
 terms have derivatives, and those derivatives agree with the expected rules
 of derivatives. In particular, we show the [frechet] function given in the
 denotational semantics is the true Frechet derivative of a term. From this
 theorem we can recover all the standard derivative identities as corollaries.
\<close>

lemma inner_prod_eq:
  fixes i::ident
  shows "(\<lambda>(v::Rvec). v \<bullet> axis i 1) = (\<lambda>(v::Rvec). v $ i)"
  unfolding cart_eq_inner_axis axis_def by (simp add: eq_commute)

theorem svar_deriv:
  fixes x:: "ident" and \<nu>:: "Rvec" and F::"real filter"
  shows "((\<lambda>v. v $ x) has_derivative (\<lambda>v'. v' \<bullet> (\<chi> i. if i = x then 1 else 0))) (at \<nu>)"
proof -
  let ?f = "(\<lambda>v. v)"
  let ?f' = "(\<lambda>v'. v')"
  let ?g = "(\<lambda>v. axis x 1)"
  let ?g' = "(\<lambda>v. 0)"
  have id_deriv: "(?f has_derivative ?f') (at \<nu>) "
    by (rule has_derivative_ident)
  have const_deriv: "(?g has_derivative ?g') (at \<nu>)"
    by (rule has_derivative_const)
  have inner_deriv:"((\<lambda>x. inner (?f x) (?g x)) has_derivative
                     (\<lambda>h. inner (?f \<nu>) (?g' h) + inner (?f' h) (?g \<nu>))) (at \<nu>)"
    by (intro has_derivative_inner [OF id_deriv const_deriv])
  from inner_prod_eq
  have left_eq: "(\<lambda>x. inner (?f x) (?g x)) = (\<lambda>v. vec_nth v x)"
    by (auto)
  from inner_deriv and inner_prod_eq
  have better_deriv:"((\<lambda>v. vec_nth v x) has_derivative
                     (\<lambda>h. inner (?f \<nu>) (?g' h) + inner (?f' h) (?g \<nu>))) (at \<nu>)"
    by (metis (no_types, lifting) UNIV_I has_derivative_transform)
  have vec_eq:"(\<chi> i. if i = x then 1 else 0) = (\<chi> i. if x = i then 1 else 0)"
    by(rule vec_extensionality, auto)
  have deriv_eq:"(\<lambda>h. \<nu> \<bullet> 0 + h \<bullet> axis x 1) = (\<lambda>v'. v' \<bullet> (\<chi> i. if i = x then 1 else 0))"
    by(rule ext, auto simp add: axis_def vec_eq)
  show ?thesis
    apply(rule has_derivative_eq_rhs[where f'= "(\<lambda>h. \<nu> \<bullet> 0 + h \<bullet> axis x 1)"])
    using better_deriv deriv_eq  by auto
qed

lemma function_case_inner:
  assumes good_interp:
    "(\<forall>x i. (Functions I i has_derivative FunctionFrechet I i x) (at x))"
  assumes IH:"((\<lambda>v. \<chi> i. sterm_sem I (args i) v)
             has_derivative (\<lambda> v. (\<chi> i. frechet I (args i) \<nu> v))) (at \<nu>)"
  shows  "((\<lambda>v. Functions I f (\<chi> i. sterm_sem I (args i) v))
            has_derivative (\<lambda>v. frechet I ($f f args) \<nu> v)) (at \<nu>)"
proof -
  let ?h = "(\<lambda>v. Functions I f (\<chi> i. sterm_sem I (args i) v))"
  let ?h' = "frechet I ($f f args) \<nu>"
  let ?g = "(\<lambda>v. \<chi> i. sterm_sem I (args i) v)"
  let ?g' = "(\<lambda>v. \<chi> i. frechet I (args i) \<nu> v)"
  let ?f = "(\<lambda>y. Functions I f y)"
  let ?f' = "FunctionFrechet I f (?g \<nu>)"
  have hEqFG:  "?h  = ?f  o ?g" by (auto)
  have hEqFG': "?h' = ?f' o ?g'"
  proof -
    have frechet_def:"frechet I (Function f args) \<nu>
        = (\<lambda>v'. FunctionFrechet I f (?g \<nu>) (\<chi> i. frechet I (args i) \<nu> v'))"
      by (auto)
    have composition:
      "(\<lambda>v'. FunctionFrechet I f (?g \<nu>) (\<chi> i. frechet I (args i) \<nu> v'))
       = (FunctionFrechet I f (?g \<nu>)) o (\<lambda> v'. \<chi> i. frechet I (args i) \<nu> v')"
      by (auto)
    from frechet_def and composition show ?thesis by (auto)
  qed
  have fDeriv: "(?f has_derivative ?f') (at (?g \<nu>))"
    using good_interp is_interp_def by blast
  from IH have gDeriv: "(?g has_derivative ?g') (at \<nu>)" by (auto)
  from fDeriv and gDeriv
  have composeDeriv: "((?f o ?g) has_derivative (?f' o ?g')) (at \<nu>)"
    using diff_chain_at good_interp by blast
  from hEqFG hEqFG' composeDeriv show ?thesis by (auto)
qed

lemma func_lemma2:"(\<forall>x i. (Functions I i has_derivative (THE f'. \<forall>x. (Functions I i has_derivative f' x) (at x)) x) (at x) \<and>
          continuous_on UNIV (\<lambda>x. Blinfun ((THE f'. \<forall>x. (Functions I i has_derivative f' x) (at x)) x))) \<Longrightarrow>
    (\<And>\<theta>. \<theta> \<in> range args \<Longrightarrow> (sterm_sem I \<theta> has_derivative frechet I \<theta> \<nu>) (at \<nu>)) \<Longrightarrow>
    ((\<lambda>v. Functions I f (vec_lambda(\<lambda>i. sterm_sem I (args i) v))) has_derivative (\<lambda>v'. (THE f'. \<forall>x. (Functions I f has_derivative f' x) (at x)) (\<chi> i. sterm_sem I (args i) \<nu>) (\<chi> i. frechet I (args i) \<nu> v'))) (at \<nu>)"
proof -
  assume a1: "\<forall>x i. (Functions I i has_derivative (THE f'. \<forall>x. (Functions I i has_derivative f' x) (at x)) x) (at x) \<and>
          continuous_on UNIV (\<lambda>x. Blinfun ((THE f'. \<forall>x. (Functions I i has_derivative f' x) (at x)) x))"
  then have a1':"\<forall>x i. (Functions I i has_derivative (THE f'. \<forall>x. (Functions I i has_derivative f' x) (at x)) x) (at x)" by auto
  assume a2: "\<And>\<theta>. \<theta> \<in> range args \<Longrightarrow> (sterm_sem I \<theta> has_derivative frechet I \<theta> \<nu>) (at \<nu>)"
  have "\<forall>f fa v. (\<exists>fb. \<not> (f (fb::ident) has_derivative fa fb (v::(real, ident) vec)) (at v)) \<or> ((\<lambda>v. (\<chi> fa. (f fa v::real))) has_derivative (\<lambda>va. (\<chi> f. fa f v va))) (at v)"
    using has_derivative_vec by force
  then have "((\<lambda>v. \<chi> f. sterm_sem I (args f) v) has_derivative (\<lambda>v. \<chi> f. frechet I (args f) \<nu> v)) (at \<nu>)"
    by (auto simp add: a2 has_derivative_vec)
  then show "((\<lambda>v. Functions I f (vec_lambda(\<lambda>f. sterm_sem I (args f) v))) has_derivative (\<lambda>v'. (THE f'. \<forall>x. (Functions I f has_derivative f' x) (at x)) (\<chi> i. sterm_sem I (args i) \<nu>) (\<chi> i. frechet I (args i) \<nu> v'))) (at \<nu>)"
    using a1' function_case_inner by auto
qed

lemma func_lemma:
  "is_interp I \<Longrightarrow>
  (\<And>\<theta> :: trm. \<theta> \<in> range args \<Longrightarrow> (sterm_sem I \<theta> has_derivative frechet I \<theta> \<nu>) (at \<nu>)) \<Longrightarrow>
  (sterm_sem I ($f f args) has_derivative frechet I ($f f args) \<nu>) (at \<nu>)"
  apply(auto simp add: sfunction_case is_interp_def function_case_inner)
  apply(erule func_lemma2)
  apply(auto)
  done

text \<open> The syntactic definition of term derivatives agrees with the semantic definition.
  Since the syntactic definition of derivative is total, this gives us that derivatives are "decidable" for
  terms (modulo computations on reals) and that they obey all the expected identities, which gives
  us the axioms we want for differential terms essentially for free.
 \<close>
lemma frechet_correctness:
  fixes I :: "interp" and \<nu>
  assumes good_interp: "is_interp I"
  shows "dfree \<theta> \<Longrightarrow> FDERIV (sterm_sem I \<theta>) \<nu> :> (frechet I \<theta> \<nu>)"
proof (induct rule: dfree.induct)
  case (dfree_Var i) then show ?case
    by (auto simp add: svar_case svar_deriv axis_def)
next
  case (dfree_Fun args i) with good_interp show ?case
    by (intro func_lemma) auto
qed auto

text \<open>If terms are semantically equivalent in all states, so are their derivatives\<close>
lemma sterm_determines_frechet:
  fixes I ::"interp"
    and J ::"interp"
    and \<theta>1 :: "trm"
    and \<theta>2 :: "trm"
    and \<nu>
  assumes good_interp1:"is_interp I"
  assumes good_interp2:"is_interp J"
  assumes free1:"dfree \<theta>1"
  assumes free2:"dfree \<theta>2"
  assumes sem:"sterm_sem I \<theta>1 = sterm_sem J \<theta>2"
  shows "frechet I \<theta>1 (fst \<nu>) (snd \<nu>) = frechet J \<theta>2 (fst \<nu>) (snd \<nu>)"
proof -
  have d1:"(sterm_sem I \<theta>1 has_derivative (frechet I \<theta>1 (fst \<nu>))) (at (fst \<nu>))"
    using frechet_correctness[OF good_interp1 free1] by auto
  have d2:"(sterm_sem J \<theta>2 has_derivative (frechet J \<theta>2 (fst \<nu>))) (at (fst \<nu>))"
    using frechet_correctness[OF good_interp2 free2] by auto
  then have d1':"(sterm_sem I \<theta>1 has_derivative (frechet J \<theta>2 (fst \<nu>))) (at (fst \<nu>))"
    using sem by auto
  thus "?thesis" using has_derivative_unique d1 d1' by metis
qed

lemma the_deriv:
  assumes deriv:"(f has_derivative F) (at x)"
  shows "(THE G. (f has_derivative G) (at x)) = F"
  apply(rule the_equality)
   subgoal by (rule deriv)
  subgoal for G by (auto simp add: deriv has_derivative_unique)
  done

lemma the_all_deriv:
  assumes deriv:"\<forall>x. (f has_derivative F x) (at x)"
  shows "(THE G. \<forall> x. (f has_derivative G x) (at x)) = F"
    apply(rule the_equality)
     subgoal by (rule deriv)
    subgoal for G
      apply(rule ext)
      subgoal for x
        apply(erule allE[where x=x])
        by (auto simp add: deriv has_derivative_unique)
      done
    done

typedef strm = "{\<theta>:: trm. dfree \<theta>}"
  morphisms raw_term simple_term
  by(rule exI[where x= "\<^bold>0"], auto simp add: dfree_Zero)

typedef good_interp = "{I:: interp. is_interp I}"
  morphisms raw_interp good_interp
  apply(rule exI[where x="\<lparr> Functions = (\<lambda>f x. 0), Funls = (\<lambda>F v. 0), Predicates = (\<lambda>p x. True), Contexts = (\<lambda>C S. S), Programs = (\<lambda>a. {}), ODEs = (\<lambda>c sp v. (\<chi> i. 0)), ODEBV = \<lambda>c sp. {}\<rparr>"])
  apply(auto simp add: is_interp_def)
proof -
  fix x ::real
  have eq:"(THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) = (\<lambda>_ _. 0)"
    by(rule the_all_deriv, auto)
  have eq':"(THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x = (\<lambda>_. 0)"
    by (simp add: eq)
  have deriv:"((\<lambda>x.0) has_derivative (\<lambda>x. 0)) (at x)"
    by auto
  then show "\<And>x. ((\<lambda>x. 0) has_derivative (THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x) (at x)"
    by (auto simp add: eq eq' deriv)
next
  have eq:"(THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) = (\<lambda>_ _. 0)"
    by(rule the_all_deriv, auto)
  have eq':"\<forall>x. (THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x = (\<lambda>_. 0)"
    by (simp add: eq)
  have deriv:"\<And>x. ((\<lambda>x.0) has_derivative (\<lambda>x. 0)) (at x)"
    by auto
  have blin:"\<And>x. bounded_linear ((THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x)"
    by (simp add: eq')
  show " continuous_on UNIV (\<lambda>x. Blinfun ((THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x))"
    apply(clarsimp simp add: continuous_on_topological[of UNIV "(\<lambda>x. Blinfun ((THE f'. \<forall>x. ((\<lambda>x. 0) has_derivative f' x) (at x)) x))"])
    apply(rule exI[where x = UNIV])
    by(auto simp add: eq' blin)
 qed

lemma frechet_linear:
  assumes good_interp:"is_interp I"
  fixes v \<theta>
  shows " dfree \<theta> \<Longrightarrow> bounded_linear (frechet I \<theta> v)"
proof(induction rule: dfree.induct)
  case (dfree_Var i)
  then show ?case by(auto)
next
  case (dfree_Const r)
  then show ?case by auto
next
  case (dfree_Fun i args)
  have blin1:"\<And>x. bounded_linear(FunctionFrechet I i x)"
    using good_interp unfolding is_interp_def using has_derivative_bounded_linear
    by blast
  have blin2:"bounded_linear (\<lambda> a. (\<chi> i. frechet I (args i) v a))"
    apply(rule bounded_linear_vec)
    using dfree_Fun.IH by auto
  then show ?case
    using bounded_linear_compose[of "FunctionFrechet I i (\<chi> i. sterm_sem I (args i) v)" "(\<lambda>a. (\<chi> i. frechet I (args i) v a))", OF blin1 blin2]
    by auto
next
  case (dfree_Plus \<theta>\<^sub>1 \<theta>\<^sub>2)
  then show ?case
    apply auto
    using bounded_linear_add by (blast)
next
  case (dfree_Times \<theta>\<^sub>1 \<theta>\<^sub>2)
  then show ?case
    by (auto simp add: bounded_linear_add bounded_linear_const_mult bounded_linear_mult_const)
next
  case (dfree_Neg \<theta>)
  then show ?case
    apply(auto)
    using bounded_linear_minus by blast
qed

setup_lifting type_definition_good_interp

setup_lifting type_definition_strm

lift_definition blin_frechet::"good_interp \<Rightarrow> strm \<Rightarrow> (real, ident) vec  \<Rightarrow> (real, ident) vec \<Rightarrow>\<^sub>L real" is "frechet"
  using frechet_linear by auto

lemmas [simp] = blin_frechet.rep_eq

lemma frechet_blin:"is_interp I \<Longrightarrow> dfree \<theta> \<Longrightarrow> (\<lambda>v. Blinfun (\<lambda>v'. frechet I \<theta> v v')) = blin_frechet (good_interp I) (simple_term \<theta>)"
  apply(rule ext)
  apply(rule blinfun_eqI)
  by (simp add: bounded_linear_Blinfun_apply frechet_linear good_interp_inverse simple_term_inverse)

lemma sterm_continuous:
  assumes good_interp:"is_interp I"
  shows "dfree \<theta> \<Longrightarrow> continuous_on UNIV (sterm_sem I \<theta>)"
proof(induction rule: dfree.induct)
  case (dfree_Fun i args)
  assume IH:"\<forall> i. dfree (args i) \<and> continuous_on UNIV (sterm_sem I (args i))"
  have con1:"continuous_on UNIV (Functions I i)"
    using good_interp unfolding is_interp_def
    using continuous_on_eq_continuous_within has_derivative_continuous by blast
  have con2:"continuous_on UNIV (\<lambda> x. (\<chi> i. sterm_sem I (args i) x))"
    apply(rule continuous_on_vec_lambda)
    using IH by auto
  have con:"continuous_on UNIV ((Functions I i) \<circ> (\<lambda>x.  (\<chi> i. sterm_sem I (args i) x)))"
    apply(rule continuous_on_compose)
     using con1 con2 apply auto
    using continuous_on_subset by blast
  show ?case
    using con comp_def by(simp)
qed (auto intro: continuous_intros)

lemma sterm_continuous':
  assumes good_interp:"is_interp I"
  shows "dfree \<theta> \<Longrightarrow> continuous_on S (sterm_sem I \<theta>)"
  using sterm_continuous continuous_on_subset good_interp by blast

lemma frechet_continuous:
  fixes I :: "interp"
  assumes good_interp:"is_interp I"
  shows "dfree \<theta> \<Longrightarrow> continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>))"
proof (induction rule: dfree.induct)
  case (dfree_Var i)
  have free:"dfree (Var i)" by (rule dfree_Var)
  have bounded_linear:"bounded_linear (\<lambda> \<nu>'. \<nu>' \<bullet> axis i 1)"
    by (auto simp add: bounded_linear_vec_nth)
  have cont:"continuous_on UNIV (\<lambda>\<nu>. Blinfun(\<lambda> \<nu>'. \<nu>' \<bullet> axis i 1))"
    using continuous_on_const by blast
  have eq:"\<And>\<nu> \<nu>'. (\<lambda>\<nu>. Blinfun(\<lambda> \<nu>'. \<nu>' \<bullet> axis i 1)) \<nu> \<nu>' = (blin_frechet (good_interp I) (simple_term (Var i))) \<nu> \<nu>'"
    unfolding axis_def apply(auto)
    by (metis (no_types) axis_def blinfun_inner_left.abs_eq blinfun_inner_left.rep_eq dfree_Var_simps frechet.simps(1) mem_Collect_eq simple_term_inverse)
  have eq':"(\<lambda>\<nu>. Blinfun(\<lambda> \<nu>'. \<nu>' \<bullet> axis i 1)) = (blin_frechet (good_interp I) (simple_term (Var i)))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    using eq by auto
  then show ?case by (metis cont)
next
  case (dfree_Const r)
  have free:"dfree (Const r)" by (rule dfree_Const)
  have bounded_linear:"bounded_linear (\<lambda> \<nu>'. 0)" by (simp)
  have cont:"continuous_on UNIV (\<lambda>\<nu>. Blinfun(\<lambda> \<nu>'. 0))"
    using continuous_on_const by blast
  have eq':"(\<lambda>\<nu>. Blinfun(\<lambda> \<nu>'. 0)) = (blin_frechet (good_interp I) (simple_term (Const r)))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    apply auto
    using zero_blinfun.abs_eq zero_blinfun.rep_eq free
    apply(auto simp add: frechet.simps(5) mem_Collect_eq simple_term_inverse)
    using frechet.simps(5) mem_Collect_eq simple_term_inverse
    by (smt blinfun.zero_left zero_blinfun_def)
  then show ?case by (metis cont)
next
  case (dfree_Fun f args) then have nbf:"nonbase f"
    and ilf:"ilength f < MAX_STR"
    and IHs:"\<forall>i. dfree (args i) \<and> continuous_on UNIV (blin_frechet (good_interp I) (simple_term (args i)))" by auto
  assume trueIH:"\<forall>i. dfree (args i) \<and> continuous_on UNIV (blin_frechet (good_interp I) (simple_term (args i)))"
  from trueIH have IH:"\<And>i.  continuous_on UNIV (blin_frechet (good_interp I) (simple_term (args i)))" by auto
  from trueIH have frees:"(\<And>i. dfree (args i))" by auto
  then have free:"dfree ($f f args)"
    using dfree.dfree_Fun ilf  nbf by blast
  have great_interp:"\<And>f. continuous_on UNIV (\<lambda>x. Blinfun (FunctionFrechet I f x))" using good_interp unfolding is_interp_def by auto
  have cont1:"\<And>v. continuous_on UNIV (\<lambda>v'. (\<chi> i. frechet I (args i) v v'))"
    apply(rule continuous_on_vec_lambda)
    using IH by (simp add: frechet_linear frees good_interp linear_continuous_on)
  have eq:"(\<lambda>v. Blinfun(\<lambda>v'. FunctionFrechet I f (\<chi> i. sterm_sem I (args i) v) (\<chi> i. frechet I (args i) v v')))
    = (blin_frechet (good_interp I) (simple_term (Function f args)))"
    using frechet_blin[OF good_interp free] by auto
  have bounded_linears:"\<And>x. bounded_linear (FunctionFrechet I f x)" using good_interp unfolding is_interp_def by blast
  let ?blin_ff ="(\<lambda>x. Blinfun (FunctionFrechet I f x))"
  have some_eq:"(\<lambda>x. Blinfun (FunctionFrechet I f (\<chi> i. sterm_sem I (args i) x))) =
                ((?blin_ff) \<circ> (\<lambda>x. (\<chi> i. sterm_sem I (args i) x)))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    unfolding comp_def by blast
  have sub_cont:"continuous_on UNIV ((?blin_ff) \<circ> (\<lambda>x. (\<chi> i. sterm_sem I (args i) x)))"
    apply(rule continuous_intros)+
     apply (simp add: frees good_interp sterm_continuous')
    using continuous_on_subset great_interp by blast
  have blin_frech_vec:"\<And>x. bounded_linear (\<lambda>v'. \<chi> i. frechet I (args i) x v')"
    by (simp add: bounded_linear_vec frechet_linear frees good_interp)
  have frech_vec_eq:"(\<lambda>x. Blinfun (\<lambda>v'. \<chi> i. frechet I (args i) x v')) = (\<lambda>x. blinfun_vec (\<lambda> i. blin_frechet (good_interp I) (simple_term (args i)) x))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    apply(rule vec_extensionality)
    subgoal for x i j
      using blin_frech_vec[of x]
      apply auto
      by (metis (no_types, lifting) blin_frechet.rep_eq bounded_linear_Blinfun_apply frechet_blin frechet_linear frees good_interp vec_lambda_beta)
    done
  have cont_frech_vec:"continuous_on UNIV (\<lambda>x. blinfun_vec (\<lambda> i. blin_frechet (good_interp I) (simple_term (args i)) x))"
    apply(rule continuous_blinfun_vec')
    using IH by blast
  have cont_intro:"\<And> s f g. continuous_on s f \<Longrightarrow> continuous_on s g \<Longrightarrow> continuous_on s (\<lambda>x. f x o\<^sub>L g x)"
    by (auto intro: continuous_intros)
  have cont:"continuous_on UNIV (\<lambda>v. blinfun_compose (Blinfun (FunctionFrechet I f (\<chi> i. sterm_sem I (args i) v))) (Blinfun(\<lambda>v'.  (\<chi> i. frechet I (args i) v v'))))"
    apply(rule cont_intro)
     subgoal using  sub_cont by simp
    using frech_vec_eq cont_frech_vec by presburger
  have best_eq:"(blin_frechet (good_interp I) (simple_term ($f f args))) = (\<lambda>v. blinfun_compose (Blinfun (FunctionFrechet I f (\<chi> i. sterm_sem I (args i) v))) (Blinfun(\<lambda>v'.  (\<chi> i. frechet I (args i) v v')))) "
    apply(rule ext)
    apply(rule blinfun_eqI)
  proof -
    fix v :: "(real, ident) vec" and i :: "(real, ident) vec"
    have "frechet I ($f f args) v i = blinfun_apply (blin_frechet (good_interp I) (simple_term ($f f args)) v) i"
      using bounded_linear_Blinfun_apply dfree_Fun_simps frechet_blin frechet_linear frees good_interp
      by (smt free)
    then have "FunctionFrechet I f (\<chi> s. sterm_sem I (args s) v) (blinfun_apply (Blinfun (\<lambda>va. \<chi> s. frechet I (args s) v va)) i) = blinfun_apply (blin_frechet (good_interp I) (simple_term ($f f args)) v) i"
      by (simp add: blin_frech_vec bounded_linear_Blinfun_apply)
    then show "blinfun_apply (blin_frechet (good_interp I) (simple_term ($f f args)) v) i = blinfun_apply (Blinfun (FunctionFrechet I f (\<chi> s. sterm_sem I (args s) v)) o\<^sub>L Blinfun (\<lambda>va. \<chi> s. frechet I (args s) v va)) i"
      by (metis (no_types) blinfun_apply_blinfun_compose bounded_linear_Blinfun_apply bounded_linears)
  qed
  then show ?case using cont best_eq by auto
next
  case (dfree_Neg \<theta>)
  assume IH1:"continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>))"
  assume free1:"dfree \<theta>"
  have free:"dfree (Neg \<theta>)" using free1 by auto
  have bounded_linear:"\<And>v. bounded_linear (\<lambda>v'. - frechet I \<theta> v v' )"
    subgoal for v
      using frechet_linear[OF good_interp free] by auto
    done
  have eq2:"(\<lambda>v. - blin_frechet (good_interp I) (simple_term \<theta>) v) = blin_frechet (good_interp I) (simple_term (Neg \<theta>))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    by (simp add: simple_term_inverse blinfun.minus_left blinfun.add_left free1  simple_term_inverse)
  have cont:"continuous_on UNIV (\<lambda>v. - blin_frechet (good_interp I) (simple_term \<theta>) v)"
    using continuous_on_minus dfree_Neg.IH by blast
  then show ?case using cont eq2 by metis
next
  case (dfree_Plus \<theta>\<^sub>1 \<theta>\<^sub>2)
  assume IH1:"continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1))"
  assume IH2:"continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2))"
  assume free1:"dfree \<theta>\<^sub>1"
  assume free2:"dfree \<theta>\<^sub>2"
  have free:"dfree (Plus \<theta>\<^sub>1 \<theta>\<^sub>2)" using free1 free2 by auto
  have bounded_linear:"\<And>v. bounded_linear (\<lambda>v'. frechet I \<theta>\<^sub>1 v v' + frechet I \<theta>\<^sub>2 v v')"
    subgoal for v
      using frechet_linear[OF good_interp free] by auto
    done
  have eq2:"(\<lambda>v. blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v + blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) = blin_frechet (good_interp I) (simple_term (Plus \<theta>\<^sub>1 \<theta>\<^sub>2))"
    apply(rule ext)
    apply(rule blinfun_eqI)
    by (simp add: blinfun.add_left free1 free2 simple_term_inverse)
  have cont:"continuous_on UNIV (\<lambda>v. blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v + blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v)"
    using continuous_on_add dfree_Plus.IH(1) dfree_Plus.IH(2) by blast
  then show ?case using cont eq2 by metis
next
  case (dfree_Times \<theta>\<^sub>1 \<theta>\<^sub>2)
  assume IH1:"continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1))"
  assume IH2:"continuous_on UNIV (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2))"
  assume free1:"dfree \<theta>\<^sub>1"
  assume free2:"dfree \<theta>\<^sub>2"
  have free:"dfree (Times \<theta>\<^sub>1 \<theta>\<^sub>2)" using free1 free2 by auto
  have bounded_linear:"\<And>v. bounded_linear (\<lambda>v'. sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v v' + frechet I \<theta>\<^sub>1 v v' * sterm_sem I \<theta>\<^sub>2 v)"
    apply(rule bounded_linear_add)
    apply(rule bounded_linear_const_mult)
    using frechet_linear[OF good_interp free2] apply auto
    apply(rule bounded_linear_mult_const)
    using frechet_linear[OF good_interp free1] by auto
  then have blin':"\<And>v. (\<lambda>v'. sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v v' + frechet I \<theta>\<^sub>1 v v' * sterm_sem I \<theta>\<^sub>2 v) \<in> {f. bounded_linear f}" by auto
  have blinfun_eq:"\<And>v. Blinfun (\<lambda>v'. sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v v' + frechet I \<theta>\<^sub>1 v v' * sterm_sem I \<theta>\<^sub>2 v)
    =  scaleR (sterm_sem I \<theta>\<^sub>1 v) (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) + scaleR (sterm_sem I \<theta>\<^sub>2 v) (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v)"
    apply(rule blinfun_eqI)
    subgoal for v i
      using Blinfun_inverse[OF blin', of v] apply auto
      using blinfun.add_left[of "sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v" "sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v"]
        blinfun.scaleR_left[of "sterm_sem I \<theta>\<^sub>1 v" "blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v"]
        blinfun.scaleR_left[of "sterm_sem I \<theta>\<^sub>2 v" "blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v"]
        bounded_linear_Blinfun_apply
        frechet_blin[OF good_interp free1]
        frechet_blin[OF good_interp free2]
        frechet_linear[OF good_interp free1]
        frechet_linear[OF good_interp free2]
        mult.commute
        real_scaleR_def
    proof -
      have f1: "\<And>v. blinfun_apply (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) = frechet I \<theta>\<^sub>1 v"
        by (metis (no_types) \<open>(\<lambda>v. Blinfun (frechet I \<theta>\<^sub>1 v)) = blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1)\<close> \<open>\<And>v. bounded_linear (frechet I \<theta>\<^sub>1 v)\<close> bounded_linear_Blinfun_apply)
      have "\<And>v. blinfun_apply (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) = frechet I \<theta>\<^sub>2 v"
      by (metis (no_types) \<open>(\<lambda>v. Blinfun (frechet I \<theta>\<^sub>2 v)) = blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2)\<close> \<open>\<And>v. bounded_linear (frechet I \<theta>\<^sub>2 v)\<close> bounded_linear_Blinfun_apply)
      then show "sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v i + frechet I \<theta>\<^sub>1 v i * sterm_sem I \<theta>\<^sub>2 v = blinfun_apply (sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v + sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) i"
        using f1 by (simp add: \<open>\<And>b. blinfun_apply (sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v + sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) b = blinfun_apply (sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) b + blinfun_apply (sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) b\<close> \<open>\<And>b. blinfun_apply (sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) b = sterm_sem I \<theta>\<^sub>1 v *\<^sub>R blinfun_apply (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v) b\<close> \<open>\<And>b. blinfun_apply (sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) b = sterm_sem I \<theta>\<^sub>2 v *\<^sub>R blinfun_apply (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v) b\<close>)
    qed
    done
  have cont':"continuous_on UNIV
    (\<lambda>v. scaleR (sterm_sem I \<theta>\<^sub>1 v) (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>2) v)
       + scaleR (sterm_sem I \<theta>\<^sub>2 v) (blin_frechet (good_interp I) (simple_term \<theta>\<^sub>1) v))"
    apply(rule continuous_on_add)
     apply(rule continuous_on_scaleR)
      apply(rule sterm_continuous[OF good_interp free1])
     apply(rule IH2)
    apply(rule continuous_on_scaleR)
     apply(rule sterm_continuous[OF good_interp free2])
    by(rule IH1)
  have cont:"continuous_on UNIV (\<lambda>v. Blinfun (\<lambda>v'. sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v v' + frechet I \<theta>\<^sub>1 v v' * sterm_sem I \<theta>\<^sub>2 v))"
    using cont' blinfun_eq by auto
  have eq:"(\<lambda>v. Blinfun (\<lambda>v'. sterm_sem I \<theta>\<^sub>1 v * frechet I \<theta>\<^sub>2 v v' + frechet I \<theta>\<^sub>1 v v' * sterm_sem I \<theta>\<^sub>2 v)) = blin_frechet (good_interp I) (simple_term (Times \<theta>\<^sub>1 \<theta>\<^sub>2))"
    using frechet_blin[OF good_interp free]
    by auto
  then show ?case by (metis cont)
qed
end


(*  Title:      HOL/Quotient_Examples/Lift_Fun.thy
    Author:     Ondrej Kuncar
*)

section \<open>Example of lifting definitions with contravariant or co/contravariant type variables\<close>

theory Lift_Fun
imports MainRLT "HOL-Library.Quotient_Syntax"
begin

text \<open>This file is meant as a test case.
  It contains examples of lifting definitions with quotients that have contravariant
  type variables or type variables which are covariant and contravariant in the same time.\<close>

subsection \<open>Contravariant type variables\<close>

text \<open>'a is a contravariant type variable and we are able to map over this variable
  in the following four definitions. This example is based on HOL/Fun.thy.\<close>

quotient_type
('a, 'b) fun' (infixr "\<rightarrow>" 55) = "'a \<Rightarrow> 'b" / "(=)"
  by (simp add: identity_equivp)

quotient_definition "comp' :: ('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'c"  is
  "comp :: ('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" done

quotient_definition "fcomp' :: ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'c" is
  fcomp done

quotient_definition "map_fun' :: ('c \<rightarrow> 'a) \<rightarrow> ('b \<rightarrow> 'd) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'c \<rightarrow> 'd"
  is "map_fun::('c \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'c \<Rightarrow> 'd" done

quotient_definition "inj_on' :: ('a \<rightarrow> 'b) \<rightarrow> 'a set \<rightarrow> bool" is inj_on done

quotient_definition "bij_betw' :: ('a \<rightarrow> 'b) \<rightarrow> 'a set \<rightarrow> 'b set \<rightarrow> bool" is bij_betw done

subsection \<open>Co/Contravariant type variables\<close>

text \<open>'a is a covariant and contravariant type variable in the same time.
  The following example is a bit artificial. We haven't had a natural one yet.\<close>

quotient_type 'a endofun = "'a \<Rightarrow> 'a" / "(=)" by (simp add: identity_equivp)

definition map_endofun' :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> ('a => 'a) \<Rightarrow> ('b => 'b)"
  where "map_endofun' f g e = map_fun g f e"

quotient_definition "map_endofun :: ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a) \<Rightarrow> 'a endofun \<Rightarrow> 'b endofun" is
  map_endofun' done

text \<open>Registration of the map function for 'a endofun.\<close>

functor map_endofun : map_endofun
proof -
  have "\<forall> x. abs_endofun (rep_endofun x) = x" using Quotient3_endofun by (auto simp: Quotient3_def)
  then show "map_endofun id id = id"
    by (auto simp: map_endofun_def map_endofun'_def map_fun_def fun_eq_iff)

  have a:"\<forall> x. rep_endofun (abs_endofun x) = x" using Quotient3_endofun
    Quotient3_rep_abs[of "(=)" abs_endofun rep_endofun] by blast
  show "\<And>f g h i. map_endofun f g \<circ> map_endofun h i = map_endofun (f \<circ> h) (i \<circ> g)"
    by (auto simp: map_endofun_def map_endofun'_def map_fun_def fun_eq_iff) (simp add: a o_assoc)
qed

text \<open>Relator for 'a endofun.\<close>

definition
  rel_endofun' :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> bool"
where
  "rel_endofun' R = (\<lambda>f g. (R ===> R) f g)"

quotient_definition "rel_endofun :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a endofun \<Rightarrow> 'b endofun \<Rightarrow> bool" is
  rel_endofun' done

lemma endofun_quotient:
assumes a: "Quotient3 R Abs Rep"
shows "Quotient3 (rel_endofun R) (map_endofun Abs Rep) (map_endofun Rep Abs)"
proof (intro Quotient3I)
  show "\<And>a. map_endofun Abs Rep (map_endofun Rep Abs a) = a"
    by (metis (opaque_lifting, no_types) a abs_o_rep id_apply map_endofun.comp map_endofun.id o_eq_dest_lhs)
next
  show "\<And>a. rel_endofun R (map_endofun Rep Abs a) (map_endofun Rep Abs a)"
  using fun_quotient3[OF a a, THEN Quotient3_rep_reflp]
  unfolding rel_endofun_def map_endofun_def map_fun_def o_def map_endofun'_def rel_endofun'_def id_def
    by (metis (mono_tags) Quotient3_endofun rep_abs_rsp)
next
  have abs_to_eq: "\<And> x y. abs_endofun x = abs_endofun y \<Longrightarrow> x = y"
  by (drule arg_cong[where f=rep_endofun]) (simp add: Quotient3_rep_abs[OF Quotient3_endofun])
  fix r s
  show "rel_endofun R r s =
          (rel_endofun R r r \<and>
           rel_endofun R s s \<and> map_endofun Abs Rep r = map_endofun Abs Rep s)"
    apply(auto simp add: rel_endofun_def rel_endofun'_def map_endofun_def map_endofun'_def)
    using fun_quotient3[OF a a,THEN Quotient3_refl1]
    apply metis
    using fun_quotient3[OF a a,THEN Quotient3_refl2]
    apply metis
    using fun_quotient3[OF a a, THEN Quotient3_rel]
    apply metis
    by (auto intro: fun_quotient3[OF a a, THEN Quotient3_rel, THEN iffD1] simp add: abs_to_eq)
qed

declare [[mapQ3 endofun = (rel_endofun, endofun_quotient)]]

quotient_definition "endofun_id_id :: ('a endofun) endofun" is "id :: ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" done

term  endofun_id_id
thm  endofun_id_id_def

quotient_type 'a endofun' = "'a endofun" / "(=)" by (simp add: identity_equivp)

text \<open>We have to map "'a endofun" to "('a endofun') endofun", i.e., mapping (lifting)
  over a type variable which is a covariant and contravariant type variable.\<close>

quotient_definition "endofun'_id_id :: ('a endofun') endofun'" is endofun_id_id done

term  endofun'_id_id
thm  endofun'_id_id_def

end