(*  Title:      HOL/Quotient_Examples/Quotient_Int.thy
    Author:     Cezary Kaliszyk
    Author:     Christian Urban

Integers based on Quotients, based on an older version by Larry
Paulson.
*)

theory Quotient_Int
imports "~~/src/HOL/Library/Quotient_Product" Nat
begin

fun
  intrel :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool" (infix "\<approx>" 50)
where
  "intrel (x, y) (u, v) = (x + v = u + y)"

quotient_type int = "nat \<times> nat" / intrel
  by (auto simp add: equivp_def fun_eq_iff)

instantiation int :: "{zero, one, plus, uminus, minus, times, ord, abs, sgn}"
begin

quotient_definition
  "0 \<Colon> int" is "(0\<Colon>nat, 0\<Colon>nat)" done

quotient_definition
  "1 \<Colon> int" is "(1\<Colon>nat, 0\<Colon>nat)" done

fun
  plus_int_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
where
  "plus_int_raw (x, y) (u, v) = (x + u, y + v)"

quotient_definition
  "(op +) \<Colon> (int \<Rightarrow> int \<Rightarrow> int)" is "plus_int_raw" by auto

fun
  uminus_int_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
where
  "uminus_int_raw (x, y) = (y, x)"

quotient_definition
  "(uminus \<Colon> (int \<Rightarrow> int))" is "uminus_int_raw" by auto

definition
  minus_int_def:  "z - w = z + (-w\<Colon>int)"

fun
  times_int_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> (nat \<times> nat)"
where
  "times_int_raw (x, y) (u, v) = (x*u + y*v, x*v + y*u)"

lemma times_int_raw_fst:
  assumes a: "x \<approx> z"
  shows "times_int_raw x y \<approx> times_int_raw z y"
  using a
  apply(cases x, cases y, cases z)
  apply(auto simp add: times_int_raw.simps intrel.simps)
  apply(hypsubst_thin)
  apply(rename_tac u v w x y z)
  apply(subgoal_tac "u*w + z*w = y*w + v*w  &  u*x + z*x = y*x + v*x")
  apply(simp add: ac_simps)
  apply(simp add: add_mult_distrib [symmetric])
done

lemma times_int_raw_snd:
  assumes a: "x \<approx> z"
  shows "times_int_raw y x \<approx> times_int_raw y z"
  using a
  apply(cases x, cases y, cases z)
  apply(auto simp add: times_int_raw.simps intrel.simps)
  apply(hypsubst_thin)
  apply(rename_tac u v w x y z)
  apply(subgoal_tac "u*w + z*w = y*w + v*w  &  u*x + z*x = y*x + v*x")
  apply(simp add: ac_simps)
  apply(simp add: add_mult_distrib [symmetric])
done

quotient_definition
  "(op *) :: (int \<Rightarrow> int \<Rightarrow> int)" is "times_int_raw"
  apply(rule equivp_transp[OF int_equivp])
  apply(rule times_int_raw_fst)
  apply(assumption)
  apply(rule times_int_raw_snd)
  apply(assumption)
done

fun
  le_int_raw :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool"
where
  "le_int_raw (x, y) (u, v) = (x+v \<le> u+y)"

quotient_definition
  le_int_def: "(op \<le>) :: int \<Rightarrow> int \<Rightarrow> bool" is "le_int_raw" by auto

definition
  less_int_def: "(z\<Colon>int) < w = (z \<le> w \<and> z \<noteq> w)"

definition
  zabs_def: "\<bar>i\<Colon>int\<bar> = (if i < 0 then - i else i)"

definition
  zsgn_def: "sgn (i\<Colon>int) = (if i = 0 then 0 else if 0 < i then 1 else - 1)"

instance ..

end

text{* The integers form a @{text comm_ring_1}*}

instance int :: comm_ring_1
proof
  fix i j k :: int
  show "(i + j) + k = i + (j + k)"
    by (descending) (auto)
  show "i + j = j + i"
    by (descending) (auto)
  show "0 + i = (i::int)"
    by (descending) (auto)
  show "- i + i = 0"
    by (descending) (auto)
  show "i - j = i + - j"
    by (simp add: minus_int_def)
  show "(i * j) * k = i * (j * k)"
    by (descending) (auto simp add: algebra_simps)
  show "i * j = j * i"
    by (descending) (auto)
  show "1 * i = i"
    by (descending) (auto)
  show "(i + j) * k = i * k + j * k"
    by (descending) (auto simp add: algebra_simps)
  show "0 \<noteq> (1::int)"
    by (descending) (auto)
qed

lemma plus_int_raw_rsp_aux:
  assumes a: "a \<approx> b" "c \<approx> d"
  shows "plus_int_raw a c \<approx> plus_int_raw b d"
  using a
  by (cases a, cases b, cases c, cases d)
     (simp)

lemma add_abs_int:
  "(abs_int (x,y)) + (abs_int (u,v)) =
   (abs_int (x + u, y + v))"
  apply(simp add: plus_int_def id_simps)
  apply(fold plus_int_raw.simps)
  apply(rule Quotient3_rel_abs[OF Quotient3_int])
  apply(rule plus_int_raw_rsp_aux)
  apply(simp_all add: rep_abs_rsp_left[OF Quotient3_int])
  done

definition int_of_nat_raw:
  "int_of_nat_raw m = (m :: nat, 0 :: nat)"

quotient_definition
  "int_of_nat :: nat \<Rightarrow> int" is "int_of_nat_raw" done

lemma int_of_nat:
  shows "of_nat m = int_of_nat m"
  by (induct m)
     (simp_all add: zero_int_def one_int_def int_of_nat_def int_of_nat_raw add_abs_int)

instance int :: linorder
proof
  fix i j k :: int
  show antisym: "i \<le> j \<Longrightarrow> j \<le> i \<Longrightarrow> i = j"
    by (descending) (auto)
  show "(i < j) = (i \<le> j \<and> \<not> j \<le> i)"
    by (auto simp add: less_int_def dest: antisym)
  show "i \<le> i"
    by (descending) (auto)
  show "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> i \<le> k"
    by (descending) (auto)
  show "i \<le> j \<or> j \<le> i"
    by (descending) (auto)
qed

instantiation int :: distrib_lattice
begin

definition
  "(inf \<Colon> int \<Rightarrow> int \<Rightarrow> int) = min"

definition
  "(sup \<Colon> int \<Rightarrow> int \<Rightarrow> int) = max"

instance
  by default
     (auto simp add: inf_int_def sup_int_def max_min_distrib2)

end

instance int :: ordered_cancel_ab_semigroup_add
proof
  fix i j k :: int
  show "i \<le> j \<Longrightarrow> k + i \<le> k + j"
    by (descending) (auto)
qed

abbreviation
  "less_int_raw i j \<equiv> le_int_raw i j \<and> \<not>(i \<approx> j)"

lemma zmult_zless_mono2_lemma:
  fixes i j::int
  and   k::nat
  shows "i < j \<Longrightarrow> 0 < k \<Longrightarrow> of_nat k * i < of_nat k * j"
  apply(induct "k")
  apply(simp)
  apply(case_tac "k = 0")
  apply(simp_all add: distrib_right add_strict_mono)
  done

lemma zero_le_imp_eq_int_raw:
  fixes k::"(nat \<times> nat)"
  shows "less_int_raw (0, 0) k \<Longrightarrow> (\<exists>n > 0. k \<approx> int_of_nat_raw n)"
  apply(cases k)
  apply(simp add:int_of_nat_raw)
  apply(auto)
  apply(rule_tac i="b" and j="a" in less_Suc_induct)
  apply(auto)
  done

lemma zero_le_imp_eq_int:
  fixes k::int
  shows "0 < k \<Longrightarrow> \<exists>n > 0. k = of_nat n"
  unfolding less_int_def int_of_nat
  by (descending) (rule zero_le_imp_eq_int_raw)

lemma zmult_zless_mono2:
  fixes i j k::int
  assumes a: "i < j" "0 < k"
  shows "k * i < k * j"
  using a
  by (drule_tac zero_le_imp_eq_int) (auto simp add: zmult_zless_mono2_lemma)

text{*The integers form an ordered integral domain*}

instance int :: linordered_idom
proof
  fix i j k :: int
  show "i < j \<Longrightarrow> 0 < k \<Longrightarrow> k * i < k * j"
    by (rule zmult_zless_mono2)
  show "\<bar>i\<bar> = (if i < 0 then -i else i)"
    by (simp only: zabs_def)
  show "sgn (i\<Colon>int) = (if i=0 then 0 else if 0<i then 1 else - 1)"
    by (simp only: zsgn_def)
qed

lemmas int_distrib =
  distrib_right [of z1 z2 w]
  distrib_left [of w z1 z2]
  left_diff_distrib [of z1 z2 w]
  right_diff_distrib [of w z1 z2]
  minus_add_distrib[of z1 z2]
  for z1 z2 w :: int

lemma int_induct2:
  assumes "P 0 0"
  and     "\<And>n m. P n m \<Longrightarrow> P (Suc n) m"
  and     "\<And>n m. P n m \<Longrightarrow> P n (Suc m)"
  shows   "P n m"
using assms
by (induction_schema) (pat_completeness, lexicographic_order)

lemma int_induct:
  fixes j :: int
  assumes a: "P 0"
  and     b: "\<And>i::int. P i \<Longrightarrow> P (i + 1)"
  and     c: "\<And>i::int. P i \<Longrightarrow> P (i - 1)"
  shows      "P j"
using a b c
unfolding minus_int_def
by (descending) (auto intro: int_induct2)

text {* Magnitide of an Integer, as a Natural Number: @{term nat} *}

definition
  "int_to_nat_raw \<equiv> \<lambda>(x, y).x - (y::nat)"

quotient_definition
  "int_to_nat::int \<Rightarrow> nat"
is
  "int_to_nat_raw"
unfolding int_to_nat_raw_def by auto

lemma nat_le_eq_zle:
  fixes w z::"int"
  shows "0 < w \<or> 0 \<le> z \<Longrightarrow> (int_to_nat w \<le> int_to_nat z) = (w \<le> z)"
  unfolding less_int_def
  by (descending) (auto simp add: int_to_nat_raw_def)

end


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

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

datatype Nat = Z | S "Nat"

fun x :: "bool => bool => bool" where
  "x True z = z"
| "x False z = False"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) z = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

fun insort :: "Nat => Nat list => Nat list" where
  "insort y (nil2) = cons2 y (nil2)"
| "insort y (cons2 z2 xs) =
     (if t2 y z2 then cons2 y (cons2 z2 xs) else cons2 z2 (insort y xs))"

fun sorted :: "Nat list => bool" where
  "sorted (nil2) = True"
| "sorted (cons2 z (nil2)) = True"
| "sorted (cons2 z (cons2 y2 ys)) =
     x (t2 z y2) (sorted (cons2 y2 ys))"

theorem property0 :
  "((sorted xs) ==> (sorted (insort y xs)))"
  oops

end


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

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun max :: "Nat => Nat => Nat" where
  "max (Z) z = z"
| "max (S z2) (Z) = S z2"
| "max (S z2) (S x2) = S (max z2 x2)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) z = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :(*This problem is very similar to TIP_prop_24.thy*)
  "((x (max a b) b) = (t2 a b))"
  apply(induct rule:x.induct)
     apply fastforce
    apply clarsimp
    apply(induct_tac z2)
     apply fastforce+
  done

end


theory Imp_List_Sum
imports "Separation_Logic_Imperative_HOL.Imp_List_Spec"
begin

text "A general sum operation can be defined for list iterators
over elements of a monoid"

locale imp_list_iterate_sum = imp_list_iterate is_list is_it
  for is_list :: "('a ::{monoid_add}) list \<Rightarrow> 'b \<Rightarrow> assn"
  and is_it :: "'a list \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'it \<Rightarrow> assn"
begin
subsubsection \<open>List-Sum\<close>

partial_function (heap) it_sum' :: "'it \<Rightarrow> 'a \<Rightarrow> 'a Heap"
  where [code]:
  "it_sum' it s = do {
    b \<leftarrow> it_has_next it;
    if b then do {
      (x,it') \<leftarrow> it_next it;
      it_sum' it' (s+x)
    } else return s
  }"

lemma it_sum'_rule[sep_heap_rules]:
  "<is_it l p l' it>
    it_sum' it s
  <\<lambda>r. is_list l p * \<up>(r = s + sum_list l')>\<^sub>t"
proof (induct l' arbitrary: it s)
  case Nil thus ?case
    apply (subst it_sum'.simps)
    apply (sep_auto intro: quit_iteration ent_true_drop(1))
    done
next
  case (Cons x l')
  show ?case
    apply (subst it_sum'.simps)
    apply (sep_auto heap: Cons.hyps simp add: add.assoc)
    done
qed

definition "it_sum p \<equiv> do {
  it \<leftarrow> it_init p;
  it_sum' it 0}"

lemma it_sum_rule[sep_heap_rules]:
  "<is_list l p> it_sum p <\<lambda>r. is_list l p * \<up>(r=sum_list l)>\<^sub>t"
  unfolding it_sum_def
  by sep_auto

end

end


theory Desargues_Property
  imports Main Projective_Plane_Axioms Pappus_Property Pascal_Property
begin

(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk .*)

text \<open>
Contents:
\<^item> We formalize Desargues's property, [\<open>desargues_prop\<close>], that states that if two triangles are perspective
from a point, then they are perspective from a line.
Note that some planes satisfy that property and some others don't, hence Desargues's property is
not a theorem though it is a theorem in projective space geometry.
\<close>

section \<open>Desargues's Property\<close>

definition distinct3 :: "[Points, Points, Points] \<Rightarrow> bool" where
"distinct3 A B C \<equiv> A \<noteq> B \<and> A \<noteq> C \<and> B \<noteq> C"

definition triangle :: "[Points, Points, Points] \<Rightarrow> bool" where
"triangle A B C \<equiv> distinct3 A B C \<and> (line A B \<noteq> line A C)"

definition meet_in :: "Lines \<Rightarrow> Lines => Points => bool " where
"meet_in l m P \<equiv> incid P l \<and> incid P m"

lemma meet_col_1:
  assumes "meet_in (line A B) (line C D) P"
  shows "col A B P"
  using assms col_def incidA_lAB incidB_lAB meet_in_def
  by blast

lemma meet_col_2:
  assumes "meet_in (line A B) (line C D) P"
  shows "col C D P"
  using assms meet_col_1 meet_in_def
  by auto

definition meet_3_in :: "[Lines, Lines, Lines, Points] \<Rightarrow> bool" where
"meet_3_in l m n P \<equiv> meet_in l m P \<and> meet_in l n P"

lemma meet_all_3:
  assumes "meet_3_in l m n P"
  shows "meet_in m n P"
  using assms meet_3_in_def meet_in_def
  by auto

lemma meet_3_col_1:
  assumes "meet_3_in (line A B) m n P"
  shows "col A B P"
  using assms meet_3_in_def meet_col_2 meet_in_def
  by auto

lemma meet_3_col_2:
  assumes "meet_3_in l (line A B) n P"
  shows "col A B P"
  using assms col_def incidA_lAB incidB_lAB meet_3_in_def meet_in_def
  by blast

lemma meet_3_col_3:
  assumes "meet_3_in l m (line A B) P"
  shows "col A B P"
  using assms meet_3_col_2 meet_3_in_def
  by auto

definition distinct7 ::
  "[Points, Points, Points, Points, Points, Points, Points] \<Rightarrow> bool" where
"distinct7 A B C D E F G \<equiv> (A \<noteq> B) \<and> (A \<noteq> C) \<and> (A \<noteq> D) \<and> (A \<noteq> E) \<and> (A \<noteq> F) \<and> (A \<noteq> G) \<and>
(B \<noteq> C) \<and> (B \<noteq> D) \<and> (B \<noteq> E) \<and> (B \<noteq> F) \<and> (B \<noteq> G) \<and>
(C \<noteq> D) \<and> (C \<noteq> E) \<and> (C \<noteq> F) \<and> (C \<noteq> G) \<and>
(D \<noteq> E) \<and> (D \<noteq> F) \<and> (D \<noteq> G) \<and>
(E \<noteq> F) \<and> (E \<noteq> G) \<and>
(F \<noteq> G)"

definition distinct3l :: "[Lines, Lines, Lines] \<Rightarrow> bool" where
"distinct3l l m n \<equiv> l \<noteq> m \<and> l \<noteq> n \<and> m \<noteq> n"

(* From now on we give less general statements on purpose to avoid a lot of uninteresting
degenerate cases, since we can hardly think of any interesting application where one would need
to instantiate a statement on such degenerate case, hence our statements and proofs will be more
textbook-like. For the working mathematician the only thing that probably matters is the main
theorem without considering all the degenerate cases for which the statement might still hold. *)

definition desargues_config ::
  "[Points, Points, Points, Points, Points, Points, Points, Points, Points, Points] => bool" where
"desargues_config A B C A' B' C' M N P R \<equiv> distinct7 A B C A' B' C' R \<and> \<not> col A B C
\<and> \<not> col A' B' C' \<and> distinct3l (line A A') (line B B') (line C C') \<and>
meet_3_in (line A A') (line B B') (line C C') R \<and> (line A B) \<noteq> (line A' B') \<and>
(line B C) \<noteq> (line B' C') \<and> (line A C) \<noteq> (line A' C') \<and> meet_in (line B C) (line B' C') M \<and>
meet_in (line A C) (line A' C') N \<and> meet_in (line A B) (line A' B') P"

lemma distinct7_rot_CW:
  assumes "distinct7 A B C D E F G"
  shows "distinct7 C A B F D E G"
  using assms distinct7_def
  by auto

(* Desargues configurations are stable under any rotation (i,j,k) of {1,2,3} *)

lemma desargues_config_rot_CCW:
  assumes "desargues_config A B C A' B' C' M N P R"
  shows "desargues_config B C A B' C' A' N P M R"
  by (simp add: assms desargues_config_rot_CW)

(* With the two following definitions we repackage the definition of a Desargues configuration in a
"high-level", i.e. textbook-like, way. *)

definition are_perspective_from_point ::
  "[Points, Points, Points, Points, Points, Points, Points] \<Rightarrow> bool" where
"are_perspective_from_point A B C A' B' C' R \<equiv> distinct7 A B C A' B' C' R \<and> triangle A B C \<and>
triangle A' B' C' \<and> distinct3l (line A A') (line B B') (line C C') \<and>
meet_3_in (line A A') (line B B') (line C C') R"

definition are_perspective_from_line ::
  "[Points, Points, Points, Points, Points, Points] \<Rightarrow> bool" where
"are_perspective_from_line A B C A' B' C' \<equiv> distinct6 A B C A' B' C' \<longrightarrow> triangle A B C \<longrightarrow>
triangle A' B' C' \<longrightarrow> line A B \<noteq> line A' B' \<longrightarrow> line A C \<noteq> line A' C' \<longrightarrow> line B C \<noteq> line B' C' \<longrightarrow>
col (inter (line A B) (line A' B')) (inter (line A C) (line A' C')) (inter (line B C) (line B' C'))"

lemma meet_in_inter:
  assumes "l \<noteq> m"
  shows "meet_in l m (inter l m)"
  by (simp add: incid_inter_left incid_inter_right meet_in_def)

lemma perspective_from_point_desargues_config:
  assumes "are_perspective_from_point A B C A' B' C' R" and "line A B \<noteq> line A' B'" and
    "line A C \<noteq> line A' C'" and "line B C \<noteq> line B' C'"
  shows "desargues_config A B C A' B' C' (inter (line B C) (line B' C')) (inter (line A C) (line A' C'))
    (inter (line A B) (line A' B')) R"
  by (smt are_perspective_from_point_def assms(1) assms(2) assms(3) assms(4) col_line_ext_1
      desargues_config_def distinct3_def incidB_lAB inter_line_ext_2 line_comm meet_in_inter
      triangle_def uniq_inter)

(* Now, we state Desargues's property in a textbook-like form *)
definition desargues_prop :: "bool" where
"desargues_prop \<equiv>
\<forall>A B C A' B' C' P.
  are_perspective_from_point A B C A' B' C' P \<longrightarrow> are_perspective_from_line A B C A' B' C'"

end


(*  Based on HOL/Real_Vector_Spaces.thy by Brian Huffman
    Adapted to the complex case by Dominique Unruh *)

section \<open>\<open>Complex_Inner_Product0\<close> -- Inner Product Spaces and Gradient Derivative\<close>

theory Complex_Inner_Product0
  imports
    Complex_Main Complex_Vector_Spaces
    "HOL-Analysis.Inner_Product"
    "Complex_Bounded_Operators-Extra.Extra_Ordered_Fields"
begin

subsection \<open>Complex inner product spaces\<close>

text \<open>
  Temporarily relax type constraints for \<^term>\<open>open\<close>, \<^term>\<open>uniformity\<close>,
  \<^term>\<open>dist\<close>, and \<^term>\<open>norm\<close>.
\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>open\<close>, SOME \<^typ>\<open>'a::open set \<Rightarrow> bool\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>dist\<close>, SOME \<^typ>\<open>'a::dist \<Rightarrow> 'a \<Rightarrow> real\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>uniformity\<close>, SOME \<^typ>\<open>('a::uniformity \<times> 'a) filter\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>norm\<close>, SOME \<^typ>\<open>'a::norm \<Rightarrow> real\<close>)\<close>

class complex_inner = complex_vector + sgn_div_norm + dist_norm + uniformity_dist + open_uniformity +
  fixes cinner :: "'a \<Rightarrow> 'a \<Rightarrow> complex"
  assumes cinner_commute: "cinner x y = cnj (cinner y x)"
    and cinner_add_left: "cinner (x + y) z = cinner x z + cinner y z"
    and cinner_scaleC_left [simp]: "cinner (scaleC r x) y = (cnj r) * (cinner x y)"
    and cinner_ge_zero [simp]: "0 \<le> cinner x x"
    and cinner_eq_zero_iff [simp]: "cinner x x = 0 \<longleftrightarrow> x = 0"
    and norm_eq_sqrt_cinner: "norm x = sqrt (cmod (cinner x x))"
begin

lemma cinner_zero_left [simp]: "cinner 0 x = 0"
  using cinner_add_left [of 0 0 x] by simp

lemma cinner_minus_left [simp]: "cinner (- x) y = - cinner x y"
  using cinner_add_left [of x "- x" y]
  by (simp add: group_add_class.add_eq_0_iff)

lemma cinner_diff_left: "cinner (x - y) z = cinner x z - cinner y z"
  using cinner_add_left [of x "- y" z] by simp

lemma cinner_sum_left: "cinner (\<Sum>x\<in>A. f x) y = (\<Sum>x\<in>A. cinner (f x) y)"
  by (cases "finite A", induct set: finite, simp_all add: cinner_add_left)

lemma call_zero_iff [simp]: "(\<forall>u. cinner x u = 0) \<longleftrightarrow> (x = 0)"
  by auto (use cinner_eq_zero_iff in blast)

text \<open>Transfer distributivity rules to right argument.\<close>

lemma cinner_add_right: "cinner x (y + z) = cinner x y + cinner x z"
  using cinner_add_left [of y z x]
  by (metis complex_cnj_add local.cinner_commute)

lemma cinner_scaleC_right [simp]: "cinner x (scaleC r y) = r * (cinner x y)"
  using cinner_scaleC_left [of r y x]
  by (metis complex_cnj_cnj complex_cnj_mult local.cinner_commute)

lemma cinner_zero_right [simp]: "cinner x 0 = 0"
  using cinner_zero_left [of x]
  by (metis (mono_tags, opaque_lifting) complex_cnj_zero local.cinner_commute)

lemma cinner_minus_right [simp]: "cinner x (- y) = - cinner x y"
  using cinner_minus_left [of y x]
  by (metis complex_cnj_minus local.cinner_commute)

lemma cinner_diff_right: "cinner x (y - z) = cinner x y - cinner x z"
  using cinner_diff_left [of y z x]
  by (metis complex_cnj_diff local.cinner_commute)

lemma cinner_sum_right: "cinner x (\<Sum>y\<in>A. f y) = (\<Sum>y\<in>A. cinner x (f y))"
proof (subst cinner_commute)
  have "(\<Sum>y\<in>A. cinner (f y) x) = (\<Sum>y\<in>A. cinner (f y) x)"
    by blast
  hence "cnj (\<Sum>y\<in>A. cinner (f y) x) = cnj (\<Sum>y\<in>A. (cinner (f y) x))"
    by simp
  hence "cnj (cinner (sum f A) x) = (\<Sum>y\<in>A. cnj (cinner (f y) x))"
    by (simp add: cinner_sum_left)
  thus "cnj (cinner (sum f A) x) = (\<Sum>y\<in>A. (cinner x (f y)))"
    by (subst (2) cinner_commute)
qed

lemmas cinner_add [algebra_simps] = cinner_add_left cinner_add_right
lemmas cinner_diff [algebra_simps]  = cinner_diff_left cinner_diff_right
lemmas cinner_scaleC = cinner_scaleC_left cinner_scaleC_right

(* text \<open>Legacy theorem names\<close>
lemmas cinner_left_distrib = cinner_add_left
lemmas cinner_right_distrib = cinner_add_right
lemmas cinner_distrib = cinner_left_distrib cinner_right_distrib *)

lemma cinner_gt_zero_iff [simp]: "0 < cinner x x \<longleftrightarrow> x \<noteq> 0"
  by (smt (verit) less_irrefl local.cinner_eq_zero_iff local.cinner_ge_zero order.not_eq_order_implies_strict)

(* In Inner_Product, we have
  lemma power2_norm_eq_cinner: "(norm x)\<^sup>2 = cinner x x"
The following are two ways of inserting the conversions between real and complex into this:
*)

lemma power2_norm_eq_cinner:
  shows "(complex_of_real (norm x))\<^sup>2 = (cinner x x)"
  by (smt (verit, del_insts) Im_complex_of_real Re_complex_of_real cinner_gt_zero_iff cinner_zero_right cmod_def complex_eq_0 complex_eq_iff less_complex_def local.norm_eq_sqrt_cinner of_real_power real_sqrt_abs real_sqrt_pow2_iff zero_complex.sel(1))

lemma power2_norm_eq_cinner':
  shows "(norm x)\<^sup>2 = Re (cinner x x)"
  by (metis Re_complex_of_real of_real_power power2_norm_eq_cinner)

text \<open>Identities involving real multiplication and division.\<close>

lemma cinner_mult_left: "cinner (of_complex m * a) b = cnj m * (cinner a b)"
  by (simp add: of_complex_def)

lemma cinner_mult_right: "cinner a (of_complex m * b) = m * (cinner a b)"
  by (metis complex_inner_class.cinner_scaleC_right scaleC_conv_of_complex)

lemma cinner_mult_left': "cinner (a * of_complex m) b = cnj m * (cinner a b)"
  by (metis cinner_mult_left mult.right_neutral mult_scaleC_right scaleC_conv_of_complex)

lemma cinner_mult_right': "cinner a (b * of_complex m) = (cinner a b) * m"
  by (simp add: complex_inner_class.cinner_scaleC_right of_complex_def)

(* In Inner_Product, we have

lemma Cauchy_Schwarz_ineq:
  "(cinner x y) * (cinner y x) \<le> cinner x x * cinner y y"
proof (cases)
  assume "y = 0"
  thus ?thesis by simp
next
  assume y: "y \<noteq> 0"
  have [simp]: "cnj (cinner y y) = cinner y y" for y
    by (metis cinner_commute)
  define r where "r = cnj (cinner x y) / cinner y y"
  have "0 \<le> cinner (x - scaleC r y) (x - scaleC r y)"
    by (rule cinner_ge_zero)
  also have "\<dots> = cinner x x - r * cinner x y - cnj r * cinner y x + r * cnj r * cinner y y"
    unfolding cinner_diff_left cinner_diff_right cinner_scaleC_left cinner_scaleC_right
    by (smt (z3) cancel_comm_monoid_add_class.diff_cancel cancel_comm_monoid_add_class.diff_zero complex_cnj_divide group_add_class.diff_add_cancel local.cinner_commute local.cinner_eq_zero_iff local.cinner_scaleC_left mult.assoc mult.commute mult_eq_0_iff nonzero_eq_divide_eq r_def y)
  also have "\<dots> = cinner x x - cinner y x * cnj r"
    unfolding r_def by auto
  also have "\<dots> = cinner x x - cinner x y * cnj (cinner x y) / cinner y y"
    unfolding r_def
    by (metis complex_cnj_divide local.cinner_commute mult.commute times_divide_eq_left)
  finally have "0 \<le> cinner x x - cinner x y * cnj (cinner x y) / cinner y y" .
  hence "cinner x y * cnj (cinner x y) / cinner y y \<le> cinner x x"
    by (simp add: le_diff_eq)
  thus "cinner x y * cinner y x \<le> cinner x x * cinner y y"
    by (metis cinner_gt_zero_iff local.cinner_commute nice_ordered_field_class.pos_divide_le_eq y)
qed

lemma Cauchy_Schwarz_ineq2:
  shows "norm (cinner x y) \<le> norm x * norm y"
proof (rule power2_le_imp_le)
  have "(norm (cinner x y))^2 = Re (cinner x y * cinner y x)"
    by (metis (full_types) Re_complex_of_real complex_norm_square local.cinner_commute)
  also have "\<dots> \<le> Re (cinner x x * cinner y y)"
    using Cauchy_Schwarz_ineq by (rule Re_mono)
  also have "\<dots> = Re (complex_of_real ((norm x)^2) * complex_of_real ((norm y)^2))"
    by (simp add: power2_norm_eq_cinner)
  also have "\<dots> = (norm x * norm y)\<^sup>2"
    by (simp add: power_mult_distrib)
  finally show "(cmod (cinner x y))^2 \<le> (norm x * norm y)\<^sup>2" .
  show "0 \<le> norm x * norm y"
    by (simp add: local.norm_eq_sqrt_cinner)
qed

(* The following variant does not hold in the complex case: *)
(* lemma norm_cauchy_schwarz: "cinner x y \<le> norm x * norm y"
  using Cauchy_Schwarz_ineq2 [of x y] by auto *)

subclass complex_normed_vector
proof
  fix a :: complex and r :: real and x y :: 'a
  show "norm x = 0 \<longleftrightarrow> x = 0"
    unfolding norm_eq_sqrt_cinner by simp
  show "norm (x + y) \<le> norm x + norm y"
  proof (rule power2_le_imp_le)
    have "Re (cinner x y) \<le> cmod (cinner x y)"
      if "\<And>x. Re x \<le> cmod x" and
        "\<And>x y. x \<le> y \<Longrightarrow> complex_of_real x \<le> complex_of_real y"
      using that by simp
    hence a1: "2 * Re (cinner x y) \<le> 2 * cmod (cinner x y)"
      if "\<And>x. Re x \<le> cmod x" and
        "\<And>x y. x \<le> y \<Longrightarrow> complex_of_real x \<le> complex_of_real y"
      using that by simp
    have "cinner x y + cinner y x = complex_of_real (2 * Re (cinner x y))"
      by (metis complex_add_cnj local.cinner_commute)
    also have "\<dots> \<le> complex_of_real (2 * cmod (cinner x y))"
      using complex_Re_le_cmod complex_of_real_mono a1
      by blast
    also have "\<dots> = 2 * abs (cinner x y)"
      unfolding abs_complex_def by simp
    also have "\<dots> \<le> 2 * complex_of_real (norm x) * complex_of_real (norm y)"
      using Cauchy_Schwarz_ineq2 unfolding abs_complex_def less_eq_complex_def by auto
    finally have xyyx: "cinner x y + cinner y x \<le> complex_of_real (2 * norm x * norm y)"
      by auto
    have "complex_of_real ((norm (x + y))\<^sup>2) = cinner (x+y) (x+y)"
      by (simp add: power2_norm_eq_cinner)
    also have "\<dots> = cinner x x + cinner x y + cinner y x + cinner y y"
      by (simp add: cinner_add)
    also have "\<dots> = complex_of_real ((norm x)\<^sup>2) + complex_of_real ((norm y)\<^sup>2) + cinner x y + cinner y x"
      by (simp add: power2_norm_eq_cinner)
    also have "\<dots> \<le> complex_of_real ((norm x)\<^sup>2) + complex_of_real ((norm y)\<^sup>2) + complex_of_real (2 * norm x * norm y)"
      using xyyx by auto
    also have "\<dots> = complex_of_real ((norm x + norm y)\<^sup>2)"
      unfolding power2_sum by auto
    finally show "(norm (x + y))\<^sup>2 \<le> (norm x + norm y)\<^sup>2"
      using complex_of_real_mono_iff by blast
    show "0 \<le> norm x + norm y"
      unfolding norm_eq_sqrt_cinner by simp
  qed
  show norm_scaleC: "norm (a *\<^sub>C x) = cmod a * norm x" for a
  proof (rule power2_eq_imp_eq)
    show "(norm (a *\<^sub>C x))\<^sup>2 = (cmod a * norm x)\<^sup>2"
      by (simp_all add: norm_eq_sqrt_cinner norm_mult power2_eq_square)
    show "0 \<le> norm (a *\<^sub>C x)"
      by (simp_all add: norm_eq_sqrt_cinner)
    show "0 \<le> cmod a * norm x"
      by (simp_all add: norm_eq_sqrt_cinner)
  qed
  show "norm (r *\<^sub>R x) = \<bar>r\<bar> * norm x"
    unfolding scaleR_scaleC norm_scaleC by auto
qed

end

(* Does not hold in the complex case *)
(* lemma csquare_bound_lemma:
  fixes x :: complex
  shows "x < (1 + x) * (1 + x)" *)

lemma csquare_continuous:
  fixes e :: real
  shows "e > 0 \<Longrightarrow> \<exists>d. 0 < d \<and> (\<forall>y. cmod (y - x) < d \<longrightarrow> cmod (y * y - x * x) < e)"
  using isCont_power[OF continuous_ident, of x, unfolded isCont_def LIM_eq, rule_format, of e 2]
  by (force simp add: power2_eq_square)

lemma cnorm_le: "norm x \<le> norm y \<longleftrightarrow> cinner x x \<le> cinner y y"
  by (smt (verit) complex_of_real_mono_iff norm_eq_sqrt_cinner norm_ge_zero of_real_power power2_norm_eq_cinner real_sqrt_le_mono real_sqrt_pow2)

lemma cnorm_lt: "norm x < norm y \<longleftrightarrow> cinner x x < cinner y y"
  by (meson cnorm_le less_le_not_le)

lemma cnorm_eq: "norm x = norm y \<longleftrightarrow> cinner x x = cinner y y"
  by (metis norm_eq_sqrt_cinner power2_norm_eq_cinner)

lemma cnorm_eq_1: "norm x = 1 \<longleftrightarrow> cinner x x = 1"
  by (metis cinner_ge_zero complex_of_real_cmod norm_eq_sqrt_cinner norm_one of_real_1 real_sqrt_eq_iff real_sqrt_one)

lemma cinner_divide_left:
  fixes a :: "'a :: {complex_inner,complex_div_algebra}"
  shows "cinner (a / of_complex m) b = (cinner a b) / cnj m"
  by (metis cinner_mult_left' complex_cnj_inverse divide_inverse mult.commute of_complex_inverse)

lemma cinner_divide_right:
  fixes a :: "'a :: {complex_inner,complex_div_algebra}"
  shows "cinner a (b / of_complex m) = (cinner a b) / m"
  by (metis cinner_mult_right' divide_inverse of_complex_inverse)

text \<open>
  Re-enable constraints for \<^term>\<open>open\<close>, \<^term>\<open>uniformity\<close>,
  \<^term>\<open>dist\<close>, and \<^term>\<open>norm\<close>.
\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>open\<close>, SOME \<^typ>\<open>'a::topological_space set \<Rightarrow> bool\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>uniformity\<close>, SOME \<^typ>\<open>('a::uniform_space \<times> 'a) filter\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>dist\<close>, SOME \<^typ>\<open>'a::metric_space \<Rightarrow> 'a \<Rightarrow> real\<close>)\<close>

setup \<open>Sign.add_const_constraint
  (\<^const_name>\<open>norm\<close>, SOME \<^typ>\<open>'a::real_normed_vector \<Rightarrow> real\<close>)\<close>

lemma bounded_sesquilinear_cinner:
  "bounded_sesquilinear (cinner::'a::complex_inner \<Rightarrow> 'a \<Rightarrow> complex)"
proof
  fix x y z :: 'a and r :: complex
  show "cinner (x + y) z = cinner x z + cinner y z"
    by (rule cinner_add_left)
  show "cinner x (y + z) = cinner x y + cinner x z"
    by (rule cinner_add_right)
  show "cinner (scaleC r x) y = scaleC (cnj r) (cinner x y)"
    unfolding complex_scaleC_def by (rule cinner_scaleC_left)
  show "cinner x (scaleC r y) = scaleC r (cinner x y)"
    unfolding complex_scaleC_def by (rule cinner_scaleC_right)
  have "\<forall>x y::'a. norm (cinner x y) \<le> norm x * norm y * 1"
    by (simp add: complex_inner_class.Cauchy_Schwarz_ineq2)
  thus "\<exists>K. \<forall>x y::'a. norm (cinner x y) \<le> norm x * norm y * K"
    by metis
qed

lemmas tendsto_cinner [tendsto_intros] =
  bounded_bilinear.tendsto [OF bounded_sesquilinear_cinner[THEN bounded_sesquilinear.bounded_bilinear]]

lemmas isCont_cinner [simp] =
  bounded_bilinear.isCont [OF bounded_sesquilinear_cinner[THEN bounded_sesquilinear.bounded_bilinear]]

lemmas has_derivative_cinner [derivative_intros] =
  bounded_bilinear.FDERIV [OF bounded_sesquilinear_cinner[THEN bounded_sesquilinear.bounded_bilinear]]

lemmas bounded_antilinear_cinner_left =
  bounded_sesquilinear.bounded_antilinear_left [OF bounded_sesquilinear_cinner]

lemmas bounded_clinear_cinner_right =
  bounded_sesquilinear.bounded_clinear_right [OF bounded_sesquilinear_cinner]

lemmas bounded_antilinear_cinner_left_comp = bounded_antilinear_cinner_left[THEN bounded_antilinear_o_bounded_clinear]

lemmas bounded_clinear_cinner_right_comp = bounded_clinear_cinner_right[THEN bounded_clinear_compose]

lemmas has_derivative_cinner_right [derivative_intros] =
  bounded_linear.has_derivative [OF bounded_clinear_cinner_right[THEN bounded_clinear.bounded_linear]]

lemmas has_derivative_cinner_left [derivative_intros] =
  bounded_linear.has_derivative [OF bounded_antilinear_cinner_left[THEN bounded_antilinear.bounded_linear]]

lemma differentiable_cinner [simp]:
  "f differentiable (at x within s) \<Longrightarrow> g differentiable at x within s \<Longrightarrow> (\<lambda>x. cinner (f x) (g x)) differentiable at x within s"
  unfolding differentiable_def by (blast intro: has_derivative_cinner)

subsection \<open>Class instances\<close>

instantiation complex :: complex_inner
begin

definition cinner_complex_def [simp]: "cinner x y = cnj x * y"

instance
proof
  fix x y z r :: complex
  show "cinner x y = cnj (cinner y x)"
    unfolding cinner_complex_def by auto
  show "cinner (x + y) z = cinner x z + cinner y z"
    unfolding cinner_complex_def
    by (simp add: ring_class.ring_distribs(2))
  show "cinner (scaleC r x) y = cnj r * cinner x y"
    unfolding cinner_complex_def complex_scaleC_def by simp
  show "0 \<le> cinner x x"
    by simp
  show "cinner x x = 0 \<longleftrightarrow> x = 0"
    unfolding cinner_complex_def by simp
  have "cmod (Complex x1 x2) = sqrt (cmod (cinner (Complex x1 x2) (Complex x1 x2)))"
    for x1 x2
    unfolding cinner_complex_def complex_cnj complex_mult complex_norm
    by (simp add: power2_eq_square)
  thus "norm x = sqrt (cmod (cinner x x))"
    by (cases x, hypsubst_thin)
qed

end

lemma
  shows complex_inner_1_left[simp]: "cinner 1 x = x"
    and complex_inner_1_right[simp]: "cinner x 1 = cnj x"
  by simp_all

(* No analogous to \<open>instantiation complex :: real_inner\<close> or to
lemma complex_inner_1 [simp]: "inner 1 x = Re x"
lemma complex_inner_1_right [simp]: "inner x 1 = Re x"
lemma complex_inner_i_left [simp]: "inner \<i> x = Im x"
lemma complex_inner_i_right [simp]: "inner x \<i> = Im x"
 *)

lemma cdot_square_norm: "cinner x x = complex_of_real ((norm x)\<^sup>2)"
  by (metis Im_complex_of_real Re_complex_of_real cinner_ge_zero complex_eq_iff less_eq_complex_def power2_norm_eq_cinner' zero_complex.simps(2))

lemma cnorm_eq_square: "norm x = a \<longleftrightarrow> 0 \<le> a \<and> cinner x x = complex_of_real (a\<^sup>2)"
  by (metis cdot_square_norm norm_ge_zero of_real_eq_iff power2_eq_iff_nonneg)

lemma cnorm_le_square: "norm x \<le> a \<longleftrightarrow> 0 \<le> a \<and> cinner x x \<le> complex_of_real (a\<^sup>2)"
  by (smt (verit) cdot_square_norm complex_of_real_mono_iff norm_ge_zero power2_le_imp_le)

lemma cnorm_ge_square: "norm x \<ge> a \<longleftrightarrow> a \<le> 0 \<or> cinner x x \<ge> complex_of_real (a\<^sup>2)"
  by (smt (verit, best) antisym_conv cnorm_eq_square cnorm_le_square complex_of_real_nn_iff nn_comparable zero_le_power2)

lemma norm_lt_square: "norm x < a \<longleftrightarrow> 0 < a \<and> cinner x x < complex_of_real (a\<^sup>2)"
  by (meson cnorm_ge_square cnorm_le_square less_le_not_le)

lemma norm_gt_square: "norm x > a \<longleftrightarrow> a < 0 \<or> cinner x x > complex_of_real (a\<^sup>2)"
  by (smt (verit, ccfv_SIG) cdot_square_norm complex_of_real_strict_mono_iff norm_ge_zero power2_eq_imp_eq power_mono)

text\<open>Dot product in terms of the norm rather than conversely.\<close>

lemmas cinner_simps = cinner_add_left cinner_add_right cinner_diff_right cinner_diff_left
  cinner_scaleC_left cinner_scaleC_right

(* Analogue to both dot_norm and dot_norm_neg *)
lemma cdot_norm: "cinner x y = ((norm (x+y))\<^sup>2 - (norm (x-y))\<^sup>2 - \<i> * (norm (x + \<i> *\<^sub>C y))\<^sup>2 + \<i> * (norm (x - \<i> *\<^sub>C y))\<^sup>2) / 4"
  unfolding power2_norm_eq_cinner
  by (simp add: power2_norm_eq_cinner cinner_add_left cinner_add_right
      cinner_diff_left cinner_diff_right ring_distribs)

lemma of_complex_inner_1 [simp]:
  "cinner (of_complex x) (1 :: 'a :: {complex_inner, complex_normed_algebra_1}) = cnj x"
  by (metis Complex_Inner_Product0.complex_inner_1_right cinner_complex_def cinner_mult_left complex_cnj_one norm_one of_complex_def power2_norm_eq_cinner scaleC_conv_of_complex)

lemma summable_of_complex_iff:
  "summable (\<lambda>x. of_complex (f x) :: 'a :: {complex_normed_algebra_1,complex_inner}) \<longleftrightarrow> summable f"
proof
  assume *: "summable (\<lambda>x. of_complex (f x) :: 'a)"
  have "bounded_clinear (cinner (1::'a))"
    by (rule bounded_clinear_cinner_right)
  then interpret bounded_linear "\<lambda>x::'a. cinner 1 x"
    by (rule bounded_clinear.bounded_linear)
  from summable [OF *] show "summable f"
    apply (subst (asm) cinner_commute) by simp
next
  assume sum: "summable f"
  thus "summable (\<lambda>x. of_complex (f x) :: 'a)"
    by (rule summable_of_complex)
qed

subsection \<open>Gradient derivative\<close>

definition\<^marker>\<open>tag important\<close>
  cgderiv :: "['a::complex_inner \<Rightarrow> complex, 'a, 'a] \<Rightarrow> bool"
  ("(cGDERIV (_)/ (_)/ :> (_))" [1000, 1000, 60] 60)
  where
    (* Must be "cinner D" not "\<lambda>h. cinner h D", otherwise not even "cGDERIV id x :> 1" holds *)
    "cGDERIV f x :> D \<longleftrightarrow> FDERIV f x :> cinner D"

lemma cgderiv_deriv [simp]: "cGDERIV f x :> D \<longleftrightarrow> DERIV f x :> cnj D"
  by (simp only: cgderiv_def has_field_derivative_def cinner_complex_def[THEN ext])

lemma cGDERIV_DERIV_compose:
  assumes "cGDERIV f x :> df" and "DERIV g (f x) :> cnj dg"
  shows "cGDERIV (\<lambda>x. g (f x)) x :> scaleC dg df"
proof (insert assms)
  show "cGDERIV (\<lambda>x. g (f x)) x :> dg *\<^sub>C df"
    if "cGDERIV f x :> df"
      and "(g has_field_derivative cnj dg) (at (f x))"
    unfolding cgderiv_def has_field_derivative_def cinner_scaleC_left complex_cnj_cnj
    using that
    by (simp add: cgderiv_def has_derivative_compose has_field_derivative_imp_has_derivative)

qed

(* Not specific to complex/real *)
(* lemma has_derivative_subst: "\<lbrakk>FDERIV f x :> df; df = d\<rbrakk> \<Longrightarrow> FDERIV f x :> d" *)

lemma cGDERIV_subst: "\<lbrakk>cGDERIV f x :> df; df = d\<rbrakk> \<Longrightarrow> cGDERIV f x :> d"
  by simp

lemma cGDERIV_const: "cGDERIV (\<lambda>x. k) x :> 0"
  unfolding cgderiv_def cinner_zero_left[THEN ext] by (rule has_derivative_const)

lemma cGDERIV_add:
  "\<lbrakk>cGDERIV f x :> df; cGDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> cGDERIV (\<lambda>x. f x + g x) x :> df + dg"
  unfolding cgderiv_def cinner_add_left[THEN ext] by (rule has_derivative_add)

lemma cGDERIV_minus:
  "cGDERIV f x :> df \<Longrightarrow> cGDERIV (\<lambda>x. - f x) x :> - df"
  unfolding cgderiv_def cinner_minus_left[THEN ext] by (rule has_derivative_minus)

lemma cGDERIV_diff:
  "\<lbrakk>cGDERIV f x :> df; cGDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> cGDERIV (\<lambda>x. f x - g x) x :> df - dg"
  unfolding cgderiv_def cinner_diff_left by (rule has_derivative_diff)

lemma cGDERIV_scaleC:
  "\<lbrakk>DERIV f x :> df; cGDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> cGDERIV (\<lambda>x. scaleC (f x) (g x)) x
      :> (scaleC (cnj (f x)) dg + scaleC (cnj df) (cnj (g x)))"
  unfolding cgderiv_def has_field_derivative_def cinner_add_left cinner_scaleC_left
  apply (rule has_derivative_subst)
   apply (erule (1) has_derivative_scaleC)
  by (simp add: ac_simps)

lemma GDERIV_mult:
  "\<lbrakk>cGDERIV f x :> df; cGDERIV g x :> dg\<rbrakk>
     \<Longrightarrow> cGDERIV (\<lambda>x. f x * g x) x :> cnj (f x) *\<^sub>C dg + cnj (g x) *\<^sub>C df"
  unfolding cgderiv_def
  apply (rule has_derivative_subst)
   apply (erule (1) has_derivative_mult)
  apply (rule ext)
  by (simp add: cinner_add ac_simps)

lemma cGDERIV_inverse:
  "\<lbrakk>cGDERIV f x :> df; f x \<noteq> 0\<rbrakk>
     \<Longrightarrow> cGDERIV (\<lambda>x. inverse (f x)) x :> - cnj ((inverse (f x))\<^sup>2) *\<^sub>C df"
  by (metis DERIV_inverse cGDERIV_DERIV_compose complex_cnj_cnj complex_cnj_minus numerals(2))

(* Don't know if this holds: *)
(* lemma cGDERIV_norm:
  assumes "x \<noteq> 0" shows "cGDERIV (\<lambda>x. norm x) x :> sgn x"
*)

lemma has_derivative_norm[derivative_intros]:
  fixes x :: "'a::complex_inner"
  assumes "x \<noteq> 0"
  shows "(norm has_derivative (\<lambda>h. Re (cinner (sgn x) h))) (at x)"
  thm has_derivative_norm
proof -
  have Re_pos: "0 < Re (cinner x x)"
    using assms
    by (metis Re_strict_mono cinner_gt_zero_iff zero_complex.simps(1))
  have Re_plus_Re: "Re (cinner x y) + Re (cinner y x) = 2 * Re (cinner x y)"
    for x y :: 'a
    by (metis cinner_commute cnj.simps(1) mult_2_right semiring_normalization_rules(7))
  have norm: "norm x = sqrt (Re (cinner x x))" for x :: 'a
    apply (subst norm_eq_sqrt_cinner, subst cmod_Re)
    using cinner_ge_zero by auto
  have v2:"((\<lambda>x. sqrt (Re (cinner x x))) has_derivative
          (\<lambda>xa. (Re (cinner x xa) + Re (cinner xa x)) * (inverse (sqrt (Re (cinner x x))) / 2))) (at x)"
    by (rule derivative_eq_intros | simp add: Re_pos)+
  have v1: "((\<lambda>x. sqrt (Re (cinner x x))) has_derivative (\<lambda>y. Re (cinner x y) / sqrt (Re (cinner x x)))) (at x)"
    if "((\<lambda>x. sqrt (Re (cinner x x))) has_derivative (\<lambda>xa. Re (cinner x xa) * inverse (sqrt (Re (cinner x x))))) (at x)"
    using that apply (subst divide_real_def)
    by simp
  have \<open>(norm has_derivative (\<lambda>y. Re (cinner x y) / norm x)) (at x)\<close>
    using v2
    apply (auto simp: Re_plus_Re norm [abs_def])
    using v1 by blast
  then show ?thesis
    by (auto simp: power2_eq_square sgn_div_norm scaleR_scaleC)
qed

bundle cinner_syntax begin
notation cinner (infix "\<bullet>\<^sub>C" 70)
end

bundle no_cinner_syntax begin
no_notation cinner (infix "\<bullet>\<^sub>C" 70)
end

end


theory HL_State
imports
  Main
  "~~/src/HOL/Library/State_Monad"
begin

section\<open>Introduction\<close>

section\<open>Hoare calculus\<close>
text\<open>Basic definitions that can be useful inside as a parameter to spec in a proof\<close>
definition TT:: "'a \<Rightarrow> bool" where "TT x = True"
definition TTT:: "'b \<Rightarrow> 'a \<Rightarrow> bool" where "TTT x y = True"
definition FF:: "'a \<Rightarrow> bool" where "FF x = False"
definition GG:: "('a \<Rightarrow> bool) \<Rightarrow> ('b => 'a \<Rightarrow> bool)" where "GG p x = p"
definition UU:: "('a \<Rightarrow> bool) \<Rightarrow> (unit => 'a \<Rightarrow> bool)" where "UU p x = p"

text\<open>Methods to get describe the basic state changes. These are described by state-monad which encapsulates the state\<close>
definition return:: "'a \<Rightarrow> ('b, 'a) state" where "return = State_Monad.return"
definition get_state:: "('a, 'a) state" where "get_state = State (\<lambda>x. (x,x))"
definition put_state:: "'a \<Rightarrow> ('a, unit) state" where "put_state x = State (\<lambda>_. ((),x))"

definition unpack_state:: "('a, unit) state \<Rightarrow> 'a \<Rightarrow> 'a" where
  "unpack_state S x \<equiv> snd(run_state S x)"

type_synonym 'a bexp = "'a \<Rightarrow> bool"
type_synonym 'a assn = "'a \<Rightarrow> bool"

subsubsection\<open>Commands\<close>
text\<open>Commands describe that can be done in the langagauge.\<close>
text\<open>I have assumed that all calls eventually be reduces to basic commands which involves manipulation of the state-monad.\<close>
datatype 'a com =
  Basic "('a, unit) state"
| Seq  "'a com" "'a com"                     ("(_;/ _)"      [61,60] 60)
| Cond "'a bexp" "'a com" "'a com"           ("(1IF _/ THEN _ / ELSE _/ FI)"  [0,0,0] 61)

text\<open>The skip-command is just a special command which leaves the state-monad unchanged. Put monad-identify - this should be a return\<close>
abbreviation annskip ("SKIP") where "SKIP == (State_Monad.return)"

type_synonym 'a sem = "('a, unit) state  => ('a, unit) state => bool"

text\<open>This could potentially be useful in the while-loop.
  It states that the predicate is not longer true in the base case, but that the final state has also been reached.
  The other case states that be predicate is true and it is possible to reach the base-case in a finite amount of steps.
 It is taken from: \url{http://isabelle.in.tum.de/dist/library/HOL/HOL-Isar_Examples/Hoare.html}\<close>
(*primrec iter :: "nat \<Rightarrow> 'a bexp \<Rightarrow> 'a sem \<Rightarrow> 'a sem"
  where
    "iter 0 b S s s' \<longleftrightarrow> \<not>b s \<and> s = s'"
  | "iter (Suc n) b S s s' \<longleftrightarrow> b s \<and> (\<exists>s''. S s s'' \<and> iter n b S s'' s')"
*)

text\<open>The semantics describe how the program should be interpreted. It takes a command and returns two states - the pre and post state of each command.\<close>
inductive Sem :: "'a com \<Rightarrow> 'a sem"
where
  "Sem (Basic f) s (f)"
| "Sem c1 s s'' \<Longrightarrow> Sem c2  s'' s' \<Longrightarrow> Sem (c1;c2) s s'"
| "b s \<Longrightarrow> Sem c1 s s' \<Longrightarrow> Sem (IF b THEN c1 ELSE c2 FI) s s'"
| "\<not>b s \<Longrightarrow> Sem c2 s s' \<Longrightarrow> Sem (IF b THEN c1 ELSE c2 FI) s s'"

inductive_cases [elim!]:
  "Sem (Basic f) s s'"
  "Sem (c1;c2) s s'"
  "Sem (IF b THEN c1 ELSE c2 FI) s s'"

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"
  where "Valid p c q \<longleftrightarrow> (\<forall>s s'. Sem c s s' \<longrightarrow>  p s \<longrightarrow> q (unpack_state s' s))"

lemma SkipRule: "p = q \<Longrightarrow> Valid p SKIP q"
by (auto simp:Valid_def)

lemma BasicRule: "\<forall>s. p s \<longrightarrow> q (unpack_state (f s) s) \<Longrightarrow> Valid p (Basic f) q"
  by (auto simp:Valid_def)

lemma SeqRule: "Valid p c1 q  \<Longrightarrow> Valid q c2 r  \<Longrightarrow> Valid p (c1;c2) r"
  apply (auto simp:Valid_def)
  sorry

lemma CondRule:
 "\<forall>s. p s \<longrightarrow> ((b s \<longrightarrow> w s) \<and> (\<not>b s \<longrightarrow>  w' s))
  \<Longrightarrow> Valid w c1 q \<Longrightarrow> Valid w' c2 q \<Longrightarrow> Valid p (Cond b c1 c2) q"
  by (auto simp:Valid_def)

definition get:: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) state" where
  "get v = do { x \<leftarrow> get_state; return (v x) }"

definition put:: "('a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> ('a, unit) state" where
  "put vu a = do { x \<leftarrow> get_state; put_state (vu x a) }"

definition assign:: "('a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a, unit) state" where
  "assign vu v =  (do { a \<leftarrow> get v; put vu a })"

definition assign1 :: "('a \<Rightarrow> 'b \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a com" ("(2_ :=/ _)" [70, 65] 61) where
  "assign1 vu v = Basic (\<lambda>e. do { a \<leftarrow> get v; put vu a })"

text\<open>This is what enables the \<close>
syntax
  "_hoare_vars" :: "[idts, 'a assn,'a com,'a assn] \<Rightarrow> bool" ("(VARS _ //{_} // _ // {_})" [0,0,55,0] 50)

text\<open>This is what enables the \<close>
syntax
  "_hoare" :: "['a assn,'a com,'a assn] => bool" ("({_} // _ // {_})" [0,55,0] 50)

definition spec:: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) state \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "spec p S q = (\<forall>x. p x  \<longrightarrow> (let (y, z) = run_state S x in q y z))"

subsection\<open>Hoare logic\<close>
text\<open>Rules based on section 3 in Verification of Sequential and Concurrent Programs\<close>
theorem get_state_rule: "spec (\<lambda>x. p x x) (get_state) p"
  by (simp add: get_state_def spec_def)

text\<open>Rule to extract a value from the Monad\<close>
theorem get_rule: "\<forall>x. spec (\<lambda>y. p y \<and> v x = v y) (S (v x)) q \<Longrightarrow> spec p (get v \<bind> S) q"
  by (simp add: spec_def get_def return_def case_prod_unfold get_state_def)

theorem return_rule: "spec (p v) (return v) p"
  by (simp add: return_def spec_def)

text\<open>The sequential rule describes all intermediate states that can be both a post-condition of statement @{text S}
  with the pre-condition @{text p} which after execution of statement @{text T} will result in a final-state of @{text r}\<close>
theorem seq_rule: "\<lbrakk>spec p S q; \<forall>x. spec (q x) T r\<rbrakk> \<Longrightarrow> spec p (do { S; T }) r"
  apply (simp add: spec_def)
  by fastforce

text\<open>Rule to capture scope of local variables\<close>
theorem let_rule: "let v = E in spec p (do { T }) r \<Longrightarrow> spec p (do { let v = E; T }) r"
  by (simp add: spec_def snd_def)

text\<open>Pre- and post-conditions can be conjoined\<close>
theorem conj_rule: "\<lbrakk>spec p S q; spec r S s\<rbrakk> \<Longrightarrow> spec (\<lambda>x. p x \<and> r x) S (\<lambda>x y. q x y \<and> s x y)"
  apply (simp add: spec_def)
  by (simp add: case_prod_unfold)

text\<open>A conjunction of the post-condition can be split up and be proved separately\<close>
theorem conj_rule_right: "\<lbrakk>spec p S q; spec p S s\<rbrakk> \<Longrightarrow> spec p S (\<lambda>x y. q x y \<and> s x y)"
  apply (simp add: spec_def)
  by (simp add: case_prod_unfold)

text\<open>A pre-condition be weaken if it still preserves the post-condition (Weakest pre-condition)\<close>
theorem weaken_rule: "\<lbrakk>\<forall>x. (p x \<longrightarrow> p0 x); spec p0 S q\<rbrakk> \<Longrightarrow> spec p S q"
  by (simp add: spec_def)

text\<open>A post-condition can be strengthen if it gets preserved by the pre-condition\<close>
theorem strengthen_rule: "\<lbrakk>\<forall>x y. (q0 x y \<longrightarrow> q x y); spec p S q0\<rbrakk> \<Longrightarrow> spec p S q"
  apply (simp add: spec_def)
  by (simp add: case_prod_unfold)

text\<open>A conditional statement can be split up into multiple proofs with difference assumptions (based on the queteria)\<close>
theorem cond_rule: "\<lbrakk>spec (\<lambda>x. p x \<and> b) S q; spec (\<lambda>x. p x \<and> \<not>b) T q\<rbrakk> \<Longrightarrow> spec p (if b then S else T) q"
  by (simp add: spec_def)

end


section "Solution to Day 1 of AoC 2020"

theory day1
  imports Main "HOL.Code_Numeral" string_utils
begin

text "This is a solution to the puzzle for day 1"

subsection "Input parsing"

definition parse_input :: "string \<Rightarrow> natural list"
  where "parse_input s = map str_to_nat (split CHR ''\<newline>'' (trim s))"

subsection "Solution Algorithm"

text "prod\\_of\\_sum takes a target number and a list of input numbers, finds the first pair that
sums to the target number, and returns the product of those two numbers"

fun prod_of_sum :: "natural \<Rightarrow> natural list \<Rightarrow> natural"
  where "prod_of_sum t (Cons h rest) = (if (List.member rest (t - h)) then (h * (t - h)) else (prod_of_sum t rest))"
  |"prod_of_sum t Nil = 0"

text "The solution to part 1 is simply $$(@{const prod_of_sum} 2020)$$ applied to the input list"

fun part1 :: "String.string \<Rightarrow> natural"
  where "part1 a = (prod_of_sum 2020 (parse_input a))"

text "For the second part we need to do a little bit more checking, we now need three different
numbers from the list to add to the target value of 2020"

fun prod3_of_sum :: "natural \<Rightarrow> natural list \<Rightarrow> natural"
  where "prod3_of_sum t (Cons h rest) =
    (let p = (h * (prod_of_sum (t - h) rest)) in
        (if (p = 0) then (prod3_of_sum t rest) else p)
    )
   "
  |"prod3_of_sum t Nil = 0"

fun part2 :: "String.string \<Rightarrow> natural"
  where "part2 s = prod3_of_sum 2020 (parse_input s)"

subsection "Testing"

text "We expect our test case to return 514579"

definition example_input :: "string" where "example_input = ''1721
979
366
299
675
1456
''"

lemma "part1 example_input = 514579"
  by eval

text "We expect our test case for part 2 to return 241861950"

lemma "part2 example_input = 241861950"
  by eval

export_code "part1" "part2" in Haskell module_name Solution

end


theory Signal
  imports Complex_Main

begin

fun Cons_sort :: "(real\<times>'v) \<Rightarrow> (real\<times>'v) list \<Rightarrow> (real\<times>'v) list" where
"Cons_sort y [] = [y]"
| "Cons_sort y (x#xs) = (if fst y < fst x then (y#(x#xs)) else (x#xs))"

lemma Cons_sort_works:
  fixes y :: "(real\<times>'v)" and ys :: "(real \<times> 'v) list"
  assumes "sorted_wrt (<) (map fst ys)"
  shows "sorted_wrt (<) (map fst (Cons_sort y ys))"
proof (cases "(fst y) < (fst (ys!0)) \<and> ys \<noteq> []")
  case True
  then show ?thesis
    using Cons_sort.elims assms in_set_conv_nth leI list.simps(9) not_less_zero nth_Cons_0
      sorted_nth_mono strict_sorted_iff strict_sorted_simps(2)
    by (smt (verit, best))
next
  case False
  then show ?thesis
    using Cons_sort.simps(1) Cons_sort.elims assms list.simps(8,9) nth_Cons_0 sorted_wrt1
    by metis
qed

typedef 'v signal = "{xs::(real\<times>'v) list. sorted_wrt (<) (map fst xs)}"
  morphisms to_list to_sig
  apply (rule_tac x=Nil in exI)
  by force

declare to_sig_inverse [simp]
    and to_list_inverse [simp]

thm list.induct

setup_lifting type_definition_signal

lift_definition sNil :: "'v signal" is Nil by simp
lift_definition ssCons :: "(real\<times>'v) \<Rightarrow> 'v signal \<Rightarrow> (real\<times>'v) list" is Cons .
lift_definition ssmap :: "((real\<times>'v) \<Rightarrow> 'a) \<Rightarrow> 'v signal \<Rightarrow> 'a list" is "map" .
lift_definition srel :: "((real\<times>'v) \<Rightarrow> (real\<times>'v) \<Rightarrow> bool) \<Rightarrow> 'v signal \<Rightarrow> 'v signal \<Rightarrow> bool" is "list_all2" .
lift_definition spred :: "((real\<times>'v) \<Rightarrow> bool) \<Rightarrow> 'v signal \<Rightarrow> bool" is "list_all" .
lift_definition snth :: "'v signal \<Rightarrow> nat \<Rightarrow> (real\<times>'v)" (infixl "!!" 90) is "(!)" .
lift_definition slength :: "'v signal \<Rightarrow> nat" is "length" .
lift_definition shd :: "'v signal \<Rightarrow> (real\<times>'v)" is "hd" .
lift_definition stl :: "'v signal \<Rightarrow> 'v signal" is "tl"
  by (simp add: distinct_tl map_tl sorted_tl strict_sorted_iff)
lift_definition sCons :: "(real\<times>'v) \<Rightarrow> 'v signal \<Rightarrow> 'v signal" (infixl "##" 90) is Cons_sort
  using Cons_sort_works by blast

lemma sCons_works:
  fixes t1 :: "(real\<times>'v)" and t :: "'v signal"
  shows "sorted_wrt (<) (map fst (to_list (sCons t1 t)))"
  using Cons_sort_works to_list
  by fastforce

lemma signal_rep:
  "t = sNil \<or> (\<exists>p t'. (fst p < fst (t'!!0) \<or> t' = sNil) \<and> t = sCons p t')"
proof (cases "t=sNil")
  case True
  then show ?thesis by blast
next
  case False
  then show ?thesis
  proof (cases "slength t = 1")
    case True
    then have "t=sCons (shd t) sNil"
      using \<open>\<not>(t=sNil)\<close>

lemma [case_names sNil sCons, cases type: signal]:
  \<comment> \<open>for backward compatibility -- names of variables differ\<close>
  "(y = sNil \<Longrightarrow> P) \<Longrightarrow> (\<And>a signal. y = sCons a signal \<Longrightarrow> P) \<Longrightarrow> P"
  by (metis order_less_irrefl sCons_def)

lemma [case_names sNil ssCons, induct type: signal]:
  \<comment> \<open>for backward compatibility -- names of variables differ\<close>
  "P sNil \<Longrightarrow> (\<And>a signal. P signal \<Longrightarrow> P (sCons a signal)) \<Longrightarrow> P signal"
proof -
  {assume "P sNil"
    assume "\<And>a signal. P signal \<Longrightarrow> P (sCons a signal)"
    have "P signal"
    proof (induct "slength signal")
      case 0
      then have "signal = sNil"
        using length_greater_0_conv list.size(3) sNil.abs_eq slength.rep_eq to_list_inverse
        by metis
      then show ?thesis
        using \<open>P sNil\<close>
        by blast
    next
      case (Suc n)
      then obtain p t' where "signal = sCons p t'"
        using order_less_irrefl sCons_def
        by metis
      then show ?thesis
      proof (cases "fst p \<le>
      have "slength t' = n"
        using Suc
      then show ?thesis
        using \<open>\<And>a signal. P signal \<Longrightarrow> P (sCons a signal)\<close> Suc

  have "sorted_wrt (<) (map fst (to_list signal))"
    using to_list
    by blast
  have "P  (to_sig [])"
    using \<open>P sNil\<close> sNil_def
    by metis
  then have "(P \<circ> to_sig) []"
    by simp
  have 1:"\<And>a signal. P signal \<Longrightarrow>
    P (if fst a < fst (signal!!0) then to_sig (a#(to_list signal)) else signal)"
    using \<open>\<And>a signal. P signal \<Longrightarrow> P (sCons a signal)\<close> sCons_def
    by (metis (full_types))
  {fix a :: "(real\<times>'a)" and signal :: "'a signal"
    {assume 2: "P (to_sig (to_list signal))"
      then have "P (sCons
    have "P (to_sig (to_list signal)) \<Longrightarrow> P (to_sig (a#(to_list signal)))"
    proof -
      {assume 2:

setup \<open>Sign.mandatory_path "signal"\<close>

lemmas inducts = signal.induct
lemmas recs = signal.rec
lemmas cases = signal.case

setup \<open>Sign.parent_path\<close>

lemmas set_simps = list.set (* legacy *)

definition smap :: "('v \<Rightarrow> 'a) \<Rightarrow> 'v signal \<Rightarrow> 'a signal" where
"smap f t = to_sig (map (\<lambda>x. (fst x, f (snd x))) (to_list t))"

definition sfind :: "real \<Rightarrow> 'v signal \<Rightarrow> 'v" where
"sfind x t = (snd (the (find (\<lambda>y. fst y = x) (to_list t))))"

lemma smap_nth:
  assumes "n<slength t"
  shows "snth (smap f t) n = (fst ((to_list t)!n), f (snd ((to_list t)!n)))"
proof -
  have 1:"distinct (map fst (to_list t)) \<and> sorted (map fst (to_list t))"
    using to_list strict_sorted_iff
    by auto
  have "\<forall>n<length (to_list t). fst ((map (\<lambda>x. (fst x, f (snd x))) (to_list t))!n) = fst ((to_list t)!n)"
    by force
  then have 2:"distinct (map fst (map (\<lambda>x. (fst x, f (snd x))) (to_list t)))
    \<and> sorted (map fst (map (\<lambda>x. (fst x, f (snd x))) (to_list t)))"
    using 1 length_map list_eq_iff_nth_eq nth_map
    by (metis (mono_tags, lifting))
  have "\<And>t. snth t n = (to_list t)!n"
    by transfer simp
  then have "snth (smap f t) n = (to_list (smap f t))!n"
    by auto
  then have "snth (smap f t) n = (to_list (to_sig (map (\<lambda>x. (fst x, f (snd x))) (to_list t))))!n"
    using smap_def
    by metis
  then have "snth (smap f t) n = (map (\<lambda>x. (fst x, f (snd x))) (to_list t))!n"
    using to_sig_inverse 2 strict_sorted_iff
    by fastforce
  then show ?thesis
    using assms length_map list_update_id map_update nth_list_update_eq slength.rep_eq
    by (metis (no_types, lifting))
qed

end


(*  Title:      Dual_Lattice.thy
    Author:     Peter Gammie, borrowing from Makarius's Lattice theory
                More modifications by Brian Huffman
*)

header {* Lattice operations on dually-ordered types *}

theory Dual_Lattice
imports Main
begin

text {*
  The \emph{dual} of an ordered structure is an isomorphic copy of the
  underlying type, with the @{text \<le>} relation defined as the inverse
  of the original one.
*}

datatype 'a dual = dual 'a

primrec undual :: "'a dual \<Rightarrow> 'a" where
  undual_dual: "undual (dual x) = x"

lemma dual_undual [simp]: "dual (undual x') = x'"
  by (cases x') simp

lemma undual_comp_dual [simp]:
  "undual \<circ> dual = id"
  by (simp add: fun_eq_iff)

lemma dual_comp_undual [simp]:
  "dual \<circ> undual = id"
  by (simp add: fun_eq_iff)

lemma dual_eq_iff: "x = y \<longleftrightarrow> undual x = undual y"
  by (induct x, induct y, simp)

subsection {* Pointwise ordering *}

instantiation dual :: (ord) ord
begin

definition
  "x \<le> y \<longleftrightarrow> undual y \<le> undual x"

definition
  "(x::'a dual) < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"

instance ..

end

lemma undual_leq [iff?]: "(undual x' \<le> undual y') = (y' \<le> x')"
  by (simp add: less_eq_dual_def)

lemma dual_leq [intro?, simp]: "(dual x \<le> dual y) = (y \<le> x)"
  by (simp add: less_eq_dual_def)

(* FIXME maybe this isn't so useful. *)

text {*
  \medskip Functions @{term dual} and @{term undual} are inverse to
  each other; this entails the following fundamental properties.
*}

text {*
  \medskip Since @{term dual} (and @{term undual}) are both injective
  and surjective, the basic logical connectives (equality,
  quantification etc.) are transferred as follows.
*}

lemma undual_equality [iff?]: "(undual x' = undual y') = (x' = y')"
  by (cases x', cases y') simp

lemma dual_equality [iff?]: "(dual x = dual y) = (x = y)"
  by simp

(* BH: a generalization of dual_ball[symmetric] is already in ball_simps *)
(* BH: This proof can be replaced with "by simp" *)
lemma dual_ball [iff?]: "(\<forall>x \<in> A. P (dual x)) = (\<forall>x' \<in> dual ` A. P x')"
  by simp

lemma range_dual [simp]: "surj dual"
proof -
  have "\<And>x'. dual (undual x') = x'" by simp
  thus "surj dual" by (rule surjI)
qed

lemma dual_all [iff?]: "(\<forall>x. P (dual x)) = (\<forall>x'. P x')"
proof -
  have "(\<forall>x \<in> UNIV. P (dual x)) = (\<forall>x' \<in> dual ` UNIV. P x')"
    by (rule dual_ball)
  thus ?thesis by simp
qed

lemma dual_ex: "(\<exists>x. P (dual x)) = (\<exists>x'. P x')"
proof -
  have "(\<forall>x. \<not> P (dual x)) = (\<forall>x'. \<not> P x')"
    by (rule dual_all)
  thus ?thesis by blast
qed

lemma dual_Collect: "{dual x| x. P (dual x)} = {x'. P x'}"
proof -
  have "{dual x| x. P (dual x)} = {x'. \<exists>x''. x' = x'' \<and> P x''}"
    by (simp only: dual_ex [symmetric])
  thus ?thesis by blast
qed

instance dual :: (preorder) preorder
proof
  fix x y z :: "'a dual"
  show "x < y \<longleftrightarrow> x \<le> y \<and> \<not> y \<le> x"
    by (rule less_dual_def)
  show "x \<le> x"
    unfolding less_eq_dual_def
    by fast
  assume "x \<le> y" and "y \<le> z" thus "x \<le> z"
    unfolding less_eq_dual_def
    by (fast elim: order_trans)
qed

instance dual :: (order) order
  by default (auto simp: less_eq_dual_def undual_equality)

subsection {* Binary infimum and supremum *}

text {*
  The class of lattices is closed under formation of dual structures.
  This means that for any theorem of lattice theory, the dualized
  statement holds as well; this important fact simplifies many proofs
  of lattice theory.
*}

instantiation dual :: (semilattice_sup) semilattice_inf
begin

definition
  "inf f g = dual (sup (undual f) (undual g))"

instance
  by default (auto simp: inf_dual_def less_eq_dual_def)

end

instantiation dual :: (semilattice_inf) semilattice_sup
begin

definition
  "sup f g = dual (inf (undual f) (undual g))"

instance
  by default (auto simp: sup_dual_def less_eq_dual_def)

end

instance dual :: (lattice) lattice ..

text {*
  Apparently, the @{text \<sqinter>} and @{text \<squnion>} operations are dual to each
  other.
*}

theorem dual_inf [intro?]: "dual (inf x y) = sup (dual x) (dual y)"
  unfolding sup_dual_def by simp
(* BH: Why the "intro?" attribute? Why not just "simp"? *)

theorem dual_sup [intro?]: "dual (sup x y) = inf (dual x) (dual y)"
  unfolding inf_dual_def by simp

lemma undual_inf [simp]: "undual (inf x y) = sup (undual x) (undual y)"
  unfolding inf_dual_def by (rule undual_dual)

lemma undual_sup [simp]: "undual (sup x y) = inf (undual x) (undual y)"
  unfolding sup_dual_def by (rule undual_dual)

text {*
  Infimum and supremum are dual to each other.
*}

theorem dual_inf' [iff?]:
    "(inf (dual x) (dual y) = s) = (sup x y = undual s)"
  by (cases s) (simp add: inf_dual_def)
(* BH: This rule seems very contrived. When is it ever useful? *)

theorem dual_sup' [iff?]:
    "(sup (dual x) (dual y) = s) = (inf x y = undual s)"
  by (cases s) (simp add: sup_dual_def)

instance dual :: (distrib_lattice) distrib_lattice
  by default (simp add: inf_dual_def sup_dual_def inf_sup_distrib1)

subsection {* Top and bottom elements *}

instantiation dual :: (order_top) order_bot
begin

definition
  "bot = dual top"

instance
  by default (simp add: bot_dual_def less_eq_dual_def)

end

instantiation dual :: (order_bot) order_top
begin

definition
  "top = dual bot"

instance
  by default (simp add: top_dual_def less_eq_dual_def)

end

instance dual :: (bounded_lattice_top) bounded_lattice_bot ..

instance dual :: (bounded_lattice_bot) bounded_lattice_top ..

instance dual :: (bounded_lattice) bounded_lattice ..

text {*
  Likewise are @{text \<bottom>} and @{text \<top>} duals of each other.
*}

theorem dual_bot [intro?, simp]: "dual bot = top"
  unfolding bot_dual_def top_dual_def by simp
(* BH: What is the "intro?" attribute for? *)

theorem dual_top [intro?, simp]: "dual top = bot"
  unfolding bot_dual_def top_dual_def by simp

theorem undual_bot [simp]: "undual bot = top"
  unfolding bot_dual_def by (rule undual_dual)

theorem undual_top [simp]: "undual top = bot"
  unfolding top_dual_def by (rule undual_dual)

instantiation dual :: (uminus) uminus
begin

definition
  "- x = dual (- undual x)"

instance ..

end

lemma undual_minus [simp]: "undual (- x) = - undual x"
  unfolding uminus_dual_def by (rule undual_dual)

instantiation dual :: (boolean_algebra) boolean_algebra
begin

definition
  "(x::'a dual) - y = inf x (- y)"

instance
  by default
    (auto simp: dual_eq_iff sup_compl_top inf_compl_bot minus_dual_def)

end

subsection {* Complete lattice operations *}

text {*
  The class of complete lattices is closed under formation of dual
  structures.
*}

instantiation dual :: (complete_lattice) complete_lattice
begin

definition
  "Sup A \<equiv> dual (INFIMUM A undual)"

definition
  "Inf A \<equiv> dual (SUPREMUM A undual)"

instance
apply intro_classes
apply (auto simp: less_eq_dual_def less_dual_def Sup_dual_def Inf_dual_def
                  INF_lower SUP_upper
           intro: INF_greatest SUP_least)
done

end

lemma SUP_dual_unfold:
  "SUPREMUM A f = dual (INFIMUM A (undual \<circ> f))"
  by (simp add: SUP_def Sup_dual_def)

lemma INF_dual_unfold:
  "INFIMUM A f = dual (SUPREMUM A (undual \<circ> f))"
  by (simp add: INF_def Inf_dual_def)

text {*
  Apparently, the @{text \<Sqinter>} and @{text \<Squnion>} operations are dual to each
  other.
*}

theorem dual_Inf [intro?]: "dual (Inf A) = Sup (dual ` A)"
  unfolding Inf_dual_def Sup_dual_def by (simp add: image_image)
(* BH: Why not [simp]? *)

theorem dual_Sup [intro?]: "dual (Sup A) = Inf (dual ` A)"
  unfolding Inf_dual_def Sup_dual_def by (simp add: image_image)
(* BH: Why not [simp]? *)

lemma undual_Inf: "undual (Inf A) = Sup (undual ` A)"
  unfolding Inf_dual_def by simp

lemma undual_Sup: "undual (Sup A) = Inf (undual ` A)"
  unfolding Sup_dual_def by simp

theorem dual_Inf' [iff?]:
    "(Inf (dual ` A) = dual s) = (Sup A = s)"
  unfolding Inf_dual_def Sup_dual_def by (simp add: image_image)
(* BH: When would this lemma ever be useful? *)

theorem dual_Sup' [iff?]:
    "(Sup (dual ` A) = dual i) = (Inf A = i)"
  unfolding Inf_dual_def Sup_dual_def by (simp add: image_image)

end


(*  Title:      HOL/ex/ThreeDivides.thy
    Author:     Benjamin Porter, 2005
*)

section \<open>Three Divides Theorem\<close>

theory ThreeDivides
imports Main "HOL-Library.LaTeXsugar"
begin

subsection \<open>Abstract\<close>

text \<open>
The following document presents a proof of the Three Divides N theorem
formalised in the Isabelle/Isar theorem proving system.

{\em Theorem}: $3$ divides $n$ if and only if $3$ divides the sum of all
digits in $n$.

{\em Informal Proof}:
Take $n = \sum{n_j * 10^j}$ where $n_j$ is the $j$'th least
significant digit of the decimal denotation of the number n and the
sum ranges over all digits. Then $$ (n - \sum{n_j}) = \sum{n_j * (10^j
- 1)} $$ We know $\forall j\; 3|(10^j - 1) $ and hence $3|LHS$,
therefore $$\forall n\; 3|n \Longleftrightarrow 3|\sum{n_j}$$
\<open>\<box>\<close>
\<close>

subsection \<open>Formal proof\<close>

subsubsection \<open>Miscellaneous summation lemmas\<close>

text \<open>If $a$ divides \<open>A x\<close> for all x then $a$ divides any
sum over terms of the form \<open>(A x)*(P x)\<close> for arbitrary $P$.\<close>

lemma div_sum:
  fixes a::nat and n::nat
  shows "\<forall>x. a dvd A x \<Longrightarrow> a dvd (\<Sum>x<n. A x * D x)"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc n)
  from Suc
  have "a dvd (A n * D n)" by (simp add: dvd_mult2)
  with Suc
  have "a dvd ((\<Sum>x<n. A x * D x) + (A n * D n))" by (simp add: dvd_add)
  thus ?case by simp
qed

subsubsection \<open>Generalised Three Divides\<close>

text \<open>This section solves a generalised form of the three divides
problem. Here we show that for any sequence of numbers the theorem
holds. In the next section we specialise this theorem to apply
directly to the decimal expansion of the natural numbers.\<close>

text \<open>Here we show that the first statement in the informal proof is
true for all natural numbers. Note we are using \<^term>\<open>D i\<close> to
denote the $i$'th element in a sequence of numbers.\<close>

lemma digit_diff_split:
  fixes n::nat and nd::nat and x::nat
  shows "n = (\<Sum>x\<in>{..<nd}. (D x)*((10::nat)^x)) \<Longrightarrow>
             (n - (\<Sum>x<nd. (D x))) = (\<Sum>x<nd. (D x)*(10^x - 1))"
by (simp add: sum_diff_distrib diff_mult_distrib2)

text \<open>Now we prove that 3 always divides numbers of the form $10^x - 1$.\<close>
lemma three_divs_0:
  shows "(3::nat) dvd (10^x - 1)"
proof (induct x)
  case 0 show ?case by simp
next
  case (Suc n)
  let ?thr = "(3::nat)"
  have "?thr dvd 9" by simp
  moreover
  have "?thr dvd (10*(10^n - 1))" by (rule dvd_mult) (rule Suc)
  hence "?thr dvd (10^(n+1) - 10)" by (simp add: nat_distrib)
  ultimately
  have"?thr dvd ((10^(n+1) - 10) + 9)"
    by (simp only: ac_simps) (rule dvd_add)
  thus ?case by simp
qed

text \<open>Expanding on the previous lemma and lemma \<open>div_sum\<close>.\<close>
lemma three_divs_1:
  fixes D :: "nat \<Rightarrow> nat"
  shows "3 dvd (\<Sum>x<nd. D x * (10^x - 1))"
  by (subst mult.commute, rule div_sum) (simp add: three_divs_0 [simplified])

text \<open>Using lemmas \<open>digit_diff_split\<close> and
\<open>three_divs_1\<close> we now prove the following lemma.
\<close>
lemma three_divs_2:
  fixes nd::nat and D::"nat\<Rightarrow>nat"
  shows "3 dvd ((\<Sum>x<nd. (D x)*(10^x)) - (\<Sum>x<nd. (D x)))"
proof -
  from three_divs_1 have "3 dvd (\<Sum>x<nd. D x * (10 ^ x - 1))" .
  thus ?thesis by (simp only: digit_diff_split)
qed

text \<open>
We now present the final theorem of this section. For any
sequence of numbers (defined by a function \<^term>\<open>D :: (nat\<Rightarrow>nat)\<close>),
we show that 3 divides the expansive sum $\sum{(D\;x)*10^x}$ over $x$
if and only if 3 divides the sum of the individual numbers
$\sum{D\;x}$.
\<close>
lemma three_div_general:
  fixes D :: "nat \<Rightarrow> nat"
  shows "(3 dvd (\<Sum>x<nd. D x * 10^x)) = (3 dvd (\<Sum>x<nd. D x))"
proof
  have mono: "(\<Sum>x<nd. D x) \<le> (\<Sum>x<nd. D x * 10^x)"
    by (rule sum_mono) simp
  txt \<open>This lets us form the term
         \<^term>\<open>(\<Sum>x<nd. D x * 10^x) - (\<Sum>x<nd. D x)\<close>\<close>

  {
    assume "3 dvd (\<Sum>x<nd. D x)"
    with three_divs_2 mono
    show "3 dvd (\<Sum>x<nd. D x * 10^x)"
      by (blast intro: dvd_diffD)
  }
  {
    assume "3 dvd (\<Sum>x<nd. D x * 10^x)"
    with three_divs_2 mono
    show "3 dvd (\<Sum>x<nd. D x)"
      by (blast intro: dvd_diffD1)
  }
qed

subsubsection \<open>Three Divides Natural\<close>

text \<open>This section shows that for all natural numbers we can
generate a sequence of digits less than ten that represent the decimal
expansion of the number. We then use the lemma \<open>three_div_general\<close> to prove our final theorem.\<close>

text \<open>\medskip Definitions of length and digit sum.\<close>

text \<open>This section introduces some functions to calculate the
required properties of natural numbers. We then proceed to prove some
properties of these functions.

The function \<open>nlen\<close> returns the number of digits in a natural
number n.\<close>

fun nlen :: "nat \<Rightarrow> nat"
where
  "nlen 0 = 0"
| "nlen x = 1 + nlen (x div 10)"

text \<open>The function \<open>sumdig\<close> returns the sum of all digits in
some number n.\<close>

definition
  sumdig :: "nat \<Rightarrow> nat" where
  "sumdig n = (\<Sum>x < nlen n. n div 10^x mod 10)"

text \<open>Some properties of these functions follow.\<close>

lemma nlen_zero:
  "0 = nlen x \<Longrightarrow> x = 0"
  by (induct x rule: nlen.induct) auto

lemma nlen_suc:
  "Suc m = nlen n \<Longrightarrow> m = nlen (n div 10)"
  by (induct n rule: nlen.induct) simp_all

text \<open>The following lemma is the principle lemma required to prove
our theorem. It states that an expansion of some natural number $n$
into a sequence of its individual digits is always possible.\<close>

lemma exp_exists:
  "m = (\<Sum>x<nlen m. (m div (10::nat)^x mod 10) * 10^x)"
proof (induct "nlen m" arbitrary: m)
  case 0 thus ?case by (simp add: nlen_zero)
next
  case (Suc nd)
  obtain c where mexp: "m = 10*(m div 10) + c \<and> c < 10"
    and cdef: "c = m mod 10" by simp
  show "m = (\<Sum>x<nlen m. m div 10^x mod 10 * 10^x)"
  proof -
    from \<open>Suc nd = nlen m\<close>
    have "nd = nlen (m div 10)" by (rule nlen_suc)
    with Suc have
      "m div 10 = (\<Sum>x<nd. m div 10 div 10^x mod 10 * 10^x)" by simp
    with mexp have
      "m = 10*(\<Sum>x<nd. m div 10 div 10^x mod 10 * 10^x) + c" by simp
    also have
      "\<dots> = (\<Sum>x<nd. m div 10 div 10^x mod 10 * 10^(x+1)) + c"
      by (subst sum_distrib_left) (simp add: ac_simps)
    also have
      "\<dots> = (\<Sum>x<nd. m div 10^(Suc x) mod 10 * 10^(Suc x)) + c"
      by (simp add: div_mult2_eq[symmetric])
    also have
      "\<dots> = (\<Sum>x\<in>{Suc 0..<Suc nd}. m div 10^x  mod 10 * 10^x) + c"
      by (simp only: sum.shift_bounds_Suc_ivl)
         (simp add: atLeast0LessThan)
    also have
      "\<dots> = (\<Sum>x<Suc nd. m div 10^x mod 10 * 10^x)"
      by (simp add: atLeast0LessThan[symmetric] sum.atLeast_Suc_lessThan cdef)
    also note \<open>Suc nd = nlen m\<close>
    finally
    show "m = (\<Sum>x<nlen m. m div 10^x mod 10 * 10^x)" .
  qed
qed

text \<open>\medskip Final theorem.\<close>

text \<open>We now combine the general theorem \<open>three_div_general\<close>
and existence result of \<open>exp_exists\<close> to prove our final
theorem.\<close>

theorem three_divides_nat:
  shows "(3 dvd n) = (3 dvd sumdig n)"
proof (unfold sumdig_def)
  have "n = (\<Sum>x<nlen n. (n div (10::nat)^x mod 10) * 10^x)"
    by (rule exp_exists)
  moreover
  have "3 dvd (\<Sum>x<nlen n. (n div (10::nat)^x mod 10) * 10^x) =
        (3 dvd (\<Sum>x<nlen n. n div 10^x mod 10))"
    by (rule three_div_general)
  ultimately
  show "3 dvd n = (3 dvd (\<Sum>x<nlen n. n div 10^x mod 10))" by simp
qed

end