(*  Title:      HOL/Matrix_LP/Cplex.thy
    Author:     Steven Obua
*)

theory Cplex
imports SparseMatrix LP ComputeFloat ComputeNumeral
begin

ML_file \<open>Cplex_tools.ML\<close>
ML_file \<open>CplexMatrixConverter.ML\<close>
ML_file \<open>FloatSparseMatrixBuilder.ML\<close>
ML_file \<open>fspmlp.ML\<close>

lemma spm_mult_le_dual_prts:
  assumes
  "sorted_sparse_matrix A1"
  "sorted_sparse_matrix A2"
  "sorted_sparse_matrix c1"
  "sorted_sparse_matrix c2"
  "sorted_sparse_matrix y"
  "sorted_sparse_matrix r1"
  "sorted_sparse_matrix r2"
  "sorted_spvec b"
  "le_spmat [] y"
  "sparse_row_matrix A1 \<le> A"
  "A \<le> sparse_row_matrix A2"
  "sparse_row_matrix c1 \<le> c"
  "c \<le> sparse_row_matrix c2"
  "sparse_row_matrix r1 \<le> x"
  "x \<le> sparse_row_matrix r2"
  "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
  shows
  "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b)
  (let s1 = diff_spmat c1 (mult_spmat y A2); s2 = diff_spmat c2 (mult_spmat y A1) in
  add_spmat (mult_spmat (pprt_spmat s2) (pprt_spmat r2)) (add_spmat (mult_spmat (pprt_spmat s1) (nprt_spmat r2))
  (add_spmat (mult_spmat (nprt_spmat s2) (pprt_spmat r1)) (mult_spmat (nprt_spmat s1) (nprt_spmat r1))))))"
  apply (simp add: Let_def)
  apply (insert assms)
  apply (simp add: sparse_row_matrix_op_simps algebra_simps)
  apply (rule mult_le_dual_prts[where A=A, simplified Let_def algebra_simps])
  apply (auto)
  done

lemma spm_mult_le_dual_prts_no_let:
  assumes
  "sorted_sparse_matrix A1"
  "sorted_sparse_matrix A2"
  "sorted_sparse_matrix c1"
  "sorted_sparse_matrix c2"
  "sorted_sparse_matrix y"
  "sorted_sparse_matrix r1"
  "sorted_sparse_matrix r2"
  "sorted_spvec b"
  "le_spmat [] y"
  "sparse_row_matrix A1 \<le> A"
  "A \<le> sparse_row_matrix A2"
  "sparse_row_matrix c1 \<le> c"
  "c \<le> sparse_row_matrix c2"
  "sparse_row_matrix r1 \<le> x"
  "x \<le> sparse_row_matrix r2"
  "A * x \<le> sparse_row_matrix (b::('a::lattice_ring) spmat)"
  shows
  "c * x \<le> sparse_row_matrix (add_spmat (mult_spmat y b)
  (mult_est_spmat r1 r2 (diff_spmat c1 (mult_spmat y A2)) (diff_spmat c2 (mult_spmat y A1))))"
  by (simp add: assms mult_est_spmat_def spm_mult_le_dual_prts[where A=A, simplified Let_def])

ML_file \<open>matrixlp.ML\<close>

end


theory HSV_CW_1_4 imports Complex_Main begin

(* We use the following command to search Isabelle's library
   for theorems that contain a particular pattern. *)
find_theorems "_ \<in> \<rat>"
thm Rats_abs_nat_div_natE

find_theorems "(_ / _)^_"
thm power_divide

(* A proof that the 2*square root of 2 is irrational. *)
theorem sqrt2_irrational_2: "2 * sqrt 2 \<notin> \<rat>"
proof auto
  assume "(2*sqrt 2) \<in> \<rat>"
  then obtain m n where
    "n \<noteq> 0" and "\<bar>2*sqrt 2\<bar> = real m / real n" and "coprime m n"
    by (rule Rats_abs_nat_div_natE)
  hence "\<bar>2*sqrt 2\<bar>^2 = (real m / real n)^2" by auto
  hence "8 = (real m / real n)^2" by simp
  hence "8 = (real m)^2 / (real n)^2" unfolding power_divide by auto
  hence "8 * (real n)^2 = (real m)^2"
    by (simp add: nonzero_eq_divide_eq `n \<noteq> 0`)

  hence "real (8 * n^2) = real(m)^2" by auto
  hence *: "8 * n^2 = m^2"
    using of_nat_power_eq_of_nat_cancel_iff by blast
  hence "even (m^2)" by presburger
  hence "even m" by simp
  then obtain m' where "m = 2 * m'" by auto
  with * have "8 * n^2 = (2 * m')^2" by auto
  hence "8 * n^2 = 4 * m'^2" by simp
  hence *: "2 * n^2 = m'^2" by simp
  hence "even (m'^2)" by presburger
  hence "even m'" by simp
  then obtain m'' where "m' = 2 * m''" by auto
  with * have "2 * n^2 = (2 * m'')^2" by auto
  hence "n^2 = 2 * m''^2" by simp
  hence "n^2 = 2* m''^2" by simp
  hence "even (n^2)" by presburger
  hence "even n" by simp
  with `even m` and `coprime m n` show False by auto
qed

(* L numbers *)
fun dirac :: "nat \<Rightarrow> nat" where
  "dirac n = (if n = 0 then 1 else 0)"

theorem dirac_suc: "dirac (Suc n) = 0"
  apply simp
  done

fun Lnum :: "nat \<Rightarrow> nat" where
  "Lnum n = (if n \<le> 1 then n else 2 + Lnum (n-1))"

value "Lnum 0" (* 0 *)
value "Lnum 1" (* 1 *)
value "Lnum 2" (* 3 *)
value "Lnum 3" (* 5 *)

(* Proving that closed form is equivalent to recursive definition *)
theorem "Lnum n = 2*n+dirac n-1"
proof (induct n)
  case 0
  then show ?case by simp
next
  case (Suc k)
  assume IH: "Lnum k = 2*k+dirac(k)-1"
  have "Lnum (Suc k) = 2*(Suc k)+dirac(Suc k)-1"
  proof (induct k)
    case 0
    then show ?case by simp
  next
    case (Suc k)
    then show ?case by simp
  qed
  then show ?case by auto
qed

(* Pyr numbers *)
fun pyr :: "nat \<Rightarrow> nat" where
  "pyr n = (if n = 0 then 0 else (n)*(n) + pyr (n-1))"

value "pyr 0" (* 0 *)
value "pyr 1" (* 1 *)
value "pyr 2" (* 5 *)
value "pyr 3" (* 14 *)

find_theorems "_ div ?x + _ div ?x"
thm div_add

(* Proving that closed form is equivalent to recursive definition *)
theorem "pyr n = ((2*n + 1) * (n + 1) * n) div 6"
proof (induct n)
  case 0
  show ?case by simp
next
  case (Suc k)
  (* induction hypothesis *)
  assume IH: "pyr k = (2*k + 1) * (k + 1) * k div 6"

  (* the actual proof *)
  have "pyr (Suc k) = (Suc k)*(Suc k) + pyr k"
    by simp
  have "... = (Suc k)*(Suc k) + ((2*k + 1) * (k + 1) * k div 6)"
    using IH by simp
  have "... = (6*(Suc k)*(Suc k) + (2*k + 1) * (k + 1) * k) div 6 "
    by linarith
  have "... = (6*(k+1)*(k+1) + (2*k + 1) * (k + 1) * k) div 6 "
    by (simp add: distrib_right power2_eq_square)
  have "... = (6*(k+1)*(k+1) + (2*k + 1) * (k^2 + k)) div 6"
    by (metis (mono_tags, lifting) Suc_eq_plus1 mult.assoc mult_Suc power2_eq_square semiring_normalization_rules(24))
    have "... = (2*(Suc k) + 1) * ((Suc k) + 1) * (Suc k) div 6"
      by (smt Groups.add_ac(3) Suc_eq_plus1 \<open>(6 * (k + 1) * (k + 1) + (2 * k + 1) * (k + 1) * k) div 6 = (6 * (k + 1) * (k + 1) + (2 * k + 1) * (k\<^sup>2 + k)) div 6\<close> add_Suc_right distrib_right nat_mult_1 numeral_Bit0 numeral_Bit1 numeral_code(1) semiring_normalization_rules(16) semiring_normalization_rules(23))
  show ?case
    using \<open>(6 * (k + 1) * (k + 1) + (2 * k + 1) * (k + 1) * k) div 6 = (6 * (k + 1) * (k + 1) + (2 * k + 1) * (k\<^sup>2 + k)) div 6\<close> \<open>(6 * (k + 1) * (k + 1) + (2 * k + 1) * (k\<^sup>2 + k)) div 6 = (2 * Suc k + 1) * (Suc k + 1) * Suc k div 6\<close> \<open>(6 * Suc k * Suc k + (2 * k + 1) * (k + 1) * k) div 6 = (6 * (k + 1) * (k + 1) + (2 * k + 1) * (k + 1) * k) div 6\<close> \<open>Suc k * Suc k + (2 * k + 1) * (k + 1) * k div 6 = (6 * Suc k * Suc k + (2 * k + 1) * (k + 1) * k) div 6\<close> \<open>Suc k * Suc k + pyr k = Suc k * Suc k + (2 * k + 1) * (k + 1) * k div 6\<close> \<open>pyr (Suc k) = Suc k * Suc k + pyr k\<close> by linarith
qed
end


(*  Title:      ZF/ArithSimp.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2000  University of Cambridge
*)

section{*Arithmetic with simplification*}

theory ArithSimp
imports Arith
begin

ML_file "~~/src/Provers/Arith/cancel_numerals.ML"
ML_file "~~/src/Provers/Arith/combine_numerals.ML"
ML_file "arith_data.ML"

subsection{*Difference*}

lemma diff_self_eq_0 [simp]: "m #- m = 0"
apply (subgoal_tac "natify (m) #- natify (m) = 0")
apply (rule_tac [2] natify_in_nat [THEN nat_induct], auto)
done

(**Addition is the inverse of subtraction**)

(*We need m:nat even if we replace the RHS by natify(m), for consider e.g.
  n=2, m=omega; then n + (m-n) = 2 + (0-2) = 2 \<noteq> 0 = natify(m).*)
lemma add_diff_inverse: "[| n \<le> m;  m:nat |] ==> n #+ (m#-n) = m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct, auto)
done

lemma add_diff_inverse2: "[| n \<le> m;  m:nat |] ==> (m#-n) #+ n = m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (simp (no_asm_simp) add: add_commute add_diff_inverse)
done

(*Proof is IDENTICAL to that of add_diff_inverse*)
lemma diff_succ: "[| n \<le> m;  m:nat |] ==> succ(m) #- n = succ(m#-n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp))
done

lemma zero_less_diff [simp]:
     "[| m: nat; n: nat |] ==> 0 < (n #- m)   \<longleftrightarrow>   m<n"
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp))
done

(** Difference distributes over multiplication **)

lemma diff_mult_distrib: "(m #- n) #* k = (m #* k) #- (n #* k)"
apply (subgoal_tac " (natify (m) #- natify (n)) #* natify (k) = (natify (m) #* natify (k)) #- (natify (n) #* natify (k))")
apply (rule_tac [2] m = "natify (m) " and n = "natify (n) " in diff_induct)
apply (simp_all add: diff_cancel)
done

lemma diff_mult_distrib2: "k #* (m #- n) = (k #* m) #- (k #* n)"
apply (simp (no_asm) add: mult_commute [of k] diff_mult_distrib)
done

subsection{*Remainder*}

(*We need m:nat even with natify*)
lemma div_termination: "[| 0<n;  n \<le> m;  m:nat |] ==> m #- n < m"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (erule rev_mp)
apply (erule rev_mp)
apply (rule_tac m = m and n = n in diff_induct)
apply (simp_all (no_asm_simp) add: diff_le_self)
done

(*for mod and div*)
lemmas div_rls =
    nat_typechecks Ord_transrec_type apply_funtype
    div_termination [THEN ltD]
    nat_into_Ord not_lt_iff_le [THEN iffD1]

lemma raw_mod_type: "[| m:nat;  n:nat |] ==> raw_mod (m, n) \<in> nat"
apply (unfold raw_mod_def)
apply (rule Ord_transrec_type)
apply (auto simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (blast intro: div_rls)
done

lemma mod_type [TC,iff]: "m mod n \<in> nat"
apply (unfold mod_def)
apply (simp (no_asm) add: mod_def raw_mod_type)
done

(** Aribtrary definitions for division by zero.  Useful to simplify
    certain equations **)

lemma DIVISION_BY_ZERO_DIV: "a div 0 = 0"
apply (unfold div_def)
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp))
done  (*NOT for adding to default simpset*)

lemma DIVISION_BY_ZERO_MOD: "a mod 0 = natify(a)"
apply (unfold mod_def)
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp))
done  (*NOT for adding to default simpset*)

lemma raw_mod_less: "m<n ==> raw_mod (m,n) = m"
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD])
done

lemma mod_less [simp]: "[| m<n; n \<in> nat |] ==> m mod n = m"
apply (frule lt_nat_in_nat, assumption)
apply (simp (no_asm_simp) add: mod_def raw_mod_less)
done

lemma raw_mod_geq:
     "[| 0<n; n \<le> m;  m:nat |] ==> raw_mod (m, n) = raw_mod (m#-n, n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (rule raw_mod_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD] not_lt_iff_le [THEN iffD2], blast)
done

lemma mod_geq: "[| n \<le> m;  m:nat |] ==> m mod n = (m#-n) mod n"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: mod_def raw_mod_geq nat_into_Ord [THEN Ord_0_lt_iff])
done

subsection{*Division*}

lemma raw_div_type: "[| m:nat;  n:nat |] ==> raw_div (m, n) \<in> nat"
apply (unfold raw_div_def)
apply (rule Ord_transrec_type)
apply (auto simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (blast intro: div_rls)
done

lemma div_type [TC,iff]: "m div n \<in> nat"
apply (unfold div_def)
apply (simp (no_asm) add: div_def raw_div_type)
done

lemma raw_div_less: "m<n ==> raw_div (m,n) = 0"
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD])
done

lemma div_less [simp]: "[| m<n; n \<in> nat |] ==> m div n = 0"
apply (frule lt_nat_in_nat, assumption)
apply (simp (no_asm_simp) add: div_def raw_div_less)
done

lemma raw_div_geq: "[| 0<n;  n \<le> m;  m:nat |] ==> raw_div(m,n) = succ(raw_div(m#-n, n))"
apply (subgoal_tac "n \<noteq> 0")
prefer 2 apply blast
apply (frule lt_nat_in_nat, erule nat_succI)
apply (rule raw_div_def [THEN def_transrec, THEN trans])
apply (simp (no_asm_simp) add: div_termination [THEN ltD] not_lt_iff_le [THEN iffD2] )
done

lemma div_geq [simp]:
     "[| 0<n;  n \<le> m;  m:nat |] ==> m div n = succ ((m#-n) div n)"
apply (frule lt_nat_in_nat, erule nat_succI)
apply (simp (no_asm_simp) add: div_def raw_div_geq)
done

declare div_less [simp] div_geq [simp]

(*A key result*)
lemma mod_div_lemma: "[| m: nat;  n: nat |] ==> (m div n)#*n #+ m mod n = m"
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (erule complete_induct)
apply (case_tac "x<n")
txt{*case x<n*}
apply (simp (no_asm_simp))
txt{*case @{term"n \<le> x"}*}
apply (simp add: not_lt_iff_le add_assoc mod_geq div_termination [THEN ltD] add_diff_inverse)
done

lemma mod_div_equality_natify: "(m div n)#*n #+ m mod n = natify(m)"
apply (subgoal_tac " (natify (m) div natify (n))#*natify (n) #+ natify (m) mod natify (n) = natify (m) ")
apply force
apply (subst mod_div_lemma, auto)
done

lemma mod_div_equality: "m: nat ==> (m div n)#*n #+ m mod n = m"
apply (simp (no_asm_simp) add: mod_div_equality_natify)
done

subsection{*Further Facts about Remainder*}

text{*(mainly for mutilated chess board)*}

lemma mod_succ_lemma:
     "[| 0<n;  m:nat;  n:nat |]
      ==> succ(m) mod n = (if succ(m mod n) = n then 0 else succ(m mod n))"
apply (erule complete_induct)
apply (case_tac "succ (x) <n")
txt{* case succ(x) < n *}
 apply (simp (no_asm_simp) add: nat_le_refl [THEN lt_trans] succ_neq_self)
 apply (simp add: ltD [THEN mem_imp_not_eq])
txt{* case @{term"n \<le> succ(x)"} *}
apply (simp add: mod_geq not_lt_iff_le)
apply (erule leE)
 apply (simp (no_asm_simp) add: mod_geq div_termination [THEN ltD] diff_succ)
txt{*equality case*}
apply (simp add: diff_self_eq_0)
done

lemma mod_succ:
  "n:nat ==> succ(m) mod n = (if succ(m mod n) = n then 0 else succ(m mod n))"
apply (case_tac "n=0")
 apply (simp (no_asm_simp) add: natify_succ DIVISION_BY_ZERO_MOD)
apply (subgoal_tac "natify (succ (m)) mod n = (if succ (natify (m) mod n) = n then 0 else succ (natify (m) mod n))")
 prefer 2
 apply (subst natify_succ)
 apply (rule mod_succ_lemma)
  apply (auto simp del: natify_succ simp add: nat_into_Ord [THEN Ord_0_lt_iff])
done

lemma mod_less_divisor: "[| 0<n;  n:nat |] ==> m mod n < n"
apply (subgoal_tac "natify (m) mod n < n")
apply (rule_tac [2] i = "natify (m) " in complete_induct)
apply (case_tac [3] "x<n", auto)
txt{* case @{term"n \<le> x"}*}
apply (simp add: mod_geq not_lt_iff_le div_termination [THEN ltD])
done

lemma mod_1_eq [simp]: "m mod 1 = 0"
by (cut_tac n = 1 in mod_less_divisor, auto)

lemma mod2_cases: "b<2 ==> k mod 2 = b | k mod 2 = (if b=1 then 0 else 1)"
apply (subgoal_tac "k mod 2: 2")
 prefer 2 apply (simp add: mod_less_divisor [THEN ltD])
apply (drule ltD, auto)
done

lemma mod2_succ_succ [simp]: "succ(succ(m)) mod 2 = m mod 2"
apply (subgoal_tac "m mod 2: 2")
 prefer 2 apply (simp add: mod_less_divisor [THEN ltD])
apply (auto simp add: mod_succ)
done

lemma mod2_add_more [simp]: "(m#+m#+n) mod 2 = n mod 2"
apply (subgoal_tac " (natify (m) #+natify (m) #+n) mod 2 = n mod 2")
apply (rule_tac [2] n = "natify (m) " in nat_induct)
apply auto
done

lemma mod2_add_self [simp]: "(m#+m) mod 2 = 0"
by (cut_tac n = 0 in mod2_add_more, auto)

subsection{*Additional theorems about @{text "\<le>"}*}

lemma add_le_self: "m:nat ==> m \<le> (m #+ n)"
apply (simp (no_asm_simp))
done

lemma add_le_self2: "m:nat ==> m \<le> (n #+ m)"
apply (simp (no_asm_simp))
done

(*** Monotonicity of Multiplication ***)

lemma mult_le_mono1: "[| i \<le> j; j:nat |] ==> (i#*k) \<le> (j#*k)"
apply (subgoal_tac "natify (i) #*natify (k) \<le> j#*natify (k) ")
apply (frule_tac [2] lt_nat_in_nat)
apply (rule_tac [3] n = "natify (k) " in nat_induct)
apply (simp_all add: add_le_mono)
done

(* @{text"\<le>"} monotonicity, BOTH arguments*)
lemma mult_le_mono: "[| i \<le> j; k \<le> l; j:nat; l:nat |] ==> i#*k \<le> j#*l"
apply (rule mult_le_mono1 [THEN le_trans], assumption+)
apply (subst mult_commute, subst mult_commute, rule mult_le_mono1, assumption+)
done

(*strict, in 1st argument; proof is by induction on k>0.
  I can't see how to relax the typing conditions.*)
lemma mult_lt_mono2: "[| i<j; 0<k; j:nat; k:nat |] ==> k#*i < k#*j"
apply (erule zero_lt_natE)
apply (frule_tac [2] lt_nat_in_nat)
apply (simp_all (no_asm_simp))
apply (induct_tac "x")
apply (simp_all (no_asm_simp) add: add_lt_mono)
done

lemma mult_lt_mono1: "[| i<j; 0<k; j:nat; k:nat |] ==> i#*k < j#*k"
apply (simp (no_asm_simp) add: mult_lt_mono2 mult_commute [of _ k])
done

lemma add_eq_0_iff [iff]: "m#+n = 0 \<longleftrightarrow> natify(m)=0 & natify(n)=0"
apply (subgoal_tac "natify (m) #+ natify (n) = 0 \<longleftrightarrow> natify (m) =0 & natify (n) =0")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
apply auto
done

lemma zero_lt_mult_iff [iff]: "0 < m#*n \<longleftrightarrow> 0 < natify(m) & 0 < natify(n)"
apply (subgoal_tac "0 < natify (m) #*natify (n) \<longleftrightarrow> 0 < natify (m) & 0 < natify (n) ")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
  apply (rule_tac [3] n = "natify (n) " in natE)
apply auto
done

lemma mult_eq_1_iff [iff]: "m#*n = 1 \<longleftrightarrow> natify(m)=1 & natify(n)=1"
apply (subgoal_tac "natify (m) #* natify (n) = 1 \<longleftrightarrow> natify (m) =1 & natify (n) =1")
apply (rule_tac [2] n = "natify (m) " in natE)
 apply (rule_tac [4] n = "natify (n) " in natE)
apply auto
done

lemma mult_is_zero: "[|m: nat; n: nat|] ==> (m #* n = 0) \<longleftrightarrow> (m = 0 | n = 0)"
apply auto
apply (erule natE)
apply (erule_tac [2] natE, auto)
done

lemma mult_is_zero_natify [iff]:
     "(m #* n = 0) \<longleftrightarrow> (natify(m) = 0 | natify(n) = 0)"
apply (cut_tac m = "natify (m) " and n = "natify (n) " in mult_is_zero)
apply auto
done

subsection{*Cancellation Laws for Common Factors in Comparisons*}

lemma mult_less_cancel_lemma:
     "[| k: nat; m: nat; n: nat |] ==> (m#*k < n#*k) \<longleftrightarrow> (0<k & m<n)"
apply (safe intro!: mult_lt_mono1)
apply (erule natE, auto)
apply (rule not_le_iff_lt [THEN iffD1])
apply (drule_tac [3] not_le_iff_lt [THEN [2] rev_iffD2])
prefer 5 apply (blast intro: mult_le_mono1, auto)
done

lemma mult_less_cancel2 [simp]:
     "(m#*k < n#*k) \<longleftrightarrow> (0 < natify(k) & natify(m) < natify(n))"
apply (rule iff_trans)
apply (rule_tac [2] mult_less_cancel_lemma, auto)
done

lemma mult_less_cancel1 [simp]:
     "(k#*m < k#*n) \<longleftrightarrow> (0 < natify(k) & natify(m) < natify(n))"
apply (simp (no_asm) add: mult_less_cancel2 mult_commute [of k])
done

lemma mult_le_cancel2 [simp]: "(m#*k \<le> n#*k) \<longleftrightarrow> (0 < natify(k) \<longrightarrow> natify(m) \<le> natify(n))"
apply (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])
apply auto
done

lemma mult_le_cancel1 [simp]: "(k#*m \<le> k#*n) \<longleftrightarrow> (0 < natify(k) \<longrightarrow> natify(m) \<le> natify(n))"
apply (simp (no_asm_simp) add: not_lt_iff_le [THEN iff_sym])
apply auto
done

lemma mult_le_cancel_le1: "k \<in> nat ==> k #* m \<le> k \<longleftrightarrow> (0 < k \<longrightarrow> natify(m) \<le> 1)"
by (cut_tac k = k and m = m and n = 1 in mult_le_cancel1, auto)

lemma Ord_eq_iff_le: "[| Ord(m); Ord(n) |] ==> m=n \<longleftrightarrow> (m \<le> n & n \<le> m)"
by (blast intro: le_anti_sym)

lemma mult_cancel2_lemma:
     "[| k: nat; m: nat; n: nat |] ==> (m#*k = n#*k) \<longleftrightarrow> (m=n | k=0)"
apply (simp (no_asm_simp) add: Ord_eq_iff_le [of "m#*k"] Ord_eq_iff_le [of m])
apply (auto simp add: Ord_0_lt_iff)
done

lemma mult_cancel2 [simp]:
     "(m#*k = n#*k) \<longleftrightarrow> (natify(m) = natify(n) | natify(k) = 0)"
apply (rule iff_trans)
apply (rule_tac [2] mult_cancel2_lemma, auto)
done

lemma mult_cancel1 [simp]:
     "(k#*m = k#*n) \<longleftrightarrow> (natify(m) = natify(n) | natify(k) = 0)"
apply (simp (no_asm) add: mult_cancel2 mult_commute [of k])
done

(** Cancellation law for division **)

lemma div_cancel_raw:
     "[| 0<n; 0<k; k:nat; m:nat; n:nat |] ==> (k#*m) div (k#*n) = m div n"
apply (erule_tac i = m in complete_induct)
apply (case_tac "x<n")
 apply (simp add: div_less zero_lt_mult_iff mult_lt_mono2)
apply (simp add: not_lt_iff_le zero_lt_mult_iff le_refl [THEN mult_le_mono]
          div_geq diff_mult_distrib2 [symmetric] div_termination [THEN ltD])
done

lemma div_cancel:
     "[| 0 < natify(n);  0 < natify(k) |] ==> (k#*m) div (k#*n) = m div n"
apply (cut_tac k = "natify (k) " and m = "natify (m)" and n = "natify (n)"
       in div_cancel_raw)
apply auto
done

subsection{*More Lemmas about Remainder*}

lemma mult_mod_distrib_raw:
     "[| k:nat; m:nat; n:nat |] ==> (k#*m) mod (k#*n) = k #* (m mod n)"
apply (case_tac "k=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (case_tac "n=0")
 apply (simp add: DIVISION_BY_ZERO_MOD)
apply (simp add: nat_into_Ord [THEN Ord_0_lt_iff])
apply (erule_tac i = m in complete_induct)
apply (case_tac "x<n")
 apply (simp (no_asm_simp) add: mod_less zero_lt_mult_iff mult_lt_mono2)
apply (simp add: not_lt_iff_le zero_lt_mult_iff le_refl [THEN mult_le_mono]
         mod_geq diff_mult_distrib2 [symmetric] div_termination [THEN ltD])
done

lemma mod_mult_distrib2: "k #* (m mod n) = (k#*m) mod (k#*n)"
apply (cut_tac k = "natify (k) " and m = "natify (m)" and n = "natify (n)"
       in mult_mod_distrib_raw)
apply auto
done

lemma mult_mod_distrib: "(m mod n) #* k = (m#*k) mod (n#*k)"
apply (simp (no_asm) add: mult_commute mod_mult_distrib2)
done

lemma mod_add_self2_raw: "n \<in> nat ==> (m #+ n) mod n = m mod n"
apply (subgoal_tac " (n #+ m) mod n = (n #+ m #- n) mod n")
apply (simp add: add_commute)
apply (subst mod_geq [symmetric], auto)
done

lemma mod_add_self2 [simp]: "(m #+ n) mod n = m mod n"
apply (cut_tac n = "natify (n) " in mod_add_self2_raw)
apply auto
done

lemma mod_add_self1 [simp]: "(n#+m) mod n = m mod n"
apply (simp (no_asm_simp) add: add_commute mod_add_self2)
done

lemma mod_mult_self1_raw: "k \<in> nat ==> (m #+ k#*n) mod n = m mod n"
apply (erule nat_induct)
apply (simp_all (no_asm_simp) add: add_left_commute [of _ n])
done

lemma mod_mult_self1 [simp]: "(m #+ k#*n) mod n = m mod n"
apply (cut_tac k = "natify (k) " in mod_mult_self1_raw)
apply auto
done

lemma mod_mult_self2 [simp]: "(m #+ n#*k) mod n = m mod n"
apply (simp (no_asm) add: mult_commute mod_mult_self1)
done

(*Lemma for gcd*)
lemma mult_eq_self_implies_10: "m = m#*n ==> natify(n)=1 | m=0"
apply (subgoal_tac "m: nat")
 prefer 2
 apply (erule ssubst)
 apply simp
apply (rule disjCI)
apply (drule sym)
apply (rule Ord_linear_lt [of "natify(n)" 1])
apply simp_all
 apply (subgoal_tac "m #* n = 0", simp)
 apply (subst mult_natify2 [symmetric])
 apply (simp del: mult_natify2)
apply (drule nat_into_Ord [THEN Ord_0_lt, THEN [2] mult_lt_mono2], auto)
done

lemma less_imp_succ_add [rule_format]:
     "[| m<n; n: nat |] ==> \<exists>k\<in>nat. n = succ(m#+k)"
apply (frule lt_nat_in_nat, assumption)
apply (erule rev_mp)
apply (induct_tac "n")
apply (simp_all (no_asm) add: le_iff)
apply (blast elim!: leE intro!: add_0_right [symmetric] add_succ_right [symmetric])
done

lemma less_iff_succ_add:
     "[| m: nat; n: nat |] ==> (m<n) \<longleftrightarrow> (\<exists>k\<in>nat. n = succ(m#+k))"
by (auto intro: less_imp_succ_add)

lemma add_lt_elim2:
     "\<lbrakk>a #+ d = b #+ c; a < b; b \<in> nat; c \<in> nat; d \<in> nat\<rbrakk> \<Longrightarrow> c < d"
by (drule less_imp_succ_add, auto)

lemma add_le_elim2:
     "\<lbrakk>a #+ d = b #+ c; a \<le> b; b \<in> nat; c \<in> nat; d \<in> nat\<rbrakk> \<Longrightarrow> c \<le> d"
by (drule less_imp_succ_add, auto)

subsubsection{*More Lemmas About Difference*}

lemma diff_is_0_lemma:
     "[| m: nat; n: nat |] ==> m #- n = 0 \<longleftrightarrow> m \<le> n"
apply (rule_tac m = m and n = n in diff_induct, simp_all)
done

lemma diff_is_0_iff: "m #- n = 0 \<longleftrightarrow> natify(m) \<le> natify(n)"
by (simp add: diff_is_0_lemma [symmetric])

lemma nat_lt_imp_diff_eq_0:
     "[| a:nat; b:nat; a<b |] ==> a #- b = 0"
by (simp add: diff_is_0_iff le_iff)

lemma raw_nat_diff_split:
     "[| a:nat; b:nat |] ==>
      (P(a #- b)) \<longleftrightarrow> ((a < b \<longrightarrow>P(0)) & (\<forall>d\<in>nat. a = b #+ d \<longrightarrow> P(d)))"
apply (case_tac "a < b")
 apply (force simp add: nat_lt_imp_diff_eq_0)
apply (rule iffI, force, simp)
apply (drule_tac x="a#-b" in bspec)
apply (simp_all add: Ordinal.not_lt_iff_le add_diff_inverse)
done

lemma nat_diff_split:
   "(P(a #- b)) \<longleftrightarrow>
    (natify(a) < natify(b) \<longrightarrow>P(0)) & (\<forall>d\<in>nat. natify(a) = b #+ d \<longrightarrow> P(d))"
apply (cut_tac P=P and a="natify(a)" and b="natify(b)" in raw_nat_diff_split)
apply simp_all
done

text{*Difference and less-than*}

lemma diff_lt_imp_lt: "[|(k#-i) < (k#-j); i\<in>nat; j\<in>nat; k\<in>nat|] ==> j<i"
apply (erule rev_mp)
apply (simp split add: nat_diff_split, auto)
 apply (blast intro: add_le_self lt_trans1)
apply (rule not_le_iff_lt [THEN iffD1], auto)
apply (subgoal_tac "i #+ da < j #+ d", force)
apply (blast intro: add_le_lt_mono)
done

lemma lt_imp_diff_lt: "[|j<i; i\<le>k; k\<in>nat|] ==> (k#-i) < (k#-j)"
apply (frule le_in_nat, assumption)
apply (frule lt_nat_in_nat, assumption)
apply (simp split add: nat_diff_split, auto)
  apply (blast intro: lt_asym lt_trans2)
 apply (blast intro: lt_irrefl lt_trans2)
apply (rule not_le_iff_lt [THEN iffD1], auto)
apply (subgoal_tac "j #+ d < i #+ da", force)
apply (blast intro: add_lt_le_mono)
done

lemma diff_lt_iff_lt: "[|i\<le>k; j\<in>nat; k\<in>nat|] ==> (k#-i) < (k#-j) \<longleftrightarrow> j<i"
apply (frule le_in_nat, assumption)
apply (blast intro: lt_imp_diff_lt diff_lt_imp_lt)
done

end


(*  Title:      HOL/Algebra/Generated_Groups.thy
    Author:     Paulo Emílio de Vilhena
*)

section \<open>Generated Groups\<close>

theory Generated_Groups
  imports Group Coset

begin

subsection \<open>Generated Groups\<close>

inductive_set generate :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set"
  for G and H where
    one:  "\<one>\<^bsub>G\<^esub> \<in> generate G H"
  | incl: "h \<in> H \<Longrightarrow> h \<in> generate G H"
  | inv:  "h \<in> H \<Longrightarrow> inv\<^bsub>G\<^esub> h \<in> generate G H"
  | eng:  "h1 \<in> generate G H \<Longrightarrow> h2 \<in> generate G H \<Longrightarrow> h1 \<otimes>\<^bsub>G\<^esub> h2 \<in> generate G H"

subsubsection \<open>Basic Properties\<close>

lemma (in group) generate_consistent:
  assumes "K \<subseteq> H" "subgroup H G" shows "generate (G \<lparr> carrier := H \<rparr>) K = generate G K"
proof
  show "generate (G \<lparr> carrier := H \<rparr>) K \<subseteq> generate G K"
  proof
    fix h assume "h \<in> generate (G \<lparr> carrier := H \<rparr>) K" thus "h \<in> generate G K"
    proof (induction, simp add: one, simp_all add: incl[of _ K G] eng)
      case inv thus ?case
        using m_inv_consistent assms generate.inv[of _ K G] by auto
    qed
  qed
next
  show "generate G K \<subseteq> generate (G \<lparr> carrier := H \<rparr>) K"
  proof
    note gen_simps = one incl eng
    fix h assume "h \<in> generate G K" thus "h \<in> generate (G \<lparr> carrier := H \<rparr>) K"
      using gen_simps[where ?G = "G \<lparr> carrier := H \<rparr>"]
    proof (induction, auto)
      fix h assume "h \<in> K" thus "inv h \<in> generate (G \<lparr> carrier := H \<rparr>) K"
        using m_inv_consistent assms generate.inv[of h K "G \<lparr> carrier := H \<rparr>"] by auto
    qed
  qed
qed

lemma (in group) generate_in_carrier:
  assumes "H \<subseteq> carrier G" and "h \<in> generate G H" shows "h \<in> carrier G"
  using assms(2,1) by (induct h rule: generate.induct) (auto)

lemma (in group) generate_incl:
  assumes "H \<subseteq> carrier G" shows "generate G H \<subseteq> carrier G"
  using generate_in_carrier[OF assms(1)] by auto

lemma (in group) generate_m_inv_closed:
  assumes "H \<subseteq> carrier G" and "h \<in> generate G H" shows "(inv h) \<in> generate G H"
  using assms(2,1)
proof (induction rule: generate.induct, auto simp add: one inv incl)
  fix h1 h2
  assume h1: "h1 \<in> generate G H" "inv h1 \<in> generate G H"
     and h2: "h2 \<in> generate G H" "inv h2 \<in> generate G H"
  hence "inv (h1 \<otimes> h2) = (inv h2) \<otimes> (inv h1)"
    by (meson assms generate_in_carrier group.inv_mult_group is_group)
  thus "inv (h1 \<otimes> h2) \<in> generate G H"
    using generate.eng[OF h2(2) h1(2)] by simp
qed

lemma (in group) generate_is_subgroup:
  assumes "H \<subseteq> carrier G" shows "subgroup (generate G H) G"
  using subgroup.intro[OF generate_incl eng one generate_m_inv_closed] assms by auto

lemma (in group) mono_generate:
  assumes "K \<subseteq> H" shows "generate G K \<subseteq> generate G H"
proof
  fix h assume "h \<in> generate G K" thus "h \<in> generate G H"
    using assms by (induction) (auto simp add: one incl inv eng)
qed

lemma (in group) generate_subgroup_incl:
  assumes "K \<subseteq> H" "subgroup H G" shows "generate G K \<subseteq> H"
  using group.generate_incl[OF subgroup_imp_group[OF assms(2)], of K] assms(1)
  by (simp add: generate_consistent[OF assms])

lemma (in group) generate_minimal:
  assumes "H \<subseteq> carrier G" shows "generate G H = \<Inter> { H'. subgroup H' G \<and> H \<subseteq> H' }"
  using generate_subgroup_incl generate_is_subgroup[OF assms] incl[of _ H] by blast

lemma (in group) generateI:
  assumes "subgroup E G" "H \<subseteq> E" and "\<And>K. \<lbrakk> subgroup K G; H \<subseteq> K \<rbrakk> \<Longrightarrow> E \<subseteq> K"
  shows "E = generate G H"
proof -
  have subset: "H \<subseteq> carrier G"
    using subgroup.subset assms by auto
  show ?thesis
    using assms unfolding generate_minimal[OF subset] by blast
qed

lemma (in group) normal_generateI:
  assumes "H \<subseteq> carrier G" and "\<And>h g. \<lbrakk> h \<in> H; g \<in> carrier G \<rbrakk> \<Longrightarrow> g \<otimes> h \<otimes> (inv g) \<in> H"
  shows "generate G H \<lhd> G"
proof (rule normal_invI[OF generate_is_subgroup[OF assms(1)]])
  fix g h assume g: "g \<in> carrier G" show "h \<in> generate G H \<Longrightarrow> g \<otimes> h \<otimes> (inv g) \<in> generate G H"
  proof (induct h rule: generate.induct)
    case one thus ?case
      using g generate.one by auto
  next
    case incl show ?case
      using generate.incl[OF assms(2)[OF incl g]] .
  next
    case (inv h)
    hence h: "h \<in> carrier G"
      using assms(1) by auto
    hence "inv (g \<otimes> h \<otimes> (inv g)) = g \<otimes> (inv h) \<otimes> (inv g)"
      using g by (simp add: inv_mult_group m_assoc)
    thus ?case
      using generate_m_inv_closed[OF assms(1) generate.incl[OF assms(2)[OF inv g]]] by simp
  next
    case (eng h1 h2)
    note in_carrier = eng(1,3)[THEN generate_in_carrier[OF assms(1)]]
    have "g \<otimes> (h1 \<otimes> h2) \<otimes> inv g = (g \<otimes> h1 \<otimes> inv g) \<otimes> (g \<otimes> h2 \<otimes> inv g)"
      using in_carrier g by (simp add: inv_solve_left m_assoc)
    thus ?case
      using generate.eng[OF eng(2,4)] by simp
  qed
qed

lemma (in group) subgroup_int_pow_closed:
  assumes "subgroup H G" "h \<in> H" shows "h [^] (k :: int) \<in> H"
  using group.int_pow_closed[OF subgroup_imp_group[OF assms(1)]] assms(2)
  unfolding int_pow_consistent[OF assms] by simp

lemma (in group) generate_pow:
  assumes "a \<in> carrier G" shows "generate G { a } = { a [^] (k :: int) | k. k \<in> UNIV }"
proof
  show "{ a [^] (k :: int) | k. k \<in> UNIV } \<subseteq> generate G { a }"
    using subgroup_int_pow_closed[OF generate_is_subgroup[of "{ a }"] incl[of a]] assms by auto
next
  show "generate G { a } \<subseteq> { a [^] (k :: int) | k. k \<in> UNIV }"
  proof
    fix h assume "h \<in> generate G { a }" hence "\<exists>k :: int. h = a [^] k"
    proof (induction)
      case one
      then show ?case
        using int_pow_0 [of G] by metis
    next
      case (incl h)
      then show ?case
        by (metis assms int_pow_1 singletonD)
    next
      case (inv h)
      then show ?case
        by (metis assms int_pow_1 int_pow_neg singletonD)
    next
      case (eng h1 h2)
      then show ?case
        using assms by (metis int_pow_mult)
    qed
    then show "h \<in> { a [^] (k :: int) | k. k \<in> UNIV }"
      by blast
  qed
qed

corollary (in group) generate_one: "generate G { \<one> } = { \<one> }"
  using generate_pow[of "\<one>", OF one_closed] by simp

corollary (in group) generate_empty: "generate G {} = { \<one> }"
  using mono_generate[of "{}" "{ \<one> }"] generate.one unfolding generate_one by auto

lemma (in group_hom)
  "subgroup K G \<Longrightarrow> subgroup (h ` K) H"
  using subgroup_img_is_subgroup by auto

lemma (in group_hom) generate_img:
  assumes "K \<subseteq> carrier G" shows "generate H (h ` K) = h ` (generate G K)"
proof
  have "h ` K \<subseteq> h ` (generate G K)"
    using incl[of _ K G] by auto
  thus "generate H (h ` K) \<subseteq> h ` (generate G K)"
    using generate_subgroup_incl subgroup_img_is_subgroup[OF G.generate_is_subgroup[OF assms]] by auto
next
  show "h ` (generate G K) \<subseteq> generate H (h ` K)"
  proof
    fix a assume "a \<in> h ` (generate G K)"
    then obtain k where "k \<in> generate G K" "a = h k"
      by blast
    show "a \<in> generate H (h ` K)"
      using \<open>k \<in> generate G K\<close> unfolding \<open>a = h k\<close>
    proof (induct k, auto simp add: generate.one[of H] generate.incl[of _ "h ` K" H])
      case (inv k) show ?case
        using assms generate.inv[of "h k" "h ` K" H] inv by auto
    next
      case eng show ?case
        using generate.eng[OF eng(2,4)] eng(1,3)[THEN G.generate_in_carrier[OF assms]] by auto
    qed
  qed
qed

subsection \<open>Derived Subgroup\<close>

subsubsection \<open>Definitions\<close>

abbreviation derived_set :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "derived_set G H \<equiv>
           \<Union>h1 \<in> H. (\<Union>h2 \<in> H. { h1 \<otimes>\<^bsub>G\<^esub> h2 \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> h1) \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> h2) })"

definition derived :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "derived G H = generate G (derived_set G H)"

subsubsection \<open>Basic Properties\<close>

lemma (in group) derived_set_incl:
  assumes "K \<subseteq> H" "subgroup H G" shows "derived_set G K \<subseteq> H"
  using assms(1) subgroupE(3-4)[OF assms(2)] by (auto simp add: subset_iff)

lemma (in group) derived_incl:
  assumes "K \<subseteq> H" "subgroup H G" shows "derived G K \<subseteq> H"
  using generate_subgroup_incl[OF derived_set_incl] assms unfolding derived_def by auto

lemma (in group) derived_set_in_carrier:
  assumes "H \<subseteq> carrier G" shows "derived_set G H \<subseteq> carrier G"
  using derived_set_incl[OF assms subgroup_self] .

lemma (in group) derived_in_carrier:
  assumes "H \<subseteq> carrier G" shows "derived G H \<subseteq> carrier G"
  using derived_incl[OF assms subgroup_self] .

lemma (in group) exp_of_derived_in_carrier:
  assumes "H \<subseteq> carrier G" shows "(derived G ^^ n) H \<subseteq> carrier G"
  using assms derived_in_carrier by (induct n) (auto)

lemma (in group) derived_is_subgroup:
  assumes "H \<subseteq> carrier G" shows "subgroup (derived G H) G"
  unfolding derived_def using generate_is_subgroup[OF derived_set_in_carrier[OF assms]] .

lemma (in group) exp_of_derived_is_subgroup:
  assumes "subgroup H G" shows "subgroup ((derived G ^^ n) H) G"
  using assms derived_is_subgroup subgroup.subset by (induct n) (auto)

lemma (in group) exp_of_derived_is_subgroup':
  assumes "H \<subseteq> carrier G" shows "subgroup ((derived G ^^ (Suc n)) H) G"
  using assms derived_is_subgroup[OF subgroup.subset] derived_is_subgroup by (induct n) (auto)

lemma (in group) mono_derived_set:
  assumes "K \<subseteq> H" shows "derived_set G K \<subseteq> derived_set G H"
  using assms by auto

lemma (in group) mono_derived:
  assumes "K \<subseteq> H" shows "derived G K \<subseteq> derived G H"
  unfolding derived_def using mono_generate[OF mono_derived_set[OF assms]] .

lemma (in group) mono_exp_of_derived:
  assumes "K \<subseteq> H" shows "(derived G ^^ n) K \<subseteq> (derived G ^^ n) H"
  using assms mono_derived by (induct n) (auto)

lemma (in group) derived_set_consistent:
  assumes "K \<subseteq> H" "subgroup H G" shows "derived_set (G \<lparr> carrier := H \<rparr>) K = derived_set G K"
  using m_inv_consistent[OF assms(2)] assms(1) by (auto simp add: subset_iff)

lemma (in group) derived_consistent:
  assumes "K \<subseteq> H" "subgroup H G" shows "derived (G \<lparr> carrier := H \<rparr>) K = derived G K"
  using generate_consistent[OF derived_set_incl] derived_set_consistent assms by (simp add: derived_def)

lemma (in comm_group) derived_eq_singleton:
  assumes "H \<subseteq> carrier G" shows "derived G H = { \<one> }"
proof (cases "derived_set G H = {}")
  case True show ?thesis
    using generate_empty unfolding derived_def True by simp
next
  case False
  have aux_lemma: "h \<in> derived_set G H \<Longrightarrow> h = \<one>" for h
    using assms by (auto simp add: subset_iff)
       (metis (no_types, lifting) m_comm m_closed inv_closed inv_solve_right l_inv l_inv_ex)
  have "derived_set G H = { \<one> }"
  proof
    show "derived_set G H \<subseteq> { \<one> }"
      using aux_lemma by auto
  next
    obtain h where h: "h \<in> derived_set G H"
      using False by blast
    thus "{ \<one> } \<subseteq> derived_set G H"
      using aux_lemma[OF h] by auto
  qed
  thus ?thesis
    using generate_one unfolding derived_def by auto
qed

lemma (in group) derived_is_normal:
  assumes "H \<lhd> G" shows "derived G H \<lhd> G"
proof -
  interpret H: normal H G
    using assms .

  show ?thesis
    unfolding derived_def
  proof (rule normal_generateI[OF derived_set_in_carrier[OF H.subset]])
    fix h g assume "h \<in> derived_set G H" and g: "g \<in> carrier G"
    then obtain h1 h2 where h: "h1 \<in> H" "h2 \<in> H" "h = h1 \<otimes> h2 \<otimes> inv h1 \<otimes> inv h2"
      by auto
    hence in_carrier: "h1 \<in> carrier G" "h2 \<in> carrier G" "g \<in> carrier G"
      using H.subset g by auto
    have "g \<otimes> h \<otimes> inv g =
           g \<otimes> h1 \<otimes> (inv g \<otimes> g) \<otimes> h2 \<otimes> (inv g \<otimes> g) \<otimes> inv h1 \<otimes> (inv g \<otimes> g) \<otimes> inv h2 \<otimes> inv g"
      unfolding h(3) by (simp add: in_carrier m_assoc)
    also have " ... =
          (g \<otimes> h1 \<otimes> inv g) \<otimes> (g \<otimes> h2 \<otimes> inv g) \<otimes> (g \<otimes> inv h1 \<otimes> inv g) \<otimes> (g \<otimes> inv h2 \<otimes> inv g)"
      using in_carrier m_assoc inv_closed m_closed by presburger
    finally have "g \<otimes> h \<otimes> inv g =
          (g \<otimes> h1 \<otimes> inv g) \<otimes> (g \<otimes> h2 \<otimes> inv g) \<otimes> inv (g \<otimes> h1 \<otimes> inv g) \<otimes> inv (g \<otimes> h2 \<otimes> inv g)"
      by (simp add: in_carrier inv_mult_group m_assoc)
    thus "g \<otimes> h \<otimes> inv g \<in> derived_set G H"
      using h(1-2)[THEN H.inv_op_closed2[OF g]] by auto
  qed
qed

lemma (in group) normal_self: "carrier G \<lhd> G"
  by (rule normal_invI[OF subgroup_self], simp)

corollary (in group) derived_self_is_normal: "derived G (carrier G) \<lhd> G"
  using derived_is_normal[OF normal_self] .

corollary (in group) derived_subgroup_is_normal:
  assumes "subgroup H G" shows "derived G H \<lhd> G \<lparr> carrier := H \<rparr>"
  using group.derived_self_is_normal[OF subgroup_imp_group[OF assms]]
        derived_consistent[OF _ assms]
  by simp

corollary (in group) derived_quot_is_group: "group (G Mod (derived G (carrier G)))"
  using normal.factorgroup_is_group[OF derived_self_is_normal] by auto

lemma (in group) derived_quot_is_comm_group: "comm_group (G Mod (derived G (carrier G)))"
proof (rule group.group_comm_groupI[OF derived_quot_is_group], simp add: FactGroup_def)
  interpret DG: normal "derived G (carrier G)" G
    using derived_self_is_normal .

  fix H K assume "H \<in> rcosets derived G (carrier G)" and "K \<in> rcosets derived G (carrier G)"
  then obtain g1 g2
    where g1: "g1 \<in> carrier G" "H = derived G (carrier G) #> g1"
      and g2: "g2 \<in> carrier G" "K = derived G (carrier G) #> g2"
    unfolding RCOSETS_def by auto
  hence "H <#> K = derived G (carrier G) #> (g1 \<otimes> g2)"
    by (simp add: DG.rcos_sum)
  also have " ... = derived G (carrier G) #> (g2 \<otimes> g1)"
  proof -
    { fix g1 g2 assume g1: "g1 \<in> carrier G" and g2: "g2 \<in> carrier G"
      have "derived G (carrier G) #> (g1 \<otimes> g2) \<subseteq> derived G (carrier G) #> (g2 \<otimes> g1)"
      proof
        fix h assume "h \<in> derived G (carrier G) #> (g1 \<otimes> g2)"
        then obtain g' where h: "g' \<in> carrier G" "g' \<in> derived G (carrier G)" "h = g' \<otimes> (g1 \<otimes> g2)"
          using DG.subset unfolding r_coset_def by auto
        hence "h = g' \<otimes> (g1 \<otimes> g2) \<otimes> (inv g1 \<otimes> inv g2 \<otimes> g2 \<otimes> g1)"
          using g1 g2 by (simp add: m_assoc)
        hence "h = (g' \<otimes> (g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2)) \<otimes> (g2 \<otimes> g1)"
          using h(1) g1 g2 inv_closed m_assoc m_closed by presburger
        moreover have "g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2 \<in> derived G (carrier G)"
          using incl[of _ "derived_set G (carrier G)"] g1 g2 unfolding derived_def by blast
        hence "g' \<otimes> (g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2) \<in> derived G (carrier G)"
          using DG.m_closed[OF h(2)] by simp
        ultimately show "h \<in> derived G (carrier G) #> (g2 \<otimes> g1)"
          unfolding r_coset_def by blast
      qed }
    thus ?thesis
      using g1(1) g2(1) by auto
  qed
  also have " ... = K <#> H"
    by (simp add: g1 g2 DG.rcos_sum)
  finally show "H <#> K = K <#> H" .
qed

corollary (in group) derived_quot_of_subgroup_is_comm_group:
  assumes "subgroup H G" shows "comm_group ((G \<lparr> carrier := H \<rparr>) Mod (derived G H))"
  using group.derived_quot_is_comm_group[OF subgroup_imp_group[OF assms]]
        derived_consistent[OF _ assms]
  by simp

proposition (in group) derived_minimal:
  assumes "H \<lhd> G" and "comm_group (G Mod H)" shows "derived G (carrier G) \<subseteq> H"
proof -
  interpret H: normal H G
    using assms(1) .

  show ?thesis
    unfolding derived_def
  proof (rule generate_subgroup_incl[OF _ H.subgroup_axioms])
    show "derived_set G (carrier G) \<subseteq> H"
    proof
      fix h assume "h \<in> derived_set G (carrier G)"
      then obtain g1 g2 where h: "g1 \<in> carrier G" "g2 \<in> carrier G" "h = g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2"
        by auto
      have "H #> (g1 \<otimes> g2) = (H #> g1) <#> (H #> g2)"
        by (simp add: h(1-2) H.rcos_sum)
      also have " ... = (H #> g2) <#> (H #> g1)"
        using comm_groupE(4)[OF assms(2)] h(1-2) unfolding FactGroup_def RCOSETS_def by auto
      also have " ... = H #> (g2 \<otimes> g1)"
        by (simp add: h(1-2) H.rcos_sum)
      finally have "H #> (g1 \<otimes> g2) = H #> (g2 \<otimes> g1)" .
      then obtain h' where "h' \<in> H" "\<one> \<otimes> (g1 \<otimes> g2) = h' \<otimes> (g2 \<otimes> g1)"
        using H.one_closed unfolding r_coset_def by blast
      thus "h \<in> H"
        using h m_assoc by auto
    qed
  qed
qed

proposition (in group) derived_of_subgroup_minimal:
  assumes "K \<lhd> G \<lparr> carrier := H \<rparr>" "subgroup H G" and "comm_group ((G \<lparr> carrier := H \<rparr>) Mod K)"
  shows "derived G H \<subseteq> K"
  using group.derived_minimal[OF subgroup_imp_group[OF assms(2)] assms(1,3)]
        derived_consistent[OF _ assms(2)]
  by simp

lemma (in group_hom) derived_img:
  assumes "K \<subseteq> carrier G" shows "derived H (h ` K) = h ` (derived G K)"
proof -
  have "derived_set H (h ` K) = h ` (derived_set G K)"
  proof
    show "derived_set H (h ` K) \<subseteq> h ` derived_set G K"
    proof
      fix a assume "a \<in> derived_set H (h ` K)"
      then obtain k1 k2
        where "k1 \<in> K" "k2 \<in> K" "a = (h k1) \<otimes>\<^bsub>H\<^esub> (h k2) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k1) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k2)"
        by auto
      hence "a = h (k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2)"
        using assms by (simp add: subset_iff)
      from this \<open>k1 \<in> K\<close> and \<open>k2 \<in> K\<close> show "a \<in> h ` derived_set G K" by auto
    qed
  next
    show "h ` (derived_set G K) \<subseteq> derived_set H (h ` K)"
    proof
      fix a assume "a \<in> h ` (derived_set G K)"
      then obtain k1 k2 where "k1 \<in> K" "k2 \<in> K" "a = h (k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2)"
        by auto
      hence "a = (h k1) \<otimes>\<^bsub>H\<^esub> (h k2) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k1) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k2)"
        using assms by (simp add: subset_iff)
      from this \<open>k1 \<in> K\<close> and \<open>k2 \<in> K\<close> show "a \<in> derived_set H (h ` K)" by auto
    qed
  qed
  thus ?thesis
    unfolding derived_def using generate_img[OF G.derived_set_in_carrier[OF assms]] by simp
qed

lemma (in group_hom) exp_of_derived_img:
  assumes "K \<subseteq> carrier G" shows "(derived H ^^ n) (h ` K) = h ` ((derived G ^^ n) K)"
  using derived_img[OF G.exp_of_derived_in_carrier[OF assms]] by (induct n) (auto)

subsubsection \<open>Generated subgroup of a group\<close>

definition subgroup_generated :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> ('a, 'b) monoid_scheme"
  where "subgroup_generated G S = G\<lparr>carrier := generate G (carrier G \<inter> S)\<rparr>"

lemma carrier_subgroup_generated: "carrier (subgroup_generated G S) = generate G (carrier G \<inter> S)"
  by (auto simp: subgroup_generated_def)

lemma (in group) subgroup_generated_subset_carrier_subset:
   "S \<subseteq> carrier G \<Longrightarrow> S \<subseteq> carrier(subgroup_generated G S)"
  by (simp add: Int_absorb1 carrier_subgroup_generated generate.incl subsetI)

lemma (in group) subgroup_generated_minimal:
   "\<lbrakk>subgroup H G; S \<subseteq> H\<rbrakk> \<Longrightarrow> carrier(subgroup_generated G S) \<subseteq> H"
  by (simp add: carrier_subgroup_generated generate_subgroup_incl le_infI2)

lemma (in group) carrier_subgroup_generated_subset:
   "carrier (subgroup_generated G A) \<subseteq> carrier G"
  apply (clarsimp simp: carrier_subgroup_generated)
  by (meson Int_lower1 generate_in_carrier)

lemma (in group) group_subgroup_generated [simp]: "group (subgroup_generated G S)"
    unfolding subgroup_generated_def
    by (simp add: generate_is_subgroup subgroup_imp_group)

lemma (in group) abelian_subgroup_generated:
  assumes "comm_group G"
  shows "comm_group (subgroup_generated G S)" (is "comm_group ?GS")
proof (rule group.group_comm_groupI)
  show "Group.group ?GS"
    by simp
next
  fix x y
  assume "x \<in> carrier ?GS" "y \<in> carrier ?GS"
  with assms show "x \<otimes>\<^bsub>?GS\<^esub> y = y \<otimes>\<^bsub>?GS\<^esub> x"
    apply (simp add: subgroup_generated_def)
    by (meson Int_lower1 comm_groupE(4) generate_in_carrier)
qed

lemma (in group) subgroup_of_subgroup_generated:
  assumes "H \<subseteq> B" "subgroup H G"
    shows "subgroup H (subgroup_generated G B)"
proof unfold_locales
  fix x
  assume "x \<in> H"
  with assms show "inv\<^bsub>subgroup_generated G B\<^esub> x \<in> H"
    unfolding subgroup_generated_def
    by (metis IntI Int_commute Int_lower2 generate.incl generate_is_subgroup m_inv_consistent subgroup_def subsetCE)
next
  show "H \<subseteq> carrier (subgroup_generated G B)"
    using assms apply (auto simp: carrier_subgroup_generated)
    by (metis Int_iff generate.incl inf.orderE subgroup.mem_carrier)
qed (use assms in \<open>auto simp: subgroup_generated_def subgroup_def\<close>)

lemma carrier_subgroup_generated_alt:
  assumes "Group.group G" "S \<subseteq> carrier G"
  shows "carrier (subgroup_generated G S) = \<Inter>{H. subgroup H G \<and> carrier G \<inter> S \<subseteq> H}"
  using assms by (auto simp: group.generate_minimal subgroup_generated_def)

lemma one_subgroup_generated [simp]: "\<one>\<^bsub>subgroup_generated G S\<^esub> = \<one>\<^bsub>G\<^esub>"
  by (auto simp: subgroup_generated_def)

lemma mult_subgroup_generated [simp]: "mult (subgroup_generated G S) = mult G"
  by (auto simp: subgroup_generated_def)

lemma (in group) inv_subgroup_generated [simp]:
  assumes "f \<in> carrier (subgroup_generated G S)"
  shows "inv\<^bsub>subgroup_generated G S\<^esub> f = inv f"
proof (rule group.inv_equality)
  show "Group.group (subgroup_generated G S)"
    by simp
  have [simp]: "f \<in> carrier G"
    by (metis Int_lower1 assms carrier_subgroup_generated generate_in_carrier)
  show "inv f \<otimes>\<^bsub>subgroup_generated G S\<^esub> f = \<one>\<^bsub>subgroup_generated G S\<^esub>"
    by (simp add: assms)
  show "f \<in> carrier (subgroup_generated G S)"
    using assms by (simp add: generate.incl subgroup_generated_def)
  show "inv f \<in> carrier (subgroup_generated G S)"
    using assms by (simp add: subgroup_generated_def generate_m_inv_closed)
qed

lemma subgroup_generated_restrict [simp]:
   "subgroup_generated G (carrier G \<inter> S) = subgroup_generated G S"
  by (simp add: subgroup_generated_def)

lemma (in subgroup) carrier_subgroup_generated_subgroup [simp]:
  "carrier (subgroup_generated G H) = H"
  by (auto simp: generate.incl carrier_subgroup_generated elim: generate.induct)

lemma (in group) subgroup_subgroup_generated_iff:
   "subgroup H (subgroup_generated G B) \<longleftrightarrow> subgroup H G \<and> H \<subseteq> carrier(subgroup_generated G B)"
 (is "?lhs = ?rhs")
proof
  assume L: ?lhs
  then have Hsub: "H \<subseteq> generate G (carrier G \<inter> B)"
    by (simp add: subgroup_def subgroup_generated_def)
  then have H: "H \<subseteq> carrier G" "H \<subseteq> carrier(subgroup_generated G B)"
    unfolding carrier_subgroup_generated
    using generate_incl by blast+
  with Hsub have "subgroup H G"
    by (metis Int_commute Int_lower2 L carrier_subgroup_generated generate_consistent
        generate_is_subgroup inf.orderE subgroup.carrier_subgroup_generated_subgroup subgroup_generated_def)
  with H show ?rhs
    by blast
next
  assume ?rhs
  then show ?lhs
    by (simp add: generate_is_subgroup subgroup_generated_def subgroup_incl)
qed

lemma (in group) subgroup_subgroup_generated:
   "subgroup (carrier(subgroup_generated G S)) G"
  using group.subgroup_self group_subgroup_generated subgroup_subgroup_generated_iff by blast

lemma pow_subgroup_generated:
   "pow (subgroup_generated G S) = (pow G :: 'a \<Rightarrow> nat \<Rightarrow> 'a)"
proof -
  have "x [^]\<^bsub>subgroup_generated G S\<^esub> n = x [^]\<^bsub>G\<^esub> n" for x and n::nat
    by (induction n) auto
  then show ?thesis
    by force
qed

lemma (in group) subgroup_generated2 [simp]: "subgroup_generated (subgroup_generated G S) S = subgroup_generated G S"
proof -
  have *: "\<And>A. carrier G \<inter> A \<subseteq> carrier (subgroup_generated (subgroup_generated G A) A)"
    by (metis (no_types, opaque_lifting) Int_assoc carrier_subgroup_generated generate.incl inf.order_iff subset_iff)
  show ?thesis
  apply (auto intro!: monoid.equality)
    using group.carrier_subgroup_generated_subset group_subgroup_generated apply blast
     apply (metis (no_types, opaque_lifting) "*" group.subgroup_subgroup_generated group_subgroup_generated subgroup_generated_minimal
        subgroup_generated_restrict subgroup_subgroup_generated_iff subset_eq)
    apply (simp add: subgroup_generated_def)
    done
qed

lemma (in group) int_pow_subgroup_generated:
  fixes n::int
  assumes "x \<in> carrier (subgroup_generated G S)"
  shows "x [^]\<^bsub>subgroup_generated G S\<^esub> n = x [^]\<^bsub>G\<^esub> n"
proof -
  have "x [^] nat (- n) \<in> carrier (subgroup_generated G S)"
    by (metis assms group.is_monoid group_subgroup_generated monoid.nat_pow_closed pow_subgroup_generated)
  then show ?thesis
    by (metis group.inv_subgroup_generated int_pow_def2 is_group pow_subgroup_generated)
qed

lemma kernel_from_subgroup_generated [simp]:
  "subgroup S G \<Longrightarrow> kernel (subgroup_generated G S) H f = kernel G H f \<inter> S"
  using subgroup.carrier_subgroup_generated_subgroup subgroup.subset
  by (fastforce simp add: kernel_def set_eq_iff)

lemma kernel_to_subgroup_generated [simp]:
  "kernel G (subgroup_generated H S) f = kernel G H f"
  by (simp add: kernel_def)

subsection \<open>And homomorphisms\<close>

lemma (in group) hom_from_subgroup_generated:
   "h \<in> hom G H \<Longrightarrow> h \<in> hom(subgroup_generated G A) H"
  apply (simp add: hom_def carrier_subgroup_generated Pi_iff)
  apply (metis group.generate_in_carrier inf_le1 is_group)
  done

lemma hom_into_subgroup:
   "\<lbrakk>h \<in> hom G G'; h ` (carrier G) \<subseteq> H\<rbrakk> \<Longrightarrow> h \<in> hom G (subgroup_generated G' H)"
  by (auto simp: hom_def carrier_subgroup_generated Pi_iff generate.incl image_subset_iff)

lemma hom_into_subgroup_eq_gen:
    "group G \<Longrightarrow>
     h \<in> hom K (subgroup_generated G H)
 \<longleftrightarrow> h \<in> hom K G \<and> h ` (carrier K) \<subseteq> carrier(subgroup_generated G H)"
  using group.carrier_subgroup_generated_subset [of G H] by (auto simp: hom_def)

lemma hom_into_subgroup_eq:
   "\<lbrakk>subgroup H G; group G\<rbrakk>
    \<Longrightarrow> (h \<in> hom K (subgroup_generated G H) \<longleftrightarrow> h \<in> hom K G \<and> h ` (carrier K) \<subseteq> H)"
  by (simp add: hom_into_subgroup_eq_gen image_subset_iff subgroup.carrier_subgroup_generated_subgroup)

lemma (in group_hom) hom_between_subgroups:
  assumes "h ` A \<subseteq> B"
  shows "h \<in> hom (subgroup_generated G A) (subgroup_generated H B)"
proof -
  have [simp]: "group G" "group H"
    by (simp_all add: G.is_group H.is_group)
  have "x \<in> generate G (carrier G \<inter> A) \<Longrightarrow> h x \<in> generate H (carrier H \<inter> B)" for x
  proof (induction x rule: generate.induct)
    case (incl h)
    then show ?case
      by (meson IntE IntI assms generate.incl hom_closed image_subset_iff)
  next
    case (inv h)
    then show ?case
      by (metis G.inv_closed G.inv_inv IntE IntI assms generate.simps hom_inv image_subset_iff local.inv_closed)
  next
    case (eng h1 h2)
    then show ?case
      by (metis G.generate_in_carrier generate.simps inf.cobounded1 local.hom_mult)
  qed (auto simp: generate.intros)
  then have "h ` carrier (subgroup_generated G A) \<subseteq> carrier (subgroup_generated H B)"
    using group.carrier_subgroup_generated_subset [of G A]
    by (auto simp: carrier_subgroup_generated)
  then show ?thesis
    by (simp add: hom_into_subgroup_eq_gen group.hom_from_subgroup_generated homh)
qed

lemma (in group_hom) subgroup_generated_by_image:
  assumes "S \<subseteq> carrier G"
  shows "carrier (subgroup_generated H (h ` S)) = h ` (carrier(subgroup_generated G S))"
proof
  have "x \<in> generate H (carrier H \<inter> h ` S) \<Longrightarrow> x \<in> h ` generate G (carrier G \<inter> S)" for x
  proof (erule generate.induct)
    show "\<one>\<^bsub>H\<^esub> \<in> h ` generate G (carrier G \<inter> S)"
      using generate.one by force
  next
    fix f
    assume "f \<in> carrier H \<inter> h ` S"
    with assms show "f \<in> h ` generate G (carrier G \<inter> S)" "inv\<^bsub>H\<^esub> f \<in> h ` generate G (carrier G \<inter> S)"
       apply (auto simp: Int_absorb1 generate.incl)
      apply (metis generate.simps hom_inv imageI subsetCE)
      done
  next
    fix h1 h2
    assume
      "h1 \<in> generate H (carrier H \<inter> h ` S)" "h1 \<in> h ` generate G (carrier G \<inter> S)"
      "h2 \<in> generate H (carrier H \<inter> h ` S)" "h2 \<in> h ` generate G (carrier G \<inter> S)"
    then show "h1 \<otimes>\<^bsub>H\<^esub> h2 \<in> h ` generate G (carrier G \<inter> S)"
      using H.subgroupE(4) group.generate_is_subgroup subgroup_img_is_subgroup
      by (simp add: G.generate_is_subgroup)
  qed
  then
  show "carrier (subgroup_generated H (h ` S)) \<subseteq> h ` carrier (subgroup_generated G S)"
    by (auto simp: carrier_subgroup_generated)
next
  have "h ` S \<subseteq> carrier H"
    by (metis (no_types) assms hom_closed image_subset_iff subsetCE)
  then show "h ` carrier (subgroup_generated G S) \<subseteq> carrier (subgroup_generated H (h ` S))"
    apply (clarsimp simp: carrier_subgroup_generated)
    by (metis Int_absorb1 assms generate_img imageI)
qed

lemma (in group_hom) iso_between_subgroups:
  assumes "h \<in> iso G H" "S \<subseteq> carrier G" "h ` S = T"
  shows "h \<in> iso (subgroup_generated G S) (subgroup_generated H T)"
  using assms
  by (metis G.carrier_subgroup_generated_subset Group.iso_iff hom_between_subgroups inj_on_subset subgroup_generated_by_image subsetI)

lemma (in group) subgroup_generated_group_carrier:
  "subgroup_generated G (carrier G) = G"
proof (rule monoid.equality)
  show "carrier (subgroup_generated G (carrier G)) = carrier G"
    by (simp add: subgroup.carrier_subgroup_generated_subgroup subgroup_self)
qed (auto simp: subgroup_generated_def)

lemma iso_onto_image:
  assumes "group G" "group H"
  shows
   "f \<in> iso G (subgroup_generated H (f ` carrier G)) \<longleftrightarrow> f \<in> hom G H \<and> inj_on f (carrier G)"
  using assms
  apply (auto simp: iso_def bij_betw_def hom_into_subgroup_eq_gen carrier_subgroup_generated hom_carrier generate.incl Int_absorb1 Int_absorb2)
  by (metis group.generateI group.subgroupE(1) group.subgroup_self group_hom.generate_img group_hom.intro group_hom_axioms.intro)

lemma (in group) iso_onto_image:
   "group H \<Longrightarrow> f \<in> iso G (subgroup_generated H (f ` carrier G)) \<longleftrightarrow> f \<in> mon G H"
  by (simp add: mon_def epi_def hom_into_subgroup_eq_gen iso_onto_image)

end


section \<open>Relations\<close>

theory Relation_Extensions
imports
  Basic_Extensions
begin

  abbreviation rev_lex_prod (infixr "<*rlex*>" 80)
    where "r\<^sub>1 <*rlex*> r\<^sub>2 \<equiv> inv_image (r\<^sub>2 <*lex*> r\<^sub>1) swap"

  lemmas sym_rtranclp[intro] = sym_rtrancl[to_pred]

  definition liftablep :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool"
    where "liftablep r f \<equiv> \<forall> x y. r x y \<longrightarrow> r (f x) (f y)"

  lemma liftablepI[intro]:
    assumes "\<And> x y. r x y \<Longrightarrow> r (f x) (f y)"
    shows "liftablep r f"
    using assms
    unfolding liftablep_def
    by simp
  lemma liftablepE[elim]:
    assumes "liftablep r f"
    assumes "r x y"
    obtains "r (f x) (f y)"
    using assms
    unfolding liftablep_def
    by simp

  lemma liftablep_rtranclp:
    assumes "liftablep r f"
    shows "liftablep r\<^sup>*\<^sup>* f"
  proof
    fix x y
    assume "r\<^sup>*\<^sup>* x y"
    thus "r\<^sup>*\<^sup>* (f x) (f y)"
      using assms
      by (induct rule: rtranclp_induct, force+)
  qed

  definition confluentp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
    where "confluentp r \<equiv> \<forall> x y1 y2. r\<^sup>*\<^sup>* x y1 \<longrightarrow> r\<^sup>*\<^sup>* x y2 \<longrightarrow> (\<exists> z. r\<^sup>*\<^sup>* y1 z \<and> r\<^sup>*\<^sup>* y2 z)"

  lemma confluentpI[intro]:
    assumes "\<And> x y1 y2. r\<^sup>*\<^sup>* x y1 \<Longrightarrow> r\<^sup>*\<^sup>* x y2 \<Longrightarrow> \<exists> z. r\<^sup>*\<^sup>* y1 z \<and> r\<^sup>*\<^sup>* y2 z"
    shows "confluentp r"
    using assms
    unfolding confluentp_def
    by simp

  lemma confluentpE[elim]:
    assumes "confluentp r"
    assumes "r\<^sup>*\<^sup>* x y1" "r\<^sup>*\<^sup>* x y2"
    obtains z
    where "r\<^sup>*\<^sup>* y1 z" "r\<^sup>*\<^sup>* y2 z"
    using assms
    unfolding confluentp_def
    by blast

  lemma confluentpI'[intro]:
    assumes "\<And> x y1 y2. r\<^sup>*\<^sup>* x y1 \<Longrightarrow> r x y2 \<Longrightarrow> \<exists> z. r\<^sup>*\<^sup>* y1 z \<and> r\<^sup>*\<^sup>* y2 z"
    shows "confluentp r"
  proof
    fix x y1 y2
    assume "r\<^sup>*\<^sup>* x y1" "r\<^sup>*\<^sup>* x y2"
    thus "\<exists> z. r\<^sup>*\<^sup>* y1 z \<and> r\<^sup>*\<^sup>* y2 z" using assms by (induct rule: rtranclp_induct, force+)
  qed

  lemma transclp_eq_implies_confluent_imp:
    assumes "r1\<^sup>*\<^sup>* = r2\<^sup>*\<^sup>*"
    assumes "confluentp r1"
    shows "confluentp r2"
    using assms
    by force

  lemma transclp_eq_implies_confluent_eq:
    assumes "r1\<^sup>*\<^sup>* = r2\<^sup>*\<^sup>*"
    shows "confluentp r1 \<longleftrightarrow> confluentp r2"
    using assms transclp_eq_implies_confluent_imp
    by metis

  definition diamondp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
    where "diamondp r \<equiv> \<forall> x y1 y2. r x y1 \<longrightarrow> r x y2 \<longrightarrow> (\<exists> z. r y1 z \<and> r y2 z)"

  lemma diamondpI[intro]:
    assumes "\<And> x y1 y2. r x y1 \<Longrightarrow> r x y2 \<Longrightarrow> \<exists> z. r y1 z \<and> r y2 z"
    shows "diamondp r"
    using assms
    unfolding diamondp_def
    by simp

  lemma diamondpE[elim]:
    assumes "diamondp r"
    assumes "r x y1" "r x y2"
    obtains z
    where "r y1 z" "r y2 z"
    using assms
    unfolding diamondp_def
    by blast

  lemma diamondp_implies_confluentp:
    assumes "diamondp r"
    shows "confluentp r"
  proof (rule confluentpI')
    fix x y1 y2
    assume "r\<^sup>*\<^sup>* x y1" "r x y2"
    hence "\<exists> z. r y1 z \<and> r\<^sup>*\<^sup>* y2 z" using assms by (induct rule: rtranclp_induct, force+)
    thus "\<exists> z. r\<^sup>*\<^sup>* y1 z \<and> r\<^sup>*\<^sup>* y2 z" by blast
  qed

  locale wellfounded_relation =
    fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
    assumes wellfounded: "wfP R"

end


theory Shweta_FreeGroup
imports Main  "HOL-Library.FuncSet" "HOL-Algebra.Group"
begin

(*From Generators.thy*)
datatype ('a,'b) monoidgentype = C 'a  'b (infix "!" 63)

datatype ('a,'b) groupgentype = P "('a,'b) monoidgentype"
                               | N  "('a,'b) monoidgentype"

type_synonym ('a,'b) word = "(('a,'b) groupgentype) list"

primrec inverse::"('a,'b) groupgentype \<Rightarrow> ('a,'b) groupgentype"
  where
"inverse (P x) = (N x)"
|"inverse (N x) = (P x)"

fun reduction:: "('a,'b) word \<Rightarrow> ('a,'b) word"
 where
"reduction [] = []"
|"reduction [x] = [x]"
|"reduction (g1#g2#wrd) = (if (g1 = inverse g2)
                             then reduction wrd
                             else (g1#(reduction (g2#wrd))))"

fun reduced::"('a,'b) word \<Rightarrow> bool"
  where
"reduced [] = True"
|"reduced [g] = True"
|"reduced (g#h#wrd) = (if (g \<noteq> inverse h) then reduced (h#wrd) else False)"

primrec iter::"nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
  where
"iter 0 f = (\<lambda> x. x)"
|"iter (Suc n) f = (\<lambda> x. f ((iter n f) x))"

lemma length_reduction : "length (reduction wrd) \<le> length wrd"
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case by simp
next
case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then show ?thesis using 3 by force
  next
    case False
    then show ?thesis using 3
    by auto
 qed
qed

lemma decreasing_length:
  assumes "reduction wrd \<noteq> wrd"
  shows "length (reduction wrd) < length wrd"
  using assms
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then have red_inv:"reduction (g1#g2#wrd) = reduction wrd" by auto
    then show ?thesis
    proof(cases "reduction wrd = wrd")
      case True
      then have "reduction (g1#g2#wrd) = wrd" using red_inv by auto
      then have "length (reduction (g1#g2#wrd)) = length wrd" by auto
      then show ?thesis
        by simp
    next
      case False
      then have "length (reduction wrd) < length wrd" using 3 True by argo
      then show ?thesis using red_inv by force
    qed
  next
    case False
    have prem:"reduction (g1#g2#wrd) \<noteq> (g1#g2#wrd)" using 3 by argo
    then have "reduction (g1#g2#wrd) = g1#reduction (g2#wrd)" using False by auto
    then have "reduction (g2#wrd) \<noteq> g2#wrd" using prem by fastforce
    then have "length (g2#wrd) > length (reduction (g2#wrd))" using 3 False by blast
    then have "length (g1#g2#wrd) > length (reduction (g1#g2#wrd))" using False by force
    then show ?thesis by fast
  qed
qed

(*Prove 1. length (reduction (wrd)) = length wrd \<Rightarrow> reduction wrd = wrd*)
lemma assumes "length (reduction (wrd)) = length wrd"
  shows "reduction wrd = wrd"
  using assms
proof(induction wrd rule: reduction.induct)
case 1
  then show ?case
    by simp
next
  case (2 x)
  then show ?case by simp
next
case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 = inverse g2")
    case True
    then have 1: "reduction (g1#g2#wrd) = reduction (wrd)" by simp
    then have "length (reduction (g1#g2#wrd)) = length (reduction (wrd))"
      by auto
    moreover have "length (wrd) > length (reduction wrd)" using  1
    by (metis "3.prems" decreasing_length impossible_Cons nat_le_linear) (*"m \<le> n \<or> n \<le> m", "length xs \<le> length ys \<Longrightarrow> xs = x # ys = False"*)
    then show ?thesis using 3 by auto
  next
    case False
    then show ?thesis
    using  decreasing_length by blast
  qed
qed
(*2.reduction wrd = wrd \<Rightarrow> reduced wrd*)
lemma assumes "reduction wrd = wrd"
  shows "reduced wrd"
  using assms
proof(induction wrd rule:reduction.induct)
case 1
then show ?case by simp
next
case (2 x)
  then show ?case by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof(cases "g1 \<noteq> inverse g2")
    case True
     then show ?thesis using 3 by force
    next
      case False
     have "g1 = inverse g2"using False by auto
     then have "(g1#g2#wrd) = reduction wrd" using 3
       by simp
     moreover then have "length (reduction(wrd)) \<le> length wrd"
       by (simp add: length_reduction)
     moreover then have "length (g1#g2#wrd) > length wrd"
       by simp
     ultimately show ?thesis  by simp
   qed
qed
(*3. lemma assumes length wrd = n shows iter (n+k) reduction = iter n reduction*)
lemma assumes "length wrd = n"
  shows " iter (n+k) reduction = iter n reduction"

  (*if xs@ys is reduced then xs is reduced*)
lemma assumes "reduced (xs@ys)"
  shows "reduced xs"
  using assms
proof (induction xs rule : reduction.induct)
case 1
then show ?case try
  by simp
next
  case (2 x)
  then show ?case try
    by simp
next
  case (3 g1 g2 wrd)
  then show ?case
  proof (cases "g1 =  inverse g2")
    case True
then show ?thesis
  using "3.prems" by force
next
  case False
  have "reduced ((g2 # wrd) @ ys)"
    by (metis "3.prems" append_Cons reduced.simps(3))
  then have "reduced (g2#wrd)"
    using "3.IH"(2) False by auto
  then show ?thesis by (simp add: False)
qed
qed


theory Analysis_More
  imports Ordinary_Differential_Equations.Flow
begin

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


section \<open>Lens Algebraic Operators\<close>

theory Lens_Algebra
imports Lens_Laws
begin

subsection \<open>Lens Composition, Plus, Unit, and Identity\<close>

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=7cm]{figures/Composition}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Composition}
  \label{fig:Comp}
  \end{figure}
  We introduce the algebraic lens operators; for more information please see our paper~\cite{Foster16a}.
  Lens composition, illustrated in Figure~\ref{fig:Comp}, constructs a lens by composing the source
  of one lens with the view of another.\<close>

definition lens_comp :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> ('a \<Longrightarrow> 'c)" (infixr ";\<^sub>L" 80) where
[lens_defs]: "lens_comp Y X = \<lparr> lens_get = lens_get Y \<circ> lens_get X
                              , lens_put = (\<lambda> \<sigma> v. lens_put X \<sigma> (lens_put Y (lens_get X \<sigma>) v)) \<rparr>"

text \<open>
  \begin{figure}
  \begin{center}
    \includegraphics[width=7cm]{figures/Sum}
  \end{center}
  \vspace{-5ex}
  \caption{Lens Sum}
  \label{fig:Sum}
  \end{figure}
  Lens plus, as illustrated in Figure~\ref{fig:Sum} parallel composes two independent lenses,
  resulting in a lens whose view is the product of the two underlying lens views.\<close>

definition lens_plus :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Longrightarrow> 'c" (infixr "+\<^sub>L" 75) where
[lens_defs]: "X +\<^sub>L Y = \<lparr> lens_get = (\<lambda> \<sigma>. (lens_get X \<sigma>, lens_get Y \<sigma>))
                       , lens_put = (\<lambda> \<sigma> (u, v). lens_put X (lens_put Y \<sigma> v) u) \<rparr>"

text \<open>The product functor lens similarly parallel composes two lenses, but in this case the lenses
  have different sources and so the resulting source is also a product.\<close>

definition lens_prod :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'd) \<Rightarrow> ('a \<times> 'b \<Longrightarrow> 'c \<times> 'd)" (infixr "\<times>\<^sub>L" 85) where
[lens_defs]: "lens_prod X Y = \<lparr> lens_get = map_prod (get\<^bsub>X\<^esub>) (get\<^bsub>Y\<^esub>)
                              , lens_put = \<lambda> (u, v) (x, y). (put\<^bsub>X\<^esub> u x, put\<^bsub>Y\<^esub> v y) \<rparr>"

text \<open>The $\lfst$ and $\lsnd$ lenses project the first and second elements, respectively, of a
  product source type.\<close>

definition fst_lens :: "'a \<Longrightarrow> 'a \<times> 'b" ("fst\<^sub>L") where
[lens_defs]: "fst\<^sub>L = \<lparr> lens_get = fst, lens_put = (\<lambda> (\<sigma>, \<rho>) u. (u, \<rho>)) \<rparr>"

definition snd_lens :: "'b \<Longrightarrow> 'a \<times> 'b" ("snd\<^sub>L") where
[lens_defs]: "snd\<^sub>L = \<lparr> lens_get = snd, lens_put = (\<lambda> (\<sigma>, \<rho>) u. (\<sigma>, u)) \<rparr>"

lemma get_fst_lens [simp]: "get\<^bsub>fst\<^sub>L\<^esub> (x, y) = x"
  by (simp add: fst_lens_def)

lemma get_snd_lens [simp]: "get\<^bsub>snd\<^sub>L\<^esub> (x, y) = y"
  by (simp add: snd_lens_def)

text \<open>The swap lens is a bijective lens which swaps over the elements of the product source type.\<close>

abbreviation swap_lens :: "'a \<times> 'b \<Longrightarrow> 'b \<times> 'a" ("swap\<^sub>L") where
"swap\<^sub>L \<equiv> snd\<^sub>L +\<^sub>L fst\<^sub>L"

text \<open>The zero lens is an ineffectual lens whose view is a unit type. This means the zero lens
  cannot distinguish or change the source type.\<close>

definition zero_lens :: "unit \<Longrightarrow> 'a" ("0\<^sub>L") where
[lens_defs]: "0\<^sub>L = \<lparr> lens_get = (\<lambda> _. ()), lens_put = (\<lambda> \<sigma> x. \<sigma>) \<rparr>"

text \<open>The identity lens is a bijective lens where the source and view type are the same.\<close>

definition id_lens :: "'a \<Longrightarrow> 'a" ("1\<^sub>L") where
[lens_defs]: "1\<^sub>L = \<lparr> lens_get = id, lens_put = (\<lambda> _. id) \<rparr>"

text \<open>The quotient operator $X \lquot Y$ shortens lens $X$ by cutting off $Y$ from the end. It is
  thus the dual of the composition operator.\<close>

definition lens_quotient :: "('a \<Longrightarrow> 'c) \<Rightarrow> ('b \<Longrightarrow> 'c) \<Rightarrow> 'a \<Longrightarrow> 'b" (infixr "'/\<^sub>L" 90) where
[lens_defs]: "X /\<^sub>L Y = \<lparr> lens_get = \<lambda> \<sigma>. (get\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \<sigma>))
                       , lens_put = \<lambda> \<sigma> v.  (get\<^bsub>Y\<^esub> (put\<^bsub>X\<^esub> (create\<^bsub>Y\<^esub> \<sigma>) v)) \<rparr>"

text \<open>Lens override uses a lens to replace part of a source type with a given value for the
  corresponding view.\<close>

definition lens_override :: "'a \<Rightarrow> 'a \<Rightarrow> ('b \<Longrightarrow> 'a) \<Rightarrow> 'a" ("_ \<oplus>\<^sub>L _ on _" [95,0,96] 95) where
[lens_defs]: "S\<^sub>1 \<oplus>\<^sub>L S\<^sub>2 on X = put\<^bsub>X\<^esub> S\<^sub>1 (get\<^bsub>X\<^esub> S\<^sub>2)"

text \<open>Lens inverse take a bijective lens and swaps the source and view types.\<close>

definition lens_inv :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('b \<Longrightarrow> 'a)" ("inv\<^sub>L") where
[lens_defs]: "lens_inv x = \<lparr> lens_get = create\<^bsub>x\<^esub>, lens_put = \<lambda> \<sigma>. get\<^bsub>x\<^esub> \<rparr>"

subsection \<open>Closure Poperties\<close>

text \<open>We show that the core lenses combinators defined above are closed under the key lens classes.\<close>

lemma id_wb_lens: "wb_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma unit_wb_lens: "wb_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma comp_wb_lens: "\<lbrakk> wb_lens x; wb_lens y \<rbrakk> \<Longrightarrow> wb_lens (x ;\<^sub>L y)"
  by (unfold_locales, simp_all add: lens_comp_def)

lemma comp_mwb_lens: "\<lbrakk> mwb_lens x; mwb_lens y \<rbrakk> \<Longrightarrow> mwb_lens (x ;\<^sub>L y)"
  by (unfold_locales, simp_all add: lens_comp_def)

lemma id_vwb_lens [simp]: "vwb_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma unit_vwb_lens [simp]: "vwb_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

lemma comp_vwb_lens: "\<lbrakk> vwb_lens x; vwb_lens y \<rbrakk> \<Longrightarrow> vwb_lens (x ;\<^sub>L y)"
  by (unfold_locales, simp_all add: lens_comp_def)

lemma unit_ief_lens: "ief_lens 0\<^sub>L"
  by (unfold_locales, simp_all add: zero_lens_def)

text \<open>Lens plus requires that the lenses be independent to show closure.\<close>

lemma plus_mwb_lens:
  assumes "mwb_lens x" "mwb_lens y" "x \<bowtie> y"
  shows "mwb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales)
   apply (simp_all add: lens_plus_def prod.case_eq_if lens_indep_sym)
  apply (simp add: lens_indep_comm)
done

lemma plus_wb_lens:
  assumes "wb_lens x" "wb_lens y" "x \<bowtie> y"
  shows "wb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales, simp_all add: lens_plus_def)
  apply (simp add: lens_indep_sym prod.case_eq_if)
done

lemma plus_vwb_lens:
  assumes "vwb_lens x" "vwb_lens y" "x \<bowtie> y"
  shows "vwb_lens (x +\<^sub>L y)"
  using assms
  apply (unfold_locales, simp_all add: lens_plus_def)
   apply (simp add: lens_indep_sym prod.case_eq_if)
  apply (simp add: lens_indep_comm prod.case_eq_if)
done

lemma prod_mwb_lens:
  "\<lbrakk> mwb_lens X; mwb_lens Y \<rbrakk> \<Longrightarrow> mwb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_wb_lens:
  "\<lbrakk> wb_lens X; wb_lens Y \<rbrakk> \<Longrightarrow> wb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_vwb_lens:
  "\<lbrakk> vwb_lens X; vwb_lens Y \<rbrakk> \<Longrightarrow> vwb_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma prod_bij_lens:
  "\<lbrakk> bij_lens X; bij_lens Y \<rbrakk> \<Longrightarrow> bij_lens (X \<times>\<^sub>L Y)"
  by (unfold_locales, simp_all add: lens_prod_def prod.case_eq_if)

lemma fst_vwb_lens: "vwb_lens fst\<^sub>L"
  by (unfold_locales, simp_all add: fst_lens_def prod.case_eq_if)

lemma snd_vwb_lens: "vwb_lens snd\<^sub>L"
  by (unfold_locales, simp_all add: snd_lens_def prod.case_eq_if)

lemma id_bij_lens: "bij_lens 1\<^sub>L"
  by (unfold_locales, simp_all add: id_lens_def)

lemma inv_id_lens: "inv\<^sub>L 1\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_inv_def id_lens_def lens_create_def)

lemma lens_inv_bij: "bij_lens X \<Longrightarrow> bij_lens (inv\<^sub>L X)"
  by (unfold_locales, simp_all add: lens_inv_def lens_create_def)

lemma swap_bij_lens: "bij_lens swap\<^sub>L"
  by (unfold_locales, simp_all add: lens_plus_def prod.case_eq_if fst_lens_def snd_lens_def)

subsection \<open>Composition Laws\<close>

text \<open>Lens composition is monoidal, with unit @{term "1\<^sub>L"}, as the following theorems demonstrate.
  It also has @{term "0\<^sub>L"} as a right annihilator. \<close>

lemma lens_comp_assoc: "(X ;\<^sub>L Y) ;\<^sub>L Z = X ;\<^sub>L (Y ;\<^sub>L Z)"
  by (auto simp add: lens_comp_def)

lemma lens_comp_left_id [simp]: "1\<^sub>L ;\<^sub>L X = X"
  by (simp add: id_lens_def lens_comp_def)

lemma lens_comp_right_id [simp]: "X ;\<^sub>L 1\<^sub>L = X"
  by (simp add: id_lens_def lens_comp_def)

lemma lens_comp_anhil [simp]: "wb_lens X \<Longrightarrow> 0\<^sub>L ;\<^sub>L X = 0\<^sub>L"
  by (simp add: zero_lens_def lens_comp_def comp_def)

subsection \<open>Independence Laws\<close>

text \<open>The zero lens @{term "0\<^sub>L"} is independent of any lens. This is because nothing can be observed
  or changed using @{term "0\<^sub>L"}. \<close>

lemma zero_lens_indep [simp]: "0\<^sub>L \<bowtie> X"
  by (auto simp add: zero_lens_def lens_indep_def)

lemma zero_lens_indep' [simp]: "X \<bowtie> 0\<^sub>L"
  by (auto simp add: zero_lens_def lens_indep_def)

text \<open>Lens independence is irreflexive, but only for effectual lenses as otherwise nothing can
  be observed.\<close>

lemma lens_indep_quasi_irrefl: "\<lbrakk> wb_lens x; eff_lens x \<rbrakk> \<Longrightarrow> \<not> (x \<bowtie> x)"
  by (auto simp add: lens_indep_def ief_lens_def ief_lens_axioms_def, metis (full_types) wb_lens.get_put)

text \<open>Lens independence is a congruence with respect to composition, as the following properties demonstrate.\<close>

lemma lens_indep_left_comp [simp]:
  "\<lbrakk> mwb_lens z; x \<bowtie> y \<rbrakk> \<Longrightarrow> (x ;\<^sub>L z) \<bowtie> (y ;\<^sub>L z)"
  apply (rule lens_indepI)
    apply (auto simp add: lens_comp_def)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_right_comp:
  "y \<bowtie> z \<Longrightarrow> (x ;\<^sub>L y) \<bowtie> (x ;\<^sub>L z)"
  apply (auto intro!: lens_indepI simp add: lens_comp_def)
    using lens_indep_comm lens_indep_sym apply fastforce
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_left_ext [intro]:
  "y \<bowtie> z \<Longrightarrow> (x ;\<^sub>L y) \<bowtie> z"
  apply (auto intro!: lens_indepI simp add: lens_comp_def)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma lens_indep_right_ext [intro]:
  "x \<bowtie> z \<Longrightarrow> x \<bowtie> (y ;\<^sub>L z)"
  by (simp add: lens_indep_left_ext lens_indep_sym)

lemma lens_comp_indep_cong_left:
  "\<lbrakk> mwb_lens Z; X ;\<^sub>L Z \<bowtie> Y ;\<^sub>L Z \<rbrakk> \<Longrightarrow> X \<bowtie> Y"
  apply (rule lens_indepI)
    apply (rename_tac u v \<sigma>)
    apply (drule_tac u=u and v=v and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_comm)
    apply (simp add: lens_comp_def)
    apply (meson mwb_lens_weak weak_lens.view_determination)
   apply (rename_tac v \<sigma>)
   apply (drule_tac v=v and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_get)
   apply (simp add: lens_comp_def)
  apply (drule lens_indep_sym)
  apply (rename_tac u \<sigma>)
  apply (drule_tac v=u and \<sigma>="create\<^bsub>Z\<^esub> \<sigma>" in lens_indep_get)
  apply (simp add: lens_comp_def)
done

lemma lens_comp_indep_cong:
  "mwb_lens Z \<Longrightarrow> (X ;\<^sub>L Z) \<bowtie> (Y ;\<^sub>L Z) \<longleftrightarrow> X \<bowtie> Y"
  using lens_comp_indep_cong_left lens_indep_left_comp by blast

text \<open>The first and second lenses are independent since the view different parts of a product source.\<close>

lemma fst_snd_lens_indep [simp]:
  "fst\<^sub>L \<bowtie> snd\<^sub>L"
  by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma snd_fst_lens_indep [simp]:
  "snd\<^sub>L \<bowtie> fst\<^sub>L"
  by (simp add: lens_indep_def fst_lens_def snd_lens_def)

lemma split_prod_lens_indep:
  assumes "mwb_lens X"
  shows "(fst\<^sub>L ;\<^sub>L X) \<bowtie> (snd\<^sub>L ;\<^sub>L X)"
  using assms fst_snd_lens_indep lens_indep_left_comp vwb_lens_mwb by blast

text \<open>Lens independence is preserved by summation.\<close>

lemma plus_pres_lens_indep [simp]: "\<lbrakk> X \<bowtie> Z; Y \<bowtie> Z \<rbrakk> \<Longrightarrow> (X +\<^sub>L Y) \<bowtie> Z"
  apply (rule lens_indepI)
    apply (simp_all add: lens_plus_def prod.case_eq_if)
   apply (simp add: lens_indep_comm)
  apply (simp add: lens_indep_sym)
done

lemma plus_pres_lens_indep' [simp]:
  "\<lbrakk> X \<bowtie> Y; X \<bowtie> Z \<rbrakk> \<Longrightarrow> X \<bowtie> Y +\<^sub>L Z"
  by (auto intro: lens_indep_sym plus_pres_lens_indep)

text \<open>Lens independence is preserved by product.\<close>

lemma lens_indep_prod:
  "\<lbrakk> X\<^sub>1 \<bowtie> X\<^sub>2; Y\<^sub>1 \<bowtie> Y\<^sub>2 \<rbrakk> \<Longrightarrow> X\<^sub>1 \<times>\<^sub>L Y\<^sub>1 \<bowtie> X\<^sub>2 \<times>\<^sub>L Y\<^sub>2"
  apply (rule lens_indepI)
    apply (auto simp add: lens_prod_def prod.case_eq_if lens_indep_comm map_prod_def)
   apply (simp_all add: lens_indep_sym)
done

subsection \<open>Algebraic Laws\<close>

text \<open>Lens plus distributes to the right through composition.\<close>

lemma plus_lens_distr: "mwb_lens Z \<Longrightarrow> (X +\<^sub>L Y) ;\<^sub>L Z = (X ;\<^sub>L Z) +\<^sub>L (Y ;\<^sub>L Z)"
  by (auto simp add: lens_comp_def lens_plus_def comp_def)

text \<open>The first lens projects the first part of a summation.\<close>

lemma fst_lens_plus:
  "wb_lens y \<Longrightarrow> fst\<^sub>L ;\<^sub>L (x +\<^sub>L y) = x"
  by (simp add: fst_lens_def lens_plus_def lens_comp_def comp_def)

text \<open>The second law requires independence as we have to apply x first, before y\<close>

lemma snd_lens_plus:
  "\<lbrakk> wb_lens x; x \<bowtie> y \<rbrakk> \<Longrightarrow> snd\<^sub>L ;\<^sub>L (x +\<^sub>L y) = y"
  apply (simp add: snd_lens_def lens_plus_def lens_comp_def comp_def)
  apply (subst lens_indep_comm)
   apply (simp_all)
done

text \<open>The swap lens switches over a summation.\<close>

lemma lens_plus_swap:
  "X \<bowtie> Y \<Longrightarrow> swap\<^sub>L ;\<^sub>L (X +\<^sub>L Y) = (Y +\<^sub>L X)"
  by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def lens_comp_def lens_indep_comm)

text \<open>The first, second, and swap lenses are all closely related.\<close>

lemma fst_snd_id_lens: "fst\<^sub>L +\<^sub>L snd\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_plus_def fst_lens_def snd_lens_def id_lens_def)

lemma swap_lens_idem: "swap\<^sub>L ;\<^sub>L swap\<^sub>L = 1\<^sub>L"
  by (simp add: fst_snd_id_lens lens_indep_sym lens_plus_swap)

lemma swap_lens_fst: "fst\<^sub>L ;\<^sub>L swap\<^sub>L = snd\<^sub>L"
  by (simp add: fst_lens_plus fst_vwb_lens)

lemma swap_lens_snd: "snd\<^sub>L ;\<^sub>L swap\<^sub>L = fst\<^sub>L"
  by (simp add: lens_indep_sym snd_lens_plus snd_vwb_lens)

text \<open>The product lens can be rewritten as a sum lens.\<close>

lemma prod_as_plus: "X \<times>\<^sub>L Y = X ;\<^sub>L fst\<^sub>L +\<^sub>L Y ;\<^sub>L snd\<^sub>L"
  by (auto simp add: lens_prod_def fst_lens_def snd_lens_def lens_comp_def lens_plus_def)

lemma prod_lens_id_equiv:
  "1\<^sub>L \<times>\<^sub>L 1\<^sub>L = 1\<^sub>L"
  by (auto simp add: lens_prod_def id_lens_def)

lemma prod_lens_comp_plus:
  "X\<^sub>2 \<bowtie> Y\<^sub>2 \<Longrightarrow> ((X\<^sub>1 \<times>\<^sub>L Y\<^sub>1) ;\<^sub>L (X\<^sub>2 +\<^sub>L Y\<^sub>2)) = (X\<^sub>1 ;\<^sub>L X\<^sub>2) +\<^sub>L (Y\<^sub>1 ;\<^sub>L Y\<^sub>2)"
  by (auto simp add: lens_comp_def lens_plus_def lens_prod_def prod.case_eq_if fun_eq_iff)

text \<open>The following laws about quotient are similar to their arithmetic analogues. Lens quotient
  reverse the effect of a composition.\<close>

lemma lens_comp_quotient:
  "weak_lens Y \<Longrightarrow> (X ;\<^sub>L Y) /\<^sub>L Y = X"
  by (simp add: lens_quotient_def lens_comp_def)

lemma lens_quotient_id: "weak_lens X \<Longrightarrow> (X /\<^sub>L X) = 1\<^sub>L"
  by (force simp add: lens_quotient_def id_lens_def)

lemma lens_quotient_id_denom: "X /\<^sub>L 1\<^sub>L = X"
  by (simp add: lens_quotient_def id_lens_def lens_create_def)

lemma lens_quotient_unit: "weak_lens X \<Longrightarrow> (0\<^sub>L /\<^sub>L X) = 0\<^sub>L"
  by (simp add: lens_quotient_def zero_lens_def)

end