theory reverse_involution
imports Main
begin
datatype nat = zero | s nat
datatype lst = nil | cons nat lst

fun app :: "lst \<Rightarrow> lst \<Rightarrow> lst" where
"app nil xs = xs" |
"app (cons x xs) ys = cons x (app xs ys)"

fun rev :: "lst \<Rightarrow> lst" where
"rev nil = nil" |
"rev (cons x xs) = app (rev xs) (cons x nil)"

lemma app_nil: "app xs nil = xs"
proof(induct xs)
case nil
then show ?case by simp
next
case (cons x1 xs)
then show ?case by simp
qed

lemma app_assoc: "app (app xs ys) zs = app xs (app ys zs)"
proof(induct xs)
case nil
then show ?case by simp
next
case (cons x1 xs)
then show ?case by simp
qed

lemma rev_app: "rev (app xs ys) = app (rev ys) (rev xs)"
proof(induct xs)
case nil
then show ?case using app_nil by simp
next
case (cons x1 xs)
then show ?case using app_assoc by simp
qed

theorem "rev (rev xs) = xs"
proof(induct xs)
case nil
then show ?case by simp
next
  case (cons x1 xs)
  then show ?case using rev_app by simp
qed

end


(*
  Programming and Proving in Isabelle/HOL
  4. Isar: A Language for Structured Proofs
*)

(* 4.1 Isar by Example *)

theory "prog-prove-sample-4"
  imports Main
begin

lemma sample1 : "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: " \<forall> A. \<exists> a. A = f a" by (simp add: surj_def)
  from 1 have 2: "EX a. {x . x \<notin> f x} = f a" by blast
  from 2 show "False" by blast
qed

lemma sample2 : "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  have 1: " \<forall> A. \<exists> a. A = f a" using 0 by (simp add: surj_def)
  have 2: "EX a. {x . x \<notin> f x} = f a" using 1 by blast
  show "False" using 2 by blast
qed

(* 4.1.1 this, then, hence and thus *)

lemma sample3 : "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists> a. {x . x \<notin> f x} = f a" by(auto simp: surj_def)
  from this show "False" by blast
qed

lemma sample4 : "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists> a. {x . x \<notin> f x} = f a" by (auto simp: surj_def)
  thus "False" by blast
qed

(* 4.1.2 Structured Lemma Statements: fixes, assumes, shows *)

lemma sample5 :
  fixes f :: " 'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof -
  have "\<exists> a. {x . x \<notin> f x} = f a" using s by (auto simp: surj_def)
  thus "False" by blast
qed

(* 4.2 Proof Patterns *)

lemma sample6 : "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists> a. {x . x \<notin> f x} = f a" by (auto simp: surj_def)
  then obtain a where "{x . x \<notin> f x} = f a" by blast
  hence "a \<notin> f a \<longleftrightarrow> a \<in> f a" by blast
  thus "False" by blast
qed

(* 4.3.3 Raw Proof Blocks *)

lemma fixes a b :: int assumes "b dvd (a+b)" shows "b dvd a"
proof -
  {
    fix k assume k : "a + b = b * k"
    have "\<exists> k'. a = b * k'"
    proof
      show "a = b * (k - 1)" using k by(simp add: algebra_simps)
    qed
  }
  then show ?thesis using assms by (auto simp add: dvd_def)
qed

(* 4.4 Case Analysis and Induction *)
(* 4.4.1 Datatype Case Analysis *)

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
  assume "xs = []"
  thus ?thesis by simp
next
  fix y ys assume "xs = y # ys"
  thus ?thesis by simp
qed

(* 4.4.2 Structural Induction *)

lemma "\<Sum>{0..n :: nat} = n * (n + 1) div 2"
proof (induction n)
  show "\<Sum>{0..0 :: nat} = 0 * (0 + 1) div 2" by simp
next
  fix n assume "\<Sum>{0..n::nat} = n * (n + 1) div 2"
  thus "\<Sum>{0..Suc n} = Suc n * (Suc n + 1) div 2" by simp
qed

lemma "\<Sum>{0..n :: nat} = n * (n + 1) div 2" (is "?P n")
proof (induction n)
  show "?P 0" by simp
next
  fix n assume "?P n"
  thus "?P(Suc n)" by simp
qed

(* 4.4.4 Rule Induction *)

inductive ev :: "nat \<Rightarrow> bool" where
  ev0 : "ev 0" |
  evSS : "ev n \<Longrightarrow> ev(Suc(Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
  "evn 0 = True" |
  "evn (Suc 0) = False" |
  "evn (Suc(Suc n)) = evn n"

lemma "ev n \<Longrightarrow> evn n"
proof(induction rule: ev.induct)
  case ev0
  show ?case by simp
next
  case evSS
  thus ?case by simp
qed

end


section \<open> Healthiness Conditions \<close>

theory utp_healthy
  imports utp_pred_laws
begin

subsection \<open> Main Definitions \<close>

text \<open> We collect closure laws for healthiness conditions in the following theorem attribute. \<close>

named_theorems closure

type_synonym '\<alpha> health = "'\<alpha> upred \<Rightarrow> '\<alpha> upred"

text \<open> A predicate $P$ is healthy, under healthiness function $H$, if $P$ is a fixed-point of $H$. \<close>

definition Healthy :: "'\<alpha> upred \<Rightarrow> '\<alpha> health \<Rightarrow> bool" (infix "is" 30)
where "P is H \<equiv> (H P = P)"

lemma Healthy_def': "P is H \<longleftrightarrow> (H P = P)"
  unfolding Healthy_def by auto

lemma Healthy_if: "P is H \<Longrightarrow> (H P = P)"
  unfolding Healthy_def by auto

lemma Healthy_intro: "H(P) = P \<Longrightarrow> P is H"
  by (simp add: Healthy_def)

declare Healthy_def' [upred_defs]

abbreviation Healthy_carrier :: "'\<alpha> health \<Rightarrow> '\<alpha> upred set" ("\<lbrakk>_\<rbrakk>\<^sub>H")
where "\<lbrakk>H\<rbrakk>\<^sub>H \<equiv> {P. P is H}"

lemma Healthy_carrier_image:
  "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H \<Longrightarrow> \<H> ` A = A"
    by (auto simp add: image_def, (metis Healthy_if mem_Collect_eq subsetCE)+)

lemma Healthy_carrier_Collect: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> A = {H(P) | P. P \<in> A}"
  by (simp add: Healthy_carrier_image Setcompr_eq_image)

lemma Healthy_func:
  "\<lbrakk> F \<in> \<lbrakk>\<H>\<^sub>1\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<H>\<^sub>2\<rbrakk>\<^sub>H; P is \<H>\<^sub>1 \<rbrakk> \<Longrightarrow> \<H>\<^sub>2(F(P)) = F(P)"
  using Healthy_if by blast

lemma Healthy_comp:
  "\<lbrakk> P is \<H>\<^sub>1; P is \<H>\<^sub>2 \<rbrakk> \<Longrightarrow> P is \<H>\<^sub>1 \<circ> \<H>\<^sub>2"
  by (simp add: Healthy_def)

lemma Healthy_apply_closed:
  assumes "F \<in> \<lbrakk>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H" "P is H"
  shows "F(P) is H"
  using assms(1) assms(2) by auto

lemma Healthy_set_image_member:
  "\<lbrakk> P \<in> F ` A; \<And> x. F x is H \<rbrakk> \<Longrightarrow> P is H"
  by blast

lemma Healthy_case_prod [closure]:
  "\<lbrakk> \<And> x y. P x y is H \<rbrakk> \<Longrightarrow> case_prod P v is H"
  by (simp add: prod.case_eq_if)

lemma Healthy_SUPREMUM:
  "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> Sup (H ` A) = \<Sqinter> A"
  by (drule Healthy_carrier_image, presburger)

lemma Healthy_INFIMUM:
  "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> Inf (H ` A) = \<Squnion> A"
  by (drule Healthy_carrier_image, presburger)

lemma Healthy_nu [closure]:
  assumes "mono F" "F \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
  shows "\<nu> F is H"
  by (metis (mono_tags) Healthy_def Healthy_func assms eq_id_iff lfp_unfold)

lemma Healthy_mu [closure]:
  assumes "mono F" "F \<in> \<lbrakk>id\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
  shows "\<mu> F is H"
  by (metis (mono_tags) Healthy_def Healthy_func assms eq_id_iff gfp_unfold)

lemma Healthy_subset_member: "\<lbrakk> A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H; P \<in> A \<rbrakk> \<Longrightarrow> H(P) = P"
  by (meson Ball_Collect Healthy_if)

lemma is_Healthy_subset_member: "\<lbrakk> A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H; P \<in> A \<rbrakk> \<Longrightarrow> P is H"
  by blast

subsection \<open> Properties of Healthiness Conditions \<close>

definition Idempotent :: "'\<alpha> health \<Rightarrow> bool" where
  "Idempotent(H) \<longleftrightarrow> (\<forall> P. H(H(P)) = H(P))"

abbreviation Monotonic :: "'\<alpha> health \<Rightarrow> bool" where
  "Monotonic(H) \<equiv> mono H"

definition IMH :: "'\<alpha> health \<Rightarrow> bool" where
  "IMH(H) \<longleftrightarrow> Idempotent(H) \<and> Monotonic(H)"

definition Antitone :: "'\<alpha> health \<Rightarrow> bool" where
  "Antitone(H) \<longleftrightarrow> (\<forall> P Q. Q \<sqsubseteq> P \<longrightarrow> (H(P) \<sqsubseteq> H(Q)))"

definition Conjunctive :: "'\<alpha> health \<Rightarrow> bool" where
  "Conjunctive(H) \<longleftrightarrow> (\<exists> Q. \<forall> P. H(P) = (P \<and> Q))"

definition FunctionalConjunctive :: "'\<alpha> health \<Rightarrow> bool" where
  "FunctionalConjunctive(H) \<longleftrightarrow> (\<exists> F. \<forall> P. H(P) = (P \<and> F(P)) \<and> Monotonic(F))"

definition WeakConjunctive :: "'\<alpha> health \<Rightarrow> bool" where
  "WeakConjunctive(H) \<longleftrightarrow> (\<forall> P. \<exists> Q. H(P) = (P \<and> Q))"

definition Disjunctuous :: "'\<alpha> health \<Rightarrow> bool" where
  [upred_defs]: "Disjunctuous H = (\<forall> P Q. H(P \<sqinter> Q) = (H(P) \<sqinter> H(Q)))"

definition Continuous :: "'\<alpha> health \<Rightarrow> bool" where
  [upred_defs]: "Continuous H = (\<forall> A. A \<noteq> {} \<longrightarrow> H (\<Sqinter> A) = \<Sqinter> (H ` A))"

lemma Healthy_Idempotent [closure]:
  "Idempotent H \<Longrightarrow> H(P) is H"
  by (simp add: Healthy_def Idempotent_def)

lemma Healthy_range: "Idempotent H \<Longrightarrow> range H = \<lbrakk>H\<rbrakk>\<^sub>H"
  by (auto simp add: image_def Healthy_if Healthy_Idempotent, metis Healthy_if)

lemma Idempotent_id [simp]: "Idempotent id"
  by (simp add: Idempotent_def)

lemma Idempotent_comp [intro]:
  "\<lbrakk> Idempotent f; Idempotent g; f \<circ> g = g \<circ> f \<rbrakk> \<Longrightarrow> Idempotent (f \<circ> g)"
  by (auto simp add: Idempotent_def comp_def, metis)

lemma Idempotent_image: "Idempotent f \<Longrightarrow> f ` f ` A = f ` A"
  by (metis (mono_tags, lifting) Idempotent_def image_cong image_image)

lemma Monotonic_id [simp]: "Monotonic id"
  by (simp add: monoI)

lemma Monotonic_id' [closure]:
  "mono (\<lambda> X. X)"
  by (simp add: monoI)

lemma Monotonic_const [closure]:
  "Monotonic (\<lambda> x. c)"
  by (simp add: mono_def)

lemma Monotonic_comp [intro]:
  "\<lbrakk> Monotonic f; Monotonic g \<rbrakk> \<Longrightarrow> Monotonic (f \<circ> g)"
  by (simp add: mono_def)

lemma Monotonic_inf [closure]:
  assumes "Monotonic P" "Monotonic Q"
  shows "Monotonic (\<lambda> X. P(X) \<sqinter> Q(X))"
  using assms by (simp add: mono_def, rel_auto)

lemma Monotonic_cond [closure]:
  assumes "Monotonic P" "Monotonic Q"
  shows "Monotonic (\<lambda> X. P(X) \<triangleleft> b \<triangleright> Q(X))"
  by (simp add: assms cond_monotonic)

lemma Conjuctive_Idempotent:
  "Conjunctive(H) \<Longrightarrow> Idempotent(H)"
  by (auto simp add: Conjunctive_def Idempotent_def)

lemma Conjunctive_Monotonic:
  "Conjunctive(H) \<Longrightarrow> Monotonic(H)"
  unfolding Conjunctive_def mono_def
  using dual_order.trans by fastforce

lemma Conjunctive_conj:
  assumes "Conjunctive(HC)"
  shows "HC(P \<and> Q) = (HC(P) \<and> Q)"
  using assms unfolding Conjunctive_def
  by (metis utp_pred_laws.inf.assoc utp_pred_laws.inf.commute)

lemma Conjunctive_distr_conj:
  assumes "Conjunctive(HC)"
  shows "HC(P \<and> Q) = (HC(P) \<and> HC(Q))"
  using assms unfolding Conjunctive_def
  by (metis Conjunctive_conj assms utp_pred_laws.inf.assoc utp_pred_laws.inf_right_idem)

lemma Conjunctive_distr_disj:
  assumes "Conjunctive(HC)"
  shows "HC(P \<or> Q) = (HC(P) \<or> HC(Q))"
  using assms unfolding Conjunctive_def
  using utp_pred_laws.inf_sup_distrib2 by fastforce

lemma Conjunctive_distr_cond:
  assumes "Conjunctive(HC)"
  shows "HC(P \<triangleleft> b \<triangleright> Q) = (HC(P) \<triangleleft> b \<triangleright> HC(Q))"
  using assms unfolding Conjunctive_def
  by (metis cond_conj_distr utp_pred_laws.inf_commute)

lemma FunctionalConjunctive_Monotonic:
  "FunctionalConjunctive(H) \<Longrightarrow> Monotonic(H)"
  unfolding FunctionalConjunctive_def by (metis mono_def utp_pred_laws.inf_mono)

lemma WeakConjunctive_Refinement:
  assumes "WeakConjunctive(HC)"
  shows "P \<sqsubseteq> HC(P)"
  using assms unfolding WeakConjunctive_def by (metis utp_pred_laws.inf.cobounded1)

lemma WeakCojunctive_Healthy_Refinement:
  assumes "WeakConjunctive(HC)" and "P is HC"
  shows "HC(P) \<sqsubseteq> P"
  using assms unfolding WeakConjunctive_def Healthy_def by simp

lemma WeakConjunctive_implies_WeakConjunctive:
  "Conjunctive(H) \<Longrightarrow> WeakConjunctive(H)"
  unfolding WeakConjunctive_def Conjunctive_def by pred_auto

declare Conjunctive_def [upred_defs]
declare mono_def [upred_defs]

lemma Disjunctuous_Monotonic: "Disjunctuous H \<Longrightarrow> Monotonic H"
  by (metis Disjunctuous_def mono_def semilattice_sup_class.le_iff_sup)

lemma ContinuousD [dest]: "\<lbrakk> Continuous H; A \<noteq> {} \<rbrakk> \<Longrightarrow> H (\<Sqinter> A) = (\<Sqinter> P\<in>A. H(P))"
  by (simp add: Continuous_def)

lemma Continuous_Disjunctous: "Continuous H \<Longrightarrow> Disjunctuous H"
  apply (auto simp add: Continuous_def Disjunctuous_def)
  apply (rename_tac P Q)
  apply (drule_tac x="{P,Q}" in spec)
  apply (simp)
  done

lemma Continuous_Monotonic [closure]: "Continuous H \<Longrightarrow> Monotonic H"
  by (simp add: Continuous_Disjunctous Disjunctuous_Monotonic)

lemma Continuous_comp [intro]:
  "\<lbrakk> Continuous f; Continuous g \<rbrakk> \<Longrightarrow> Continuous (f \<circ> g)"
  by (simp add: Continuous_def)

lemma Continuous_const [closure]: "Continuous (\<lambda> X. P)"
  by pred_auto

text \<open> Closure laws derived from continuity \<close>

lemma Sup_Continuous_closed [closure]:
  "\<lbrakk> Continuous H; \<And> i. i \<in> A \<Longrightarrow> P(i) is H; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter> i\<in>A. P(i)) is H"
  by (drule ContinuousD[of H "P ` A"], simp add: UINF_mem_UNIV[THEN sym] UINF_as_Sup[THEN sym])
     (metis (no_types, lifting) Healthy_def' SUP_cong image_image)

lemma UINF_mem_Continuous_closed [closure]:
  "\<lbrakk> Continuous H; \<And> i. i \<in> A \<Longrightarrow> P(i) is H; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter> i\<in>A \<bullet> P(i)) is H"
  by (simp add: Sup_Continuous_closed UINF_as_Sup_collect)

lemma UINF_mem_Continuous_closed_pair [closure]:
  assumes "Continuous H" "\<And> i j. (i, j) \<in> A \<Longrightarrow> P i j is H" "A \<noteq> {}"
  shows "(\<Sqinter> (i,j)\<in>A \<bullet> P i j) is H"
proof -
  have "(\<Sqinter> (i,j)\<in>A \<bullet> P i j) = (\<Sqinter> x\<in>A \<bullet> P (fst x) (snd x))"
    by (rel_auto)
  also have "... is H"
    by (metis (mono_tags) UINF_mem_Continuous_closed assms(1) assms(2) assms(3) prod.collapse)
  finally show ?thesis .
qed

lemma UINF_mem_Continuous_closed_triple [closure]:
  assumes "Continuous H" "\<And> i j k. (i, j, k) \<in> A \<Longrightarrow> P i j k is H" "A \<noteq> {}"
  shows "(\<Sqinter> (i,j,k)\<in>A \<bullet> P i j k) is H"
proof -
  have "(\<Sqinter> (i,j,k)\<in>A \<bullet> P i j k) = (\<Sqinter> x\<in>A \<bullet> P (fst x) (fst (snd x)) (snd (snd x)))"
    by (rel_auto)
  also have "... is H"
    by (metis (mono_tags) UINF_mem_Continuous_closed assms(1) assms(2) assms(3) prod.collapse)
  finally show ?thesis .
qed

lemma UINF_mem_Continuous_closed_quad [closure]:
  assumes "Continuous H" "\<And> i j k l. (i, j, k, l) \<in> A \<Longrightarrow> P i j k l is H" "A \<noteq> {}"
  shows "(\<Sqinter> (i,j,k,l)\<in>A \<bullet> P i j k l) is H"
proof -
  have "(\<Sqinter> (i,j,k,l)\<in>A \<bullet> P i j k l) = (\<Sqinter> x\<in>A \<bullet> P (fst x) (fst (snd x)) (fst (snd (snd x))) (snd (snd (snd x))))"
    by (rel_auto)
  also have "... is H"
    by (metis (mono_tags) UINF_mem_Continuous_closed assms(1) assms(2) assms(3) prod.collapse)
  finally show ?thesis .
qed

lemma UINF_mem_Continuous_closed_quint [closure]:
  assumes "Continuous H" "\<And> i j k l m. (i, j, k, l, m) \<in> A \<Longrightarrow> P i j k l m is H" "A \<noteq> {}"
  shows "(\<Sqinter> (i,j,k,l,m)\<in>A \<bullet> P i j k l m) is H"
proof -
  have "(\<Sqinter> (i,j,k,l,m)\<in>A \<bullet> P i j k l m)
         = (\<Sqinter> x\<in>A \<bullet> P (fst x) (fst (snd x)) (fst (snd (snd x))) (fst (snd (snd (snd x)))) (snd (snd (snd (snd x)))))"
    by (rel_auto)
  also have "... is H"
    by (metis (mono_tags) UINF_mem_Continuous_closed assms(1) assms(2) assms(3) prod.collapse)
  finally show ?thesis .
qed

lemma UINF_ind_closed [closure]:
  assumes "Continuous H" "\<And> i. P i = true" "\<And> i. Q i is H"
  shows "UINF P Q is H"
proof -
  from assms(2) have "UINF P Q = (\<Sqinter> i \<bullet> Q i)"
    by (rel_auto)
  also have "... is H"
    using UINF_mem_Continuous_closed[of H UNIV P]
    by (simp add: Sup_Continuous_closed UINF_as_Sup_collect' assms)
  finally show ?thesis .
qed

text \<open> All continuous functions are also Scott-continuous \<close>

lemma sup_continuous_Continuous [closure]: "Continuous F \<Longrightarrow> sup_continuous F"
  by (simp add: Continuous_def sup_continuous_def)

lemma USUP_healthy: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> (\<Squnion> P\<in>A \<bullet> F(P)) = (\<Squnion> P\<in>A \<bullet> F(H(P)))"
  by (rule USUP_cong, simp add: Healthy_subset_member)

lemma UINF_healthy: "A \<subseteq> \<lbrakk>H\<rbrakk>\<^sub>H \<Longrightarrow> (\<Sqinter> P\<in>A \<bullet> F(P)) = (\<Sqinter> P\<in>A \<bullet> F(H(P)))"
  by (rule UINF_cong, simp add: Healthy_subset_member)

end


(*  Title:       EpiMonoIso
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter EpiMonoIso

theory EpiMonoIso
imports Category
begin

  text\<open>
    This theory defines and develops properties of epimorphisms, monomorphisms,
    isomorphisms, sections, and retractions.
\<close>

  context category
  begin

     definition epi
     where "epi f = (arr f \<and> inj_on (\<lambda>g. g \<cdot> f) {g. seq g f})"

     definition mono
     where "mono f = (arr f \<and> inj_on (\<lambda>g. f \<cdot> g) {g. seq f g})"

     lemma epiI [intro]:
     assumes "arr f" and "\<And>g g'. seq g f \<and> seq g' f \<and> g \<cdot> f = g' \<cdot> f \<Longrightarrow> g = g'"
     shows "epi f"
       using assms epi_def inj_on_def by blast

     lemma epi_implies_arr:
     assumes "epi f"
     shows "arr f"
       using assms epi_def by auto

     (*
      * TODO: epiE and monoE don't need both seq hypotheses.
      * Also, they are not stated in the form of elimination rules.
      *)

     lemma epiE [elim]:
     assumes "epi f"
     and "seq g f" and "seq g' f" and "g \<cdot> f = g' \<cdot> f"
     shows "g = g'"
       using assms unfolding epi_def inj_on_def by blast

     lemma monoI [intro]:
     assumes "arr g" and "\<And>f f'. seq g f \<and> seq g f' \<and> g \<cdot> f = g \<cdot> f' \<Longrightarrow> f = f'"
     shows "mono g"
       using assms mono_def inj_on_def by blast

     lemma mono_implies_arr:
     assumes "mono f"
     shows "arr f"
       using assms mono_def by auto

     lemma monoE [elim]:
     assumes "mono g"
     and "seq g f" and "seq g f'" and "g \<cdot> f = g \<cdot> f'"
     shows "f' = f"
       using assms unfolding mono_def inj_on_def by blast

     definition inverse_arrows
     where "inverse_arrows f g \<equiv> ide (g \<cdot> f) \<and> ide (f \<cdot> g)"

     lemma inverse_arrowsI [intro]:
     assumes "ide (g \<cdot> f)" and "ide (f \<cdot> g)"
     shows "inverse_arrows f g"
       using assms inverse_arrows_def by blast

     lemma inverse_arrowsE [elim]:
     assumes "inverse_arrows f g"
     and "\<lbrakk> ide (g \<cdot> f); ide (f \<cdot> g) \<rbrakk> \<Longrightarrow> T"
     shows "T"
       using assms inverse_arrows_def by blast

     lemma inverse_arrows_sym:
       shows "inverse_arrows f g \<longleftrightarrow> inverse_arrows g f"
       using inverse_arrows_def by auto

     lemma ide_self_inverse:
     assumes "ide a"
     shows "inverse_arrows a a"
       using assms by auto

     lemma inverse_arrow_unique:
     assumes "inverse_arrows f g" and "inverse_arrows f g'"
     shows "g = g'"
       using assms apply (elim inverse_arrowsE)
       by (metis comp_cod_arr ide_compE comp_assoc seqE)

     lemma inverse_arrows_compose:
     assumes "seq g f" and "inverse_arrows f f'" and "inverse_arrows g g'"
     shows "inverse_arrows (g \<cdot> f) (f' \<cdot> g')"
       using assms apply (elim inverse_arrowsE, intro inverse_arrowsI)
        apply (metis seqE comp_arr_dom ide_compE comp_assoc)
       by (metis seqE comp_arr_dom ide_compE comp_assoc)

     definition "section"
     where "section f \<equiv> \<exists>g. ide (g \<cdot> f)"

     lemma sectionI [intro]:
     assumes "ide (g \<cdot> f)"
     shows "section f"
       using assms section_def by auto

     lemma sectionE [elim]:
     assumes "section f"
     obtains g where "ide (g \<cdot> f)"
       using assms section_def by blast

     definition retraction
     where "retraction g \<equiv> \<exists>f. ide (g \<cdot> f)"

     lemma retractionI [intro]:
     assumes "ide (g \<cdot> f)"
     shows "retraction g"
       using assms retraction_def by auto

     lemma retractionE [elim]:
     assumes "retraction g"
     obtains f where "ide (g \<cdot> f)"
       using assms retraction_def by blast

     lemma section_is_mono:
     assumes "section g"
     shows "mono g"
     proof
       show "arr g" using assms section_def by blast
       from assms obtain h where h: "ide (h \<cdot> g)" by blast
       have hg: "seq h g" using h by auto
       fix f f'
       assume "seq g f \<and> seq g f' \<and> g \<cdot> f = g \<cdot> f'"
       thus "f = f'"
         using hg h ide_compE seqE comp_assoc comp_cod_arr by metis
     qed

     lemma retraction_is_epi:
     assumes "retraction g"
     shows "epi g"
     proof
       show "arr g" using assms retraction_def by blast
       from assms obtain f where f: "ide (g \<cdot> f)" by blast
       have gf: "seq g f" using f by auto
       fix h h'
       assume "seq h g \<and> seq h' g \<and> h \<cdot> g = h' \<cdot> g"
       thus "h = h'"
         using gf f ide_compE seqE comp_assoc comp_arr_dom by metis
     qed

     lemma section_retraction_compose:
     assumes "ide (e \<cdot> m)" and "ide (e' \<cdot> m')" and "seq m' m"
     shows "ide ((e \<cdot> e') \<cdot> (m' \<cdot> m))"
       using assms seqI seqE ide_compE comp_assoc comp_arr_dom by metis

     lemma retractions_compose [intro]:
     assumes "retraction e" and "retraction e'" and "seq e' e"
     shows "retraction (e' \<cdot> e)"
     proof -
       from assms(1-2) obtain m m'
       where *: "ide (e \<cdot> m) \<and> ide (e' \<cdot> m')"
         using retraction_def by auto
       hence "seq m m'"
         using assms(3) by (metis seqE seqI ide_compE)
       with * show ?thesis
         using section_retraction_compose retractionI by blast
     qed

     lemma monos_compose [intro]:
     assumes "mono m" and "mono m'" and "seq m' m"
     shows "mono (m' \<cdot> m)"
     proof -
       have "inj_on (\<lambda>f. (m' \<cdot> m) \<cdot> f) {f. seq (m' \<cdot> m) f}"
         unfolding inj_on_def
         using assms
         by (metis CollectD seqE monoE comp_assoc)
       thus ?thesis using assms(3) mono_def by force
     qed

     lemma epis_compose [intro]:
     assumes "epi e" and "epi e'" and "seq e' e"
     shows "epi (e' \<cdot> e)"
     proof -
       have "inj_on (\<lambda>g. g \<cdot> (e' \<cdot> e)) {g. seq g (e' \<cdot> e)}"
         unfolding inj_on_def
         using assms by (metis CollectD epiE match_2 comp_assoc)
       thus ?thesis using assms(3) epi_def by force
     qed

     definition iso
     where "iso f \<equiv> \<exists>g. inverse_arrows f g"

     lemma isoI [intro]:
     assumes "inverse_arrows f g"
     shows "iso f"
       using assms iso_def by auto

     lemma isoE [elim]:
     assumes "iso f"
     obtains g where "inverse_arrows f g"
       using assms iso_def by blast

     lemma ide_is_iso [simp]:
     assumes "ide a"
     shows "iso a"
       using assms ide_self_inverse by auto

     lemma iso_is_arr:
     assumes "iso f"
     shows "arr f"
       using assms by blast

     lemma iso_is_section:
     assumes "iso f"
     shows "section f"
       using assms inverse_arrows_def by blast

     lemma iso_is_retraction:
     assumes "iso f"
     shows "retraction f"
       using assms inverse_arrows_def by blast

    lemma iso_iff_mono_and_retraction:
    shows "iso f \<longleftrightarrow> mono f \<and> retraction f"
    proof
      show "iso f \<Longrightarrow> mono f \<and> retraction f"
        by (simp add: iso_is_retraction iso_is_section section_is_mono)
      show "mono f \<and> retraction f \<Longrightarrow> iso f"
      proof -
        assume f: "mono f \<and> retraction f"
        from f obtain g where g: "ide (f \<cdot> g)" by blast
        have "inverse_arrows f g"
          using f g comp_arr_dom comp_cod_arr comp_assoc inverse_arrowsI
          by (metis ide_char' ide_compE monoE mono_implies_arr)
        thus "iso f" by auto
      qed
    qed

    lemma iso_iff_section_and_epi:
    shows "iso f \<longleftrightarrow> section f \<and> epi f"
    proof
      show "iso f \<Longrightarrow> section f \<and> epi f"
        by (simp add: iso_is_retraction iso_is_section retraction_is_epi)
      show "section f \<and> epi f \<Longrightarrow> iso f"
      proof -
        assume f: "section f \<and> epi f"
        from f obtain g where g: "ide (g \<cdot> f)" by blast
        have "inverse_arrows f g"
          using f g comp_arr_dom comp_cod_arr epi_implies_arr
                comp_assoc ide_compE inverse_arrowsI epiE ide_char'
          by metis
        thus "iso f" by auto
      qed
    qed

    lemma iso_iff_section_and_retraction:
    shows "iso f \<longleftrightarrow> section f \<and> retraction f"
      using iso_is_retraction iso_is_section iso_iff_mono_and_retraction section_is_mono
      by auto

    lemma isos_compose [intro]:
    assumes "iso f" and "iso f'" and "seq f' f"
    shows "iso (f' \<cdot> f)"
    proof -
      from assms(1) obtain g where g: "inverse_arrows f g" by blast
      from assms(2) obtain g' where g': "inverse_arrows f' g'" by blast
      have "inverse_arrows (f' \<cdot> f) (g \<cdot> g')"
        using assms g g inverse_arrowsI inverse_arrowsE section_retraction_compose
        by (simp add: g' inverse_arrows_compose)
      thus ?thesis using iso_def by auto
    qed

    lemma iso_cancel_left:
    assumes "iso f" and "f \<cdot> g = f \<cdot> g'" and "seq f g"
    shows "g = g'"
      using assms iso_is_section section_is_mono monoE by metis

    lemma iso_cancel_right:
    assumes "iso g" and "f \<cdot> g = f' \<cdot> g" and "seq f g" and "iso g"
    shows "f = f'"
      using assms iso_is_retraction retraction_is_epi epiE by metis

    definition isomorphic
    where "isomorphic a a' = (\<exists>f. \<guillemotleft>f : a \<rightarrow> a'\<guillemotright> \<and> iso f)"

    lemma isomorphicI [intro]:
    assumes "iso f"
    shows "isomorphic (dom f) (cod f)"
      using assms isomorphic_def iso_is_arr by blast

    lemma isomorphicE [elim]:
    assumes "isomorphic a a'"
    obtains f where "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright> \<and> iso f"
      using assms isomorphic_def by meson

    definition iso_in_hom  ("\<guillemotleft>_ : _ \<cong> _\<guillemotright>")
    where "iso_in_hom f a b \<equiv> \<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<and> iso f"

    lemma iso_in_homI [intro]:
    assumes "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>" and "iso f"
    shows "\<guillemotleft>f : a \<cong> b\<guillemotright>"
      using assms iso_in_hom_def by simp

    lemma iso_in_homE [elim]:
    assumes "\<guillemotleft>f : a \<cong> b\<guillemotright>"
    and "\<lbrakk>\<guillemotleft>f : a \<rightarrow> b\<guillemotright>; iso f\<rbrakk> \<Longrightarrow> T"
    shows T
      using assms iso_in_hom_def by simp

    lemma isomorphicI':
    assumes "\<guillemotleft>f : a \<cong> b\<guillemotright>"
    shows "isomorphic a b"
      using assms iso_in_hom_def isomorphic_def by auto

    lemma ide_iso_in_hom:
    assumes "ide a"
    shows "\<guillemotleft>a : a \<cong> a\<guillemotright>"
      using assms by fastforce

    lemma comp_iso_in_hom [intro]:
    assumes "\<guillemotleft>f : a \<cong> b\<guillemotright>" and "\<guillemotleft>g : b \<cong> c\<guillemotright>"
    shows "\<guillemotleft>g \<cdot> f : a \<cong> c\<guillemotright>"
      using assms iso_in_hom_def by auto

    definition inv
    where "inv f = (SOME g. inverse_arrows f g)"

    lemma inv_is_inverse:
    assumes "iso f"
    shows "inverse_arrows f (inv f)"
      using assms inv_def someI [of "inverse_arrows f"] by auto

    lemma iso_inv_iso [intro, simp]:
    assumes "iso f"
    shows "iso (inv f)"
      using assms inv_is_inverse inverse_arrows_sym by blast

    lemma inverse_unique:
    assumes "inverse_arrows f g"
    shows "inv f = g"
      using assms inv_is_inverse inverse_arrow_unique isoI by auto

    lemma inv_ide [simp]:
    assumes "ide a"
    shows "inv a = a"
      using assms by (simp add: inverse_arrowsI inverse_unique)

    lemma inv_inv [simp]:
    assumes "iso f"
    shows "inv (inv f) = f"
      using assms inverse_arrows_sym inverse_unique by blast

    lemma comp_arr_inv:
    assumes "inverse_arrows f g"
    shows "f \<cdot> g = dom g"
      using assms by auto

    lemma comp_inv_arr:
    assumes "inverse_arrows f g"
    shows "g \<cdot> f = dom f"
      using assms by auto

    lemma comp_arr_inv':
    assumes "iso f"
    shows "f \<cdot> inv f = cod f"
      using assms inv_is_inverse by blast

    lemma comp_inv_arr':
    assumes "iso f"
    shows "inv f \<cdot> f = dom f"
      using assms inv_is_inverse by blast

    lemma inv_in_hom [simp]:
    assumes "iso f" and "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
    shows "\<guillemotleft>inv f : b \<rightarrow> a\<guillemotright>"
      using assms inv_is_inverse seqE inverse_arrowsE
      by (metis ide_compE in_homE in_homI)

    lemma arr_inv [simp]:
    assumes "iso f"
    shows "arr (inv f)"
      using assms inv_in_hom by blast

    lemma dom_inv [simp]:
    assumes "iso f"
    shows "dom (inv f) = cod f"
      using assms inv_in_hom by blast

    lemma cod_inv [simp]:
    assumes "iso f"
    shows "cod (inv f) = dom f"
      using assms inv_in_hom by blast

    lemma inv_comp:
    assumes "iso f" and "iso g" and "seq g f"
    shows "inv (g \<cdot> f) = inv f \<cdot> inv g"
      using assms inv_is_inverse inverse_unique inverse_arrows_compose inverse_arrows_def
      by meson

    lemma isomorphic_reflexive:
    assumes "ide f"
    shows "isomorphic f f"
      unfolding isomorphic_def
      using assms ide_is_iso ide_in_hom by blast

    lemma isomorphic_symmetric:
    assumes "isomorphic f g"
    shows "isomorphic g f"
      using assms inv_in_hom by blast

    lemma isomorphic_transitive [trans]:
    assumes "isomorphic f g" and "isomorphic g h"
    shows "isomorphic f h"
      using assms isomorphic_def isos_compose by auto

    text \<open>
      A section or retraction of an isomorphism is in fact an inverse.
\<close>

    lemma section_retraction_of_iso:
    assumes "iso f"
    shows "ide (g \<cdot> f) \<Longrightarrow> inverse_arrows f g"
    and "ide (f \<cdot> g) \<Longrightarrow> inverse_arrows f g"
    proof -
      show "ide (g \<cdot> f) \<Longrightarrow> inverse_arrows f g"
        using assms
        by (metis comp_inv_arr' epiE ide_compE inv_is_inverse iso_iff_section_and_epi)
      show "ide (f \<cdot> g) \<Longrightarrow> inverse_arrows f g"
        using assms
        by (metis ide_compE comp_arr_inv' inv_is_inverse iso_iff_mono_and_retraction monoE)
    qed

    text \<open>
      A situation that occurs frequently is that we have a commuting triangle,
      but we need the triangle obtained by inverting one side that is an isomorphism.
      The following fact streamlines this derivation.
\<close>

    lemma invert_side_of_triangle:
    assumes "arr h" and "f \<cdot> g = h"
    shows "iso f \<Longrightarrow> seq (inv f) h \<and> g = inv f \<cdot> h"
    and "iso g \<Longrightarrow> seq h (inv g) \<and> f = h \<cdot> inv g"
    proof -
      show "iso f \<Longrightarrow> seq (inv f) h \<and> g = inv f \<cdot> h"
        by (metis assms seqE inv_is_inverse comp_cod_arr comp_inv_arr comp_assoc)
      show "iso g \<Longrightarrow> seq h (inv g) \<and> f = h \<cdot> inv g"
        by (metis assms seqE inv_is_inverse comp_arr_dom comp_arr_inv dom_inv comp_assoc)
    qed

    text \<open>
      A similar situation is where we have a commuting square and we want to
      invert two opposite sides.
\<close>

    lemma invert_opposite_sides_of_square:
    assumes "seq f g" and "f \<cdot> g = h \<cdot> k"
    shows "\<lbrakk> iso f; iso k \<rbrakk> \<Longrightarrow> seq g (inv k) \<and> seq (inv f) h \<and> g \<cdot> inv k = inv f \<cdot> h"
      by (metis assms invert_side_of_triangle comp_assoc)

    text \<open>
      The following versions of \<open>inv_comp\<close> provide information needed for repeated
      application to a composition of more than two arrows and seem often to be more
      useful.
\<close>

    lemma inv_comp_left:
    assumes "iso (g \<cdot> f)" and "iso g"
    shows "inv (g \<cdot> f) = inv f \<cdot> inv g" and "iso f"
    proof -
      have 1: "inv f = inv (g \<cdot> f) \<cdot> g"
      proof -
        have "inv (g \<cdot> f) \<cdot> g = inv (g \<cdot> f) \<cdot> inv (inv g)"
         using assms by simp
        also have "... = inv (inv g \<cdot> g \<cdot> f)"
          using assms inv_comp iso_is_arr by simp
        also have "... = inv ((inv g \<cdot> g) \<cdot> f)"
          using comp_assoc by simp
        also have "... = inv f"
          using assms comp_ide_arr invert_side_of_triangle(1) iso_is_arr comp_assoc
          by metis
        finally show ?thesis by simp
      qed
      show "inv (g \<cdot> f) = inv f \<cdot> inv g"
        using assms 1 comp_arr_dom comp_assoc
        by (metis arr_inv cod_comp dom_inv invert_side_of_triangle(2) iso_is_arr seqI)
      show "iso f"
        using assms 1 comp_assoc inv_is_inverse
        by (metis arr_inv invert_side_of_triangle(1) inv_inv iso_inv_iso isos_compose)
    qed

    lemma inv_comp_right:
    assumes "iso (g \<cdot> f)" and "iso f"
    shows "inv (g \<cdot> f) = inv f \<cdot> inv g" and "iso g"
    proof -
      have 1: "inv g = f \<cdot> inv (g \<cdot> f)"
      proof -
        have "f \<cdot> inv (g \<cdot> f) = inv (inv f) \<cdot> inv (g \<cdot> f)"
          using assms by simp
        also have "... = inv ((g \<cdot> f) \<cdot> inv f)"
          using assms inv_comp iso_is_arr by simp
        also have "... = inv (g \<cdot> f \<cdot> inv f)"
          using comp_assoc by simp
        also have "... = inv g"
          using assms comp_arr_dom invert_side_of_triangle(2) iso_is_arr comp_assoc
          by metis
        finally show ?thesis by simp
      qed
      show "inv (g \<cdot> f) = inv f \<cdot> inv g"
        using assms 1 comp_cod_arr comp_assoc
        by (metis arr_inv cod_inv dom_comp seqI invert_side_of_triangle(1) iso_is_arr)
      show "iso g"
        using assms 1 comp_assoc inv_is_inverse
        by (metis arr_inv invert_side_of_triangle(2) inv_inv iso_inv_iso isos_compose)
    qed

  end

end


(*  Title:      HOL/Groups.thy
    Author:     Gertrud Bauer
    Author:     Steven Obua
    Author:     Lawrence C Paulson
    Author:     Markus Wenzel
    Author:     Jeremy Avigad
*)

section \<open>Groups, also combined with orderings\<close>

theory Groups
  imports Orderings
begin

subsection \<open>Dynamic facts\<close>

named_theorems ac_simps "associativity and commutativity simplification rules"
  and algebra_simps "algebra simplification rules"
  and field_simps "algebra simplification rules for fields"

text \<open>
  The rewrites accumulated in \<open>algebra_simps\<close> deal with the classical
  algebraic structures of groups, rings and family. They simplify terms by
  multiplying everything out (in case of a ring) and bringing sums and
  products into a canonical form (by ordered rewriting). As a result it
  decides group and ring equalities but also helps with inequalities.

  Of course it also works for fields, but it knows nothing about
  multiplicative inverses or division. This is catered for by \<open>field_simps\<close>.

  Facts in \<open>field_simps\<close> multiply with denominators in (in)equations if they
  can be proved to be non-zero (for equations) or positive/negative (for
  inequalities). Can be too aggressive and is therefore separate from the more
  benign \<open>algebra_simps\<close>.
\<close>

subsection \<open>Abstract structures\<close>

text \<open>
  These locales provide basic structures for interpretation into bigger
  structures; extensions require careful thinking, otherwise undesired effects
  may occur due to interpretation.
\<close>

locale semigroup =
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "\<^bold>*" 70)
  assumes assoc [ac_simps]: "a \<^bold>* b \<^bold>* c = a \<^bold>* (b \<^bold>* c)"

locale abel_semigroup = semigroup +
  assumes commute [ac_simps]: "a \<^bold>* b = b \<^bold>* a"
begin

lemma left_commute [ac_simps]: "b \<^bold>* (a \<^bold>* c) = a \<^bold>* (b \<^bold>* c)"
proof -
  have "(b \<^bold>* a) \<^bold>* c = (a \<^bold>* b) \<^bold>* c"
    by (simp only: commute)
  then show ?thesis
    by (simp only: assoc)
qed

end

locale monoid = semigroup +
  fixes z :: 'a ("\<^bold>1")
  assumes left_neutral [simp]: "\<^bold>1 \<^bold>* a = a"
  assumes right_neutral [simp]: "a \<^bold>* \<^bold>1 = a"

locale comm_monoid = abel_semigroup +
  fixes z :: 'a ("\<^bold>1")
  assumes comm_neutral: "a \<^bold>* \<^bold>1 = a"
begin

sublocale monoid
  by standard (simp_all add: commute comm_neutral)

end

locale group = semigroup +
  fixes z :: 'a ("\<^bold>1")
  fixes inverse :: "'a \<Rightarrow> 'a"
  assumes group_left_neutral: "\<^bold>1 \<^bold>* a = a"
  assumes left_inverse [simp]:  "inverse a \<^bold>* a = \<^bold>1"
begin

lemma left_cancel: "a \<^bold>* b = a \<^bold>* c \<longleftrightarrow> b = c"
proof
  assume "a \<^bold>* b = a \<^bold>* c"
  then have "inverse a \<^bold>* (a \<^bold>* b) = inverse a \<^bold>* (a \<^bold>* c)" by simp
  then have "(inverse a \<^bold>* a) \<^bold>* b = (inverse a \<^bold>* a) \<^bold>* c"
    by (simp only: assoc)
  then show "b = c" by (simp add: group_left_neutral)
qed simp

sublocale monoid
proof
  fix a
  have "inverse a \<^bold>* a = \<^bold>1" by simp
  then have "inverse a \<^bold>* (a \<^bold>* \<^bold>1) = inverse a \<^bold>* a"
    by (simp add: group_left_neutral assoc [symmetric])
  with left_cancel show "a \<^bold>* \<^bold>1 = a"
    by (simp only: left_cancel)
qed (fact group_left_neutral)

lemma inverse_unique:
  assumes "a \<^bold>* b = \<^bold>1"
  shows "inverse a = b"
proof -
  from assms have "inverse a \<^bold>* (a \<^bold>* b) = inverse a"
    by simp
  then show ?thesis
    by (simp add: assoc [symmetric])
qed

lemma inverse_neutral [simp]: "inverse \<^bold>1 = \<^bold>1"
  by (rule inverse_unique) simp

lemma inverse_inverse [simp]: "inverse (inverse a) = a"
  by (rule inverse_unique) simp

lemma right_inverse [simp]: "a \<^bold>* inverse a = \<^bold>1"
proof -
  have "a \<^bold>* inverse a = inverse (inverse a) \<^bold>* inverse a"
    by simp
  also have "\<dots> = \<^bold>1"
    by (rule left_inverse)
  then show ?thesis by simp
qed

lemma inverse_distrib_swap: "inverse (a \<^bold>* b) = inverse b \<^bold>* inverse a"
proof (rule inverse_unique)
  have "a \<^bold>* b \<^bold>* (inverse b \<^bold>* inverse a) =
    a \<^bold>* (b \<^bold>* inverse b) \<^bold>* inverse a"
    by (simp only: assoc)
  also have "\<dots> = \<^bold>1"
    by simp
  finally show "a \<^bold>* b \<^bold>* (inverse b \<^bold>* inverse a) = \<^bold>1" .
qed

lemma right_cancel: "b \<^bold>* a = c \<^bold>* a \<longleftrightarrow> b = c"
proof
  assume "b \<^bold>* a = c \<^bold>* a"
  then have "b \<^bold>* a \<^bold>* inverse a= c \<^bold>* a \<^bold>* inverse a"
    by simp
  then show "b = c"
    by (simp add: assoc)
qed simp

end

subsection \<open>Generic operations\<close>

class zero =
  fixes zero :: 'a  ("0")

class one =
  fixes one  :: 'a  ("1")

hide_const (open) zero one

lemma Let_0 [simp]: "Let 0 f = f 0"
  unfolding Let_def ..

lemma Let_1 [simp]: "Let 1 f = f 1"
  unfolding Let_def ..

setup \<open>
  Reorient_Proc.add
    (fn Const(@{const_name Groups.zero}, _) => true
      | Const(@{const_name Groups.one}, _) => true
      | _ => false)
\<close>

simproc_setup reorient_zero ("0 = x") = Reorient_Proc.proc
simproc_setup reorient_one ("1 = x") = Reorient_Proc.proc

typed_print_translation \<open>
  let
    fun tr' c = (c, fn ctxt => fn T => fn ts =>
      if null ts andalso Printer.type_emphasis ctxt T then
        Syntax.const @{syntax_const "_constrain"} $ Syntax.const c $
          Syntax_Phases.term_of_typ ctxt T
      else raise Match);
  in map tr' [@{const_syntax Groups.one}, @{const_syntax Groups.zero}] end;
\<close> \<comment> \<open>show types that are presumably too general\<close>

class plus =
  fixes plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "+" 65)

class minus =
  fixes minus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "-" 65)

class uminus =
  fixes uminus :: "'a \<Rightarrow> 'a"  ("- _" [81] 80)

class times =
  fixes times :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "*" 70)

subsection \<open>Semigroups and Monoids\<close>

class semigroup_add = plus +
  assumes add_assoc [algebra_simps, field_simps]: "(a + b) + c = a + (b + c)"
begin

sublocale add: semigroup plus
  by standard (fact add_assoc)

end

hide_fact add_assoc

class ab_semigroup_add = semigroup_add +
  assumes add_commute [algebra_simps, field_simps]: "a + b = b + a"
begin

sublocale add: abel_semigroup plus
  by standard (fact add_commute)

declare add.left_commute [algebra_simps, field_simps]

lemmas add_ac = add.assoc add.commute add.left_commute

end

hide_fact add_commute

lemmas add_ac = add.assoc add.commute add.left_commute

class semigroup_mult = times +
  assumes mult_assoc [algebra_simps, field_simps]: "(a * b) * c = a * (b * c)"
begin

sublocale mult: semigroup times
  by standard (fact mult_assoc)

end

hide_fact mult_assoc

class ab_semigroup_mult = semigroup_mult +
  assumes mult_commute [algebra_simps, field_simps]: "a * b = b * a"
begin

sublocale mult: abel_semigroup times
  by standard (fact mult_commute)

declare mult.left_commute [algebra_simps, field_simps]

lemmas mult_ac = mult.assoc mult.commute mult.left_commute

end

hide_fact mult_commute

lemmas mult_ac = mult.assoc mult.commute mult.left_commute

class monoid_add = zero + semigroup_add +
  assumes add_0_left: "0 + a = a"
    and add_0_right: "a + 0 = a"
begin

sublocale add: monoid plus 0
  by standard (fact add_0_left add_0_right)+

end

lemma zero_reorient: "0 = x \<longleftrightarrow> x = 0"
  by (fact eq_commute)

class comm_monoid_add = zero + ab_semigroup_add +
  assumes add_0: "0 + a = a"
begin

subclass monoid_add
  by standard (simp_all add: add_0 add.commute [of _ 0])

sublocale add: comm_monoid plus 0
  by standard (simp add: ac_simps)

end

class monoid_mult = one + semigroup_mult +
  assumes mult_1_left: "1 * a  = a"
    and mult_1_right: "a * 1 = a"
begin

sublocale mult: monoid times 1
  by standard (fact mult_1_left mult_1_right)+

end

lemma one_reorient: "1 = x \<longleftrightarrow> x = 1"
  by (fact eq_commute)

class comm_monoid_mult = one + ab_semigroup_mult +
  assumes mult_1: "1 * a = a"
begin

subclass monoid_mult
  by standard (simp_all add: mult_1 mult.commute [of _ 1])

sublocale mult: comm_monoid times 1
  by standard (simp add: ac_simps)

end

class cancel_semigroup_add = semigroup_add +
  assumes add_left_imp_eq: "a + b = a + c \<Longrightarrow> b = c"
  assumes add_right_imp_eq: "b + a = c + a \<Longrightarrow> b = c"
begin

lemma add_left_cancel [simp]: "a + b = a + c \<longleftrightarrow> b = c"
  by (blast dest: add_left_imp_eq)

lemma add_right_cancel [simp]: "b + a = c + a \<longleftrightarrow> b = c"
  by (blast dest: add_right_imp_eq)

end

class cancel_ab_semigroup_add = ab_semigroup_add + minus +
  assumes add_diff_cancel_left' [simp]: "(a + b) - a = b"
  assumes diff_diff_add [algebra_simps, field_simps]: "a - b - c = a - (b + c)"
begin

lemma add_diff_cancel_right' [simp]: "(a + b) - b = a"
  using add_diff_cancel_left' [of b a] by (simp add: ac_simps)

subclass cancel_semigroup_add
proof
  fix a b c :: 'a
  assume "a + b = a + c"
  then have "a + b - a = a + c - a"
    by simp
  then show "b = c"
    by simp
next
  fix a b c :: 'a
  assume "b + a = c + a"
  then have "b + a - a = c + a - a"
    by simp
  then show "b = c"
    by simp
qed

lemma add_diff_cancel_left [simp]: "(c + a) - (c + b) = a - b"
  unfolding diff_diff_add [symmetric] by simp

lemma add_diff_cancel_right [simp]: "(a + c) - (b + c) = a - b"
  using add_diff_cancel_left [symmetric] by (simp add: ac_simps)

lemma diff_right_commute: "a - c - b = a - b - c"
  by (simp add: diff_diff_add add.commute)

end

class cancel_comm_monoid_add = cancel_ab_semigroup_add + comm_monoid_add
begin

lemma diff_zero [simp]: "a - 0 = a"
  using add_diff_cancel_right' [of a 0] by simp

lemma diff_cancel [simp]: "a - a = 0"
proof -
  have "(a + 0) - (a + 0) = 0"
    by (simp only: add_diff_cancel_left diff_zero)
  then show ?thesis by simp
qed

lemma add_implies_diff:
  assumes "c + b = a"
  shows "c = a - b"
proof -
  from assms have "(b + c) - (b + 0) = a - b"
    by (simp add: add.commute)
  then show "c = a - b" by simp
qed

lemma add_cancel_right_right [simp]: "a = a + b \<longleftrightarrow> b = 0"
  (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?Q
  then show ?P by simp
next
  assume ?P
  then have "a - a = a + b - a" by simp
  then show ?Q by simp
qed

lemma add_cancel_right_left [simp]: "a = b + a \<longleftrightarrow> b = 0"
  using add_cancel_right_right [of a b] by (simp add: ac_simps)

lemma add_cancel_left_right [simp]: "a + b = a \<longleftrightarrow> b = 0"
  by (auto dest: sym)

lemma add_cancel_left_left [simp]: "b + a = a \<longleftrightarrow> b = 0"
  by (auto dest: sym)

end

class comm_monoid_diff = cancel_comm_monoid_add +
  assumes zero_diff [simp]: "0 - a = 0"
begin

lemma diff_add_zero [simp]: "a - (a + b) = 0"
proof -
  have "a - (a + b) = (a + 0) - (a + b)"
    by simp
  also have "\<dots> = 0"
    by (simp only: add_diff_cancel_left zero_diff)
  finally show ?thesis .
qed

end

subsection \<open>Groups\<close>

class group_add = minus + uminus + monoid_add +
  assumes left_minus: "- a + a = 0"
  assumes add_uminus_conv_diff [simp]: "a + (- b) = a - b"
begin

lemma diff_conv_add_uminus: "a - b = a + (- b)"
  by simp

sublocale add: group plus 0 uminus
  by standard (simp_all add: left_minus)

lemma minus_unique: "a + b = 0 \<Longrightarrow> - a = b"
  by (fact add.inverse_unique)

lemma minus_zero: "- 0 = 0"
  by (fact add.inverse_neutral)

lemma minus_minus: "- (- a) = a"
  by (fact add.inverse_inverse)

lemma right_minus: "a + - a = 0"
  by (fact add.right_inverse)

lemma diff_self [simp]: "a - a = 0"
  using right_minus [of a] by simp

subclass cancel_semigroup_add
  by standard (simp_all add: add.left_cancel add.right_cancel)

lemma minus_add_cancel [simp]: "- a + (a + b) = b"
  by (simp add: add.assoc [symmetric])

lemma add_minus_cancel [simp]: "a + (- a + b) = b"
  by (simp add: add.assoc [symmetric])

lemma diff_add_cancel [simp]: "a - b + b = a"
  by (simp only: diff_conv_add_uminus add.assoc) simp

lemma add_diff_cancel [simp]: "a + b - b = a"
  by (simp only: diff_conv_add_uminus add.assoc) simp

lemma minus_add: "- (a + b) = - b + - a"
  by (fact add.inverse_distrib_swap)

lemma right_minus_eq [simp]: "a - b = 0 \<longleftrightarrow> a = b"
proof
  assume "a - b = 0"
  have "a = (a - b) + b" by (simp add: add.assoc)
  also have "\<dots> = b" using \<open>a - b = 0\<close> by simp
  finally show "a = b" .
next
  assume "a = b"
  then show "a - b = 0" by simp
qed

lemma eq_iff_diff_eq_0: "a = b \<longleftrightarrow> a - b = 0"
  by (fact right_minus_eq [symmetric])

lemma diff_0 [simp]: "0 - a = - a"
  by (simp only: diff_conv_add_uminus add_0_left)

lemma diff_0_right [simp]: "a - 0 = a"
  by (simp only: diff_conv_add_uminus minus_zero add_0_right)

lemma diff_minus_eq_add [simp]: "a - - b = a + b"
  by (simp only: diff_conv_add_uminus minus_minus)

lemma neg_equal_iff_equal [simp]: "- a = - b \<longleftrightarrow> a = b"
proof
  assume "- a = - b"
  then have "- (- a) = - (- b)" by simp
  then show "a = b" by simp
next
  assume "a = b"
  then show "- a = - b" by simp
qed

lemma neg_equal_0_iff_equal [simp]: "- a = 0 \<longleftrightarrow> a = 0"
  by (subst neg_equal_iff_equal [symmetric]) simp

lemma neg_0_equal_iff_equal [simp]: "0 = - a \<longleftrightarrow> 0 = a"
  by (subst neg_equal_iff_equal [symmetric]) simp

text \<open>The next two equations can make the simplifier loop!\<close>

lemma equation_minus_iff: "a = - b \<longleftrightarrow> b = - a"
proof -
  have "- (- a) = - b \<longleftrightarrow> - a = b"
    by (rule neg_equal_iff_equal)
  then show ?thesis
    by (simp add: eq_commute)
qed

lemma minus_equation_iff: "- a = b \<longleftrightarrow> - b = a"
proof -
  have "- a = - (- b) \<longleftrightarrow> a = -b"
    by (rule neg_equal_iff_equal)
  then show ?thesis
    by (simp add: eq_commute)
qed

lemma eq_neg_iff_add_eq_0: "a = - b \<longleftrightarrow> a + b = 0"
proof
  assume "a = - b"
  then show "a + b = 0" by simp
next
  assume "a + b = 0"
  moreover have "a + (b + - b) = (a + b) + - b"
    by (simp only: add.assoc)
  ultimately show "a = - b"
    by simp
qed

lemma add_eq_0_iff2: "a + b = 0 \<longleftrightarrow> a = - b"
  by (fact eq_neg_iff_add_eq_0 [symmetric])

lemma neg_eq_iff_add_eq_0: "- a = b \<longleftrightarrow> a + b = 0"
  by (auto simp add: add_eq_0_iff2)

lemma add_eq_0_iff: "a + b = 0 \<longleftrightarrow> b = - a"
  by (auto simp add: neg_eq_iff_add_eq_0 [symmetric])

lemma minus_diff_eq [simp]: "- (a - b) = b - a"
  by (simp only: neg_eq_iff_add_eq_0 diff_conv_add_uminus add.assoc minus_add_cancel) simp

lemma add_diff_eq [algebra_simps, field_simps]: "a + (b - c) = (a + b) - c"
  by (simp only: diff_conv_add_uminus add.assoc)

lemma diff_add_eq_diff_diff_swap: "a - (b + c) = a - c - b"
  by (simp only: diff_conv_add_uminus add.assoc minus_add)

lemma diff_eq_eq [algebra_simps, field_simps]: "a - b = c \<longleftrightarrow> a = c + b"
  by auto

lemma eq_diff_eq [algebra_simps, field_simps]: "a = c - b \<longleftrightarrow> a + b = c"
  by auto

lemma diff_diff_eq2 [algebra_simps, field_simps]: "a - (b - c) = (a + c) - b"
  by (simp only: diff_conv_add_uminus add.assoc) simp

lemma diff_eq_diff_eq: "a - b = c - d \<Longrightarrow> a = b \<longleftrightarrow> c = d"
  by (simp only: eq_iff_diff_eq_0 [of a b] eq_iff_diff_eq_0 [of c d])

end

class ab_group_add = minus + uminus + comm_monoid_add +
  assumes ab_left_minus: "- a + a = 0"
  assumes ab_diff_conv_add_uminus: "a - b = a + (- b)"
begin

subclass group_add
  by standard (simp_all add: ab_left_minus ab_diff_conv_add_uminus)

subclass cancel_comm_monoid_add
proof
  fix a b c :: 'a
  have "b + a - a = b"
    by simp
  then show "a + b - a = b"
    by (simp add: ac_simps)
  show "a - b - c = a - (b + c)"
    by (simp add: algebra_simps)
qed

lemma uminus_add_conv_diff [simp]: "- a + b = b - a"
  by (simp add: add.commute)

lemma minus_add_distrib [simp]: "- (a + b) = - a + - b"
  by (simp add: algebra_simps)

lemma diff_add_eq [algebra_simps, field_simps]: "(a - b) + c = (a + c) - b"
  by (simp add: algebra_simps)

end

subsection \<open>(Partially) Ordered Groups\<close>

text \<open>
  The theory of partially ordered groups is taken from the books:

    \<^item> \<^emph>\<open>Lattice Theory\<close> by Garret Birkhoff, American Mathematical Society, 1979
    \<^item> \<^emph>\<open>Partially Ordered Algebraic Systems\<close>, Pergamon Press, 1963

  Most of the used notions can also be looked up in
    \<^item> \<^url>\<open>http://www.mathworld.com\<close> by Eric Weisstein et. al.
    \<^item> \<^emph>\<open>Algebra I\<close> by van der Waerden, Springer
\<close>

class ordered_ab_semigroup_add = order + ab_semigroup_add +
  assumes add_left_mono: "a \<le> b \<Longrightarrow> c + a \<le> c + b"
begin

lemma add_right_mono: "a \<le> b \<Longrightarrow> a + c \<le> b + c"
  by (simp add: add.commute [of _ c] add_left_mono)

text \<open>non-strict, in both arguments\<close>
lemma add_mono: "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c \<le> b + d"
  apply (erule add_right_mono [THEN order_trans])
  apply (simp add: add.commute add_left_mono)
  done

end

text \<open>Strict monotonicity in both arguments\<close>
class strict_ordered_ab_semigroup_add = ordered_ab_semigroup_add +
  assumes add_strict_mono: "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"

class ordered_cancel_ab_semigroup_add =
  ordered_ab_semigroup_add + cancel_ab_semigroup_add
begin

lemma add_strict_left_mono: "a < b \<Longrightarrow> c + a < c + b"
  by (auto simp add: less_le add_left_mono)

lemma add_strict_right_mono: "a < b \<Longrightarrow> a + c < b + c"
  by (simp add: add.commute [of _ c] add_strict_left_mono)

subclass strict_ordered_ab_semigroup_add
  apply standard
  apply (erule add_strict_right_mono [THEN less_trans])
  apply (erule add_strict_left_mono)
  done

lemma add_less_le_mono: "a < b \<Longrightarrow> c \<le> d \<Longrightarrow> a + c < b + d"
  apply (erule add_strict_right_mono [THEN less_le_trans])
  apply (erule add_left_mono)
  done

lemma add_le_less_mono: "a \<le> b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d"
  apply (erule add_right_mono [THEN le_less_trans])
  apply (erule add_strict_left_mono)
  done

end

class ordered_ab_semigroup_add_imp_le = ordered_cancel_ab_semigroup_add +
  assumes add_le_imp_le_left: "c + a \<le> c + b \<Longrightarrow> a \<le> b"
begin

lemma add_less_imp_less_left:
  assumes less: "c + a < c + b"
  shows "a < b"
proof -
  from less have le: "c + a \<le> c + b"
    by (simp add: order_le_less)
  have "a \<le> b"
    apply (insert le)
    apply (drule add_le_imp_le_left)
    apply (insert le)
    apply (drule add_le_imp_le_left)
    apply assumption
    done
  moreover have "a \<noteq> b"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then have "a = b" by simp
    then have "c + a = c + b" by simp
    with less show "False" by simp
  qed
  ultimately show "a < b"
    by (simp add: order_le_less)
qed

lemma add_less_imp_less_right: "a + c < b + c \<Longrightarrow> a < b"
  by (rule add_less_imp_less_left [of c]) (simp add: add.commute)

lemma add_less_cancel_left [simp]: "c + a < c + b \<longleftrightarrow> a < b"
  by (blast intro: add_less_imp_less_left add_strict_left_mono)

lemma add_less_cancel_right [simp]: "a + c < b + c \<longleftrightarrow> a < b"
  by (blast intro: add_less_imp_less_right add_strict_right_mono)

lemma add_le_cancel_left [simp]: "c + a \<le> c + b \<longleftrightarrow> a \<le> b"
  apply auto
   apply (drule add_le_imp_le_left)
   apply (simp_all add: add_left_mono)
  done

lemma add_le_cancel_right [simp]: "a + c \<le> b + c \<longleftrightarrow> a \<le> b"
  by (simp add: add.commute [of a c] add.commute [of b c])

lemma add_le_imp_le_right: "a + c \<le> b + c \<Longrightarrow> a \<le> b"
  by simp

lemma max_add_distrib_left: "max x y + z = max (x + z) (y + z)"
  unfolding max_def by auto

lemma min_add_distrib_left: "min x y + z = min (x + z) (y + z)"
  unfolding min_def by auto

lemma max_add_distrib_right: "x + max y z = max (x + y) (x + z)"
  unfolding max_def by auto

lemma min_add_distrib_right: "x + min y z = min (x + y) (x + z)"
  unfolding min_def by auto

end

subsection \<open>Support for reasoning about signs\<close>

class ordered_comm_monoid_add = comm_monoid_add + ordered_ab_semigroup_add
begin

lemma add_nonneg_nonneg [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> a + b"
  using add_mono[of 0 a 0 b] by simp

lemma add_nonpos_nonpos: "a \<le> 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> a + b \<le> 0"
  using add_mono[of a 0 b 0] by simp

lemma add_nonneg_eq_0_iff: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  using add_left_mono[of 0 y x] add_right_mono[of 0 x y] by auto

lemma add_nonpos_eq_0_iff: "x \<le> 0 \<Longrightarrow> y \<le> 0 \<Longrightarrow> x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  using add_left_mono[of y 0 x] add_right_mono[of x 0 y] by auto

lemma add_increasing: "0 \<le> a \<Longrightarrow> b \<le> c \<Longrightarrow> b \<le> a + c"
  using add_mono [of 0 a b c] by simp

lemma add_increasing2: "0 \<le> c \<Longrightarrow> b \<le> a \<Longrightarrow> b \<le> a + c"
  by (simp add: add_increasing add.commute [of a])

lemma add_decreasing: "a \<le> 0 \<Longrightarrow> c \<le> b \<Longrightarrow> a + c \<le> b"
  using add_mono [of a 0 c b] by simp

lemma add_decreasing2: "c \<le> 0 \<Longrightarrow> a \<le> b \<Longrightarrow> a + c \<le> b"
  using add_mono[of a b c 0] by simp

lemma add_pos_nonneg: "0 < a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 < a + b"
  using less_le_trans[of 0 a "a + b"] by (simp add: add_increasing2)

lemma add_pos_pos: "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> 0 < a + b"
  by (intro add_pos_nonneg less_imp_le)

lemma add_nonneg_pos: "0 \<le> a \<Longrightarrow> 0 < b \<Longrightarrow> 0 < a + b"
  using add_pos_nonneg[of b a] by (simp add: add_commute)

lemma add_neg_nonpos: "a < 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> a + b < 0"
  using le_less_trans[of "a + b" a 0] by (simp add: add_decreasing2)

lemma add_neg_neg: "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> a + b < 0"
  by (intro add_neg_nonpos less_imp_le)

lemma add_nonpos_neg: "a \<le> 0 \<Longrightarrow> b < 0 \<Longrightarrow> a + b < 0"
  using add_neg_nonpos[of b a] by (simp add: add_commute)

lemmas add_sign_intros =
  add_pos_nonneg add_pos_pos add_nonneg_pos add_nonneg_nonneg
  add_neg_nonpos add_neg_neg add_nonpos_neg add_nonpos_nonpos

end

class strict_ordered_comm_monoid_add = comm_monoid_add + strict_ordered_ab_semigroup_add
begin

lemma pos_add_strict: "0 < a \<Longrightarrow> b < c \<Longrightarrow> b < a + c"
  using add_strict_mono [of 0 a b c] by simp

end

class ordered_cancel_comm_monoid_add = ordered_comm_monoid_add + cancel_ab_semigroup_add
begin

subclass ordered_cancel_ab_semigroup_add ..
subclass strict_ordered_comm_monoid_add ..

lemma add_strict_increasing: "0 < a \<Longrightarrow> b \<le> c \<Longrightarrow> b < a + c"
  using add_less_le_mono [of 0 a b c] by simp

lemma add_strict_increasing2: "0 \<le> a \<Longrightarrow> b < c \<Longrightarrow> b < a + c"
  using add_le_less_mono [of 0 a b c] by simp

end

class ordered_ab_semigroup_monoid_add_imp_le = monoid_add + ordered_ab_semigroup_add_imp_le
begin

lemma add_less_same_cancel1 [simp]: "b + a < b \<longleftrightarrow> a < 0"
  using add_less_cancel_left [of _ _ 0] by simp

lemma add_less_same_cancel2 [simp]: "a + b < b \<longleftrightarrow> a < 0"
  using add_less_cancel_right [of _ _ 0] by simp

lemma less_add_same_cancel1 [simp]: "a < a + b \<longleftrightarrow> 0 < b"
  using add_less_cancel_left [of _ 0] by simp

lemma less_add_same_cancel2 [simp]: "a < b + a \<longleftrightarrow> 0 < b"
  using add_less_cancel_right [of 0] by simp

lemma add_le_same_cancel1 [simp]: "b + a \<le> b \<longleftrightarrow> a \<le> 0"
  using add_le_cancel_left [of _ _ 0] by simp

lemma add_le_same_cancel2 [simp]: "a + b \<le> b \<longleftrightarrow> a \<le> 0"
  using add_le_cancel_right [of _ _ 0] by simp

lemma le_add_same_cancel1 [simp]: "a \<le> a + b \<longleftrightarrow> 0 \<le> b"
  using add_le_cancel_left [of _ 0] by simp

lemma le_add_same_cancel2 [simp]: "a \<le> b + a \<longleftrightarrow> 0 \<le> b"
  using add_le_cancel_right [of 0] by simp

subclass cancel_comm_monoid_add
  by standard auto

subclass ordered_cancel_comm_monoid_add
  by standard

end

class ordered_ab_group_add = ab_group_add + ordered_ab_semigroup_add
begin

subclass ordered_cancel_ab_semigroup_add ..

subclass ordered_ab_semigroup_monoid_add_imp_le
proof
  fix a b c :: 'a
  assume "c + a \<le> c + b"
  then have "(-c) + (c + a) \<le> (-c) + (c + b)"
    by (rule add_left_mono)
  then have "((-c) + c) + a \<le> ((-c) + c) + b"
    by (simp only: add.assoc)
  then show "a \<le> b" by simp
qed

lemma max_diff_distrib_left: "max x y - z = max (x - z) (y - z)"
  using max_add_distrib_left [of x y "- z"] by simp

lemma min_diff_distrib_left: "min x y - z = min (x - z) (y - z)"
  using min_add_distrib_left [of x y "- z"] by simp

lemma le_imp_neg_le:
  assumes "a \<le> b"
  shows "- b \<le> - a"
proof -
  from assms have "- a + a \<le> - a + b"
    by (rule add_left_mono)
  then have "0 \<le> - a + b"
    by simp
  then have "0 + (- b) \<le> (- a + b) + (- b)"
    by (rule add_right_mono)
  then show ?thesis
    by (simp add: algebra_simps)
qed

lemma neg_le_iff_le [simp]: "- b \<le> - a \<longleftrightarrow> a \<le> b"
proof
  assume "- b \<le> - a"
  then have "- (- a) \<le> - (- b)"
    by (rule le_imp_neg_le)
  then show "a \<le> b"
    by simp
next
  assume "a \<le> b"
  then show "- b \<le> - a"
    by (rule le_imp_neg_le)
qed

lemma neg_le_0_iff_le [simp]: "- a \<le> 0 \<longleftrightarrow> 0 \<le> a"
  by (subst neg_le_iff_le [symmetric]) simp

lemma neg_0_le_iff_le [simp]: "0 \<le> - a \<longleftrightarrow> a \<le> 0"
  by (subst neg_le_iff_le [symmetric]) simp

lemma neg_less_iff_less [simp]: "- b < - a \<longleftrightarrow> a < b"
  by (auto simp add: less_le)

lemma neg_less_0_iff_less [simp]: "- a < 0 \<longleftrightarrow> 0 < a"
  by (subst neg_less_iff_less [symmetric]) simp

lemma neg_0_less_iff_less [simp]: "0 < - a \<longleftrightarrow> a < 0"
  by (subst neg_less_iff_less [symmetric]) simp

text \<open>The next several equations can make the simplifier loop!\<close>

lemma less_minus_iff: "a < - b \<longleftrightarrow> b < - a"
proof -
  have "- (- a) < - b \<longleftrightarrow> b < - a"
    by (rule neg_less_iff_less)
  then show ?thesis by simp
qed

lemma minus_less_iff: "- a < b \<longleftrightarrow> - b < a"
proof -
  have "- a < - (- b) \<longleftrightarrow> - b < a"
    by (rule neg_less_iff_less)
  then show ?thesis by simp
qed

lemma le_minus_iff: "a \<le> - b \<longleftrightarrow> b \<le> - a"
proof -
  have mm: "- (- a) < - b \<Longrightarrow> - (- b) < -a" for a b :: 'a
    by (simp only: minus_less_iff)
  have "- (- a) \<le> - b \<longleftrightarrow> b \<le> - a"
    apply (auto simp only: le_less)
      apply (drule mm)
      apply (simp_all)
    apply (drule mm[simplified], assumption)
    done
  then show ?thesis by simp
qed

lemma minus_le_iff: "- a \<le> b \<longleftrightarrow> - b \<le> a"
  by (auto simp add: le_less minus_less_iff)

lemma diff_less_0_iff_less [simp]: "a - b < 0 \<longleftrightarrow> a < b"
proof -
  have "a - b < 0 \<longleftrightarrow> a + (- b) < b + (- b)"
    by simp
  also have "\<dots> \<longleftrightarrow> a < b"
    by (simp only: add_less_cancel_right)
  finally show ?thesis .
qed

lemmas less_iff_diff_less_0 = diff_less_0_iff_less [symmetric]

lemma diff_less_eq [algebra_simps, field_simps]: "a - b < c \<longleftrightarrow> a < c + b"
  apply (subst less_iff_diff_less_0 [of a])
  apply (rule less_iff_diff_less_0 [of _ c, THEN ssubst])
  apply (simp add: algebra_simps)
  done

lemma less_diff_eq[algebra_simps, field_simps]: "a < c - b \<longleftrightarrow> a + b < c"
  apply (subst less_iff_diff_less_0 [of "a + b"])
  apply (subst less_iff_diff_less_0 [of a])
  apply (simp add: algebra_simps)
  done

lemma diff_gt_0_iff_gt [simp]: "a - b > 0 \<longleftrightarrow> a > b"
  by (simp add: less_diff_eq)

lemma diff_le_eq [algebra_simps, field_simps]: "a - b \<le> c \<longleftrightarrow> a \<le> c + b"
  by (auto simp add: le_less diff_less_eq )

lemma le_diff_eq [algebra_simps, field_simps]: "a \<le> c - b \<longleftrightarrow> a + b \<le> c"
  by (auto simp add: le_less less_diff_eq)

lemma diff_le_0_iff_le [simp]: "a - b \<le> 0 \<longleftrightarrow> a \<le> b"
  by (simp add: algebra_simps)

lemmas le_iff_diff_le_0 = diff_le_0_iff_le [symmetric]

lemma diff_ge_0_iff_ge [simp]: "a - b \<ge> 0 \<longleftrightarrow> a \<ge> b"
  by (simp add: le_diff_eq)

lemma diff_eq_diff_less: "a - b = c - d \<Longrightarrow> a < b \<longleftrightarrow> c < d"
  by (auto simp only: less_iff_diff_less_0 [of a b] less_iff_diff_less_0 [of c d])

lemma diff_eq_diff_less_eq: "a - b = c - d \<Longrightarrow> a \<le> b \<longleftrightarrow> c \<le> d"
  by (auto simp only: le_iff_diff_le_0 [of a b] le_iff_diff_le_0 [of c d])

lemma diff_mono: "a \<le> b \<Longrightarrow> d \<le> c \<Longrightarrow> a - c \<le> b - d"
  by (simp add: field_simps add_mono)

lemma diff_left_mono: "b \<le> a \<Longrightarrow> c - a \<le> c - b"
  by (simp add: field_simps)

lemma diff_right_mono: "a \<le> b \<Longrightarrow> a - c \<le> b - c"
  by (simp add: field_simps)

lemma diff_strict_mono: "a < b \<Longrightarrow> d < c \<Longrightarrow> a - c < b - d"
  by (simp add: field_simps add_strict_mono)

lemma diff_strict_left_mono: "b < a \<Longrightarrow> c - a < c - b"
  by (simp add: field_simps)

lemma diff_strict_right_mono: "a < b \<Longrightarrow> a - c < b - c"
  by (simp add: field_simps)

end

ML_file "Tools/group_cancel.ML"

simproc_setup group_cancel_add ("a + b::'a::ab_group_add") =
  \<open>fn phi => fn ss => try Group_Cancel.cancel_add_conv\<close>

simproc_setup group_cancel_diff ("a - b::'a::ab_group_add") =
  \<open>fn phi => fn ss => try Group_Cancel.cancel_diff_conv\<close>

simproc_setup group_cancel_eq ("a = (b::'a::ab_group_add)") =
  \<open>fn phi => fn ss => try Group_Cancel.cancel_eq_conv\<close>

simproc_setup group_cancel_le ("a \<le> (b::'a::ordered_ab_group_add)") =
  \<open>fn phi => fn ss => try Group_Cancel.cancel_le_conv\<close>

simproc_setup group_cancel_less ("a < (b::'a::ordered_ab_group_add)") =
  \<open>fn phi => fn ss => try Group_Cancel.cancel_less_conv\<close>

class linordered_ab_semigroup_add =
  linorder + ordered_ab_semigroup_add

class linordered_cancel_ab_semigroup_add =
  linorder + ordered_cancel_ab_semigroup_add
begin

subclass linordered_ab_semigroup_add ..

subclass ordered_ab_semigroup_add_imp_le
proof
  fix a b c :: 'a
  assume le1: "c + a \<le> c + b"
  show "a \<le> b"
  proof (rule ccontr)
    assume *: "\<not> ?thesis"
    then have "b \<le> a" by (simp add: linorder_not_le)
    then have "c + b \<le> c + a" by (rule add_left_mono)
    with le1 have "a = b"
      apply -
      apply (drule antisym)
       apply simp_all
      done
    with * show False
      by (simp add: linorder_not_le [symmetric])
  qed
qed

end

class linordered_ab_group_add = linorder + ordered_ab_group_add
begin

subclass linordered_cancel_ab_semigroup_add ..

lemma equal_neg_zero [simp]: "a = - a \<longleftrightarrow> a = 0"
proof
  assume "a = 0"
  then show "a = - a" by simp
next
  assume A: "a = - a"
  show "a = 0"
  proof (cases "0 \<le> a")
    case True
    with A have "0 \<le> - a" by auto
    with le_minus_iff have "a \<le> 0" by simp
    with True show ?thesis by (auto intro: order_trans)
  next
    case False
    then have B: "a \<le> 0" by auto
    with A have "- a \<le> 0" by auto
    with B show ?thesis by (auto intro: order_trans)
  qed
qed

lemma neg_equal_zero [simp]: "- a = a \<longleftrightarrow> a = 0"
  by (auto dest: sym)

lemma neg_less_eq_nonneg [simp]: "- a \<le> a \<longleftrightarrow> 0 \<le> a"
proof
  assume *: "- a \<le> a"
  show "0 \<le> a"
  proof (rule classical)
    assume "\<not> ?thesis"
    then have "a < 0" by auto
    with * have "- a < 0" by (rule le_less_trans)
    then show ?thesis by auto
  qed
next
  assume *: "0 \<le> a"
  then have "- a \<le> 0" by (simp add: minus_le_iff)
  from this * show "- a \<le> a" by (rule order_trans)
qed

lemma neg_less_pos [simp]: "- a < a \<longleftrightarrow> 0 < a"
  by (auto simp add: less_le)

lemma less_eq_neg_nonpos [simp]: "a \<le> - a \<longleftrightarrow> a \<le> 0"
  using neg_less_eq_nonneg [of "- a"] by simp

lemma less_neg_neg [simp]: "a < - a \<longleftrightarrow> a < 0"
  using neg_less_pos [of "- a"] by simp

lemma double_zero [simp]: "a + a = 0 \<longleftrightarrow> a = 0"
proof
  assume "a + a = 0"
  then have a: "- a = a" by (rule minus_unique)
  then show "a = 0" by (simp only: neg_equal_zero)
next
  assume "a = 0"
  then show "a + a = 0" by simp
qed

lemma double_zero_sym [simp]: "0 = a + a \<longleftrightarrow> a = 0"
  apply (rule iffI)
   apply (drule sym)
   apply simp_all
  done

lemma zero_less_double_add_iff_zero_less_single_add [simp]: "0 < a + a \<longleftrightarrow> 0 < a"
proof
  assume "0 < a + a"
  then have "0 - a < a" by (simp only: diff_less_eq)
  then have "- a < a" by simp
  then show "0 < a" by simp
next
  assume "0 < a"
  with this have "0 + 0 < a + a"
    by (rule add_strict_mono)
  then show "0 < a + a" by simp
qed

lemma zero_le_double_add_iff_zero_le_single_add [simp]: "0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
  by (auto simp add: le_less)

lemma double_add_less_zero_iff_single_add_less_zero [simp]: "a + a < 0 \<longleftrightarrow> a < 0"
proof -
  have "\<not> a + a < 0 \<longleftrightarrow> \<not> a < 0"
    by (simp add: not_less)
  then show ?thesis by simp
qed

lemma double_add_le_zero_iff_single_add_le_zero [simp]: "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
proof -
  have "\<not> a + a \<le> 0 \<longleftrightarrow> \<not> a \<le> 0"
    by (simp add: not_le)
  then show ?thesis by simp
qed

lemma minus_max_eq_min: "- max x y = min (- x) (- y)"
  by (auto simp add: max_def min_def)

lemma minus_min_eq_max: "- min x y = max (- x) (- y)"
  by (auto simp add: max_def min_def)

end

class abs =
  fixes abs :: "'a \<Rightarrow> 'a"  ("\<bar>_\<bar>")

class sgn =
  fixes sgn :: "'a \<Rightarrow> 'a"

class ordered_ab_group_add_abs = ordered_ab_group_add + abs +
  assumes abs_ge_zero [simp]: "\<bar>a\<bar> \<ge> 0"
    and abs_ge_self: "a \<le> \<bar>a\<bar>"
    and abs_leI: "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b"
    and abs_minus_cancel [simp]: "\<bar>-a\<bar> = \<bar>a\<bar>"
    and abs_triangle_ineq: "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
begin

lemma abs_minus_le_zero: "- \<bar>a\<bar> \<le> 0"
  unfolding neg_le_0_iff_le by simp

lemma abs_of_nonneg [simp]:
  assumes nonneg: "0 \<le> a"
  shows "\<bar>a\<bar> = a"
proof (rule antisym)
  show "a \<le> \<bar>a\<bar>" by (rule abs_ge_self)
  from nonneg le_imp_neg_le have "- a \<le> 0" by simp
  from this nonneg have "- a \<le> a" by (rule order_trans)
  then show "\<bar>a\<bar> \<le> a" by (auto intro: abs_leI)
qed

lemma abs_idempotent [simp]: "\<bar>\<bar>a\<bar>\<bar> = \<bar>a\<bar>"
  by (rule antisym) (auto intro!: abs_ge_self abs_leI order_trans [of "- \<bar>a\<bar>" 0 "\<bar>a\<bar>"])

lemma abs_eq_0 [simp]: "\<bar>a\<bar> = 0 \<longleftrightarrow> a = 0"
proof -
  have "\<bar>a\<bar> = 0 \<Longrightarrow> a = 0"
  proof (rule antisym)
    assume zero: "\<bar>a\<bar> = 0"
    with abs_ge_self show "a \<le> 0" by auto
    from zero have "\<bar>-a\<bar> = 0" by simp
    with abs_ge_self [of "- a"] have "- a \<le> 0" by auto
    with neg_le_0_iff_le show "0 \<le> a" by auto
  qed
  then show ?thesis by auto
qed

lemma abs_zero [simp]: "\<bar>0\<bar> = 0"
  by simp

lemma abs_0_eq [simp]: "0 = \<bar>a\<bar> \<longleftrightarrow> a = 0"
proof -
  have "0 = \<bar>a\<bar> \<longleftrightarrow> \<bar>a\<bar> = 0" by (simp only: eq_ac)
  then show ?thesis by simp
qed

lemma abs_le_zero_iff [simp]: "\<bar>a\<bar> \<le> 0 \<longleftrightarrow> a = 0"
proof
  assume "\<bar>a\<bar> \<le> 0"
  then have "\<bar>a\<bar> = 0" by (rule antisym) simp
  then show "a = 0" by simp
next
  assume "a = 0"
  then show "\<bar>a\<bar> \<le> 0" by simp
qed

lemma abs_le_self_iff [simp]: "\<bar>a\<bar> \<le> a \<longleftrightarrow> 0 \<le> a"
proof -
  have "0 \<le> \<bar>a\<bar>"
    using abs_ge_zero by blast
  then have "\<bar>a\<bar> \<le> a \<Longrightarrow> 0 \<le> a"
    using order.trans by blast
  then show ?thesis
    using abs_of_nonneg eq_refl by blast
qed

lemma zero_less_abs_iff [simp]: "0 < \<bar>a\<bar> \<longleftrightarrow> a \<noteq> 0"
  by (simp add: less_le)

lemma abs_not_less_zero [simp]: "\<not> \<bar>a\<bar> < 0"
proof -
  have "x \<le> y \<Longrightarrow> \<not> y < x" for x y by auto
  then show ?thesis by simp
qed

lemma abs_ge_minus_self: "- a \<le> \<bar>a\<bar>"
proof -
  have "- a \<le> \<bar>-a\<bar>" by (rule abs_ge_self)
  then show ?thesis by simp
qed

lemma abs_minus_commute: "\<bar>a - b\<bar> = \<bar>b - a\<bar>"
proof -
  have "\<bar>a - b\<bar> = \<bar>- (a - b)\<bar>"
    by (simp only: abs_minus_cancel)
  also have "\<dots> = \<bar>b - a\<bar>" by simp
  finally show ?thesis .
qed

lemma abs_of_pos: "0 < a \<Longrightarrow> \<bar>a\<bar> = a"
  by (rule abs_of_nonneg) (rule less_imp_le)

lemma abs_of_nonpos [simp]:
  assumes "a \<le> 0"
  shows "\<bar>a\<bar> = - a"
proof -
  let ?b = "- a"
  have "- ?b \<le> 0 \<Longrightarrow> \<bar>- ?b\<bar> = - (- ?b)"
    unfolding abs_minus_cancel [of ?b]
    unfolding neg_le_0_iff_le [of ?b]
    unfolding minus_minus by (erule abs_of_nonneg)
  then show ?thesis using assms by auto
qed

lemma abs_of_neg: "a < 0 \<Longrightarrow> \<bar>a\<bar> = - a"
  by (rule abs_of_nonpos) (rule less_imp_le)

lemma abs_le_D1: "\<bar>a\<bar> \<le> b \<Longrightarrow> a \<le> b"
  using abs_ge_self by (blast intro: order_trans)

lemma abs_le_D2: "\<bar>a\<bar> \<le> b \<Longrightarrow> - a \<le> b"
  using abs_le_D1 [of "- a"] by simp

lemma abs_le_iff: "\<bar>a\<bar> \<le> b \<longleftrightarrow> a \<le> b \<and> - a \<le> b"
  by (blast intro: abs_leI dest: abs_le_D1 abs_le_D2)

lemma abs_triangle_ineq2: "\<bar>a\<bar> - \<bar>b\<bar> \<le> \<bar>a - b\<bar>"
proof -
  have "\<bar>a\<bar> = \<bar>b + (a - b)\<bar>"
    by (simp add: algebra_simps)
  then have "\<bar>a\<bar> \<le> \<bar>b\<bar> + \<bar>a - b\<bar>"
    by (simp add: abs_triangle_ineq)
  then show ?thesis
    by (simp add: algebra_simps)
qed

lemma abs_triangle_ineq2_sym: "\<bar>a\<bar> - \<bar>b\<bar> \<le> \<bar>b - a\<bar>"
  by (simp only: abs_minus_commute [of b] abs_triangle_ineq2)

lemma abs_triangle_ineq3: "\<bar>\<bar>a\<bar> - \<bar>b\<bar>\<bar> \<le> \<bar>a - b\<bar>"
  by (simp add: abs_le_iff abs_triangle_ineq2 abs_triangle_ineq2_sym)

lemma abs_triangle_ineq4: "\<bar>a - b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
proof -
  have "\<bar>a - b\<bar> = \<bar>a + - b\<bar>"
    by (simp add: algebra_simps)
  also have "\<dots> \<le> \<bar>a\<bar> + \<bar>- b\<bar>"
    by (rule abs_triangle_ineq)
  finally show ?thesis by simp
qed

lemma abs_diff_triangle_ineq: "\<bar>a + b - (c + d)\<bar> \<le> \<bar>a - c\<bar> + \<bar>b - d\<bar>"
proof -
  have "\<bar>a + b - (c + d)\<bar> = \<bar>(a - c) + (b - d)\<bar>"
    by (simp add: algebra_simps)
  also have "\<dots> \<le> \<bar>a - c\<bar> + \<bar>b - d\<bar>"
    by (rule abs_triangle_ineq)
  finally show ?thesis .
qed

lemma abs_add_abs [simp]: "\<bar>\<bar>a\<bar> + \<bar>b\<bar>\<bar> = \<bar>a\<bar> + \<bar>b\<bar>"
  (is "?L = ?R")
proof (rule antisym)
  show "?L \<ge> ?R" by (rule abs_ge_self)
  have "?L \<le> \<bar>\<bar>a\<bar>\<bar> + \<bar>\<bar>b\<bar>\<bar>" by (rule abs_triangle_ineq)
  also have "\<dots> = ?R" by simp
  finally show "?L \<le> ?R" .
qed

end

lemma dense_eq0_I:
  fixes x::"'a::{dense_linorder,ordered_ab_group_add_abs}"
  shows "(\<And>e. 0 < e \<Longrightarrow> \<bar>x\<bar> \<le> e) \<Longrightarrow> x = 0"
  apply (cases "\<bar>x\<bar> = 0")
   apply simp
  apply (simp only: zero_less_abs_iff [symmetric])
  apply (drule dense)
  apply (auto simp add: not_less [symmetric])
  done

hide_fact (open) ab_diff_conv_add_uminus add_0 mult_1 ab_left_minus

lemmas add_0 = add_0_left (* FIXME duplicate *)
lemmas mult_1 = mult_1_left (* FIXME duplicate *)
lemmas ab_left_minus = left_minus (* FIXME duplicate *)
lemmas diff_diff_eq = diff_diff_add (* FIXME duplicate *)

subsection \<open>Canonically ordered monoids\<close>

text \<open>Canonically ordered monoids are never groups.\<close>

class canonically_ordered_monoid_add = comm_monoid_add + order +
  assumes le_iff_add: "a \<le> b \<longleftrightarrow> (\<exists>c. b = a + c)"
begin

lemma zero_le[simp]: "0 \<le> x"
  by (auto simp: le_iff_add)

lemma le_zero_eq[simp]: "n \<le> 0 \<longleftrightarrow> n = 0"
  by (auto intro: antisym)

lemma not_less_zero[simp]: "\<not> n < 0"
  by (auto simp: less_le)

lemma zero_less_iff_neq_zero: "0 < n \<longleftrightarrow> n \<noteq> 0"
  by (auto simp: less_le)

text \<open>This theorem is useful with \<open>blast\<close>\<close>
lemma gr_zeroI: "(n = 0 \<Longrightarrow> False) \<Longrightarrow> 0 < n"
  by (rule zero_less_iff_neq_zero[THEN iffD2]) iprover

lemma not_gr_zero[simp]: "\<not> 0 < n \<longleftrightarrow> n = 0"
  by (simp add: zero_less_iff_neq_zero)

subclass ordered_comm_monoid_add
  proof qed (auto simp: le_iff_add add_ac)

lemma gr_implies_not_zero: "m < n \<Longrightarrow> n \<noteq> 0"
  by auto

lemma add_eq_0_iff_both_eq_0[simp]: "x + y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
  by (intro add_nonneg_eq_0_iff zero_le)

lemma zero_eq_add_iff_both_eq_0[simp]: "0 = x + y \<longleftrightarrow> x = 0 \<and> y = 0"
  using add_eq_0_iff_both_eq_0[of x y] unfolding eq_commute[of 0] .

lemmas zero_order = zero_le le_zero_eq not_less_zero zero_less_iff_neq_zero not_gr_zero
  \<comment> \<open>This should be attributed with \<open>[iff]\<close>, but then \<open>blast\<close> fails in \<open>Set\<close>.\<close>

end

class ordered_cancel_comm_monoid_diff =
  canonically_ordered_monoid_add + comm_monoid_diff + ordered_ab_semigroup_add_imp_le
begin

context
  fixes a b :: 'a
  assumes le: "a \<le> b"
begin

lemma add_diff_inverse: "a + (b - a) = b"
  using le by (auto simp add: le_iff_add)

lemma add_diff_assoc: "c + (b - a) = c + b - a"
  using le by (auto simp add: le_iff_add add.left_commute [of c])

lemma add_diff_assoc2: "b - a + c = b + c - a"
  using le by (auto simp add: le_iff_add add.assoc)

lemma diff_add_assoc: "c + b - a = c + (b - a)"
  using le by (simp add: add.commute add_diff_assoc)

lemma diff_add_assoc2: "b + c - a = b - a + c"
  using le by (simp add: add.commute add_diff_assoc)

lemma diff_diff_right: "c - (b - a) = c + a - b"
  by (simp add: add_diff_inverse add_diff_cancel_left [of a c "b - a", symmetric] add.commute)

lemma diff_add: "b - a + a = b"
  by (simp add: add.commute add_diff_inverse)

lemma le_add_diff: "c \<le> b + c - a"
  by (auto simp add: add.commute diff_add_assoc2 le_iff_add)

lemma le_imp_diff_is_add: "a \<le> b \<Longrightarrow> b - a = c \<longleftrightarrow> b = c + a"
  by (auto simp add: add.commute add_diff_inverse)

lemma le_diff_conv2: "c \<le> b - a \<longleftrightarrow> c + a \<le> b"
  (is "?P \<longleftrightarrow> ?Q")
proof
  assume ?P
  then have "c + a \<le> b - a + a"
    by (rule add_right_mono)
  then show ?Q
    by (simp add: add_diff_inverse add.commute)
next
  assume ?Q
  then have "a + c \<le> a + (b - a)"
    by (simp add: add_diff_inverse add.commute)
  then show ?P by simp
qed

end

end

subsection \<open>Tools setup\<close>

lemma add_mono_thms_linordered_semiring:
  fixes i j k :: "'a::ordered_ab_semigroup_add"
  shows "i \<le> j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
    and "i = j \<and> k \<le> l \<Longrightarrow> i + k \<le> j + l"
    and "i \<le> j \<and> k = l \<Longrightarrow> i + k \<le> j + l"
    and "i = j \<and> k = l \<Longrightarrow> i + k = j + l"
  by (rule add_mono, clarify+)+

lemma add_mono_thms_linordered_field:
  fixes i j k :: "'a::ordered_cancel_ab_semigroup_add"
  shows "i < j \<and> k = l \<Longrightarrow> i + k < j + l"
    and "i = j \<and> k < l \<Longrightarrow> i + k < j + l"
    and "i < j \<and> k \<le> l \<Longrightarrow> i + k < j + l"
    and "i \<le> j \<and> k < l \<Longrightarrow> i + k < j + l"
    and "i < j \<and> k < l \<Longrightarrow> i + k < j + l"
  by (auto intro: add_strict_right_mono add_strict_left_mono
      add_less_le_mono add_le_less_mono add_strict_mono)

code_identifier
  code_module Groups \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


theory SINVAR_Dependability
imports "../TopoS_Helper"
begin

subsection \<open>SecurityInvariant Dependability\<close>

type_synonym dependability_level = nat

definition default_node_properties :: "dependability_level"
  where  "default_node_properties \<equiv> 0"

text \<open>Less-equal other nodes depend on the output of a node than its dependability level.\<close>
fun sinvar :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
  "sinvar G nP = (\<forall> (e1,e2) \<in> edges G. (num_reachable G e1) \<le> (nP e1))"

definition receiver_violation :: "bool" where
  "receiver_violation \<equiv> False"

text\<open>It does not matter whether we iterate over all edges or all nodes. We chose all edges because it is in line with the other models.\<close>
  fun sinvar_nodes :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> bool" where
    "sinvar_nodes G nP = (\<forall> v \<in> nodes G. (num_reachable G v) \<le> (nP v))"

  theorem sinvar_edges_nodes_iff: "wf_graph G \<Longrightarrow>
    sinvar_nodes G nP = sinvar G nP"
  proof(unfold sinvar_nodes.simps sinvar.simps, rule iffI)
    assume a1: "wf_graph G"
      and  a2: "\<forall>v\<in>nodes G. num_reachable G v \<le> nP v"

      from a1[simplified wf_graph_def] have f1: "fst ` edges G \<subseteq> nodes G" by simp
      from f1 a2 have "\<forall>v \<in> (fst ` edges G). num_reachable G v \<le> nP v" by auto

      thus "\<forall>(e1, _) \<in> edges G. num_reachable G e1 \<le> nP e1" by auto
    next
    assume a1: "wf_graph G"
      and  a2: "\<forall>(e1, _)\<in>edges G. num_reachable G e1 \<le> nP e1"

      from a2 have g1: "\<forall> v \<in> (fst ` edges G). num_reachable G v \<le> nP v" by auto

      from FiniteGraph.succ_tran_empty[OF a1] num_reachable_zero_iff[OF a1, symmetric]
      have g2: "\<forall> v. v \<notin> (fst ` edges G) \<longrightarrow> num_reachable G v \<le> nP v" by (metis le0)

      from g1 g2 show "\<forall>v\<in>nodes G. num_reachable G v \<le> nP v" by metis
  qed

  lemma num_reachable_le_nodes: "\<lbrakk> wf_graph G \<rbrakk> \<Longrightarrow> num_reachable G v \<le> card (nodes G)"
    unfolding num_reachable_def
    using succ_tran_subseteq_nodes card_seteq nat_le_linear wf_graph.finiteV by metis

  text\<open>nP is valid if all dependability level are greater equal the total number of nodes in the graph\<close>
  lemma "\<lbrakk> wf_graph G; \<forall>v \<in> nodes G. nP v \<ge> card (nodes G) \<rbrakk> \<Longrightarrow> sinvar G nP"
    apply(subst sinvar_edges_nodes_iff[symmetric], simp)
    apply(simp add:)
    using num_reachable_le_nodes by (metis le_trans)

  text\<open>Generate a valid configuration to start from:\<close>
   text\<open>Takes arbitrary configuration, returns a valid one\<close>
   fun dependability_fix_nP :: "'v graph \<Rightarrow> ('v \<Rightarrow> dependability_level) \<Rightarrow> ('v \<Rightarrow> dependability_level)" where
      "dependability_fix_nP G nP = (\<lambda>v. if num_reachable G v \<le> (nP v) then (nP v) else num_reachable G v)"

   text\<open>@{const dependability_fix_nP} always gives you a valid solution\<close>
   lemma dependability_fix_nP_valid: "\<lbrakk> wf_graph G \<rbrakk> \<Longrightarrow> sinvar G (dependability_fix_nP G nP)"
      by(subst sinvar_edges_nodes_iff[symmetric], simp_all)

   text\<open>furthermore, it gives you a minimal solution, i.e. if someone supplies a configuration with a value lower than
          calculated by @{const dependability_fix_nP}, this is invalid!\<close>
   lemma dependability_fix_nP_minimal_solution: "\<lbrakk> wf_graph G; \<exists> v \<in> nodes G. (nP v) < (dependability_fix_nP G (\<lambda>_. 0)) v \<rbrakk> \<Longrightarrow> \<not> sinvar G nP"
      apply(subst sinvar_edges_nodes_iff[symmetric], simp)
      apply(simp)
      apply(clarify)
      apply(rule_tac x="v" in bexI)
       apply(simp_all)
      done

(*
lemma card_less_equal_trancl: "finite A \<Longrightarrow> card {e2. (aa, e2) \<in> (A - X)\<^sup>+} \<le> card {e2. (aa, e2) \<in> (A)\<^sup>+}"
apply(subgoal_tac "{e2. (aa, e2) \<in> (A - X)\<^sup>+} \<subseteq> {e2. (aa, e2) \<in> (A)\<^sup>+}")
apply(rule card_mono)
defer
apply(simp)
apply (metis (lifting) Collect_mono Diff_subset trancl_mono)
by (metis (lifting) Range_iff finite_Range mem_Collect_eq rev_finite_subset subsetI trancl_range)
*)

interpretation SecurityInvariant_preliminaries
where sinvar = sinvar
  apply unfold_locales
    apply(frule_tac finite_distinct_list[OF wf_graph.finiteE])
    apply(erule_tac exE)
    apply(rename_tac list_edges)
    apply(rule_tac ff="list_edges" in SecurityInvariant_withOffendingFlows.mono_imp_set_offending_flows_not_empty[OF sinvar_mono])
        apply(auto)[4]
    apply(auto simp add: SecurityInvariant_withOffendingFlows.is_offending_flows_def graph_ops)[1]
   apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_sinvar_mono[OF sinvar_mono])
  apply(fact SecurityInvariant_withOffendingFlows.sinvar_mono_imp_is_offending_flows_mono[OF sinvar_mono])
done

interpretation Dependability: SecurityInvariant_ACS
where default_node_properties = SINVAR_Dependability.default_node_properties
and sinvar = SINVAR_Dependability.sinvar
  unfolding SINVAR_Dependability.default_node_properties_def
  proof
    fix G::"'a graph" and f nP
    assume "wf_graph G" and "f \<in> set_offending_flows G nP"
    thus "\<forall>i\<in>fst ` f. \<not> sinvar G (nP(i := 0))"
     apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
      SecurityInvariant_withOffendingFlows.is_offending_flows_def)
     apply (simp split: prod.split_asm prod.split)
     apply (simp add:graph_ops)
     apply(clarify)
     apply (metis gr0I le0)
     done
  next
   fix otherbot
   assume assm: "\<forall>G f nP i. wf_graph G \<and> f \<in> set_offending_flows G nP \<and> i \<in> fst ` f \<longrightarrow> \<not> sinvar G (nP(i := otherbot))"
   have unique_default_example_succ_tran:
    "succ_tran \<lparr>nodes = {vertex_1, vertex_2}, edges = {(vertex_1, vertex_2)}\<rparr> vertex_1 = {vertex_2}"
    using unique_default_example1 by blast
   from assm show "otherbot = 0"
    apply -
    apply(elim default_uniqueness_by_counterexample_ACS)
    apply(simp)
    apply (simp add: SecurityInvariant_withOffendingFlows.set_offending_flows_def
        SecurityInvariant_withOffendingFlows.is_offending_flows_min_set_def
        SecurityInvariant_withOffendingFlows.is_offending_flows_def)
    apply (simp add:graph_ops)
    apply (simp split: prod.split_asm prod.split)
    apply(rule_tac x="\<lparr> nodes={vertex_1,vertex_2}, edges = {(vertex_1,vertex_2)} \<rparr>" in exI, simp)
    apply(rule conjI)
     apply(simp add: wf_graph_def)
    apply(rule_tac x="(\<lambda> x. 0)(vertex_1 := 0, vertex_2 := 0)" in exI, simp)
    apply(rule conjI)
     apply(simp add: unique_default_example_succ_tran num_reachable_def)
    apply(rule_tac x="vertex_1" in exI, simp)
    apply(rule_tac x="{(vertex_1,vertex_2)}" in exI, simp)
    apply(simp add: unique_default_example_succ_tran num_reachable_def)
    apply(simp add: succ_tran_def unique_default_example_simp1 unique_default_example_simp2)
    done
  qed

  lemma TopoS_Dependability: "SecurityInvariant sinvar default_node_properties receiver_violation"
  unfolding receiver_violation_def by unfold_locales

hide_const (open) sinvar receiver_violation default_node_properties

end


(*
    ex.thy,v 1.1 2016/09/29 17:37:37 jdf Exp
    Original Author: Tjark Weber
    Updated to Isabelle 2016 by Jacques Fleuriot
*)

section {* Predicate Logic *}

 theory predicate_logic imports Main begin

text {*
We are again talking about proofs in the calculus of Natural Deduction.  In
addition to the rules given in the exercise "Propositional Logic", you may
now also use

exI: ?P ?x ⟹ ∃x. ?P x
exE:⟦∃x. ?P x; ⋀x. ?P x ⟹ ?Q⟧ ⟹ ?Q
allI: (⋀x. ?P x) ⟹ ∀x. ?P x
allE: ⟦∀x. ?P x; ?P ?x ⟹ ?R⟧ ⟹ ?R

Give a proof of the f collowing propositions or an argument why the formula is
not valid:
*}

lemma "(∃x. ∀y. P x y) ⟶ (∀y. ∃x. P x y)"
  apply (rule impI)
  apply (erule exE)
  apply (rule allI)
  apply (erule allE)
  apply (rule exI)
  apply assumption
  done

lemma "(∀x. P x ⟶ Q) = ((∃x. P x) ⟶ Q)"
  apply (rule iffI)
  apply (rule impI)
   apply (erule exE)
   apply (erule allE)
   apply (erule impE)
    apply assumption
   apply assumption
  apply (rule allI)
  apply (rule impI)
  apply (erule impE)
   apply (rule exI)
   apply assumption
  apply assumption
  done

lemma "((∀ x. P x) ∧ (∀ x. Q x)) = (∀ x. (P x ∧ Q x))"
  apply (rule iffI)
   apply (erule conjE)
   apply (rule allI)
   apply (erule allE)
   apply (erule allE)
   apply (rule conjI)
    apply assumption
   apply assumption
  apply (rule conjI)
   apply (rule allI, erule allE, erule conjE, assumption)+

lemma "((∀ x. P x) ∨ (∀ x. Q x)) = (∀ x. (P x ∨ Q x))"
  oops
  text {*
    Auto Quickcheck found a counterexample:
      P = {a⇩1}
      Q = {a⇩2}
    Evaluated terms:
      ∀x xa. P x ∨ Q xa = False
      ∀x. P x ∨ Q x = True
  *}

lemma "((∃ x. P x) ∨ (∃ x. Q x)) = (∃ x. (P x ∨ Q x))"
  apply (rule iffI)
   apply (erule disjE)
    apply (erule exE)
    apply (rule exI)
    apply (rule disjI1)
    apply assumption
   apply (erule exE)
   apply (rule exI)
   apply (rule disjI2)
   apply assumption
  apply (erule exE)
  apply (erule disjE)
   apply (rule disjI1)
   apply (rule exI)
   apply assumption
  apply (rule disjI2)
  apply (rule exI)
  apply assumption

lemma "(∀x. ∃y. P x y) ⟶ (∃y. ∀x. P x y)"
  oops
  text {*
  Auto Quickcheck found a counterexample:
     P = (λx. undefined)(a⇩1 := {a⇩2}, a⇩2 := {a⇩1})
  *}

lemma "(¬ (∀ x. P x)) = (∃ x. ¬ P x)"
  apply (rule iffI)
   apply (rule classical)
   apply (erule notE)
   apply (rule allI)
   apply (rule classical)
   apply (erule notE)
   apply (rule exI)
   apply assumption
  apply (erule exE)
  apply (rule notI)
  apply (erule allE)
  apply (erule notE)
  apply assumption

end


(*
  File:     Range_Search.thy
  Author:   Martin Rau, TU München
*)

section \<open>Range Searching\<close>

theory Range_Search
imports
  KD_Tree
begin

text\<open>
  Given two \<open>k\<close>-dimensional points \<open>p\<^sub>0\<close> and \<open>p\<^sub>1\<close> which bound the search space, the search should
  return only the points which satisfy the following criteria:

  For every point p in the resulting set: \newline
  \hspace{1cm}  For every axis @{term "k"}: \newline
  \hspace{2cm}    @{term "p\<^sub>0$k \<le> p$k \<and> p$k \<le> p\<^sub>1$k"} \newline

  For a \<open>2\<close>-d tree a query corresponds to selecting all the points in the rectangle that
  has \<open>p\<^sub>0\<close> and \<open>p\<^sub>1\<close> as its defining edges.
\<close>

subsection \<open>Rectangle Definition\<close>

lemma cbox_point_def:
  fixes p\<^sub>0 :: "('k::finite) point"
  shows "cbox p\<^sub>0 p\<^sub>1 = { p. \<forall>k. p\<^sub>0$k \<le> p$k \<and> p$k \<le> p\<^sub>1$k }"
proof -
  have "cbox p\<^sub>0 p\<^sub>1 = { p. \<forall>k. p\<^sub>0 \<bullet> axis k 1 \<le> p \<bullet> axis k 1 \<and> p \<bullet> axis k 1 \<le> p\<^sub>1 \<bullet> axis k 1 }"
    unfolding cbox_def using axis_inverse by auto
  also have "... = { p. \<forall>k. p\<^sub>0$k \<bullet> 1 \<le> p$k \<bullet> 1 \<and> p$k \<bullet> 1 \<le> p\<^sub>1$k \<bullet> 1 }"
    using inner_axis[of _ _ 1] by (smt Collect_cong)
  also have "... = { p. \<forall>k. p\<^sub>0$k \<le> p$k \<and> p$k \<le> p\<^sub>1$k }"
    by simp
  finally show ?thesis .
qed

subsection \<open>Search Function\<close>

fun search :: "('k::finite) point \<Rightarrow> 'k point \<Rightarrow> 'k kdt \<Rightarrow> 'k point set" where
  "search p\<^sub>0 p\<^sub>1 (Leaf p) = (if p \<in> cbox p\<^sub>0 p\<^sub>1 then { p } else {})"
| "search p\<^sub>0 p\<^sub>1 (Node k v l r) = (
    if v < p\<^sub>0$k then
      search p\<^sub>0 p\<^sub>1 r
    else if p\<^sub>1$k < v then
      search p\<^sub>0 p\<^sub>1 l
    else
      search p\<^sub>0 p\<^sub>1 l \<union> search p\<^sub>0 p\<^sub>1 r
  )"

subsection \<open>Auxiliary Lemmas\<close>

lemma l_empty:
  assumes "invar (Node k v l r)" "v < p\<^sub>0$k"
  shows "set_kdt l \<inter> cbox p\<^sub>0 p\<^sub>1 = {}"
proof -
  have "\<forall>p \<in> set_kdt l. p$k < p\<^sub>0$k"
    using assms by auto
  hence "\<forall>p \<in> set_kdt l. p \<notin> cbox p\<^sub>0 p\<^sub>1"
    using cbox_point_def leD by blast
  thus ?thesis by blast
qed

lemma r_empty:
  assumes "invar (Node k v l r)" "p\<^sub>1$k < v"
  shows "set_kdt r \<inter> cbox p\<^sub>0 p\<^sub>1 = {}"
proof -
  have "\<forall>p \<in> set_kdt r. p\<^sub>1$k < p$k"
    using assms by auto
  hence "\<forall>p \<in> set_kdt r. p \<notin> cbox p\<^sub>0 p\<^sub>1"
    using cbox_point_def leD by blast
  thus ?thesis by blast
qed

subsection \<open>Main Theorem\<close>

theorem search_cbox:
  assumes "invar kdt"
  shows "search p\<^sub>0 p\<^sub>1 kdt = set_kdt kdt \<inter> cbox p\<^sub>0 p\<^sub>1"
  using assms l_empty r_empty by (induction kdt) (auto, blast+)

end