section \<open>Euclidean Space: Executability\<close>
theory Executable_Euclidean_Space
imports
  "HOL-Analysis.Multivariate_Analysis"
  "List-Index.List_Index"
  "HOL-Library.Float"
  "HOL-Library.Code_Cardinality"
  Affine_Arithmetic_Auxiliarities
begin

subsection \<open>Ordered representation of Basis and Rounding of Components\<close>

class executable_euclidean_space = ordered_euclidean_space +
  fixes Basis_list eucl_down eucl_truncate_down eucl_truncate_up
  assumes eucl_down_def:
    "eucl_down p b = (\<Sum>i \<in> Basis. round_down p (b \<bullet> i) *\<^sub>R i)"
  assumes eucl_truncate_down_def:
    "eucl_truncate_down q b = (\<Sum>i \<in> Basis. truncate_down q (b \<bullet> i) *\<^sub>R i)"
  assumes eucl_truncate_up_def:
    "eucl_truncate_up q b = (\<Sum>i \<in> Basis. truncate_up q (b \<bullet> i) *\<^sub>R i)"
  assumes Basis_list[simp]: "set Basis_list = Basis"
  assumes distinct_Basis_list[simp]: "distinct Basis_list"
begin

lemma length_Basis_list:
  "length Basis_list = card Basis"
  by (metis Basis_list distinct_Basis_list distinct_card)

end

lemma eucl_truncate_down_zero[simp]: "eucl_truncate_down p 0 = 0"
  by (auto simp: eucl_truncate_down_def truncate_down_zero)

lemma eucl_truncate_up_zero[simp]: "eucl_truncate_up p 0 = 0"
  by (auto simp: eucl_truncate_up_def)

subsection \<open>Instantiations\<close>

instantiation real::executable_euclidean_space
begin

definition Basis_list_real :: "real list" where
  "Basis_list_real = [1]"

definition "eucl_down prec b = round_down prec b"
definition "eucl_truncate_down prec b = truncate_down prec b"
definition "eucl_truncate_up prec b = truncate_up prec b"

instance proof qed (auto simp: Basis_list_real_def eucl_down_real_def eucl_truncate_down_real_def
  eucl_truncate_up_real_def)

end

instantiation prod::(executable_euclidean_space, executable_euclidean_space)
  executable_euclidean_space
begin

definition Basis_list_prod :: "('a \<times> 'b) list" where
  "Basis_list_prod =
    zip Basis_list (replicate (length (Basis_list::'a list)) 0) @
    zip (replicate (length (Basis_list::'b list)) 0) Basis_list"

definition "eucl_down p a = (eucl_down p (fst a), eucl_down p (snd a))"
definition "eucl_truncate_down p a = (eucl_truncate_down p (fst a), eucl_truncate_down p (snd a))"
definition "eucl_truncate_up p a = (eucl_truncate_up p (fst a), eucl_truncate_up p (snd a))"

instance
proof
  show "set Basis_list = (Basis::('a*'b) set)"
    by (auto simp: Basis_list_prod_def Basis_prod_def elim!: in_set_zipE)
      (auto simp: Basis_list[symmetric] in_set_zip in_set_conv_nth simp del: Basis_list)
  show "distinct (Basis_list::('a*'b)list)"
    using distinct_Basis_list[where 'a='a] distinct_Basis_list[where 'a='b]
    by (auto simp: Basis_list_prod_def Basis_list intro: distinct_zipI1 distinct_zipI2
      elim!: in_set_zipE)
qed
  (auto simp: eucl_down_prod_def eucl_truncate_down_prod_def eucl_truncate_up_prod_def
    sum_Basis_prod_eq inner_add_left inner_sum_left inner_Basis eucl_down_def
    eucl_truncate_down_def eucl_truncate_up_def
    intro!: euclidean_eqI[where 'a="'a*'b"])

end

lemma eucl_truncate_down_Basis[simp]:
  "i \<in> Basis \<Longrightarrow> eucl_truncate_down e x \<bullet> i = truncate_down e (x \<bullet> i)"
  by (simp add: eucl_truncate_down_def)

lemma eucl_truncate_down_correct:
  "dist (x::'a::executable_euclidean_space) (eucl_down e x) \<in>
    {0..sqrt (DIM('a)) * 2 powr of_int (- e)}"
proof -
  have "dist x (eucl_down e x) = sqrt (\<Sum>i\<in>Basis. (dist (x \<bullet> i) (eucl_down e x \<bullet> i))\<^sup>2)"
    unfolding euclidean_dist_l2[where 'a='a] L2_set_def ..
  also have "\<dots> \<le> sqrt (\<Sum>i\<in>(Basis::'a set). ((2 powr of_int (- e))\<^sup>2))"
    by (intro real_sqrt_le_mono sum_mono power_mono)
      (auto simp: dist_real_def eucl_down_def abs_round_down_le)
  finally show ?thesis
    by (simp add: real_sqrt_mult)
qed

lemma eucl_down: "eucl_down e (x::'a::executable_euclidean_space) \<le> x"
  by (auto simp add: eucl_le[where 'a='a] round_down eucl_down_def)

lemma eucl_truncate_down: "eucl_truncate_down e (x::'a::executable_euclidean_space) \<le> x"
  by (auto simp add: eucl_le[where 'a='a] truncate_down)

lemma eucl_truncate_down_le:
  "x \<le> y \<Longrightarrow> eucl_truncate_down w x \<le> (y::'a::executable_euclidean_space)"
  using eucl_truncate_down
  by (rule order.trans)

lemma eucl_truncate_up_Basis[simp]: "i \<in> Basis \<Longrightarrow> eucl_truncate_up e x \<bullet> i = truncate_up e (x \<bullet> i)"
  by (simp add: eucl_truncate_up_def truncate_up_def)

lemma eucl_truncate_up: "x \<le> eucl_truncate_up e (x::'a::executable_euclidean_space)"
  by (auto simp add: eucl_le[where 'a='a] round_up truncate_up_def)

lemma eucl_truncate_up_le: "x \<le> y \<Longrightarrow> x \<le> eucl_truncate_up e (y::'a::executable_euclidean_space)"
  using _ eucl_truncate_up
  by (rule order.trans)

lemma eucl_truncate_down_mono:
  fixes x::"'a::executable_euclidean_space"
  shows "x \<le> y \<Longrightarrow> eucl_truncate_down p x \<le> eucl_truncate_down p y"
  by (auto simp: eucl_le[where 'a='a] intro!: truncate_down_mono)

lemma eucl_truncate_up_mono:
  fixes x::"'a::executable_euclidean_space"
  shows "x \<le> y \<Longrightarrow> eucl_truncate_up p x \<le> eucl_truncate_up p y"
  by (auto simp: eucl_le[where 'a='a] intro!: truncate_up_mono)

lemma infnorm[code]:
  fixes x::"'a::executable_euclidean_space"
  shows "infnorm x = fold max (map (\<lambda>i. abs (x \<bullet> i)) Basis_list) 0"
  by (auto simp: Max.set_eq_fold[symmetric] infnorm_Max[symmetric] infnorm_pos_le
    intro!: max.absorb2[symmetric])

declare Inf_real_def[code del]
declare Sup_real_def[code del]
declare Inf_prod_def[code del]
declare Sup_prod_def[code del]
declare [[code abort: "Inf::real set \<Rightarrow> real"]]
declare [[code abort: "Sup::real set \<Rightarrow> real"]]
declare [[code abort: "Inf::('a::Inf * 'b::Inf) set \<Rightarrow> 'a * 'b"]]
declare [[code abort: "Sup::('a::Sup * 'b::Sup) set \<Rightarrow> 'a * 'b"]]

lemma nth_Basis_list_in_Basis[simp]:
  "n < length (Basis_list::'a::executable_euclidean_space list) \<Longrightarrow> Basis_list ! n \<in> (Basis::'a set)"
  by (metis Basis_list nth_mem)

subsection \<open>Representation as list\<close>

lemma nth_eq_iff_index:
  "distinct xs \<Longrightarrow> n < length xs \<Longrightarrow> xs ! n = i \<longleftrightarrow> n = index xs i"
  using index_nth_id by fastforce

lemma in_Basis_index_Basis_list: "i \<in> Basis \<Longrightarrow> i = Basis_list ! index Basis_list i"
  by simp

lemmas [simp] = length_Basis_list

lemma sum_Basis_sum_nth_Basis_list:
  "(\<Sum>i\<in>Basis. f i) = (\<Sum>i<DIM('a::executable_euclidean_space). f ((Basis_list::'a list) ! i))"
  apply (rule sum.reindex_cong[OF _ _ refl])
   apply (auto intro!: inj_on_nth)
  by (metis Basis_list image_iff in_Basis_index_Basis_list index_less_size_conv length_Basis_list lessThan_iff)

definition "eucl_of_list xs = (\<Sum>(x, i)\<leftarrow>zip xs Basis_list. x *\<^sub>R i)"

lemma eucl_of_list_nth:
  assumes "length xs = DIM('a)"
  shows "eucl_of_list xs = (\<Sum>i<DIM('a::executable_euclidean_space). (xs ! i) *\<^sub>R ((Basis_list::'a list) ! i))"
  by (auto simp: eucl_of_list_def sum_list_sum_nth length_Basis_list assms atLeast0LessThan)

lemma eucl_of_list_inner:
  fixes i::"'a::executable_euclidean_space"
  assumes i: "i \<in> Basis"
  assumes l: "length xs = DIM('a)"
  shows "eucl_of_list xs \<bullet> i = xs ! (index Basis_list i)"
  by (simp add: eucl_of_list_nth[OF l] inner_sum_left assms inner_Basis
      nth_eq_iff_index sum.delta if_distrib cong: if_cong)

lemma inner_eucl_of_list:
  fixes i::"'a::executable_euclidean_space"
  assumes i: "i \<in> Basis"
  assumes l: "length xs = DIM('a)"
  shows "i \<bullet> eucl_of_list xs = xs ! (index Basis_list i)"
  using eucl_of_list_inner[OF assms] by (auto simp: inner_commute)

definition "list_of_eucl x = map ((\<bullet>) x) Basis_list"

lemma index_Basis_list_nth[simp]:
  "i < DIM('a::executable_euclidean_space) \<Longrightarrow> index Basis_list ((Basis_list::'a list) ! i) = i"
  by (simp add: index_nth_id)

lemma list_of_eucl_eucl_of_list[simp]:
  "length xs = DIM('a::executable_euclidean_space) \<Longrightarrow> list_of_eucl (eucl_of_list xs::'a) = xs"
  by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: nth_equalityI)

lemma eucl_of_list_list_of_eucl[simp]:
  "eucl_of_list (list_of_eucl x) = x"
  by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: euclidean_eqI[where 'a='a])

lemma length_list_of_eucl[simp]: "length (list_of_eucl (x::'a::executable_euclidean_space)) = DIM('a)"
  by (auto simp: list_of_eucl_def)

lemma list_of_eucl_nth[simp]: "n < DIM('a::executable_euclidean_space) \<Longrightarrow> list_of_eucl x ! n = x \<bullet> (Basis_list ! n::'a)"
  by (auto simp: list_of_eucl_def)

lemma nth_ge_len: "n \<ge> length xs \<Longrightarrow> xs ! n = [] ! (n - length xs)"
  by (induction xs arbitrary: n) auto

lemma list_of_eucl_nth_if: "list_of_eucl x ! n = (if n < DIM('a::executable_euclidean_space) then x \<bullet> (Basis_list ! n::'a) else [] ! (n - DIM('a)))"
  apply (auto simp: list_of_eucl_def )
  apply (subst nth_ge_len)
   apply auto
  done

lemma list_of_eucl_eq_iff:
  "list_of_eucl (x::'a::executable_euclidean_space) = list_of_eucl (y::'b::executable_euclidean_space) \<longleftrightarrow>
  (DIM('a) = DIM('b) \<and> (\<forall>i < DIM('b). x \<bullet> Basis_list ! i = y \<bullet> Basis_list ! i))"
  by (auto simp: list_eq_iff_nth_eq)

lemma eucl_of_list_inj: "length xs = DIM('a::executable_euclidean_space) \<Longrightarrow> length ys = DIM('a) \<Longrightarrow>
  (eucl_of_list xs::'a) = eucl_of_list (ys) \<Longrightarrow> xs = ys"
  apply (auto intro!: nth_equalityI simp: euclidean_eq_iff[where 'a="'a"] eucl_of_list_inner)
  using nth_Basis_list_in_Basis[where 'a="'a"]
  by fastforce

lemma eucl_of_list_map_plus[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. f x + g x) xs)::'a) =
    eucl_of_list (map f xs) + eucl_of_list (map g xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_uminus[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. - f x) xs)::'a) = - eucl_of_list (map f xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_mult_left[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. r * f x) xs)::'a) = r *\<^sub>R eucl_of_list (map f xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_mult_right[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. f x * r) xs)::'a) = r *\<^sub>R eucl_of_list (map f xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_divide_right[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. f x / r) xs)::'a) = eucl_of_list (map f xs) /\<^sub>R r"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner divide_simps)

lemma eucl_of_list_map_const[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. c) xs)::'a) = c *\<^sub>R One"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma replicate_eq_list_of_eucl_zero: "replicate DIM('a::executable_euclidean_space) 0 = list_of_eucl (0::'a)"
  by (auto intro!: nth_equalityI)

lemma eucl_of_list_append_zeroes[simp]: "eucl_of_list (xs @ replicate n 0) = eucl_of_list xs"
  unfolding eucl_of_list_def
  apply (auto simp: sum_list_sum_nth)
  apply (rule sum.mono_neutral_cong_right)
  by (auto simp: nth_append)

lemma Basis_prodD:
  assumes "(i, j) \<in> Basis"
  shows "i \<in> Basis \<and> j = 0 \<or> i = 0 \<and> j \<in> Basis"
  using assms
  by (auto simp: Basis_prod_def)

lemma eucl_of_list_take_DIM[simp]:
  assumes "d = DIM('b::executable_euclidean_space)"
  shows "(eucl_of_list (take d xs)::'b) = (eucl_of_list xs)"
  by (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list sum_list_sum_nth assms dest!: Basis_prodD)

lemma eucl_of_list_eqI:
  assumes "take DIM('a) (xs @ replicate (DIM('a) - length xs) 0) =
    take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)"
  shows "eucl_of_list xs = (eucl_of_list ys::'a::executable_euclidean_space)"
proof -
  have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ replicate (DIM('a) - length xs) 0))"
    by simp
  also note assms
  also have "eucl_of_list (take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)) = (eucl_of_list ys::'a)"
    by simp
  finally show ?thesis .
qed

lemma eucl_of_list_replicate_zero[simp]: "eucl_of_list (replicate E 0) = 0"
proof -
  have "eucl_of_list (replicate E 0) = (eucl_of_list (replicate E 0 @ replicate (DIM('a) - E) 0)::'a)"
    by simp
  also have "\<dots> = eucl_of_list (replicate DIM('a) 0)"
    apply (rule eucl_of_list_eqI)
    by (auto simp: min_def nth_append intro!: nth_equalityI)
  also have "\<dots> = 0"
    by (simp add: replicate_eq_list_of_eucl_zero)
  finally show ?thesis by simp
qed

lemma eucl_of_list_Nil[simp]: "eucl_of_list [] = 0"
  using eucl_of_list_replicate_zero[of 0] by simp

lemma fst_eucl_of_list_prod:
  shows "fst (eucl_of_list xs::'b::executable_euclidean_space  \<times> _) = (eucl_of_list (take DIM('b) xs)::'b)"
  apply (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list dest!: Basis_prodD)
  apply (simp add: sum_list_sum_nth)
  apply (rule sum.mono_neutral_cong_right)
  subgoal by simp
  subgoal by auto
  subgoal by (auto simp: Basis_list_prod_def nth_append)
  subgoal by (auto simp: Basis_list_prod_def nth_append)
  done

lemma index_zip_replicate2[simp]: "index (zip as (replicate d b)) (a, b) = index as a"
  if "d = length as"
  using that
  by (induction as arbitrary: d) auto

lemma index_Basis_list_prod[simp]:
  fixes a::"'a::executable_euclidean_space" and b::"'b::executable_euclidean_space"
  shows "a \<in> Basis \<Longrightarrow> index Basis_list (a, 0::'b) = index Basis_list a"
    "b \<in> Basis \<Longrightarrow> index Basis_list (0::'a, b) = DIM('a) + index Basis_list b"
  by (auto simp: Basis_list_prod_def index_append
      in_set_zip zip_replicate index_map_inj dest: spec[where x="index Basis_list a"])

lemma eucl_of_list_eq_takeI:
  assumes "(eucl_of_list (take DIM('a::executable_euclidean_space) xs)::'a) = x"
  shows "eucl_of_list xs = x"
  using eucl_of_list_take_DIM[OF refl, of xs, where 'b='a] assms
  by auto

lemma eucl_of_list_inner_le:
  fixes i::"'a::executable_euclidean_space"
  assumes i: "i \<in> Basis"
  assumes l: "length xs \<ge> DIM('a)"
  shows "eucl_of_list xs \<bullet> i = xs ! (index Basis_list i)"
proof -
  have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ (replicate (DIM('a) - length xs) 0)))"
    by (rule eucl_of_list_eq_takeI) simp
  also have "\<dots> \<bullet> i = xs ! (index Basis_list i)"
    using assms
    by (subst eucl_of_list_inner) auto
  finally show ?thesis .
qed

lemma eucl_of_list_prod_if:
  assumes "length xs = DIM('a::executable_euclidean_space) + DIM('b::executable_euclidean_space)"
  shows "eucl_of_list xs =
    (eucl_of_list (take DIM('a) xs)::'a, eucl_of_list (drop DIM('a) xs)::'b)"
  apply (rule euclidean_eqI)
  using assms
  apply (auto simp: eucl_of_list_inner dest!: Basis_prodD)
   apply (subst eucl_of_list_inner_le)
  apply (auto simp: Basis_list_prod_def index_append in_set_zip)
  done

lemma snd_eucl_of_list_prod:
  shows "snd (eucl_of_list xs::'b::executable_euclidean_space  \<times> 'c::executable_euclidean_space) =
    (eucl_of_list (drop DIM('b) xs)::'c)"
proof (cases "length xs \<le> DIM('b)")
  case True
  then show ?thesis
    by (auto simp: eucl_of_list_inner eucl_of_list_def snd_sum_list dest!: Basis_prodD)
      (simp add: sum_list_sum_nth Basis_list_prod_def nth_append)
next
  case False
  have "xs = take DIM('b) xs @ drop DIM('b) xs" by simp
  also have "eucl_of_list \<dots> = (eucl_of_list (\<dots> @ replicate (length xs - DIM('c)) 0)::'b \<times> 'c)"
    by simp
  finally have "eucl_of_list xs = (eucl_of_list (xs @ replicate (DIM('b) + DIM('c) - length xs) 0)::'b \<times> 'c)"
    by simp
  also have "\<dots> = eucl_of_list (take (DIM ('b \<times> 'c)) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
    by simp
  finally have *: "(eucl_of_list xs::'b\<times>'c) = eucl_of_list (take DIM('b \<times> 'c) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
    by simp
  show ?thesis
    apply (subst *)
    apply (subst eucl_of_list_prod_if)
    subgoal by simp
    subgoal
      apply simp
      apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
      apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
      apply (rule arg_cong[where f=eucl_of_list])
      by (auto intro!: nth_equalityI simp: nth_append min_def split: if_splits)
    done
qed

lemma eucl_of_list_prod:
  shows "eucl_of_list xs = (eucl_of_list (take DIM('b) xs)::'b::executable_euclidean_space,
    eucl_of_list (drop DIM('b) xs)::'c::executable_euclidean_space)"
  using snd_eucl_of_list_prod[of xs, where 'b='b and 'c='c]
  using fst_eucl_of_list_prod[of xs, where 'b='b and 'a='c]
  by (auto simp del: snd_eucl_of_list_prod fst_eucl_of_list_prod simp add: prod_eq_iff)

lemma eucl_of_list_real[simp]: "eucl_of_list [x] = (x::real)"
  by (auto simp: eucl_of_list_def Basis_list_real_def)

lemma eucl_of_list_append[simp]:
  assumes "length xs = DIM('i::executable_euclidean_space)"
  assumes "length ys = DIM('j::executable_euclidean_space)"
  shows "eucl_of_list (xs @ ys) = (eucl_of_list xs::'i, eucl_of_list ys::'j)"
  using assms
  by (auto simp: eucl_of_list_prod)

lemma list_allI: "(\<And>x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> list_all P xs"
  by (auto simp: list_all_iff)

lemma
  concat_map_nthI:
  assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set (f x) \<Longrightarrow> P y"
  assumes "j < length (concat (map f xs))"
  shows "P (concat (map f xs) ! j)"
proof -
  have "list_all P (concat (map f xs))"
    by (rule list_allI) (auto simp: assms)
  then show ?thesis
    by (auto simp: list_all_length assms)
qed

lemma map_nth_append1:
  assumes "length xs = d"
  shows "map ((!) (xs @ ys)) [0..<d] = xs"
  using assms
  by (auto simp: nth_append intro!: nth_equalityI)

lemma map_nth_append2:
  assumes "length ys = d"
  shows "map ((!) (xs @ ys)) [length xs..<length xs + d] = ys"
  using assms
  by (auto simp: intro!: nth_equalityI)

lemma length_map2 [simp]: "length (map2 f xs ys) = min (length xs) (length ys)"
  by simp

lemma map2_nth [simp]: "map2 f xs ys ! n = f (xs ! n) (ys ! n)"
  if "n < length xs" "n < length ys"
  using that by simp

lemma list_of_eucl_add: "list_of_eucl (x + y) = map2 (+) (list_of_eucl x) (list_of_eucl y)"
  by (auto intro!: nth_equalityI simp: inner_simps)

lemma list_of_eucl_inj:
  "list_of_eucl z = list_of_eucl y \<Longrightarrow> y = z"
  by (metis eucl_of_list_list_of_eucl)

lemma length_Basis_list_pos[simp]: "length Basis_list > 0"
  by (metis length_pos_if_in_set Basis_list SOME_Basis)

lemma Basis_list_nth_nonzero:
  "i < length (Basis_list::'a::executable_euclidean_space list) \<Longrightarrow> (Basis_list::'a list) ! i \<noteq> 0"
  by (auto dest!: nth_mem simp: nonzero_Basis)

lemma nth_Basis_list_prod:
  "i < DIM('a) + DIM('b) \<Longrightarrow> (Basis_list::('a::executable_euclidean_space \<times> 'b::executable_euclidean_space) list) ! i =
    (if i < DIM('a) then (Basis_list ! i, 0) else (0, Basis_list ! (i - DIM('a))))"
  by (auto simp: Basis_list_nth_nonzero prod_eq_iff Basis_list_prod_def nth_append not_less)

lemma eucl_of_list_if:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "distinct xs"
  shows "eucl_of_list (map (\<lambda>xa. if xa = x then 1 else 0) (xs::nat list)) =
    (if x \<in> set xs then Basis_list ! index xs x else 0::'a)"
  by (rule euclidean_eqI) (auto simp: eucl_of_list_inner inner_Basis index_nth_id)

lemma take_append_take_minus_idem: "take n XS @ map ((!) XS) [n..<length XS] = XS"
  by (auto intro!: nth_equalityI simp: nth_append min_def)

lemma sum_list_Basis_list[simp]: "sum_list (map f Basis_list) = (\<Sum>b\<in>Basis. f b)"
  by (subst sum_list_distinct_conv_sum_set) (auto simp: Basis_list distinct_Basis_list)

lemma hd_Basis_list[simp]: "hd Basis_list \<in> Basis"
  unfolding Basis_list[symmetric]
  by (rule hd_in_set) (auto simp: set_empty[symmetric])

definition "inner_lv_rel a b = sum_list (map2 (*) a b)"

lemma eucl_of_list_inner_eq: "(eucl_of_list xs::'a) \<bullet> eucl_of_list ys = inner_lv_rel xs ys"
  if "length xs = DIM('a::executable_euclidean_space)" "length ys = DIM('a)"
  using that
  by (subst euclidean_inner[abs_def], subst sum_list_Basis_list[symmetric])
      (auto simp: eucl_of_list_inner sum_list_sum_nth index_nth_id inner_lv_rel_def)

lemma euclidean_vec_componentwise:
  "(\<Sum>(xa::'a::euclidean_space^'b::finite)\<in>Basis. f xa) = (\<Sum>a\<in>Basis. (\<Sum>b::'b\<in>UNIV. f (axis b a)))"
  apply (auto simp: Basis_vec_def)
  apply (subst sum.swap)
  apply (subst sum.Union_disjoint)
    apply auto
      apply (simp add: axis_eq_axis nonzero_Basis)
   apply (simp add: axis_eq_axis nonzero_Basis)
  apply (subst sum.reindex)
   apply (auto intro!: injI)
  subgoal
    apply (auto simp: set_eq_iff)
    by (metis (full_types) all_not_in_conv inner_axis_axis inner_eq_zero_iff nonempty_Basis nonzero_Basis)
  apply (rule sum.cong[OF refl])
  apply (auto )
  apply (rule sum.reindex_cong[OF _ _ refl])
  apply (auto intro!: inj_onI)
  using axis_eq_axis by blast

lemma vec_nth_inner_scaleR_craziness:
  "f (x $ i \<bullet> j) *\<^sub>R j = (\<Sum>xa\<in>UNIV. f (x $ xa \<bullet> j) *\<^sub>R axis xa j) $ i"
  by vector (auto simp: axis_def if_distrib scaleR_vec_def sum.delta' cong: if_cong)

instantiation vec :: ("{executable_euclidean_space}", enum) executable_euclidean_space
begin

definition Basis_list_vec :: "('a, 'b) vec list" where
  "Basis_list_vec = concat (map (\<lambda>n. map (axis n) Basis_list) enum_class.enum)"

definition eucl_down_vec :: "int \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
  "eucl_down_vec p x = (\<chi> i. eucl_down p (x $ i))"

definition eucl_truncate_down_vec :: "nat \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
  "eucl_truncate_down_vec p x = (\<chi> i. eucl_truncate_down p (x $ i))"

definition eucl_truncate_up_vec :: "nat \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
  "eucl_truncate_up_vec p x = (\<chi> i. eucl_truncate_up p (x $ i))"

instance
proof
  show *: "set (Basis_list::('a, 'b) vec list) = Basis"
    unfolding Basis_list_vec_def Basis_vec_def
    apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map Basis_vec_def
        intro!: distinct_concat inj_onI split: if_splits)
    apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map enum_distinct
        UNIV_enum[symmetric]
        intro!: distinct_concat inj_onI split: if_splits)
    done
  have "length (Basis_list::('a, 'b) vec list) = CARD('b) * DIM('a)"
    by (auto simp: Basis_list_vec_def length_concat o_def enum_distinct
        sum_list_distinct_conv_sum_set UNIV_enum[symmetric])
  then show "distinct (Basis_list::('a, 'b) vec list)"
    using * by (auto intro!: card_distinct)
qed (simp_all only: vector_cart[symmetric] vec_eq_iff
    eucl_down_vec_def eucl_down_def
    eucl_truncate_down_vec_def eucl_truncate_down_def
    eucl_truncate_up_vec_def eucl_truncate_up_def,
    auto simp: euclidean_vec_componentwise inner_axis Basis_list_vec_def
    vec_nth_inner_scaleR_craziness
    intro!: sum.cong[OF refl])
end

lemma concat_same_lengths_nth:
  assumes "\<And>xs. xs \<in> set XS \<Longrightarrow> length xs = N"
  assumes "i < length XS * N" "N > 0"
  shows "concat XS ! i = XS ! (i div N) ! (i mod N)"
using assms by (induction XS arbitrary: i)
  (auto simp: nth_append nth_Cons div_eq_0_iff le_div_geq le_mod_geq split: nat.splits)

lemma concat_map_map_index:
  shows "concat (map (\<lambda>n. map (f n) xs) ys) =
    map (\<lambda>i. f (ys ! (i div length xs)) (xs ! (i mod length xs))) [0..<length xs * length ys]"
  apply (auto intro!: nth_equalityI simp: length_concat o_def sum_list_sum_nth)
  apply (subst concat_same_lengths_nth)
     apply auto
  apply (subst nth_map_upt)
  apply (auto simp: ac_simps)
  apply (subst nth_map)
  apply (metis div_eq_0_iff div_mult2_eq mult.commute mult_0 not_less0)
  apply (subst nth_map)
  subgoal for i
    using gr_implies_not_zero by fastforce
  subgoal by simp
  done

lemma
  sum_list_zip_map:
  assumes "distinct xs"
  shows "(\<Sum>(x, y)\<leftarrow>zip xs (map g xs). f x y) = (\<Sum>x\<in>set xs. f x (g x))"
  by (force simp add: sum_list_distinct_conv_sum_set assms distinct_zipI1 split_beta'
    in_set_zip in_set_conv_nth inj_on_convol_ident
    intro!: sum.reindex_cong[where l="\<lambda>x. (x, g x)"])

lemma
  sum_list_zip_map_of:
  assumes "distinct bs"
  assumes "length xs = length bs"
  shows "(\<Sum>(x, y)\<leftarrow>zip xs bs. f x y) = (\<Sum>x\<in>set bs. f (the (map_of (zip bs xs) x)) x)"
proof -
  have "(\<Sum>(x, y)\<leftarrow>zip xs bs. f x y) = (\<Sum>(y, x)\<leftarrow>zip bs xs. f x y)"
    by (subst zip_commute) (auto simp: o_def split_beta')
  also have "\<dots> = (\<Sum>(x, y)\<leftarrow>zip bs (map (the o map_of (zip bs xs)) bs). f y x)"
  proof (rule arg_cong, rule map_cong)
    have "xs = (map (the \<circ> map_of (zip bs xs)) bs)"
      using assms
      by (auto intro!: nth_equalityI simp: map_nth map_of_zip_nth)
    then show "zip bs xs = zip bs (map (the \<circ> map_of (zip bs xs)) bs)"
      by simp
  qed auto
  also have "\<dots> = (\<Sum>x\<in>set bs. f (the (map_of (zip bs xs) x)) x)"
    using assms(1)
    by (subst sum_list_zip_map) (auto simp: o_def)
  finally show ?thesis .
qed

lemma vec_nth_matrix:
  "vec_nth (vec_nth (matrix y) i) j = vec_nth (y (axis j 1)) i"
  unfolding matrix_def by simp

lemma matrix_eqI:
  assumes "\<And>x. x \<in> Basis \<Longrightarrow> A *v x = B *v x"
  shows "(A::real^'n^'n) = B"
  apply vector
  using assms
  apply (auto simp: Basis_vec_def)
  by (metis cart_eq_inner_axis matrix_vector_mul_component)

lemma matrix_columnI:
  assumes "\<And>i. column i A = column i B"
  shows "(A::real^'n^'n) = B"
  using assms
  apply vector
  apply (auto simp: column_def)
  apply vector
  by (metis iso_tuple_UNIV_I vec_lambda_inject)

lemma
  vec_nth_Basis:
  fixes x::"real^'n"
  shows "x \<in> Basis \<Longrightarrow> vec_nth x i = (if x = axis i 1 then 1 else 0)"
  apply (auto simp: Basis_vec_def)
  by (metis cart_eq_inner_axis inner_axis_axis)

lemma vec_nth_eucl_of_list_eq: "length M = CARD('n) \<Longrightarrow>
  vec_nth (eucl_of_list M::real^'n::enum) i = M ! index Basis_list (axis i (1::real))"
  apply (auto simp: eucl_of_list_def)
  apply (subst sum_list_zip_map_of)
   apply (auto intro!: distinct_zipI2 simp: split_beta')
  apply (subst sum.cong[OF refl])
   apply (subst vec_nth_Basis)
    apply (force simp: set_zip)
  apply (rule refl)
  apply (auto simp: if_distrib sum.delta cong: if_cong)
  subgoal
    apply (cases "map_of (zip Basis_list M) (axis i 1::real^'n::enum)")
    subgoal premises prems
    proof -
      have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum) set)" using prems
        by (auto simp: in_set_zip)
      then show ?thesis
        using prems
        by (subst (asm) map_of_eq_None_iff) simp
    qed
    subgoal for a
      apply (auto simp: in_set_zip)
      subgoal premises prems for n
        by (metis DIM_cart DIM_real index_Basis_list_nth mult.right_neutral prems(2) prems(3))
      done
    done
  done

lemma index_Basis_list_axis1: "index Basis_list (axis i (1::real)) = index enum_class.enum i"
  apply (auto simp: Basis_list_vec_def Basis_list_real_def )
  apply (subst index_map_inj)
  by (auto intro!: injI simp: axis_eq_axis)

lemma vec_nth_eq_list_of_eucl1:
  "(vec_nth (M::real^'n::enum) i) = list_of_eucl M ! (index enum_class.enum i)"
  apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
  apply (subst vec_nth_eucl_of_list_eq)
  unfolding index_Basis_list_axis1
  by auto

lemma enum_3[simp]: "(enum_class.enum::3 list) = [0, 1, 2]"
  by code_simp+

lemma three_eq_zero: "(3::3) = 0" by simp

lemma forall_3': "(\<forall>i::3. P i) \<longleftrightarrow> P 0 \<and> P 1 \<and> P 2"
  using forall_3 three_eq_zero by auto

lemma axis_one_neq_zero[simp]: "axis xa (1::'a::zero_neq_one) \<noteq> 0"
  by (auto simp: axis_def vec_eq_iff)

type_synonym R3 = "real*real*real"

lemma Basis_list_R3: "Basis_list = [(1,0,0), (0, 1, 0), (0, 0, 1)::R3]"
  by (auto simp: Basis_list_prod_def Basis_list_real_def zero_prod_def)

lemma Basis_list_vec3: "Basis_list = [axis 0 1::real^3, axis 1 1, axis 2 1]"
  by (auto simp: Basis_list_vec_def Basis_list_real_def)

lemma eucl_of_list3[simp]: "eucl_of_list [a, b, c] = (a, b, c)"
  by (auto simp: eucl_of_list_inner Basis_list_vec_def zero_prod_def
      Basis_prod_def Basis_list_vec3 Basis_list_R3
      intro!: euclidean_eqI[where 'a=R3])

subsection \<open>Bounded Linear Functions\<close>

subsection \<open>bounded linear functions\<close>

locale blinfun_syntax
begin
no_notation vec_nth (infixl "$" 90)
notation blinfun_apply (infixl "$" 999)
end

lemma bounded_linear_via_derivative:
  fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector" \<comment> \<open>TODO: generalize?\<close>
  assumes "\<And>i. ((\<lambda>x. blinfun_apply (f x) i) has_derivative (\<lambda>x. f' y x i)) (at y)"
  shows "bounded_linear (f' y x)"
proof -
  interpret linear "f' y x"
  proof (unfold_locales, goal_cases)
    case (1 v w)
    from has_derivative_unique[OF assms[of "v + w", unfolded blinfun.bilinear_simps]
      has_derivative_add[OF assms[of v] assms[of w]], THEN fun_cong, of x]
    show ?case .
  next
    case (2 r v)
    from has_derivative_unique[OF assms[of "r *\<^sub>R v", unfolded blinfun.bilinear_simps]
      has_derivative_scaleR_right[OF assms[of v], of r], THEN fun_cong, of x]
    show ?case .
  qed
  let ?bnd = "\<Sum>i\<in>Basis. norm (f' y x i)"
  {
    fix v
    have "f' y x v = (\<Sum>i\<in>Basis. (v \<bullet> i) *\<^sub>R f' y x i)"
      by (subst euclidean_representation[symmetric]) (simp add: sum scaleR)
    also have "norm \<dots> \<le> norm v * ?bnd"
      by (auto intro!: order.trans[OF norm_sum] sum_mono mult_right_mono
        simp: sum_distrib_left Basis_le_norm)
    finally have "norm (f' y x v) \<le> norm v * ?bnd" .
  }
  then show ?thesis by unfold_locales auto
qed

definition blinfun_scaleR::"('a::real_normed_vector \<Rightarrow>\<^sub>L real) \<Rightarrow> 'b::real_normed_vector \<Rightarrow> ('a \<Rightarrow>\<^sub>L 'b)"
  where "blinfun_scaleR a b = blinfun_scaleR_left b o\<^sub>L a"

lemma blinfun_scaleR_transfer[transfer_rule]:
  "rel_fun (pcr_blinfun (=) (=)) (rel_fun (=) (pcr_blinfun (=) (=)))
    (\<lambda>a b c. a c *\<^sub>R b) blinfun_scaleR"
  by (auto simp: blinfun_scaleR_def rel_fun_def pcr_blinfun_def cr_blinfun_def OO_def)

lemma blinfun_scaleR_rep_eq[simp]:
  "blinfun_scaleR a b c = a c *\<^sub>R b"
  by (simp add: blinfun_scaleR_def)

lemma bounded_linear_blinfun_scaleR: "bounded_linear (blinfun_scaleR a)"
  unfolding blinfun_scaleR_def[abs_def]
  by (auto intro!: bounded_linear_intros)

lemma blinfun_scaleR_has_derivative[derivative_intros]:
  assumes "(f has_derivative f') (at x within s)"
  shows "((\<lambda>x. blinfun_scaleR a (f x)) has_derivative (\<lambda>x. blinfun_scaleR a (f' x))) (at x within s)"
  using bounded_linear_blinfun_scaleR assms
  by (rule bounded_linear.has_derivative)

lemma blinfun_componentwise:
  fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
  shows "f = (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
  by (auto intro!: blinfun_eqI
    simp: blinfun.sum_left euclidean_representation blinfun.scaleR_right[symmetric]
      blinfun.sum_right[symmetric])

lemma
  blinfun_has_derivative_componentwiseI:
  fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> ((\<lambda>x. f x i) has_derivative blinfun_apply (f' i)) (at x)"
  shows "(f has_derivative (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' i x))) (at x)"
  by (subst blinfun_componentwise) (force intro: derivative_eq_intros assms simp: blinfun.bilinear_simps)

lemma
  has_derivative_BlinfunI:
  fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
  assumes "\<And>i. ((\<lambda>x. f x i) has_derivative (\<lambda>x. f' y x i)) (at y)"
  shows "(f has_derivative (\<lambda>x. Blinfun (f' y x))) (at y)"
proof -
  have 1: "f = (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
    by (rule blinfun_componentwise)
  moreover have 2: "(\<dots> has_derivative (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i))) (at y)"
    by (force intro: assms derivative_eq_intros)
  moreover
  interpret f': bounded_linear "f' y x" for x
    by (rule bounded_linear_via_derivative) (rule assms)
  have 3: "(\<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i)) i = f' y x i" for x i
    by (auto simp: if_distrib if_distribR blinfun.bilinear_simps
      f'.scaleR[symmetric] f'.sum[symmetric] euclidean_representation
      intro!: blinfun_euclidean_eqI)
  have 4: "blinfun_apply (Blinfun (f' y x)) = f' y x" for x
    apply (subst bounded_linear_Blinfun_apply)
    subgoal by unfold_locales
    subgoal by simp
    done
  show ?thesis
    apply (subst 1)
    apply (rule 2[THEN has_derivative_eq_rhs])
    apply (rule ext)
    apply (rule blinfun_eqI)
    apply (subst 3)
    apply (subst 4)
    apply (rule refl)
    done
qed

lemma
  has_derivative_Blinfun:
  assumes "(f has_derivative f') F"
  shows "(f has_derivative Blinfun f') F"
  using assms
  by (subst bounded_linear_Blinfun_apply) auto

lift_definition flip_blinfun::
  "('a::real_normed_vector \<Rightarrow>\<^sub>L 'b::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_normed_vector) \<Rightarrow> 'b \<Rightarrow>\<^sub>L 'a \<Rightarrow>\<^sub>L 'c" is
  "\<lambda>f x y. f y x"
  using bounded_bilinear.bounded_linear_left bounded_bilinear.bounded_linear_right bounded_bilinear.flip
  by auto

lemma flip_blinfun_apply[simp]: "flip_blinfun f a b = f b a"
  by transfer simp

lemma le_norm_blinfun:
  shows "norm (blinfun_apply f x) / norm x \<le> norm f"
  by transfer (rule le_onorm)

lemma norm_flip_blinfun[simp]: "norm (flip_blinfun x) = norm x" (is "?l = ?r")
proof (rule antisym)
  from order_trans[OF norm_blinfun, OF mult_right_mono, OF norm_blinfun, OF norm_ge_zero, of x]
  show "?l \<le> ?r"
    by (auto intro!: norm_blinfun_bound simp: ac_simps)
  have "norm (x a b) \<le> norm (flip_blinfun x) * norm a * norm b" for a b
  proof -
    have "norm (x a b) / norm a \<le> norm (flip_blinfun x b)"
      by (rule order_trans[OF _ le_norm_blinfun]) auto
    also have "\<dots> \<le> norm (flip_blinfun x) * norm b"
      by (rule norm_blinfun)
    finally show ?thesis
      by (auto simp add: divide_simps blinfun.bilinear_simps algebra_simps split: if_split_asm)
  qed
  then show "?r \<le> ?l"
    by (auto intro!: norm_blinfun_bound)
qed

lemma bounded_linear_flip_blinfun[bounded_linear]: "bounded_linear flip_blinfun"
  by unfold_locales (auto simp: blinfun.bilinear_simps intro!: blinfun_eqI exI[where x=1])

lemma dist_swap2_swap2[simp]: "dist (flip_blinfun f) (flip_blinfun g) = dist f g"
  by (metis (no_types) bounded_linear_flip_blinfun dist_blinfun_def linear_simps(2)
    norm_flip_blinfun)

context includes blinfun.lifting begin

lift_definition blinfun_of_vmatrix::"(real^'m^'n) \<Rightarrow> ((real^('m::finite)) \<Rightarrow>\<^sub>L (real^('n::finite)))" is
  "matrix_vector_mult:: ((real, 'm) vec, 'n) vec \<Rightarrow> ((real, 'm) vec \<Rightarrow> (real, 'n) vec)"
  unfolding linear_linear
  by (rule matrix_vector_mul_linear)

lemma matrix_blinfun_of_vmatrix[simp]: "matrix (blinfun_of_vmatrix M) = M"
  apply vector
  apply (auto simp: matrix_def)
  apply transfer
  by (metis cart_eq_inner_axis matrix_vector_mul_component)

end

lemma blinfun_apply_componentwise:
  "B = (\<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (blinfun_apply B i))"
  using blinfun_componentwise[of "\<lambda>x. B", unfolded fun_eq_iff]
  by blast

lemma blinfun_apply_eq_sum:
  assumes [simp]: "length v = CARD('n)"
  shows "blinfun_apply (B::(real^'n::enum)\<Rightarrow>\<^sub>L(real^'m::enum)) (eucl_of_list v) =
    (\<Sum>i<CARD('m). \<Sum>j<CARD('n). ((B (Basis_list ! j) \<bullet> Basis_list ! i) * v ! j) *\<^sub>R (Basis_list ! i))"
  apply (subst blinfun_apply_componentwise[of B])
  apply (auto intro!: euclidean_eqI[where 'a="(real,'m) vec"]
      simp: blinfun.bilinear_simps eucl_of_list_inner inner_sum_left inner_Basis if_distrib
        sum_Basis_sum_nth_Basis_list nth_eq_iff_index if_distribR
        cong: if_cong)
  apply (subst sum.swap)
  by (auto simp: sum.delta algebra_simps)

lemma in_square_lemma[intro, simp]: "x * C + y < D * C" if "x < D" "y < C" for x::nat
proof -
  have "x * C + y < (D - 1) * C + C"
    apply (rule add_le_less_mono)
     apply (rule mult_right_mono)
    using that
    by auto
  also have "\<dots> \<le> D * C"
    using that
    by (auto simp: algebra_simps)
  finally show ?thesis .
qed

lemma less_square_imp_div_less[intro, simp]: "i < E * D \<Longrightarrow>  i div E < D" for i::nat
  by (metis div_eq_0_iff div_mult2_eq gr_implies_not0 mult_not_zero)

lemma in_square_lemma'[intro, simp]: "i < L \<Longrightarrow> n < N \<Longrightarrow> i * N + n < N * L" for i n::nat
  by (metis in_square_lemma mult.commute)

lemma
  distinct_nth_eq_iff:
  "distinct xs \<Longrightarrow> x < length xs \<Longrightarrow> y < length xs \<Longrightarrow> xs ! x = xs ! y \<longleftrightarrow> x = y"
  by (drule inj_on_nth[where I="{..<length xs}"]) (auto simp: inj_onD)

lemma index_Basis_list_axis2:
  "index Basis_list (axis (j::'j::enum) (axis (i::'i::enum) (1::real))) =
    (index enum_class.enum j) * CARD('i) + index enum_class.enum i"
  apply (auto simp: Basis_list_vec_def Basis_list_real_def o_def)
  apply (subst concat_map_map_index)
  unfolding card_UNIV_length_enum[symmetric]
  subgoal
  proof -
    have index_less_cardi: "index enum_class.enum k < CARD('i)" for k::'i
      by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
    have index_less_cardj: "index enum_class.enum k < CARD('j)" for k::'j
      by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
    have *: "axis j (axis i 1) =
      (\<lambda>i. axis (enum_class.enum ! (i div CARD('i)))
                      (axis (enum_class.enum ! (i mod CARD('i))) 1))
      ((index enum_class.enum j) * CARD('i) + index enum_class.enum i)"
      by (auto simp: index_less_cardi enum_UNIV)
    note less=in_square_lemma[OF index_less_cardj index_less_cardi, of j i]
    show ?thesis
      apply (subst *)
      apply (subst index_map_inj_on[where S="{..<CARD('j)*CARD('i)}"])
      subgoal
        apply (auto intro!: inj_onI simp: axis_eq_axis )
         apply (subst (asm) distinct_nth_eq_iff)
        apply (auto simp: enum_distinct card_UNIV_length_enum)
        subgoal for x y
          using gr_implies_not0 by fastforce
        subgoal for x y
          using gr_implies_not0 by fastforce
        subgoal for x y
          apply (drule inj_onD[OF inj_on_nth[OF enum_distinct[where 'a='j], where I = "{..<CARD('j)}"], rotated])
             apply (auto simp: card_UNIV_length_enum mult.commute)
          subgoal
            by (metis mod_mult_div_eq)
          done
        done
      subgoal using less by auto
      subgoal by (auto simp: card_UNIV_length_enum ac_simps)
      subgoal apply (subst index_upt)
        subgoal using less by auto
        subgoal using less by (auto simp: ac_simps)
        subgoal using less by auto
        done
      done
  qed
  done

lemma
  vec_nth_Basis2:
  fixes x::"real^'n^'m"
  shows "x \<in> Basis \<Longrightarrow> vec_nth (vec_nth x i) j = ((if x = axis i (axis j 1) then 1 else 0))"
  by (auto simp: Basis_vec_def axis_def)

lemma vec_nth_eucl_of_list_eq2: "length M = CARD('n) * CARD('m) \<Longrightarrow>
  vec_nth (vec_nth (eucl_of_list M::real^'n::enum^'m::enum) i) j = M ! index Basis_list (axis i (axis j (1::real)))"
  apply (auto simp: eucl_of_list_def)
  apply (subst sum_list_zip_map_of)
   apply (auto intro!: distinct_zipI2 simp: split_beta')
  apply (subst sum.cong[OF refl])
   apply (subst vec_nth_Basis2)
    apply (force simp: set_zip)
  apply (rule refl)
  apply (auto simp: if_distrib sum.delta cong: if_cong)
  subgoal
    apply (cases "map_of (zip Basis_list M) (axis i (axis j 1)::real^'n::enum^'m::enum)")
    subgoal premises prems
    proof -
      have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum^'m::enum) set)" using prems
        by (auto simp: in_set_zip)
      then show ?thesis
        using prems
        by (subst (asm) map_of_eq_None_iff) auto
    qed
    subgoal for a
      apply (auto simp: in_set_zip)
      subgoal premises prems for n
      proof -
        have "n < card (Basis::(real^'n::_^'m::_) set)"
          by (simp add: prems(4))
        then show ?thesis
          by (metis index_Basis_list_nth prems(2))
      qed
      done
    done
  done

lemma vec_nth_eq_list_of_eucl2:
  "vec_nth (vec_nth (M::real^'n::enum^'m::enum) i) j =
    list_of_eucl M ! (index enum_class.enum i * CARD('n) + index enum_class.enum j)"
  apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
  apply (subst vec_nth_eucl_of_list_eq2)
  unfolding index_Basis_list_axis2
  by auto

theorem
  eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list:
  assumes "length M = CARD('n) * CARD('m)"
  assumes "length v = CARD('n)"
  shows "(eucl_of_list M::real^'n::enum^'m::enum) *v eucl_of_list v =
    (\<Sum>i<CARD('m).
      (\<Sum>j<CARD('n). M ! (i * CARD('n) + j) * v ! j) *\<^sub>R Basis_list ! i)"
  apply (vector matrix_vector_mult_def)
  apply auto
  apply (subst vec_nth_eucl_of_list_eq2)
   apply (auto simp: assms)
  apply (subst vec_nth_eucl_of_list_eq)
   apply (auto simp: assms index_Basis_list_axis2 index_Basis_list_axis1 vec_nth_Basis sum.delta
      nth_eq_iff_index
      if_distrib cong: if_cong)
  subgoal for i
    apply (rule sum.reindex_cong[where l="nth enum_class.enum"])
      apply (auto simp: enum_distinct card_UNIV_length_enum distinct_nth_eq_iff intro!: inj_onI)
     apply (rule image_eqI[OF ])
      apply (rule nth_index[symmetric])
      apply (auto simp: enum_UNIV)
    by (auto simp: algebra_simps enum_UNIV enum_distinct index_nth_id)
  subgoal for i
    using index_less[of i "enum_class.enum" "CARD('n)"]
    by (auto simp: enum_UNIV card_UNIV_length_enum)
  done

lemma index_enum_less[intro, simp]: "index enum_class.enum (i::'n::enum) < CARD('n)"
  by (auto intro!: index_less simp: enum_UNIV card_UNIV_length_enum)

lemmas [intro, simp] = enum_distinct
lemmas [simp] = card_UNIV_length_enum[symmetric] enum_UNIV

lemma sum_index_enum_eq:
  "(\<Sum>(k::'n::enum)\<in>UNIV. f (index enum_class.enum k)) = (\<Sum>i<CARD('n). f i)"
  by (rule sum.reindex_cong[where l="nth enum_class.enum"])
    (force intro!: inj_onI simp: distinct_nth_eq_iff index_nth_id)+

end


(* 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.*)
  theory TIP_sort_HSort2Permutes
  imports "../../Test_Base"
begin

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

datatype Heap = Node "Heap" "int" "Heap" | Nil

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => int list" where
  "toList (Node p y q) = cons2 y (toList (hmerge p q))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "int => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "int list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "int list => int list" where
  "hsort2 x = toList (toHeap2 x)"

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

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z x2) = False"
| "isPermutation (cons2 x3 xs) y =
     ((elem x3 y) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 y)))"

theorem property0 :
  "isPermutation (hsort2 xs) xs"
  oops

end


(*<*)
theory Code3_4_Trie2
  imports Main
begin
(*>*)

datatype ('a,'v)trie = Trie  "'v option"  "('a * ('a,'v)trie)list"
value "Trie None [(a,Trie None [
                                (I,Trie None [(I,Trie (Some 1) [])]),
                                (n,Trie (Some 2) []),
                                (p,Trie None [(e,Trie (Some 3) [])])]),
                  (c,Trie None [(a,Trie None [
                                (n,Trie (Some 4) []),
                                (r,Trie (Some 5) []),
                                (t,Trie (Some 6) [])])])]"
term "a::char"(*"a" :: "char" *)
value "a::string"  (*"a":: "char list"  *)
definition "l ≡ ''a''"
value "l"
(*
definition "l2 ≡ a::char"

definition "llchar  ≡ Trie None [(''a'',Trie None [
                                (I,Trie None [(I,Trie (Some (1::nat)) [])]),
                                (n,Trie (Some 2) []),
                                (p,Trie None [(e,Trie (Some 3) [])])]),
                  (c,Trie None [(a,Trie None [
                                (n,Trie (Some 4) []),
                                (r,Trie (Some 5) []),
                                (t,Trie (Some 6) [])])])]"
*)
definition "ll = Trie None [((1::nat),Trie None [(2,Trie None [(2,Trie (Some (11::nat)) [])]),
                                                 (3,Trie (Some 12) []),
                                                 (4,Trie None [(5,Trie (Some 13) [])])
                                                ]
                           )]"
definition "ll1=Trie None [
                 (''a'',Trie None[
                         (''l'',Trie None [
                                       (''l'',Trie (Some ''all'') [])]),
                         (''n'',Trie (Some ''an'') []),
                         (''p'',Trie None [
                                       (''e'',Trie (Some ''ape'') [])])]),
                 (''c'',Trie None [
                         (''a'',Trie None [
                                        (''n'',Trie (Some ''can'')[]),
                                        (''r'',Trie (Some ''car'') []),
                                        (''t'',Trie (Some ''cat'') [])])])]"

value ll1
(*"ll"
  :: "(nat, nat) trie"*)

primrec "value" :: "('a,'v)trie  ⇒ 'v option" where
"value(Trie ov al) = ov"

primrec alist :: "('a,'v)trie ⇒ ('a * ('a,'v)trie)list" where
"alist(Trie ov al) = al"

value "alist ll"
(*
"[(1, Trie None [(2, Trie None [(2, Trie (Some 1) [])]), (3, Trie (Some 2) []), (4, Trie None [(5, Trie (Some 3) [])])])]"
  :: "(nat \<times> (nat, nat) trie) list"
*)
value "value ll"
(*
"None"
  :: "nat option"
*)
primrec assoc :: "('key * 'val)list ⇒ 'key ⇒'val option" where
"assoc [] x = None" |
"assoc (p#ps) x =
   (let (a,b) = p in if a=x then Some b else assoc ps x)"
value "ll"
value " assoc (alist ll) (1::nat)"

primrec lookup :: "('a, 'v) trie ⇒ 'a list ⇒ 'v option" where
"lookup t [] = value t" |
"lookup t (a#as) = (case assoc (alist t) a of
                      None \<Rightarrow> None
                    | Some at \<Rightarrow> lookup at as)"
value "lookup ll []"
value "lookup ll [(1::nat),2,2]"

primrec update:: "('a,'v)trie ⇒ 'a list ⇒ 'v  ⇒ ('a,'v)trie" where
"update t []     v = Trie (Some v) (alist t)" |
"update t (a#as) v =
   (let tt = (case assoc (alist t) a of
                None ⇒ Trie None [] | Some at ⇒ at)
    in Trie (value t) ((a,update tt as v) # alist t))"
definition "testnone=Trie None []"
value " ll1"
value " assoc (alist ll1 ) (''a'')"
value "alist ll"
value "update ll1 [''a'',''n'',''m''] (''a'')"
value "update ll1 [] (''a'')"
value "update ll [1,(3::nat)] 9"
value "update ll [(2::nat),3] 2"

declare Let_def[simp] option.split[split]

theorem "\<forall>t v bs. lookup (update t as v) bs =
                    (if as=bs then Some v else lookup t bs)"
  apply(induct_tac as)
  apply auto
    apply(case_tac[!] bs)
  apply auto
done

(*<*)

(* Exercise 1 *)

primrec update1 :: "('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a, 'v) trie"
where
  "update1 t []     vo = Trie vo (alist t)" |
  "update1 t (a#as) vo =
     (let tt = (case assoc (alist t) a of
                  None \<Rightarrow> Trie None []
                | Some at \<Rightarrow> at)
      in Trie (value t) ((a, update1 tt as vo) # alist t))"

theorem [simp]: "\<forall>t v bs. lookup (update1 t as v) bs =
                    (if as = bs then v else lookup t bs)"
apply (induct_tac as, auto)
apply (case_tac[!] bs, auto)
done

(* Exercise 2 *)

primrec overwrite :: "'a \<Rightarrow> 'b \<Rightarrow> ('a * 'b) list \<Rightarrow> ('a * 'b) list" where
"overwrite a v [] = [(a,v)]" |
"overwrite a v (p#ps) = (if a = fst p then (a,v)#ps else p # overwrite a v ps)"

lemma [simp]: "\<forall> a v b. assoc (overwrite a v ps) b = assoc ((a,v)#ps) b"
apply (induct_tac ps, auto)
apply (case_tac[!] a)
done

primrec update2 :: "('a, 'v) trie \<Rightarrow> 'a list \<Rightarrow> 'v option \<Rightarrow> ('a, 'v) trie"
where
  "update2 t []     vo = Trie vo (alist t)" |
  "update2 t (a#as) vo =
     (let tt = (case assoc (alist t) a of
                  None \<Rightarrow> Trie None []
                | Some at \<Rightarrow> at)
      in Trie (value t) (overwrite a (update2 tt as vo) (alist t)))"

theorem "\<forall>t v bs. lookup (update2 t as vo) bs =
                    (if as = bs then vo else lookup t bs)"
apply (induct_tac as, auto)
apply (case_tac[!] bs, auto)
done

(* Exercise 3 *)
datatype ('a,dead 'v) triem = Triem  "'v option" "'a \<Rightarrow> ('a,'v) triem option"

primrec valuem :: "('a, 'v) triem \<Rightarrow> 'v option" where
"valuem (Triem ov m) = ov"

primrec mapping :: "('a,'v) triem \<Rightarrow> 'a \<Rightarrow> ('a, 'v) triem option" where
"mapping (Triem ov m) = m"

primrec lookupm :: "('a,'v) triem \<Rightarrow> 'a list \<Rightarrow> 'v option" where
  "lookupm t [] = valuem t" |
  "lookupm t (a#as) = (case mapping t a of
                        None \<Rightarrow> None
                      | Some at \<Rightarrow> lookupm at as)"

lemma [simp]: "lookupm (Triem None  (\<lambda>c. None)) as = None"
apply (case_tac as, simp_all)
done

primrec updatem :: "('a,'v)triem \<Rightarrow> 'a list \<Rightarrow> 'v \<Rightarrow> ('a,'v)triem" where
  "updatem t []     v = Triem (Some v) (mapping t)" |
  "updatem t (a#as) v =
     (let tt = (case mapping t a of
                  None \<Rightarrow> Triem None (\<lambda>c. None)
                | Some at \<Rightarrow> at)
      in Triem (valuem t)
              (\<lambda>c. if c = a then Some (updatem tt as v) else mapping t c))"

theorem "\<forall>t v bs. lookupm (updatem t as v) bs =
                    (if as = bs then Some v else lookupm t bs)"
apply (induct_tac as, auto)
apply (case_tac[!] bs, auto)
done

end
(*>*)


theory T173
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(* Author: Alexander Maletzky *)

theory More_Modules
  imports HOL.Modules
begin

text \<open>More facts about modules.\<close>

section \<open>Modules over Commutative Rings\<close>

context module
begin

lemma scale_minus_both [simp]: "(- a) *s (- x) = a *s x"
  by simp

subsection \<open>Submodules Spanned by Sets of Module-Elements\<close>

lemma span_insertI:
  assumes "p \<in> span B"
  shows "p \<in> span (insert r B)"
proof -
  have "B \<subseteq> insert r B" by blast
  hence "span B \<subseteq> span (insert r B)" by (rule span_mono)
  with assms show ?thesis ..
qed

lemma span_insertD:
  assumes "p \<in> span (insert r B)" and "r \<in> span B"
  shows "p \<in> span B"
  using assms(1)
proof (induct p rule: span_induct_alt)
  case base
  show "0 \<in> span B" by (fact span_zero)
next
  case step: (step q b a)
  from step(1) have "b = r \<or> b \<in> B" by simp
  thus "q *s b + a \<in> span B"
  proof
    assume eq: "b = r"
    from step(2) assms(2) show ?thesis unfolding eq by (intro span_add span_scale)
  next
    assume "b \<in> B"
    hence "b \<in> span B" using span_superset ..
    with step(2) show ?thesis by (intro span_add span_scale)
  qed
qed

lemma span_insert_idI:
  assumes "r \<in> span B"
  shows "span (insert r B) = span B"
proof (intro subset_antisym subsetI)
  fix p
  assume "p \<in> span (insert r B)"
  from this assms show "p \<in> span B" by (rule span_insertD)
next
  fix p
  assume "p \<in> span B"
  thus "p \<in> span (insert r B)" by (rule span_insertI)
qed

lemma span_insert_zero: "span (insert 0 B) = span B"
  using span_zero by (rule span_insert_idI)

lemma span_Diff_zero: "span (B - {0}) = span B"
  by (metis span_insert_zero insert_Diff_single)

lemma span_insert_subset:
  assumes "span A \<subseteq> span B" and "r \<in> span B"
  shows "span (insert r A) \<subseteq> span B"
proof
  fix p
  assume "p \<in> span (insert r A)"
  thus "p \<in> span B"
  proof (induct p rule: span_induct_alt)
    case base
    show ?case by (fact span_zero)
  next
    case step: (step q b a)
    show ?case
    proof (intro span_add span_scale)
      from \<open>b \<in> insert r A\<close> show "b \<in> span B"
      proof
        assume "b = r"
        thus "b \<in> span B" using assms(2) by simp
      next
        assume "b \<in> A"
        hence "b \<in> span A" using span_superset ..
        thus "b \<in> span B" using assms(1) ..
      qed
    qed fact
  qed
qed

lemma replace_span:
  assumes "q \<in> span B"
  shows "span (insert q (B - {p})) \<subseteq> span B"
  by (rule span_insert_subset, rule span_mono, fact Diff_subset, fact)

lemma sum_in_spanI: "(\<Sum>b\<in>B. q b *s b) \<in> span B"
  by (auto simp: intro: span_sum span_scale dest: span_base)

lemma span_closed_sum_list: "(\<And>x. x \<in> set xs \<Longrightarrow> x \<in> span B) \<Longrightarrow> sum_list xs \<in> span B"
  by (induct xs) (auto intro: span_zero span_add)

lemma spanE:
  assumes "p \<in> span B"
  obtains A q where "finite A" and "A \<subseteq> B" and "p = (\<Sum>b\<in>A. (q b) *s b)"
  using assms by (auto simp: span_explicit)

lemma span_finite_subset:
  assumes "p \<in> span B"
  obtains A where "finite A" and "A \<subseteq> B" and "p \<in> span A"
proof -
  from assms obtain A q where "finite A" and "A \<subseteq> B" and p: "p = (\<Sum>a\<in>A. q a *s a)"
    by (rule spanE)
  note this(1, 2)
  moreover have "p \<in> span A" unfolding p by (rule sum_in_spanI)
  ultimately show ?thesis ..
qed

lemma span_finiteE:
  assumes "finite B" and "p \<in> span B"
  obtains q where "p = (\<Sum>b\<in>B. (q b) *s b)"
  using assms by (auto simp: span_finite)

lemma span_subset_spanI:
  assumes "A \<subseteq> span B"
  shows "span A \<subseteq> span B"
  using assms subspace_span by (rule span_minimal)

lemma span_insert_cong:
  assumes "span A = span B"
  shows "span (insert p A) = span (insert p B)" (is "?l = ?r")
proof
  have 1: "span (insert p C1) \<subseteq> span (insert p C2)" if "span C1 = span C2" for C1 C2
  proof (rule span_subset_spanI)
    show "insert p C1 \<subseteq> span (insert p C2)"
    proof (rule insert_subsetI)
      show "p \<in> span (insert p C2)" by (rule span_base) simp
    next
      have "C1 \<subseteq> span C1" by (rule span_superset)
      also from that have "\<dots> = span C2" .
      also have "\<dots> \<subseteq> span (insert p C2)" by (rule span_mono) blast
      finally show "C1 \<subseteq> span (insert p C2)" .
    qed
  qed
  from assms show "?l \<subseteq> ?r" by (rule 1)
  from assms[symmetric] show "?r \<subseteq> ?l" by (rule 1)
qed

lemma span_induct' [consumes 1, case_names base step]:
  assumes "p \<in> span B" and "P 0"
    and "\<And>a q p. a \<in> span B \<Longrightarrow> P a \<Longrightarrow> p \<in> B \<Longrightarrow> q \<noteq> 0 \<Longrightarrow> P (a + q *s p)"
  shows "P p"
  using assms(1, 1)
proof (induct p rule: span_induct_alt)
  case base
  from assms(2) show ?case .
next
  case (step q b a)
  from step.hyps(1) have "b \<in> span B" by (rule span_base)
  hence "q *s b \<in> span B" by (rule span_scale)
  with step.prems have "a \<in> span B" by (simp only: span_add_eq)
  hence "P a" by (rule step.hyps)
  show ?case
  proof (cases "q = 0")
    case True
    from \<open>P a\<close> show ?thesis by (simp add: True)
  next
    case False
    with \<open>a \<in> span B\<close> \<open>P a\<close> step.hyps(1) have "P (a + q *s b)" by (rule assms(3))
    thus ?thesis by (simp only: add.commute)
  qed
qed

lemma span_INT_subset: "span (\<Inter>a\<in>A. f a) \<subseteq> (\<Inter>a\<in>A. span (f a))" (is "?l \<subseteq> ?r")
proof
  fix p
  assume "p \<in> ?l"
  show "p \<in> ?r"
  proof
    fix a
    assume "a \<in> A"
    from \<open>p \<in> ?l\<close> show "p \<in> span (f a)"
    proof (induct p rule: span_induct')
      case base
      show ?case by (fact span_zero)
    next
      case (step p q b)
      from step(3) \<open>a \<in> A\<close> have "b \<in> f a" ..
      hence "b \<in> span (f a)" by (rule span_base)
      with step(2) show ?case by (intro span_add span_scale)
    qed
  qed
qed

lemma span_INT: "span (\<Inter>a\<in>A. span (f a)) = (\<Inter>a\<in>A. span (f a))" (is "?l = ?r")
proof
  have "?l \<subseteq> (\<Inter>a\<in>A. span (span (f a)))" by (rule span_INT_subset)
  also have "... = ?r" by (simp add: span_span)
  finally show "?l \<subseteq> ?r" .
qed (fact span_superset)

lemma span_Int_subset: "span (A \<inter> B) \<subseteq> span A \<inter> span B"
proof -
  have "span (A \<inter> B) = span (\<Inter>x\<in>{A, B}. x)" by simp
  also have "\<dots> \<subseteq> (\<Inter>x\<in>{A, B}. span x)" by (fact span_INT_subset)
  also have "\<dots> = span A \<inter> span B" by simp
  finally show ?thesis .
qed

lemma span_Int: "span (span A \<inter> span B) = span A \<inter> span B"
proof -
  have "span (span A \<inter> span B) = span (\<Inter>x\<in>{A, B}. span x)" by simp
  also have "\<dots> = (\<Inter>x\<in>{A, B}. span x)" by (fact span_INT)
  also have "\<dots> = span A \<inter> span B" by simp
  finally show ?thesis .
qed

lemma span_image_scale_eq_image_scale: "span ((*s) q ` F) = (*s) q ` span F" (is "?A = ?B")
proof (intro subset_antisym subsetI)
  fix p
  assume "p \<in> ?A"
  thus "p \<in> ?B"
  proof (induct p rule: span_induct')
    case base
    from span_zero show ?case by (rule rev_image_eqI) simp
  next
    case (step p r a)
    from step.hyps(2) obtain p' where "p' \<in> span F" and p: "p = q *s p'" ..
    from step.hyps(3) obtain a' where "a' \<in> F" and a: "a = q *s a'" ..
    from this(1) have "a' \<in> span F" by (rule span_base)
    hence "r *s a' \<in> span F" by (rule span_scale)
    with \<open>p' \<in> span F\<close> have "p' + r *s a' \<in> span F" by (rule span_add)
    hence "q *s (p' + r *s a') \<in> ?B" by (rule imageI)
    also have "q *s (p' + r *s a') = p + r *s a" by (simp add: a p algebra_simps)
    finally show ?case .
  qed
next
  fix p
  assume "p \<in> ?B"
  then obtain p' where "p' \<in> span F" and "p = q *s p'" ..
  from this(1) show "p \<in> ?A" unfolding \<open>p = q *s p'\<close>
  proof (induct p' rule: span_induct')
    case base
    show ?case by (simp add: span_zero)
  next
    case (step p r a)
    from step.hyps(3) have "q *s a \<in> (*s) q ` F" by (rule imageI)
    hence "q *s a \<in> ?A" by (rule span_base)
    hence "r *s (q *s a) \<in> ?A" by (rule span_scale)
    with step.hyps(2) have "q *s p + r *s (q *s a) \<in> ?A" by (rule span_add)
    also have "q *s p + r *s (q *s a) = q *s (p + r *s a)" by (simp add: algebra_simps)
    finally show ?case .
  qed
qed

end (* module *)

section \<open>Ideals over Commutative Rings\<close>

lemma module_times: "module (*)"
  by (standard, simp_all add: algebra_simps)

interpretation ideal: module times
  by (fact module_times)

declare ideal.scale_scale[simp del]

abbreviation "ideal \<equiv> ideal.span"

lemma ideal_eq_UNIV_iff_contains_one: "ideal B = UNIV \<longleftrightarrow> 1 \<in> ideal B"
proof
  assume *: "1 \<in> ideal B"
  show "ideal B = UNIV"
  proof
    show "UNIV \<subseteq> ideal B"
    proof
      fix x
      from * have "x * 1 \<in> ideal B" by (rule ideal.span_scale)
      thus "x \<in> ideal B" by simp
    qed
  qed simp
qed simp

lemma ideal_eq_zero_iff [iff]: "ideal F = {0} \<longleftrightarrow> F \<subseteq> {0}"
  by (metis empty_subsetI ideal.span_empty ideal.span_eq)

lemma ideal_field_cases:
  obtains "ideal B = {0}" | "ideal (B::'a::field set) = UNIV"
proof (cases "ideal B = {0}")
  case True
  thus ?thesis ..
next
  case False
  hence "\<not> B \<subseteq> {0}" by simp
  then obtain b where "b \<in> B" and "b \<noteq> 0" by blast
  from this(1) have "b \<in> ideal B" by (rule ideal.span_base)
  hence "inverse b * b \<in> ideal B" by (rule ideal.span_scale)
  with \<open>b \<noteq> 0\<close> have "ideal B = UNIV" by (simp add: ideal_eq_UNIV_iff_contains_one)
  thus ?thesis ..
qed

corollary ideal_field_disj: "ideal B = {0} \<or> ideal (B::'a::field set) = UNIV"
  by (rule ideal_field_cases) blast+

lemma image_ideal_subset:
  assumes "\<And>x y. h (x + y) = h x + h y" and "\<And>x y. h (x * y) = h x * h y"
  shows "h ` ideal F \<subseteq> ideal (h ` F)"
proof (intro subsetI, elim imageE)
  fix g f
  assume g: "g = h f"
  assume "f \<in> ideal F"
  thus "g \<in> ideal (h ` F)" unfolding g
  proof (induct f rule: ideal.span_induct_alt)
    case base
    have "h 0 = h (0 + 0)" by simp
    also have "\<dots> = h 0 + h 0" by (simp only: assms(1))
    finally show ?case by (simp add: ideal.span_zero)
  next
    case (step c f g)
    from step.hyps(1) have "h f \<in> ideal (h ` F)"
      by (intro ideal.span_base imageI)
    hence "h c * h f \<in> ideal (h ` F)" by (rule ideal.span_scale)
    hence "h c * h f + h g \<in> ideal (h ` F)"
      using step.hyps(2) by (rule ideal.span_add)
    thus ?case by (simp only: assms)
  qed
qed

lemma image_ideal_eq_surj:
  assumes "\<And>x y. h (x + y) = h x + h y" and "\<And>x y. h (x * y) = h x * h y" and "surj h"
  shows "h ` ideal B = ideal (h ` B)"
proof
  from assms(1, 2) show "h ` ideal B \<subseteq> ideal (h ` B)" by (rule image_ideal_subset)
next
  show "ideal (h ` B) \<subseteq> h ` ideal B"
  proof
    fix b
    assume "b \<in> ideal (h ` B)"
    thus "b \<in> h ` ideal B"
    proof (induct b rule: ideal.span_induct_alt)
      case base
      have "h 0 = h (0 + 0)" by simp
      also have "\<dots> = h 0 + h 0" by (simp only: assms(1))
      finally have "0 = h 0" by simp
      with ideal.span_zero show ?case by (rule rev_image_eqI)
    next
      case (step c b a)
      from assms(3) obtain c' where c: "c = h c'" by (rule surjE)
      from step.hyps(2) obtain a' where "a' \<in> ideal B" and a: "a = h a'" ..
      from step.hyps(1) obtain b' where "b' \<in> B" and b: "b = h b'" ..
      from this(1) have "b' \<in> ideal B" by (rule ideal.span_base)
      hence "c' * b' \<in> ideal B" by (rule ideal.span_scale)
      hence "c' * b' + a' \<in> ideal B" using \<open>a' \<in> _\<close> by (rule ideal.span_add)
      moreover have "c * b + a = h (c' * b' + a')"
        by (simp add: c b a assms(1, 2))
      ultimately show ?case by (rule rev_image_eqI)
    qed
  qed
qed

context
  fixes h :: "'a \<Rightarrow> 'a::comm_ring_1"
  assumes h_plus: "h (x + y) = h x + h y"
  assumes h_times: "h (x * y) = h x * h y"
  assumes h_idem: "h (h x) = h x"
begin

lemma in_idealE_homomorphism_finite:
  assumes "finite B" and "B \<subseteq> range h" and "p \<in> range h" and "p \<in> ideal B"
  obtains q where "\<And>b. q b \<in> range h" and "p = (\<Sum>b\<in>B. q b * b)"
proof -
  from assms(1, 4) obtain q0 where p: "p = (\<Sum>b\<in>B. q0 b * b)" by (rule ideal.span_finiteE)
  define q where "q = (\<lambda>b. h (q0 b))"
  show ?thesis
  proof
    fix b
    show "q b \<in> range h" unfolding q_def by (rule rangeI)
  next
    from assms(3) obtain p' where "p = h p'" ..
    hence "p = h p" by (simp only: h_idem)
    also from \<open>finite B\<close> have "\<dots> = (\<Sum>b\<in>B. q b * h b)" unfolding p
    proof (induct B)
      case empty
      have "h 0 = h (0 + 0)" by simp
      also have "\<dots> = h 0 + h 0" by (simp only: h_plus)
      finally show ?case by simp
    next
      case (insert b B)
      thus ?case by (simp add: h_plus h_times q_def)
    qed
    also from refl have "\<dots> = (\<Sum>b\<in>B. q b * b)"
    proof (rule sum.cong)
      fix b
      assume "b \<in> B"
      hence "b \<in> range h" using assms(2) ..
      then obtain b' where "b = h b'" ..
      thus "q b * h b = q b * b" by (simp only: h_idem)
    qed
    finally show "p = (\<Sum>b\<in>B. q b * b)" .
  qed
qed

corollary in_idealE_homomorphism:
  assumes "B \<subseteq> range h" and "p \<in> range h" and "p \<in> ideal B"
  obtains A q where "finite A" and "A \<subseteq> B" and "\<And>b. q b \<in> range h" and "p = (\<Sum>b\<in>A. q b * b)"
proof -
  from assms(3) obtain A where "finite A" and "A \<subseteq> B" and "p \<in> ideal A"
    by (rule ideal.span_finite_subset)
  from this(2) assms(1) have "A \<subseteq> range h" by (rule subset_trans)
  with \<open>finite A\<close> obtain q where "\<And>b. q b \<in> range h" and "p = (\<Sum>b\<in>A. q b * b)"
    using assms(2) \<open>p \<in> ideal A\<close> by (rule in_idealE_homomorphism_finite) blast
  with \<open>finite A\<close> \<open>A \<subseteq> B\<close> show ?thesis ..
qed

lemma ideal_induct_homomorphism [consumes 3, case_names 0 plus]:
  assumes "B \<subseteq> range h" and "p \<in> range h" and "p \<in> ideal B"
  assumes "P 0" and "\<And>c b a. c \<in> range h \<Longrightarrow> b \<in> B \<Longrightarrow> P a \<Longrightarrow> a \<in> range h \<Longrightarrow> P (c * b + a)"
  shows "P p"
proof -
  from assms(1-3) obtain A q where "finite A" and "A \<subseteq> B" and rl: "\<And>f. q f \<in> range h"
    and p: "p = (\<Sum>f\<in>A. q f * f)" by (rule in_idealE_homomorphism) blast
  show ?thesis unfolding p using \<open>finite A\<close> \<open>A \<subseteq> B\<close>
  proof (induct A)
    case empty
    from assms(4) show ?case by simp
  next
    case (insert a A)
    from insert.hyps(1, 2) have "(\<Sum>f\<in>insert a A. q f * f) = q a * a + (\<Sum>f\<in>A. q f * f)" by simp
    also from rl have "P \<dots>"
    proof (rule assms(5))
      have "a \<in> insert a A" by simp
      thus "a \<in> B" using insert.prems ..
    next
      from insert.prems have "A \<subseteq> B" by simp
      thus "P (\<Sum>f\<in>A. q f * f)" by (rule insert.hyps)
    next
      from insert.prems have "A \<subseteq> B" by simp
      hence "A \<subseteq> range h" using assms(1) by (rule subset_trans)
      with \<open>finite A\<close> show "(\<Sum>f\<in>A. q f * f) \<in> range h"
      proof (induct A)
        case empty
        have "h 0 = h (0 + 0)" by simp
        also have "\<dots> = h 0 + h 0" by (simp only: h_plus)
        finally have "(\<Sum>f\<in>{}. q f * f) = h 0" by simp
        thus ?case by (rule image_eqI) simp
      next
        case (insert a A)
        from insert.prems have "a \<in> range h" and "A \<subseteq> range h" by simp_all
        from this(1) obtain a' where a: "a = h a'" ..
        from \<open>q a \<in> range h\<close> obtain q' where q: "q a = h q'" ..
        from \<open>A \<subseteq> _\<close> have "(\<Sum>f\<in>A. q f * f) \<in> range h" by (rule insert.hyps)
        then obtain m where eq: "(\<Sum>f\<in>A. q f * f) = h m" ..
        from insert.hyps(1, 2) have "(\<Sum>f\<in>insert a A. q f * f) = q a * a + (\<Sum>f\<in>A. q f * f)" by simp
        also have "\<dots> = h (q' * a' + m)" unfolding q by (simp add: a eq h_plus h_times)
        also have "\<dots> \<in> range h" by (rule rangeI)
        finally show ?case .
      qed
    qed
    finally show ?case .
  qed
qed

lemma image_ideal_eq_Int: "h ` ideal B = ideal (h ` B) \<inter> range h"
proof
  from h_plus h_times have "h ` ideal B \<subseteq> ideal (h ` B)" by (rule image_ideal_subset)
  thus "h ` ideal B \<subseteq> ideal (h ` B) \<inter> range h" by blast
next
  show "ideal (h ` B) \<inter> range h \<subseteq> h ` ideal B"
  proof
    fix b
    assume "b \<in> ideal (h ` B) \<inter> range h"
    hence "b \<in> ideal (h ` B)" and "b \<in> range h" by simp_all
    have "h ` B \<subseteq> range h" by blast
    thus "b \<in> h ` ideal B" using \<open>b \<in> range h\<close> \<open>b \<in> ideal (h ` B)\<close>
    proof (induct b rule: ideal_induct_homomorphism)
      case 0
      have "h 0 = h (0 + 0)" by simp
      also have "\<dots> = h 0 + h 0" by (simp only: h_plus)
      finally have "0 = h 0" by simp
      with ideal.span_zero show ?case by (rule rev_image_eqI)
    next
      case (plus c b a)
      from plus.hyps(1) obtain c' where c: "c = h c'" ..
      from plus.hyps(3) obtain a' where "a' \<in> ideal B" and a: "a = h a'" ..
      from plus.hyps(2) obtain b' where "b' \<in> B" and b: "b = h b'" ..
      from this(1) have "b' \<in> ideal B" by (rule ideal.span_base)
      hence "c' * b' \<in> ideal B" by (rule ideal.span_scale)
      hence "c' * b' + a' \<in> ideal B" using \<open>a' \<in> _\<close> by (rule ideal.span_add)
      moreover have "c * b + a = h (c' * b' + a')" by (simp add: a b c h_plus h_times)
      ultimately show ?case by (rule rev_image_eqI)
    qed
  qed
qed

end

end (* theory *)


theory Rewrite_Examples
imports Main "HOL-Library.Rewrite"
begin

section \<open>The rewrite Proof Method by Example\<close>

(* This file is intended to give an overview over
   the features of the pattern-based rewrite proof method.

   See also https://www21.in.tum.de/~noschinl/Pattern-2014/
*)
lemma
  fixes a::int and b::int and c::int
  assumes "P (b + a)"
  shows "P (a + b)"
by (rewrite at "a + b" add.commute)
   (rule assms)

(* Selecting a specific subterm in a large, ambiguous term. *)
lemma
  fixes a b c :: int
  assumes "f (a - a + (a - a)) + f (   0    + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f _ + f \<hole> = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (a - a +    0   ) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite at "f (_ + \<hole>) + f _ = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (  0   + (a - a)) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f (\<hole> + _) + _ = _" diff_self) fact

lemma
  fixes a b c :: int
  assumes "f (a - a +    0   ) + f ((a - a) + c) = f 0 + f c"
  shows   "f (a - a + (a - a)) + f ((a - a) + c) = f 0 + f c"
  by (rewrite in "f (_ + \<hole>) + _ = _" diff_self) fact

lemma
  fixes x y :: nat
  shows"x + y > c \<Longrightarrow> y + x > c"
  by (rewrite at "\<hole> > c" add.commute) assumption

(* We can also rewrite in the assumptions.  *)
lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite in asm add.commute) fact

lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite in "x + y > c" at asm add.commute) fact

lemma
  fixes x y :: nat
  assumes "y + x > c \<Longrightarrow> y + x > c"
  shows   "x + y > c \<Longrightarrow> y + x > c"
  by (rewrite at "\<hole> > c" at asm  add.commute) fact

lemma
  assumes "P {x::int. y + 1 = 1 + x}"
  shows   "P {x::int. y + 1 = x + 1}"
  by (rewrite at "x+1" in "{x::int. \<hole> }" add.commute) fact

lemma
  assumes "P {x::int. y + 1 = 1 + x}"
  shows   "P {x::int. y + 1 = x + 1}"
  by (rewrite at "any_identifier_will_work+1" in "{any_identifier_will_work::int. \<hole> }" add.commute)
   fact

lemma
  assumes "P {(x::nat, y::nat, z). x + z * 3 = Q (\<lambda>s t. s * t + y - 3)}"
  shows   "P {(x::nat, y::nat, z). x + z * 3 = Q (\<lambda>s t. y + s * t - 3)}"
  by (rewrite at "b + d * e" in "\<lambda>(a, b, c). _ = Q (\<lambda>d e. \<hole>)" add.commute) fact

(* This is not limited to the first assumption *)
lemma
  assumes "PROP P \<equiv> PROP Q"
  shows "PROP R \<Longrightarrow> PROP P \<Longrightarrow> PROP Q"
    by (rewrite at asm assms)

lemma
  assumes "PROP P \<equiv> PROP Q"
  shows "PROP R \<Longrightarrow> PROP R \<Longrightarrow> PROP P \<Longrightarrow> PROP Q"
    by (rewrite at asm assms)

(* Rewriting "at asm" selects each full assumption, not any parts *)
lemma
  assumes "(PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP S \<Longrightarrow> PROP R)"
  shows "PROP S \<Longrightarrow> (PROP P \<Longrightarrow> PROP Q) \<Longrightarrow> PROP R"
  apply (rewrite at asm assms)
  apply assumption
  done

(* Rewriting with conditional rewriting rules works just as well. *)
lemma test_theorem:
  fixes x :: nat
  shows "x \<le> y \<Longrightarrow> x \<ge> y \<Longrightarrow> x = y"
  by (rule Orderings.order_antisym)

(* Premises of the conditional rule yield new subgoals. The
   assumptions of the goal are propagated into these subgoals
*)
lemma
  fixes f :: "nat \<Rightarrow> nat"
  shows "f x \<le> 0 \<Longrightarrow> f x \<ge> 0 \<Longrightarrow> f x = 0"
  apply (rewrite at "f x" to "0" test_theorem)
  apply assumption
  apply assumption
  apply (rule refl)
  done

(* This holds also for rewriting in assumptions. The order of assumptions is preserved *)
lemma
  assumes rewr: "PROP P \<Longrightarrow> PROP Q \<Longrightarrow> PROP R \<equiv> PROP R'"
  assumes A1: "PROP S \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP P"
  assumes A2: "PROP S \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP Q"
  assumes C: "PROP S \<Longrightarrow> PROP R' \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP V"
  shows "PROP S \<Longrightarrow> PROP R \<Longrightarrow> PROP T \<Longrightarrow> PROP U \<Longrightarrow> PROP V"
  apply (rewrite at asm rewr)
  apply (fact A1)
  apply (fact A2)
  apply (fact C)
  done

(*
   Instantiation.

   Since all rewriting is now done via conversions,
   instantiation becomes fairly easy to do.
*)

(* We first introduce a function f and an extended
   version of f that is annotated with an invariant. *)
fun f :: "nat \<Rightarrow> nat" where "f n = n"
definition "f_inv (I :: nat \<Rightarrow> bool) n \<equiv> f n"

lemma annotate_f: "f = f_inv I"
  by (simp add: f_inv_def fun_eq_iff)

(* We have a lemma with a bound variable n, and
   want to add an invariant to f. *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>_. True) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite to "f_inv (\<lambda>_. True)" annotate_f) fact

(* We can also add an invariant that contains the variable n bound in the outer context.
   For this, we need to bind this variable to an identifier. *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>x. n < x + 1) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite in "\<lambda>n. \<hole>" to "f_inv (\<lambda>x. n < x + 1)" annotate_f) fact

(* Any identifier will work *)
lemma
  assumes "P (\<lambda>n. f_inv (\<lambda>x. n < x + 1) n + 1) = x"
  shows "P (\<lambda>n. f n + 1) = x"
  by (rewrite in "\<lambda>abc. \<hole>" to "f_inv (\<lambda>x. abc < x + 1)" annotate_f) fact

(* The "for" keyword. *)
lemma
  assumes "P (2 + 1)"
  shows "\<And>x y. P (1 + 2 :: nat)"
by (rewrite in "P (1 + 2)" at for (x) add.commute) fact

lemma
  assumes "\<And>x y. P (y + x)"
  shows "\<And>x y. P (x + y :: nat)"
by (rewrite in "P (x + _)" at for (x y) add.commute) fact

lemma
  assumes "\<And>x y z. y + x + z = z + y + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "x + y" in "x + y + z" in for (x y z) add.commute) fact

lemma
  assumes "\<And>x y z. z + (x + y) = z + y + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "(_ + y) + z" in for (y z) add.commute) fact

lemma
  assumes "\<And>x y z. x + y + z = y + z + (x::int)"
  shows   "\<And>x y z. x + y + z = z + y + (x::int)"
by (rewrite at "\<hole> + _" at "_ = \<hole>" in for () add.commute) fact

lemma
  assumes eq: "\<And>x. P x \<Longrightarrow> g x = x"
  assumes f1: "\<And>x. Q x \<Longrightarrow> P x"
  assumes f2: "\<And>x. Q x \<Longrightarrow> x"
  shows "\<And>x. Q x \<Longrightarrow> g x"
  apply (rewrite at "g x" in for (x) eq)
  apply (fact f1)
  apply (fact f2)
  done

(* The for keyword can be used anywhere in the pattern where there is an \<And>-Quantifier. *)
lemma
  assumes "(\<And>(x::int). x < 1 + x)"
  and     "(x::int) + 1 > x"
  shows   "(\<And>(x::int). x + 1 > x) \<Longrightarrow> (x::int) + 1 > x"
by (rewrite at "x + 1" in for (x) at asm add.commute)
   (rule assms)

(* The rewrite method also has an ML interface *)
lemma
  assumes "\<And>a b. P ((a + 1) * (1 + b)) "
  shows "\<And>a b :: nat. P ((a + 1) * (b + 1))"
  apply (tactic \<open>
    let
      val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
      (* Note that the pattern order is reversed *)
      val pat = [
        Rewrite.For [(x, SOME \<^typ>\<open>nat\<close>)],
        Rewrite.In,
        Rewrite.Term (@{const plus(nat)} $ Free (x, \<^typ>\<open>nat\<close>) $ \<^term>\<open>1 :: nat\<close>, [])]
      val to = NONE
    in CCONVERSION (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) 1 end
  \<close>)
  apply (fact assms)
  done

lemma
  assumes "Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. a + b))"
  shows "Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. b + a))"
  apply (tactic \<open>
    let
      val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
      val pat = [
        Rewrite.Concl,
        Rewrite.In,
        Rewrite.Term (Free ("Q", (\<^typ>\<open>int\<close> --> TVar (("'b",0), [])) --> \<^typ>\<open>bool\<close>)
          $ Abs ("x", \<^typ>\<open>int\<close>, Rewrite.mk_hole 1 (\<^typ>\<open>int\<close> --> TVar (("'b",0), [])) $ Bound 0), [(x, \<^typ>\<open>int\<close>)]),
        Rewrite.In,
        Rewrite.Term (@{const plus(int)} $ Free (x, \<^typ>\<open>int\<close>) $ Var (("c", 0), \<^typ>\<open>int\<close>), [])
        ]
      val to = NONE
    in CCONVERSION (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) 1 end
  \<close>)
  apply (fact assms)
  done

(* There is also conversion-like rewrite function: *)
ML \<open>
  val ct = \<^cprop>\<open>Q (\<lambda>b :: int. P (\<lambda>a. a + b) (\<lambda>a. b + a))\<close>
  val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
  val pat = [
    Rewrite.Concl,
    Rewrite.In,
    Rewrite.Term (Free ("Q", (\<^typ>\<open>int\<close> --> TVar (("'b",0), [])) --> \<^typ>\<open>bool\<close>)
      $ Abs ("x", \<^typ>\<open>int\<close>, Rewrite.mk_hole 1 (\<^typ>\<open>int\<close> --> TVar (("'b",0), [])) $ Bound 0), [(x, \<^typ>\<open>int\<close>)]),
    Rewrite.In,
    Rewrite.Term (@{const plus(int)} $ Free (x, \<^typ>\<open>int\<close>) $ Var (("c", 0), \<^typ>\<open>int\<close>), [])
    ]
  val to = NONE
  val th = Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute} ct
\<close>

section \<open>Regression tests\<close>

ML \<open>
  val ct = \<^cterm>\<open>(\<lambda>b :: int. (\<lambda>a. b + a))\<close>
  val (x, ctxt) = yield_singleton Variable.add_fixes "x" \<^context>
  val pat = [
    Rewrite.In,
    Rewrite.Term (@{const plus(int)} $ Var (("c", 0), \<^typ>\<open>int\<close>) $ Var (("c", 0), \<^typ>\<open>int\<close>), [])
    ]
  val to = NONE
  val _ =
    case try (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) ct of
      NONE => ()
    | _ => error "should not have matched anything"
\<close>

ML \<open>
  Rewrite.params_pconv (Conv.all_conv |> K |> K) \<^context> (Vartab.empty, []) \<^cterm>\<open>\<And>x. PROP A\<close>
\<close>

lemma
  assumes eq: "PROP A \<Longrightarrow> PROP B \<equiv> PROP C"
  assumes f1: "PROP D \<Longrightarrow> PROP A"
  assumes f2: "PROP D \<Longrightarrow> PROP C"
  shows "\<And>x. PROP D \<Longrightarrow> PROP B"
  apply (rewrite eq)
  apply (fact f1)
  apply (fact f2)
  done

end


(* Specification of the following loop back device

          g
           --------------------
          |      -------       |
       x  |     |       |      |  y
    ------|---->|       |------| ----->
          |  z  |   f   | z    |
          |  -->|       |---   |
          | |   |       |   |  |
          | |    -------    |  |
          | |               |  |
          |  <--------------   |
          |                    |
           --------------------

First step: Notation in Agent Network Description Language (ANDL)
-----------------------------------------------------------------

agent f
        input  channel i1:'b i2: ('b,'c) tc
        output channel o1:'c o2: ('b,'c) tc
is
        Rf(i1,i2,o1,o2)  (left open in the example)
end f

agent g
        input  channel x:'b
        output channel y:'c
is network
        (y,z) = f$(x,z)
end network
end g

Remark: the type of the feedback depends at most on the types of the input and
        output of g. (No type miracles inside g)

Second step: Translation of ANDL specification to HOLCF Specification
---------------------------------------------------------------------

Specification of agent f ist translated to predicate is_f

is_f :: ('b stream * ('b,'c) tc stream ->
                'c stream * ('b,'c) tc stream) => bool

is_f f  = !i1 i2 o1 o2.
        f$(i1,i2) = (o1,o2) --> Rf(i1,i2,o1,o2)

Specification of agent g is translated to predicate is_g which uses
predicate is_net_g

is_net_g :: ('b stream * ('b,'c) tc stream -> 'c stream * ('b,'c) tc stream) =>
            'b stream => 'c stream => bool

is_net_g f x y =
        ? z. (y,z) = f$(x,z) &
        !oy hz. (oy,hz) = f$(x,hz) --> z << hz

is_g :: ('b stream -> 'c stream) => bool

is_g g  = ? f. is_f f  & (!x y. g$x = y --> is_net_g f x y

Third step: (show conservativity)
-----------

Suppose we have a model for the theory TH1 which contains the axiom

        ? f. is_f f

In this case there is also a model for the theory TH2 that enriches TH1 by
axiom

        ? g. is_g g

The result is proved by showing that there is a definitional extension
that extends TH1 by a definition of g.

We define:

def_g g  =
         (? f. is_f f  &
              g = (LAM x. fst (f$(x,fix$(LAM k. snd (f$(x,k)))))) )

Now we prove:

        (? f. is_f f ) --> (? g. is_g g)

using the theorems

loopback_eq)    def_g = is_g                    (real work)

L1)             (? f. is_f f ) --> (? g. def_g g)  (trivial)

*)

theory Focus_ex
imports "HOLCF-Library.Stream"
begin

typedecl ('a, 'b) tc
axiomatization where tc_arity: "OFCLASS(('a::pcpo, 'b::pcpo) tc, pcop_class)"
instance tc :: (pcpo, pcpo) pcpo by (rule tc_arity)

axiomatization
  Rf :: "('b stream * ('b,'c) tc stream * 'c stream * ('b,'c) tc stream) \<Rightarrow> bool"

definition
  is_f :: "('b stream * ('b,'c) tc stream \<rightarrow> 'c stream * ('b,'c) tc stream) \<Rightarrow> bool" where
  "is_f f \<longleftrightarrow> (\<forall>i1 i2 o1 o2. f\<cdot>(i1, i2) = (o1, o2) \<longrightarrow> Rf (i1, i2, o1, o2))"

definition
  is_net_g :: "('b stream * ('b,'c) tc stream \<rightarrow> 'c stream * ('b,'c) tc stream) \<Rightarrow>
    'b stream \<Rightarrow> 'c stream \<Rightarrow> bool" where
  "is_net_g f x y \<equiv> (\<exists>z.
                        (y, z) = f\<cdot>(x,z) \<and>
                        (\<forall>oy hz. (oy, hz) = f\<cdot>(x, hz) \<longrightarrow> z << hz))"

definition
  is_g :: "('b stream \<rightarrow> 'c stream) \<Rightarrow> bool" where
  "is_g g \<equiv> (\<exists>f. is_f f \<and> (\<forall>x y. g\<cdot>x = y \<longrightarrow> is_net_g f x y))"

definition
  def_g :: "('b stream \<rightarrow> 'c stream) => bool" where
  "def_g g \<equiv> (\<exists>f. is_f f \<and> g = (LAM x. fst (f\<cdot>(x, fix\<cdot>(LAM  k. snd (f\<cdot>(x, k)))))))"

(* first some logical trading *)

lemma lemma1:
  "is_g g \<longleftrightarrow>
    (\<exists>f. is_f(f) \<and> (\<forall>x.(\<exists>z. (g\<cdot>x,z) = f\<cdot>(x,z) \<and> (\<forall>w y. (y, w) = f\<cdot>(x, w) \<longrightarrow> z << w))))"
apply (simp add: is_g_def is_net_g_def)
apply fast
done

lemma lemma2:
  "(\<exists>f. is_f f \<and> (\<forall>x. (\<exists>z. (g\<cdot>x, z) = f\<cdot>(x, z) \<and> (\<forall>w y. (y, w) = f\<cdot>(x,w) \<longrightarrow> z << w)))) \<longleftrightarrow>
  (\<exists>f. is_f f \<and> (\<forall>x. \<exists>z.
        g\<cdot>x = fst (f\<cdot>(x, z)) \<and>
          z = snd (f\<cdot>(x, z)) \<and>
        (\<forall>w y. (y, w) = f\<cdot>(x, w) \<longrightarrow> z << w)))"
apply (rule iffI)
apply (erule exE)
apply (rule_tac x = "f" in exI)
apply (erule conjE)+
apply (erule conjI)
apply (intro strip)
apply (erule allE)
apply (erule exE)
apply (rule_tac x = "z" in exI)
apply (erule conjE)+
apply (rule conjI)
apply (rule_tac [2] conjI)
prefer 3 apply (assumption)
apply (drule sym)
apply (simp)
apply (drule sym)
apply (simp)
apply (erule exE)
apply (rule_tac x = "f" in exI)
apply (erule conjE)+
apply (erule conjI)
apply (intro strip)
apply (erule allE)
apply (erule exE)
apply (rule_tac x = "z" in exI)
apply (erule conjE)+
apply (rule conjI)
prefer 2 apply (assumption)
apply (rule prod_eqI)
apply simp
apply simp
done

lemma lemma3: "def_g g \<longrightarrow> is_g g"
apply (tactic \<open>simp_tac (put_simpset HOL_ss \<^context>
  addsimps [@{thm def_g_def}, @{thm lemma1}, @{thm lemma2}]) 1\<close>)
apply (rule impI)
apply (erule exE)
apply (rule_tac x = "f" in exI)
apply (erule conjE)+
apply (erule conjI)
apply (intro strip)
apply (rule_tac x = "fix\<cdot>(LAM k. snd (f\<cdot>(x, k)))" in exI)
apply (rule conjI)
 apply (simp)
 apply (rule prod_eqI, simp, simp)
 apply (rule trans)
  apply (rule fix_eq)
 apply (simp (no_asm))
apply (intro strip)
apply (rule fix_least)
apply (simp (no_asm))
apply (erule exE)
apply (drule sym)
back
apply simp
done

lemma lemma4: "is_g g \<longrightarrow> def_g g"
apply (tactic \<open>simp_tac (put_simpset HOL_ss \<^context>
  delsimps (@{thms HOL.ex_simps} @ @{thms HOL.all_simps})
  addsimps [@{thm lemma1}, @{thm lemma2}, @{thm def_g_def}]) 1\<close>)
apply (rule impI)
apply (erule exE)
apply (rule_tac x = "f" in exI)
apply (erule conjE)+
apply (erule conjI)
apply (rule cfun_eqI)
apply (erule_tac x = "x" in allE)
apply (erule exE)
apply (erule conjE)+
apply (subgoal_tac "fix\<cdot>(LAM k. snd (f\<cdot>(x, k))) = z")
 apply simp
apply (subgoal_tac "\<forall>w y. f\<cdot>(x, w) = (y, w) \<longrightarrow> z << w")
apply (rule fix_eqI)
apply simp
apply (subgoal_tac "f\<cdot>(x, za) = (fst (f\<cdot>(x, za)), za)")
apply fast
apply (rule prod_eqI, simp, simp)
apply (intro strip)
apply (erule allE)+
apply (erule mp)
apply (erule sym)
done

(* now we assemble the result *)

lemma loopback_eq: "def_g = is_g"
apply (rule ext)
apply (rule iffI)
apply (erule lemma3 [THEN mp])
apply (erule lemma4 [THEN mp])
done

lemma L2:
  "(\<exists>f. is_f (f::'b stream * ('b,'c) tc stream \<rightarrow> 'c stream * ('b,'c) tc stream)) \<longrightarrow>
    (\<exists>g. def_g (g::'b stream \<rightarrow> 'c stream))"
apply (simp add: def_g_def)
done

theorem conservative_loopback:
  "(\<exists>f. is_f (f::'b stream * ('b,'c) tc stream \<rightarrow> 'c stream * ('b,'c) tc stream)) \<longrightarrow>
    (\<exists>g. is_g (g::'b stream \<rightarrow> 'c stream))"
apply (rule loopback_eq [THEN subst])
apply (rule L2)
done

end