(*  Title:      HOL/Datatype_Examples/Derivation_Trees/Parallel.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Parallel composition.
*)

section \<open>Parallel Composition\<close>

theory Parallel
imports DTree
begin

no_notation plus_class.plus (infixl "+" 65)

consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)

axiomatization where
    Nplus_comm: "(a::N) + b = b + (a::N)"
and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"

subsection\<open>Corecursive Definition of Parallel Composition\<close>

fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
fun par_c where
"par_c (tr1,tr2) =
 Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
 Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"

declare par_r.simps[simp del]  declare par_c.simps[simp del]

definition par :: "dtree \<times> dtree \<Rightarrow> dtree" where
"par \<equiv> unfold par_r par_c"

abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"

lemma finite_par_c: "finite (par_c (tr1, tr2))"
unfolding par_c.simps apply(rule finite_UnI)
  apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
  apply(intro finite_imageI finite_cartesian_product finite_vimageI)
  using finite_cont by auto

lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp

lemma cont_par:
"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
unfolding par_def ..

lemma Inl_cont_par[simp]:
"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
unfolding cont_par par_c.simps by auto

lemma Inr_cont_par[simp]:
"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
unfolding cont_par par_c.simps by auto

lemma Inl_in_cont_par:
"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto

lemma Inr_in_cont_par:
"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto

subsection\<open>Structural Coinduction Proofs\<close>

lemma rel_set_rel_sum_eq[simp]:
"rel_set (rel_sum (op =) \<phi>) A1 A2 \<longleftrightarrow>
 Inl -` A1 = Inl -` A2 \<and> rel_set \<phi> (Inr -` A1) (Inr -` A2)"
unfolding rel_set_rel_sum rel_set_eq ..

(* Detailed proofs of commutativity and associativity: *)
theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
proof-
  let ?\<theta> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
  {fix trA trB
   assume "?\<theta> trA trB" hence "trA = trB"
   apply (induct rule: dtree_coinduct)
   unfolding rel_set_rel_sum rel_set_eq unfolding rel_set_def proof safe
     fix tr1 tr2  show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
     unfolding root_par by (rule Nplus_comm)
   next
     fix n tr1 tr2 assume "Inl n \<in> cont (tr1 \<parallel> tr2)" thus "n \<in> Inl -` (cont (tr2 \<parallel> tr1))"
     unfolding Inl_in_cont_par by auto
   next
     fix n tr1 tr2 assume "Inl n \<in> cont (tr2 \<parallel> tr1)" thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2))"
     unfolding Inl_in_cont_par by auto
   next
     fix tr1 tr2 trA' assume "Inr trA' \<in> cont (tr1 \<parallel> tr2)"
     then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     unfolding Inr_in_cont_par by auto
     thus "\<exists> trB' \<in> Inr -` (cont (tr2 \<parallel> tr1)). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
   next
     fix tr1 tr2 trB' assume "Inr trB' \<in> cont (tr2 \<parallel> tr1)"
     then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     unfolding Inr_in_cont_par by auto
     thus "\<exists> trA' \<in> Inr -` (cont (tr1 \<parallel> tr2)). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
   qed
  }
  thus ?thesis by blast
qed

lemma par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
proof-
  let ?\<theta> =
  "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
  {fix trA trB
   assume "?\<theta> trA trB" hence "trA = trB"
   apply (induct rule: dtree_coinduct)
   unfolding rel_set_rel_sum rel_set_eq unfolding rel_set_def proof safe
     fix tr1 tr2 tr3  show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
     unfolding root_par by (rule Nplus_assoc)
   next
     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont ((tr1 \<parallel> tr2) \<parallel> tr3))"
     thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2 \<parallel> tr3))" unfolding Inl_in_cont_par by simp
   next
     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont (tr1 \<parallel> tr2 \<parallel> tr3))"
     thus "n \<in> Inl -` (cont ((tr1 \<parallel> tr2) \<parallel> tr3))" unfolding Inl_in_cont_par by simp
   next
     fix trA' tr1 tr2 tr3 assume "Inr trA' \<in> cont ((tr1 \<parallel> tr2) \<parallel> tr3)"
     then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
     thus "\<exists> trB' \<in> Inr -` (cont (tr1 \<parallel> tr2 \<parallel> tr3)). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "tr1' \<parallel> tr2' \<parallel> tr3'"])
     unfolding Inr_in_cont_par by auto
   next
     fix trB' tr1 tr2 tr3 assume "Inr trB' \<in> cont (tr1 \<parallel> tr2 \<parallel> tr3)"
     then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
     thus "\<exists> trA' \<in> Inr -` cont ((tr1 \<parallel> tr2) \<parallel> tr3). ?\<theta> trA' trB'"
     apply(intro bexI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
     unfolding Inr_in_cont_par by auto
   qed
  }
  thus ?thesis by blast
qed

end


(*  Title:      ZF/Perm.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge

The theory underlying permutation groups
  -- Composition of relations, the identity relation
  -- Injections, surjections, bijections
  -- Lemmas for the Schroeder-Bernstein Theorem
*)

section{*Injections, Surjections, Bijections, Composition*}

theory Perm imports func begin

definition
  (*composition of relations and functions; NOT Suppes's relative product*)
  comp     :: "[i,i]=>i"      (infixr "O" 60)  where
    "r O s == {xz \<in> domain(s)*range(r) .
               \<exists>x y z. xz=<x,z> & <x,y>:s & <y,z>:r}"

definition
  (*the identity function for A*)
  id    :: "i=>i"  where
    "id(A) == (\<lambda>x\<in>A. x)"

definition
  (*one-to-one functions from A to B*)
  inj   :: "[i,i]=>i"  where
    "inj(A,B) == { f \<in> A->B. \<forall>w\<in>A. \<forall>x\<in>A. f`w=f`x \<longrightarrow> w=x}"

definition
  (*onto functions from A to B*)
  surj  :: "[i,i]=>i"  where
    "surj(A,B) == { f \<in> A->B . \<forall>y\<in>B. \<exists>x\<in>A. f`x=y}"

definition
  (*one-to-one and onto functions*)
  bij   :: "[i,i]=>i"  where
    "bij(A,B) == inj(A,B) \<inter> surj(A,B)"

subsection{*Surjective Function Space*}

lemma surj_is_fun: "f \<in> surj(A,B) ==> f \<in> A->B"
apply (unfold surj_def)
apply (erule CollectD1)
done

lemma fun_is_surj: "f \<in> Pi(A,B) ==> f \<in> surj(A,range(f))"
apply (unfold surj_def)
apply (blast intro: apply_equality range_of_fun domain_type)
done

lemma surj_range: "f \<in> surj(A,B) ==> range(f)=B"
apply (unfold surj_def)
apply (best intro: apply_Pair elim: range_type)
done

text{* A function with a right inverse is a surjection *}

lemma f_imp_surjective:
    "[| f \<in> A->B;  !!y. y \<in> B ==> d(y): A;  !!y. y \<in> B ==> f`d(y) = y |]
     ==> f \<in> surj(A,B)"
  by (simp add: surj_def, blast)

lemma lam_surjective:
    "[| !!x. x \<in> A ==> c(x): B;
        !!y. y \<in> B ==> d(y): A;
        !!y. y \<in> B ==> c(d(y)) = y
     |] ==> (\<lambda>x\<in>A. c(x)) \<in> surj(A,B)"
apply (rule_tac d = d in f_imp_surjective)
apply (simp_all add: lam_type)
done

text{*Cantor's theorem revisited*}
lemma cantor_surj: "f \<notin> surj(A,Pow(A))"
apply (unfold surj_def, safe)
apply (cut_tac cantor)
apply (best del: subsetI)
done

subsection{*Injective Function Space*}

lemma inj_is_fun: "f \<in> inj(A,B) ==> f \<in> A->B"
apply (unfold inj_def)
apply (erule CollectD1)
done

text{*Good for dealing with sets of pairs, but a bit ugly in use [used in AC]*}
lemma inj_equality:
    "[| <a,b>:f;  <c,b>:f;  f \<in> inj(A,B) |] ==> a=c"
apply (unfold inj_def)
apply (blast dest: Pair_mem_PiD)
done

lemma inj_apply_equality: "[| f \<in> inj(A,B);  f`a=f`b;  a \<in> A;  b \<in> A |] ==> a=b"
by (unfold inj_def, blast)

text{* A function with a left inverse is an injection *}

lemma f_imp_injective: "[| f \<in> A->B;  \<forall>x\<in>A. d(f`x)=x |] ==> f \<in> inj(A,B)"
apply (simp (no_asm_simp) add: inj_def)
apply (blast intro: subst_context [THEN box_equals])
done

lemma lam_injective:
    "[| !!x. x \<in> A ==> c(x): B;
        !!x. x \<in> A ==> d(c(x)) = x |]
     ==> (\<lambda>x\<in>A. c(x)) \<in> inj(A,B)"
apply (rule_tac d = d in f_imp_injective)
apply (simp_all add: lam_type)
done

subsection{*Bijections*}

lemma bij_is_inj: "f \<in> bij(A,B) ==> f \<in> inj(A,B)"
apply (unfold bij_def)
apply (erule IntD1)
done

lemma bij_is_surj: "f \<in> bij(A,B) ==> f \<in> surj(A,B)"
apply (unfold bij_def)
apply (erule IntD2)
done

lemma bij_is_fun: "f \<in> bij(A,B) ==> f \<in> A->B"
  by (rule bij_is_inj [THEN inj_is_fun])

lemma lam_bijective:
    "[| !!x. x \<in> A ==> c(x): B;
        !!y. y \<in> B ==> d(y): A;
        !!x. x \<in> A ==> d(c(x)) = x;
        !!y. y \<in> B ==> c(d(y)) = y
     |] ==> (\<lambda>x\<in>A. c(x)) \<in> bij(A,B)"
apply (unfold bij_def)
apply (blast intro!: lam_injective lam_surjective)
done

lemma RepFun_bijective: "(\<forall>y\<in>x. EX! y'. f(y') = f(y))
      ==> (\<lambda>z\<in>{f(y). y \<in> x}. THE y. f(y) = z) \<in> bij({f(y). y \<in> x}, x)"
apply (rule_tac d = f in lam_bijective)
apply (auto simp add: the_equality2)
done

subsection{*Identity Function*}

lemma idI [intro!]: "a \<in> A ==> <a,a> \<in> id(A)"
apply (unfold id_def)
apply (erule lamI)
done

lemma idE [elim!]: "[| p \<in> id(A);  !!x.[| x \<in> A; p=<x,x> |] ==> P |] ==>  P"
by (simp add: id_def lam_def, blast)

lemma id_type: "id(A) \<in> A->A"
apply (unfold id_def)
apply (rule lam_type, assumption)
done

lemma id_conv [simp]: "x \<in> A ==> id(A)`x = x"
apply (unfold id_def)
apply (simp (no_asm_simp))
done

lemma id_mono: "A<=B ==> id(A) \<subseteq> id(B)"
apply (unfold id_def)
apply (erule lam_mono)
done

lemma id_subset_inj: "A<=B ==> id(A): inj(A,B)"
apply (simp add: inj_def id_def)
apply (blast intro: lam_type)
done

lemmas id_inj = subset_refl [THEN id_subset_inj]

lemma id_surj: "id(A): surj(A,A)"
apply (unfold id_def surj_def)
apply (simp (no_asm_simp))
done

lemma id_bij: "id(A): bij(A,A)"
apply (unfold bij_def)
apply (blast intro: id_inj id_surj)
done

lemma subset_iff_id: "A \<subseteq> B \<longleftrightarrow> id(A) \<in> A->B"
apply (unfold id_def)
apply (force intro!: lam_type dest: apply_type)
done

text{*@{term id} as the identity relation*}
lemma id_iff [simp]: "<x,y> \<in> id(A) \<longleftrightarrow> x=y & y \<in> A"
by auto

subsection{*Converse of a Function*}

lemma inj_converse_fun: "f \<in> inj(A,B) ==> converse(f) \<in> range(f)->A"
apply (unfold inj_def)
apply (simp (no_asm_simp) add: Pi_iff function_def)
apply (erule CollectE)
apply (simp (no_asm_simp) add: apply_iff)
apply (blast dest: fun_is_rel)
done

text{* Equations for converse(f) *}

text{*The premises are equivalent to saying that f is injective...*}
lemma left_inverse_lemma:
     "[| f \<in> A->B;  converse(f): C->A;  a \<in> A |] ==> converse(f)`(f`a) = a"
by (blast intro: apply_Pair apply_equality converseI)

lemma left_inverse [simp]: "[| f \<in> inj(A,B);  a \<in> A |] ==> converse(f)`(f`a) = a"
by (blast intro: left_inverse_lemma inj_converse_fun inj_is_fun)

lemma left_inverse_eq:
     "[|f \<in> inj(A,B); f ` x = y; x \<in> A|] ==> converse(f) ` y = x"
by auto

lemmas left_inverse_bij = bij_is_inj [THEN left_inverse]

lemma right_inverse_lemma:
     "[| f \<in> A->B;  converse(f): C->A;  b \<in> C |] ==> f`(converse(f)`b) = b"
by (rule apply_Pair [THEN converseD [THEN apply_equality]], auto)

(*Should the premises be f \<in> surj(A,B), b \<in> B for symmetry with left_inverse?
  No: they would not imply that converse(f) was a function! *)
lemma right_inverse [simp]:
     "[| f \<in> inj(A,B);  b \<in> range(f) |] ==> f`(converse(f)`b) = b"
by (blast intro: right_inverse_lemma inj_converse_fun inj_is_fun)

lemma right_inverse_bij: "[| f \<in> bij(A,B);  b \<in> B |] ==> f`(converse(f)`b) = b"
by (force simp add: bij_def surj_range)

subsection{*Converses of Injections, Surjections, Bijections*}

lemma inj_converse_inj: "f \<in> inj(A,B) ==> converse(f): inj(range(f), A)"
apply (rule f_imp_injective)
apply (erule inj_converse_fun, clarify)
apply (rule right_inverse)
 apply assumption
apply blast
done

lemma inj_converse_surj: "f \<in> inj(A,B) ==> converse(f): surj(range(f), A)"
by (blast intro: f_imp_surjective inj_converse_fun left_inverse inj_is_fun
                 range_of_fun [THEN apply_type])

text{*Adding this as an intro! rule seems to cause looping*}
lemma bij_converse_bij [TC]: "f \<in> bij(A,B) ==> converse(f): bij(B,A)"
apply (unfold bij_def)
apply (fast elim: surj_range [THEN subst] inj_converse_inj inj_converse_surj)
done

subsection{*Composition of Two Relations*}

text{*The inductive definition package could derive these theorems for @{term"r O s"}*}

lemma compI [intro]: "[| <a,b>:s; <b,c>:r |] ==> <a,c> \<in> r O s"
by (unfold comp_def, blast)

lemma compE [elim!]:
    "[| xz \<in> r O s;
        !!x y z. [| xz=<x,z>;  <x,y>:s;  <y,z>:r |] ==> P |]
     ==> P"
by (unfold comp_def, blast)

lemma compEpair:
    "[| <a,c> \<in> r O s;
        !!y. [| <a,y>:s;  <y,c>:r |] ==> P |]
     ==> P"
by (erule compE, simp)

lemma converse_comp: "converse(R O S) = converse(S) O converse(R)"
by blast

subsection{*Domain and Range -- see Suppes, Section 3.1*}

text{*Boyer et al., Set Theory in First-Order Logic, JAR 2 (1986), 287-327*}
lemma range_comp: "range(r O s) \<subseteq> range(r)"
by blast

lemma range_comp_eq: "domain(r) \<subseteq> range(s) ==> range(r O s) = range(r)"
by (rule range_comp [THEN equalityI], blast)

lemma domain_comp: "domain(r O s) \<subseteq> domain(s)"
by blast

lemma domain_comp_eq: "range(s) \<subseteq> domain(r) ==> domain(r O s) = domain(s)"
by (rule domain_comp [THEN equalityI], blast)

lemma image_comp: "(r O s)``A = r``(s``A)"
by blast

lemma inj_inj_range: "f \<in> inj(A,B) ==> f \<in> inj(A,range(f))"
  by (auto simp add: inj_def Pi_iff function_def)

lemma inj_bij_range: "f \<in> inj(A,B) ==> f \<in> bij(A,range(f))"
  by (auto simp add: bij_def intro: inj_inj_range inj_is_fun fun_is_surj)

subsection{*Other Results*}

lemma comp_mono: "[| r'<=r; s'<=s |] ==> (r' O s') \<subseteq> (r O s)"
by blast

text{*composition preserves relations*}
lemma comp_rel: "[| s<=A*B;  r<=B*C |] ==> (r O s) \<subseteq> A*C"
by blast

text{*associative law for composition*}
lemma comp_assoc: "(r O s) O t = r O (s O t)"
by blast

(*left identity of composition; provable inclusions are
        id(A) O r \<subseteq> r
  and   [| r<=A*B; B<=C |] ==> r \<subseteq> id(C) O r *)
lemma left_comp_id: "r<=A*B ==> id(B) O r = r"
by blast

(*right identity of composition; provable inclusions are
        r O id(A) \<subseteq> r
  and   [| r<=A*B; A<=C |] ==> r \<subseteq> r O id(C) *)
lemma right_comp_id: "r<=A*B ==> r O id(A) = r"
by blast

subsection{*Composition Preserves Functions, Injections, and Surjections*}

lemma comp_function: "[| function(g);  function(f) |] ==> function(f O g)"
by (unfold function_def, blast)

text{*Don't think the premises can be weakened much*}
lemma comp_fun: "[| g \<in> A->B;  f \<in> B->C |] ==> (f O g) \<in> A->C"
apply (auto simp add: Pi_def comp_function Pow_iff comp_rel)
apply (subst range_rel_subset [THEN domain_comp_eq], auto)
done

(*Thanks to the new definition of "apply", the premise f \<in> B->C is gone!*)
lemma comp_fun_apply [simp]:
     "[| g \<in> A->B;  a \<in> A |] ==> (f O g)`a = f`(g`a)"
apply (frule apply_Pair, assumption)
apply (simp add: apply_def image_comp)
apply (blast dest: apply_equality)
done

text{*Simplifies compositions of lambda-abstractions*}
lemma comp_lam:
    "[| !!x. x \<in> A ==> b(x): B |]
     ==> (\<lambda>y\<in>B. c(y)) O (\<lambda>x\<in>A. b(x)) = (\<lambda>x\<in>A. c(b(x)))"
apply (subgoal_tac "(\<lambda>x\<in>A. b(x)) \<in> A -> B")
 apply (rule fun_extension)
   apply (blast intro: comp_fun lam_funtype)
  apply (rule lam_funtype)
 apply simp
apply (simp add: lam_type)
done

lemma comp_inj:
     "[| g \<in> inj(A,B);  f \<in> inj(B,C) |] ==> (f O g) \<in> inj(A,C)"
apply (frule inj_is_fun [of g])
apply (frule inj_is_fun [of f])
apply (rule_tac d = "%y. converse (g) ` (converse (f) ` y)" in f_imp_injective)
 apply (blast intro: comp_fun, simp)
done

lemma comp_surj:
    "[| g \<in> surj(A,B);  f \<in> surj(B,C) |] ==> (f O g) \<in> surj(A,C)"
apply (unfold surj_def)
apply (blast intro!: comp_fun comp_fun_apply)
done

lemma comp_bij:
    "[| g \<in> bij(A,B);  f \<in> bij(B,C) |] ==> (f O g) \<in> bij(A,C)"
apply (unfold bij_def)
apply (blast intro: comp_inj comp_surj)
done

subsection{*Dual Properties of @{term inj} and @{term surj}*}

text{*Useful for proofs from
    D Pastre.  Automatic theorem proving in set theory.
    Artificial Intelligence, 10:1--27, 1978.*}

lemma comp_mem_injD1:
    "[| (f O g): inj(A,C);  g \<in> A->B;  f \<in> B->C |] ==> g \<in> inj(A,B)"
by (unfold inj_def, force)

lemma comp_mem_injD2:
    "[| (f O g): inj(A,C);  g \<in> surj(A,B);  f \<in> B->C |] ==> f \<in> inj(B,C)"
apply (unfold inj_def surj_def, safe)
apply (rule_tac x1 = x in bspec [THEN bexE])
apply (erule_tac [3] x1 = w in bspec [THEN bexE], assumption+, safe)
apply (rule_tac t = "op ` (g) " in subst_context)
apply (erule asm_rl bspec [THEN bspec, THEN mp])+
apply (simp (no_asm_simp))
done

lemma comp_mem_surjD1:
    "[| (f O g): surj(A,C);  g \<in> A->B;  f \<in> B->C |] ==> f \<in> surj(B,C)"
apply (unfold surj_def)
apply (blast intro!: comp_fun_apply [symmetric] apply_funtype)
done

lemma comp_mem_surjD2:
    "[| (f O g): surj(A,C);  g \<in> A->B;  f \<in> inj(B,C) |] ==> g \<in> surj(A,B)"
apply (unfold inj_def surj_def, safe)
apply (drule_tac x = "f`y" in bspec, auto)
apply (blast intro: apply_funtype)
done

subsubsection{*Inverses of Composition*}

text{*left inverse of composition; one inclusion is
        @{term "f \<in> A->B ==> id(A) \<subseteq> converse(f) O f"} *}
lemma left_comp_inverse: "f \<in> inj(A,B) ==> converse(f) O f = id(A)"
apply (unfold inj_def, clarify)
apply (rule equalityI)
 apply (auto simp add: apply_iff, blast)
done

text{*right inverse of composition; one inclusion is
                @{term "f \<in> A->B ==> f O converse(f) \<subseteq> id(B)"} *}
lemma right_comp_inverse:
    "f \<in> surj(A,B) ==> f O converse(f) = id(B)"
apply (simp add: surj_def, clarify)
apply (rule equalityI)
apply (best elim: domain_type range_type dest: apply_equality2)
apply (blast intro: apply_Pair)
done

subsubsection{*Proving that a Function is a Bijection*}

lemma comp_eq_id_iff:
    "[| f \<in> A->B;  g \<in> B->A |] ==> f O g = id(B) \<longleftrightarrow> (\<forall>y\<in>B. f`(g`y)=y)"
apply (unfold id_def, safe)
 apply (drule_tac t = "%h. h`y " in subst_context)
 apply simp
apply (rule fun_extension)
  apply (blast intro: comp_fun lam_type)
 apply auto
done

lemma fg_imp_bijective:
    "[| f \<in> A->B;  g \<in> B->A;  f O g = id(B);  g O f = id(A) |] ==> f \<in> bij(A,B)"
apply (unfold bij_def)
apply (simp add: comp_eq_id_iff)
apply (blast intro: f_imp_injective f_imp_surjective apply_funtype)
done

lemma nilpotent_imp_bijective: "[| f \<in> A->A;  f O f = id(A) |] ==> f \<in> bij(A,A)"
by (blast intro: fg_imp_bijective)

lemma invertible_imp_bijective:
     "[| converse(f): B->A;  f \<in> A->B |] ==> f \<in> bij(A,B)"
by (simp add: fg_imp_bijective comp_eq_id_iff
              left_inverse_lemma right_inverse_lemma)

subsubsection{*Unions of Functions*}

text{*See similar theorems in func.thy*}

text{*Theorem by KG, proof by LCP*}
lemma inj_disjoint_Un:
     "[| f \<in> inj(A,B);  g \<in> inj(C,D);  B \<inter> D = 0 |]
      ==> (\<lambda>a\<in>A \<union> C. if a \<in> A then f`a else g`a) \<in> inj(A \<union> C, B \<union> D)"
apply (rule_tac d = "%z. if z \<in> B then converse (f) `z else converse (g) `z"
       in lam_injective)
apply (auto simp add: inj_is_fun [THEN apply_type])
done

lemma surj_disjoint_Un:
    "[| f \<in> surj(A,B);  g \<in> surj(C,D);  A \<inter> C = 0 |]
     ==> (f \<union> g) \<in> surj(A \<union> C, B \<union> D)"
apply (simp add: surj_def fun_disjoint_Un)
apply (blast dest!: domain_of_fun
             intro!: fun_disjoint_apply1 fun_disjoint_apply2)
done

text{*A simple, high-level proof; the version for injections follows from it,
  using  @{term "f \<in> inj(A,B) \<longleftrightarrow> f \<in> bij(A,range(f))"}  *}
lemma bij_disjoint_Un:
     "[| f \<in> bij(A,B);  g \<in> bij(C,D);  A \<inter> C = 0;  B \<inter> D = 0 |]
      ==> (f \<union> g) \<in> bij(A \<union> C, B \<union> D)"
apply (rule invertible_imp_bijective)
apply (subst converse_Un)
apply (auto intro: fun_disjoint_Un bij_is_fun bij_converse_bij)
done

subsubsection{*Restrictions as Surjections and Bijections*}

lemma surj_image:
    "f \<in> Pi(A,B) ==> f \<in> surj(A, f``A)"
apply (simp add: surj_def)
apply (blast intro: apply_equality apply_Pair Pi_type)
done

lemma surj_image_eq: "f \<in> surj(A, B) ==> f``A = B"
  by (auto simp add: surj_def image_fun) (blast dest: apply_type)

lemma restrict_image [simp]: "restrict(f,A) `` B = f `` (A \<inter> B)"
by (auto simp add: restrict_def)

lemma restrict_inj:
    "[| f \<in> inj(A,B);  C<=A |] ==> restrict(f,C): inj(C,B)"
apply (unfold inj_def)
apply (safe elim!: restrict_type2, auto)
done

lemma restrict_surj: "[| f \<in> Pi(A,B);  C<=A |] ==> restrict(f,C): surj(C, f``C)"
apply (insert restrict_type2 [THEN surj_image])
apply (simp add: restrict_image)
done

lemma restrict_bij:
    "[| f \<in> inj(A,B);  C<=A |] ==> restrict(f,C): bij(C, f``C)"
apply (simp add: inj_def bij_def)
apply (blast intro: restrict_surj surj_is_fun)
done

subsubsection{*Lemmas for Ramsey's Theorem*}

lemma inj_weaken_type: "[| f \<in> inj(A,B);  B<=D |] ==> f \<in> inj(A,D)"
apply (unfold inj_def)
apply (blast intro: fun_weaken_type)
done

lemma inj_succ_restrict:
     "[| f \<in> inj(succ(m), A) |] ==> restrict(f,m) \<in> inj(m, A-{f`m})"
apply (rule restrict_bij [THEN bij_is_inj, THEN inj_weaken_type], assumption, blast)
apply (unfold inj_def)
apply (fast elim: range_type mem_irrefl dest: apply_equality)
done

lemma inj_extend:
    "[| f \<in> inj(A,B);  a\<notin>A;  b\<notin>B |]
     ==> cons(<a,b>,f) \<in> inj(cons(a,A), cons(b,B))"
apply (unfold inj_def)
apply (force intro: apply_type  simp add: fun_extend)
done

end


section \<open>Extended integers (i.e. with infinity)\<close>

text\<open>
  This section formalizes the extended integers, which serve as the codomain for the $p$-adic
  valuation. The element $\infty$ is added to the integers to serve as a maximxal element in the
  order, which is the valuation of $0$.
\<close>

theory Extended_Int
imports Main "HOL-Library.Countable" "HOL-Library.Order_Continuity" "HOL-Library.Extended_Nat"
begin

text\<open>
  The following is based very closely on the theory \<^theory>\<open>HOL-Library.Extended_Nat\<close> from the
  standard Isabelle distribution, with adaptations made to formalize the integers extended with
  an element for infinity. This is the standard range for the valuation function on a discretely
  valued ring such as the field of $p$-adic numbers, such as in \cite{engler2005valued}.
\<close>

context
  fixes f :: "nat \<Rightarrow> 'a::{canonically_ordered_monoid_add, linorder_topology, complete_linorder}"
begin

lemma sums_SUP[simp, intro]: "f sums (SUP n. \<Sum>i<n. f i)"
  unfolding sums_def by (intro LIMSEQ_SUP monoI sum_mono2 zero_le) auto

lemma suminf_eq_SUP: "suminf f = (SUP n. \<Sum>i<n. f i)"
  using sums_SUP by (rule sums_unique[symmetric])

end

subsection \<open>Type definition\<close>

text \<open>
  We extend the standard natural numbers by a special value indicating
  infinity.
\<close>

typedef eint = "UNIV :: int option set" ..

definition eint :: "int \<Rightarrow> eint" where
  "eint n = Abs_eint (Some n)"

instantiation eint :: infinity
begin

definition "\<infinity> = Abs_eint None"
instance ..

end

fun int_option_enumeration :: "int option \<Rightarrow> nat" where
"int_option_enumeration (Some n) = (if n \<ge> 0 then nat (2*(n + 1)) else  nat (2*(-n) + 1))"|
"int_option_enumeration None = (0::nat)"

lemma int_option_enumeration_inj:
"inj int_option_enumeration"
proof
  have pos_even: "\<And>n::int. n \<ge> 0 \<Longrightarrow> even (int_option_enumeration (Some n)) \<and> (int_option_enumeration (Some n))> 0"
  proof-
    fix n::int assume "n \<ge>0" then have "(int_option_enumeration (Some n)) = nat (2*(n + 1))"
      by simp
    then show "even (int_option_enumeration (Some n)) \<and> 0 < int_option_enumeration (Some n)"
      by (smt \<open>0 \<le> n\<close> even_of_nat int_nat_eq oddE zero_less_nat_eq)
  qed
  have neg_odd: "\<And>n::int. n < 0 \<Longrightarrow> odd (int_option_enumeration (Some n))"
    by (smt evenE even_of_nat int_nat_eq int_option_enumeration.simps(1))
  fix x y assume A: "x \<in> UNIV" "y \<in> UNIV" "int_option_enumeration x = int_option_enumeration y"
  show "x = y"
    apply(cases "x = None")
      using A pos_even neg_odd
      apply (metis dvd_0_right int_option_enumeration.elims int_option_enumeration.simps(2) not_gr0 not_le)
    proof-
      assume "x \<noteq>None"
      then obtain n where n_def: "x = Some n"
        by auto
      then have y_not_None: "y \<noteq> None"
        using A
        by (metis \<open>\<And>thesis. (\<And>n. x = Some n \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
              add_cancel_right_right even_add int_option_enumeration.simps(2)
              linorder_not_less neg_odd neq0_conv pos_even)
      then obtain m where m_def: "y = Some m"
        by blast
      show ?thesis
      proof(cases "n \<ge>0")
        case True
        then show ?thesis
          using n_def A neg_odd pos_even m_def int_option_enumeration.simps(1)
          by (smt int_nat_eq)
      next
        case False
        then show ?thesis
          using n_def A neg_odd pos_even m_def int_option_enumeration.simps(1)
          by (smt int_nat_eq)
      qed
  qed
qed

definition eint_enumeration where
"eint_enumeration = int_option_enumeration \<circ> Rep_eint"

lemma eint_enumeration_inj:
"inj eint_enumeration"
  unfolding eint_enumeration_def
  using int_option_enumeration_inj Rep_eint_inject
  by (metis (mono_tags, lifting) comp_apply injD inj_on_def)

instance eint :: countable
proof
  show "\<exists>to_int::eint \<Rightarrow> nat. inj to_int"
    using eint_enumeration_inj by blast
qed

old_rep_datatype eint "\<infinity> :: eint"
proof -
  fix P i assume "\<And>j. P (eint j)" "P \<infinity>"
  then show "P i"
  proof induct
    case (Abs_eint y) then show ?case
      by (cases y rule: option.exhaust)
         (auto simp: eint_def infinity_eint_def)
  qed
qed (auto simp add: eint_def infinity_eint_def Abs_eint_inject)

declare [[coercion "eint::int\<Rightarrow>eint"]]

lemmas eint2_cases = eint.exhaust[case_product eint.exhaust]
lemmas eint3_cases = eint.exhaust[case_product eint.exhaust eint.exhaust]

lemma not_infinity_eq [iff]: "(x \<noteq> \<infinity>) = (\<exists>i. x = eint i)"
  by (cases x) auto

lemma not_eint_eq [iff]: "(\<forall>y. x \<noteq> eint y) = (x = \<infinity>)"
  by (cases x) auto

lemma eint_ex_split: "(\<exists>c::eint. P c) \<longleftrightarrow> P \<infinity> \<or> (\<exists>c::int. P c)"
  by (metis eint.exhaust)

primrec the_eint :: "eint \<Rightarrow> int"
  where "the_eint (eint n) = n"

subsection \<open>Constructors and numbers\<close>

instantiation eint :: zero_neq_one
begin

definition
  "0 = eint 0"

definition
  "1 = eint 1"

instance
  proof qed (simp add: zero_eint_def one_eint_def)

end

lemma eint_0 [code_post]: "eint 0 = 0"
  by (simp add: zero_eint_def)

lemma eint_1 [code_post]: "eint 1 = 1"
  by (simp add: one_eint_def)

lemma eint_0_iff: "eint x = 0 \<longleftrightarrow> x = 0" "0 = eint x \<longleftrightarrow> x = 0"
  by (auto simp add: zero_eint_def)

lemma eint_1_iff: "eint x = 1 \<longleftrightarrow> x = 1" "1 = eint x \<longleftrightarrow> x = 1"
  by (auto simp add: one_eint_def)

lemma infinity_ne_i0 [simp]: "(\<infinity>::eint) \<noteq> 0"
  by (simp add: zero_eint_def)

lemma i0_ne_infinity [simp]: "0 \<noteq> (\<infinity>::eint)"
  by (simp add: zero_eint_def)

lemma zero_one_eint_neq:
  "\<not> 0 = (1::eint)"
  "\<not> 1 = (0::eint)"
  unfolding zero_eint_def one_eint_def by simp_all

lemma infinity_ne_i1 [simp]: "(\<infinity>::eint) \<noteq> 1"
  by (simp add: one_eint_def)

lemma i1_ne_infinity [simp]: "1 \<noteq> (\<infinity>::eint)"
  by (simp add: one_eint_def)

subsection \<open>Addition\<close>

instantiation eint :: comm_monoid_add
begin

definition [nitpick_simp]:
  "m + n = (case m of \<infinity> \<Rightarrow> \<infinity> | eint m \<Rightarrow> (case n of \<infinity> \<Rightarrow> \<infinity> | eint n \<Rightarrow> eint (m + n)))"

lemma plus_eint_simps [simp, code]:
  fixes q :: eint
  shows "eint m + eint n = eint (m + n)"
    and "\<infinity> + q = \<infinity>"
    and "q + \<infinity> = \<infinity>"
  by (simp_all add: plus_eint_def split: eint.splits)

instance
proof
  fix n m q :: eint
  show "n + m + q = n + (m + q)"
    by (cases n m q rule: eint3_cases) auto
  show "n + m = m + n"
    by (cases n m rule: eint2_cases) auto
  show "0 + n = n"
    by (cases n) (simp_all add: zero_eint_def)
qed

end

lemma eSuc_eint: "(eint n) + 1 = eint (n + 1)"
  by (simp add: one_eint_def)

lemma eSuc_infinity [simp]: " \<infinity> + (1::eint) = \<infinity>"
  unfolding plus_eint_def
  by auto

lemma eSuc_inject [simp]: " m + (1::eint)=  n + 1 \<longleftrightarrow> m = n"
  unfolding plus_eint_def
  apply(cases "m = \<infinity>")
  apply (metis (no_types, lifting) eSuc_eint
    eint.distinct(2) eint.exhaust eint.simps(4) eint.simps(5) plus_eint_def)
  apply(cases "n = \<infinity>")
  using eSuc_eint plus_eint_def apply auto[1]
  unfolding one_eint_def
  using add.commute eSuc_eint
  by auto

lemma eSuc_eint_iff: "x + 1 = eint y \<longleftrightarrow> (\<exists>n. y = n + 1 \<and> x = eint n)"
  apply(cases "x = \<infinity>")
  apply simp
  unfolding plus_eint_def one_eint_def
  using eSuc_eint
  by auto

lemma enat_eSuc_iff: "eint y = x + 1 \<longleftrightarrow> (\<exists>n. y = n + 1 \<and> eint n = x)"
  using eSuc_eint_iff
  by metis

lemma iadd_Suc: "((m::eint) + 1) + n = (m + n) + 1"
  by (metis ab_semigroup_add_class.add_ac(1) add.assoc add.commute)

lemma iadd_Suc_right: "(m::eint) + (n + 1) = (m + n) + 1"
  using add.assoc[of m n 1] by auto

subsection \<open>Multiplication\<close>

instantiation eint :: "{comm_semiring}"
begin

definition times_eint_def [nitpick_simp]:
  "m * n = (case m of \<infinity> \<Rightarrow>  \<infinity> | eint m \<Rightarrow>
    (case n of \<infinity> \<Rightarrow> \<infinity> | eint n \<Rightarrow> eint (m * n)))"

lemma times_eint_simps [simp, code]:
  "eint m * eint n = eint (m * n)"
  "\<infinity> * \<infinity> = (\<infinity>::eint)"
  "\<infinity> * eint n = \<infinity>"
  "eint m * \<infinity> = \<infinity>"
  unfolding times_eint_def zero_eint_def
  by (simp_all split: eint.split)

lemma sum_infinity_imp_summand_infinity:
  assumes "a + b = (\<infinity>::eint)"
  shows "a = \<infinity> \<or> b = \<infinity>"
  using assms
  by (metis  not_eint_eq plus_eint_simps(1))

lemma sum_finite_imp_summands_finite:
  assumes "a + b \<noteq> (\<infinity>::eint)"
  shows "a \<noteq> \<infinity>" "b \<noteq> \<infinity>"
  using assms eint.simps(5) apply fastforce
  using assms eint.simps(5) by fastforce

instance
proof
  fix a b c :: eint
  show "(a * b) * c = a * (b * c)"
    unfolding times_eint_def zero_eint_def
    by (simp split: eint.split)
  show comm: "a * b = b * a"
    unfolding times_eint_def zero_eint_def
    by (simp split: eint.split)
  show distr: "(a + b) * c = a * c + b * c"
    unfolding times_eint_def plus_eint_def
    apply(cases "a + b = \<infinity>")
    apply(cases "a = \<infinity>")
    apply simp
    using sum_infinity_imp_summand_infinity[of a b]
    apply (metis eint.simps(5) plus_eint_def plus_eint_simps(3))
    apply(cases "c = \<infinity>")
     apply (metis eint.exhaust plus_eint_def plus_eint_simps(3) times_eint_def times_eint_simps(4))
    using sum_finite_imp_summands_finite[of a b]
    apply auto
    by (simp add: semiring_normalization_rules(1))
qed

end

lemma mult_one_right[simp]:
"(n::eint)*1 = n"
  apply(cases "n = \<infinity>")
  apply (simp add: one_eint_def)
  by (metis eint2_cases mult_cancel_left2 one_eint_def times_eint_simps(1))

lemma mult_one_left[simp]:
"1*(n::eint) = n"
  by (metis mult.commute mult_one_right)

lemma mult_eSuc: "((m::eint) + 1) * n = m * n + n"
  by (simp add: distrib_right)

lemma mult_eSuc': "((m::eint) + 1) * n = n + m * n"
  using mult_eSuc add.commute by simp

lemma mult_eSuc_right: "(m::eint) * (n + 1) =  m * n +  m "
  by(simp add: distrib_left)

lemma mult_eSuc_right': "(m::eint) * (n + 1) =  m + m * n  "
  using mult_eSuc_right add.commute by simp

subsection \<open>Numerals\<close>

lemma numeral_eq_eint:
  "numeral k = eint (numeral k)"
  by simp

lemma eint_numeral [code_abbrev]:
  "eint (numeral k) = numeral k"
  using numeral_eq_eint ..

lemma infinity_ne_numeral [simp]: "(\<infinity>::eint) \<noteq> numeral k"
  by auto

lemma numeral_ne_infinity [simp]: "numeral k \<noteq> (\<infinity>::eint)"
  by simp

subsection \<open>Subtraction\<close>

instantiation eint :: minus
begin

definition diff_eint_def:
"a - b = (case a of (eint x) \<Rightarrow> (case b of (eint y) \<Rightarrow> eint (x - y) | \<infinity> \<Rightarrow> \<infinity>)
          | \<infinity> \<Rightarrow> \<infinity>)"

instance ..

end

lemma idiff_eint_eint [simp, code]: "eint a - eint b = eint (a - b)"
  by (simp add: diff_eint_def)

lemma idiff_infinity [simp, code]: "\<infinity> - n = (\<infinity>::eint)"
  by (simp add: diff_eint_def)

lemma idiff_infinity_right [simp, code]: "eint a - \<infinity> = \<infinity>"
  by (simp add: diff_eint_def)

lemma idiff_0 [simp]: "(0::eint) - n = -n"
  by (cases n, simp_all add: zero_eint_def)

lemmas idiff_eint_0 [simp] = idiff_0 [unfolded zero_eint_def]

lemma idiff_0_right [simp]: "(n::eint) - 0 = n"
  by (cases n) (simp_all add: zero_eint_def)

lemmas idiff_eint_0_right [simp] = idiff_0_right [unfolded zero_eint_def]

lemma idiff_self [simp]: "n \<noteq> \<infinity> \<Longrightarrow> (n::eint) - n = 0"
  by (auto simp: zero_eint_def)

lemma eSuc_minus_eSuc [simp]: "((n::eint) + 1) - (m + 1) = n - m"
  apply(cases "n = \<infinity>")
  apply simp
  apply(cases "m = \<infinity>")
  apply (metis eSuc_infinity eint.exhaust idiff_infinity_right infinity_ne_i1 sum_infinity_imp_summand_infinity)
proof-
  assume A: "n \<noteq>\<infinity>" "m \<noteq> \<infinity>"
  obtain a where a_def: "n = eint a"
    using A
    by auto
  obtain b where b_def: "m = eint b"
    using A
    by auto
  show ?thesis
    using  idiff_eint_eint[of "a + 1" "b + 1"]
           idiff_eint_eint[of a b]
  by (simp add: a_def b_def eSuc_eint)
qed

lemma eSuc_minus_1 [simp]: "((n::eint)+ 1) - 1 = n"
  using eSuc_minus_eSuc[of n 0]
  by auto

(*lemmas idiff_self_eq_0_eint = idiff_self_eq_0[unfolded zero_eint_def]*)

subsection \<open>Ordering\<close>

instantiation eint :: linordered_ab_semigroup_add
begin

definition [nitpick_simp]:
  "m \<le> n = (case n of eint n1 \<Rightarrow> (case m of eint m1 \<Rightarrow> m1 \<le> n1 | \<infinity> \<Rightarrow> False)
    | \<infinity> \<Rightarrow> True)"

definition [nitpick_simp]:
  "m < n = (case m of eint m1 \<Rightarrow> (case n of eint n1 \<Rightarrow> m1 < n1 | \<infinity> \<Rightarrow> True)
    | \<infinity> \<Rightarrow> False)"

lemma eint_ord_simps [simp]:
  "eint m \<le> eint n \<longleftrightarrow> m \<le> n"
  "eint m < eint n \<longleftrightarrow> m < n"
  "q \<le> (\<infinity>::eint)"
  "q < (\<infinity>::eint) \<longleftrightarrow> q \<noteq> \<infinity>"
  "(\<infinity>::eint) \<le> q \<longleftrightarrow> q = \<infinity>"
  "(\<infinity>::eint) < q \<longleftrightarrow> False"
  by (simp_all add: less_eq_eint_def less_eint_def split: eint.splits)

lemma numeral_le_eint_iff[simp]:
  shows "numeral m \<le> eint n \<longleftrightarrow> numeral m \<le> n"
  by auto

lemma numeral_less_eint_iff[simp]:
  shows "numeral m < eint n \<longleftrightarrow> numeral m < n"
  by simp

lemma eint_ord_code [code]:
  "eint m \<le> eint n \<longleftrightarrow> m \<le> n"
  "eint m < eint n \<longleftrightarrow> m < n"
  "q \<le> (\<infinity>::eint) \<longleftrightarrow> True"
  "eint m < \<infinity> \<longleftrightarrow> True"
  "\<infinity> \<le> eint n \<longleftrightarrow> False"
  "(\<infinity>::eint) < q \<longleftrightarrow> False"
  by simp_all

lemma eint_ord_plus_one[simp]:
  assumes "eint n \<le> x"
  assumes "x < y"
  shows "eint (n + 1) \<le> y"
proof-
  obtain m where "x = eint m"
    using assms(2)
    by fastforce
  show ?thesis apply(cases "y = \<infinity>")
  apply simp
    using \<open>x = eint m\<close> assms(1) assms(2)
    by force
qed

instance
  by standard (auto simp add: less_eq_eint_def less_eint_def plus_eint_def split: eint.splits)

end

instance eint :: "{strict_ordered_comm_monoid_add}"
proof
  show "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d" for a b c d :: eint
    by (cases a b c d rule: eint2_cases[case_product eint2_cases]) auto
qed

(* BH: These equations are already proven generally for any type in
class linordered_semidom. However, eint is not in that class because
it does not have the cancellation property. Would it be worthwhile to
a generalize linordered_semidom to a new class that includes eint? *)

lemma add_diff_assoc_eint: "z \<le> y \<Longrightarrow> x + (y - z) = x + y - (z::eint)"
by(cases x)(auto simp add: diff_eint_def split: eint.split)

lemma eint_ord_number [simp]:
  "(numeral m :: eint) \<le> numeral n \<longleftrightarrow> (numeral m :: nat) \<le> numeral n"
  "(numeral m :: eint) < numeral n \<longleftrightarrow> (numeral m :: nat) < numeral n"
  apply simp
  by simp

lemma infinity_ileE [elim!]: "\<infinity> \<le> eint m \<Longrightarrow> R"
  by simp

lemma infinity_ilessE [elim!]: "\<infinity> < eint m \<Longrightarrow> R"
  by simp

lemma imult_infinity: "(0::eint) < n \<Longrightarrow> \<infinity> * n = \<infinity>"
  by (simp add: zero_eint_def less_eint_def split: eint.splits)

lemma imult_infinity_right: "(0::eint) < n \<Longrightarrow> n * \<infinity> = \<infinity>"
  by (simp add: zero_eint_def less_eint_def split: eint.splits)

lemma min_eint_simps [simp]:
  "min (eint m) (eint n) = eint (min m n)"
  "min q (\<infinity>::eint) = q"
  "min (\<infinity>::eint) q = q"
  by (auto simp add: min_def)

lemma max_eint_simps [simp]:
  "max (eint m) (eint n) = eint (max m n)"
  "max q \<infinity> = (\<infinity>::eint)"
  "max \<infinity> q = (\<infinity>::eint)"
  by (simp_all add: max_def)

lemma eint_ile: "n \<le> eint m \<Longrightarrow> \<exists>k. n = eint k"
  by (cases n) simp_all

lemma eint_iless: "n < eint m \<Longrightarrow> \<exists>k. n = eint k"
  by (cases n) simp_all

lemma iadd_le_eint_iff:
  "x + y \<le> eint n \<longleftrightarrow> (\<exists>y' x'. x = eint x' \<and> y = eint y' \<and> x' + y' \<le> n)"
by(cases x y rule: eint.exhaust[case_product eint.exhaust]) simp_all

lemma chain_incr: "\<forall>i. \<exists>j. Y i < Y j \<Longrightarrow> \<exists>j. eint k < Y j"
proof-
  assume A: "\<forall>i. \<exists>j. Y i < Y j"
  then have "\<forall>i. \<exists>n::int. Y i = eint n"
    by (metis eint.exhaust eint_ord_simps(6))
  then obtain i n where in_def: "Y (i::'a) = eint n"
    by blast
  show "\<exists>j. eint k < Y j"
  proof(rule ccontr)
    assume C: "\<not>(\<exists>j. eint k < Y j)"
    then have C':"\<forall>j. Y j \<le> eint k"
      using le_less_linear
      by blast
    then have "Y (i::'a) \<le> eint k"
      by simp
    have "\<And>m::nat. \<exists>j::'a. Y j \<ge> eint (n + int m)"
    proof- fix m
      show "\<exists>j::'a. Y j \<ge> eint (n + int m)"
        apply(induction m)
         apply (metis in_def int_ops(1) order_refl plus_int_code(1))
      proof- fix m
        assume "\<exists>j. eint (n + int m) \<le> Y j"
        then obtain j where j_def: "eint (n + int m) \<le> Y j"
          by blast
        obtain j' where j'_def: "Y j < Y j'"
          using A by blast
        have "eint (n + int (Suc m)) = eint (n + m + 1)"
          by auto
        then have "eint (n + int (Suc m)) \<le> Y j'"
          using j_def j'_def  eint_ord_plus_one[of "n + m" "Y j" "Y j'"]
          by presburger
        then show "\<exists>j. eint (n + int (Suc m)) \<le> Y j"
          by blast
      qed
    qed
    then show False
      by (metis A C \<open>Y i \<le> eint k\<close>   eint_ord_simps(1) in_def
          order.not_eq_order_implies_strict zle_iff_zadd)
  qed
qed

lemma eint_ord_Suc:
  assumes "(x::eint) < y"
  shows "x + 1 < y + 1"
  apply(cases "y = \<infinity>")
  using assms i1_ne_infinity sum_infinity_imp_summand_infinity
   apply fastforce
  by (metis add_mono_thms_linordered_semiring(3) assms eSuc_inject order_less_le)

lemma eSuc_ile_mono [simp]: "(n::eint) + 1 \<le> m+ 1 \<longleftrightarrow> n \<le> m"
  by (meson add_mono_thms_linordered_semiring(3) eint_ord_Suc linorder_not_le)

lemma eSuc_mono [simp]: "(n::eint) + 1 < m+ 1 \<longleftrightarrow> n < m"
  by (meson add_mono_thms_linordered_semiring(3) eint_ord_Suc linorder_not_le)

lemma ile_eSuc [simp]: "(n::eint) \<le> n + 1"
  by (metis add.right_neutral add_left_mono eint_1_iff(2) eint_ord_code(1) linear not_one_le_zero zero_eint_def)

lemma ileI1: "(m::eint) < n \<Longrightarrow> m + 1 \<le> n"
  by (metis eSuc_eint eint.exhaust eint_ex_split eint_iless eint_ord_Suc eint_ord_code(6)
      eint_ord_plus_one eint_ord_simps(3) less_le_trans linear )

lemma Suc_ile_eq: "eint (m +1) \<le> n \<longleftrightarrow> eint m < n"
  by (cases n) auto

lemma iless_Suc_eq [simp]: "eint m < n + 1 \<longleftrightarrow> eint m \<le> n"
  by (metis Suc_ile_eq eSuc_eint eSuc_ile_mono)

lemma eSuc_max: "(max (x::eint) y) + 1 = max (x+1) (y+1)"
  by (simp add: max_def)

lemma eSuc_Max:
  assumes "finite A" "A \<noteq> ({}::eint set)"
  shows " (Max A) + 1 = Max ((+)1 ` A)"
using assms proof induction
  case (insert x A)
  thus ?case
    using Max_insert[of A x] Max_singleton[of x] add.commute[of 1] eSuc_max finite_imageI
          image_insert image_is_empty
  by (simp add: add.commute hom_Max_commute)
qed simp

instantiation eint :: "{order_top}"
begin

definition top_eint :: eint where "top_eint = \<infinity>"

instance
  by standard (simp add: top_eint_def)

end

lemma finite_eint_bounded:
  assumes le_fin: "\<And>y. y \<in> A \<Longrightarrow> eint m \<le> y \<and> y \<le> eint n"
  shows "finite A"
proof (rule finite_subset)
  show "finite (eint ` {m..n})" by blast
  have "A \<subseteq> {eint m..eint n}" using le_fin by fastforce
  also have "\<dots> \<subseteq> eint ` {m..n}"
    apply (rule subsetI)
    subgoal for x by (cases x) auto
    done
  finally show "A \<subseteq> eint ` {m..n}" .
qed

subsection \<open>Cancellation simprocs\<close>

lemma add_diff_cancel_eint[simp]: "x \<noteq> \<infinity> \<Longrightarrow> x + y - x = (y::eint)"
by (metis add.commute add.right_neutral add_diff_assoc_eint idiff_self order_refl)

lemma eint_add_left_cancel: "a + b = a + c \<longleftrightarrow> a = (\<infinity>::eint) \<or> b = c"
  unfolding plus_eint_def by (simp split: eint.split)

lemma eint_add_left_cancel_le: "a + b \<le> a + c \<longleftrightarrow> a = (\<infinity>::eint) \<or> b \<le> c"
  unfolding plus_eint_def by (simp split: eint.split)

lemma eint_add_left_cancel_less: "a + b < a + c \<longleftrightarrow> a \<noteq> (\<infinity>::eint) \<and> b < c"
  unfolding plus_eint_def by (simp split: eint.split)

lemma plus_eq_infty_iff_eint: "(m::eint) + n = \<infinity> \<longleftrightarrow> m=\<infinity> \<or> n=\<infinity>"
using eint_add_left_cancel by fastforce

ML \<open>
structure Cancel_Enat_Common =
struct
  (* copied from src/HOL/Tools/nat_numeral_simprocs.ML *)
  fun find_first_t _    _ []         = raise TERM("find_first_t", [])
    | find_first_t past u (t::terms) =
          if u aconv t then (rev past @ terms)
          else find_first_t (t::past) u terms

  fun dest_summing (Const (\<^const_name>\<open>Groups.plus\<close>, _) $ t $ u, ts) =
        dest_summing (t, dest_summing (u, ts))
    | dest_summing (t, ts) = t :: ts

  val mk_sum = Arith_Data.long_mk_sum
  fun dest_sum t = dest_summing (t, [])
  val find_first = find_first_t []
  val trans_tac = Numeral_Simprocs.trans_tac
  val norm_ss =
    simpset_of (put_simpset HOL_basic_ss \<^context>
      addsimps @{thms ac_simps add_0_left add_0_right})
  fun norm_tac ctxt = ALLGOALS (simp_tac (put_simpset norm_ss ctxt))
  fun simplify_meta_eq ctxt cancel_th th =
    Arith_Data.simplify_meta_eq [] ctxt
      ([th, cancel_th] MRS trans)
  fun mk_eq (a, b) = HOLogic.mk_Trueprop (HOLogic.mk_eq (a, b))
end

structure Eq_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_eq
  val dest_bal = HOLogic.dest_bin \<^const_name>\<open>HOL.eq\<close> \<^typ>\<open>eint\<close>
  fun simp_conv _ _ = SOME @{thm eint_add_left_cancel}
)

structure Le_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_binrel \<^const_name>\<open>Orderings.less_eq\<close>
  val dest_bal = HOLogic.dest_bin \<^const_name>\<open>Orderings.less_eq\<close> \<^typ>\<open>eint\<close>
  fun simp_conv _ _ = SOME @{thm eint_add_left_cancel_le}
)

structure Less_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_binrel \<^const_name>\<open>Orderings.less\<close>
  val dest_bal = HOLogic.dest_bin \<^const_name>\<open>Orderings.less\<close> \<^typ>\<open>eint\<close>
  fun simp_conv _ _ = SOME @{thm eint_add_left_cancel_less}
)
\<close>

simproc_setup eint_eq_cancel
  ("(l::eint) + m = n" | "(l::eint) = m + n") =
  \<open>fn phi => fn ctxt => fn ct => Eq_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>

simproc_setup eint_le_cancel
  ("(l::eint) + m \<le> n" | "(l::eint) \<le> m + n") =
  \<open>fn phi => fn ctxt => fn ct => Le_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>

simproc_setup eint_less_cancel
  ("(l::eint) + m < n" | "(l::eint) < m + n") =
  \<open>fn phi => fn ctxt => fn ct => Less_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>

text \<open>TODO: add regression tests for these simprocs\<close>

text \<open>TODO: add simprocs for combining and cancelling numerals\<close>

subsection \<open>Well-ordering\<close>

lemma less_eintE:
  "[| n < eint m; !!k. n = eint k ==> k < m ==> P |] ==> P"
by (induct n) auto

lemma less_infinityE:
  "[| n < \<infinity>; !!k. n = eint k ==> P |] ==> P"
by (induct n) auto

subsection \<open>Traditional theorem names\<close>

lemmas eint_defs = zero_eint_def one_eint_def
  plus_eint_def less_eq_eint_def less_eint_def

instantiation eint :: uminus
begin

definition
"- b = (case b of \<infinity> \<Rightarrow> \<infinity> | eint m \<Rightarrow> eint (-m))"

lemma eint_uminus_eq:
"(a::eint) + (-a) = a - a"
  apply(induction a)
  apply (simp add: uminus_eint_def)
  by simp

instance..
end

section\<open>Additional Lemmas (Useful for the Proof of Hensel's Lemma)\<close>

lemma eint_mult_mono:
  assumes "(c::eint) > 0 \<and> c \<noteq> \<infinity>"
  assumes "k > n"
  shows "k*c > n*c"
  using assms apply(induction k, induction n, induction c)
  by(auto simp add: zero_eint_def)

lemma eint_mult_mono':
  assumes "(c::eint) \<ge> 0 \<and> c \<noteq> \<infinity>"
  assumes "k > n"
  shows "k*c \<ge> n*c"
  apply(cases "c = 0")
   apply (metis add.right_neutral assms(2) eint_add_left_cancel eint_ord_code(3)
         eint_ord_simps(4) eq_iff less_le_trans mult.commute mult_eSuc_right'
         mult_one_right not_less times_eint_simps(4) zero_eint_def)
    using assms eint_mult_mono
    by (simp add: le_less)

lemma eint_minus_le:
  assumes "(b::eint) < c"
  shows "c - b > 0"
  using assms apply(induction b, induction c)
  by (auto simp add: zero_eint_def)

lemma eint_nat_times:
  assumes "(c::eint) > 0"
  shows "(Suc n)*(c::eint) > 0"
  using assms  apply(induction c)
  apply (simp add: zero_eint_def)
  by simp

lemma eint_pos_times_is_pos:
  assumes "(c::eint) > 0"
  assumes "b > 0"
  shows "b*c > 0"
  using assms apply(induction c, induction b)
  by(auto simp add: zero_eint_def imult_infinity_right)

lemma eint_nat_is_pos:
"eint (Suc n) > 0"
  by (simp add: zero_eint_def)

lemma eint_pow_int_is_pos:
  assumes "n > 0"
  shows "eint n > 0"
  using assms by (simp add: zero_eint_def)

lemma eint_nat_times':
  assumes "(c::eint) \<ge> 0"
  shows "(Suc n)*c \<ge> 0"
  using assms zero_eint_def by fastforce

lemma eint_pos_int_times_ge:
  assumes "(c::eint) \<ge> 0"
  assumes "n > 0"
  shows "eint n * c \<ge> c"
  using assms apply(induction c)
  apply (smt eSuc_eint eint.distinct(2) eint_mult_mono' eint_pow_int_is_pos eq_iff ileI1 less_le mult.commute mult_one_right one_eint_def zero_eint_def)
  by simp

lemma eint_pos_int_times_gt:
  assumes "(c::eint) > 0"
  assumes "c \<noteq>\<infinity>"
  assumes "n > 1"
  shows "eint n * c > c"
  using assms eint_mult_mono[of c 1 "eint n"]
  by (metis eint_ord_simps(2) mult_one_left one_eint_def)

lemma eint_add_cancel_fact[simp]:
  assumes "(c::eint) \<noteq> \<infinity>"
  shows "c + (b - c) = b"
  using assms apply(induction c, induction b)
  by auto

lemma nat_mult_not_infty[simp]:
  assumes "c \<noteq> \<infinity>"
  shows "(eint n) * c \<noteq> \<infinity>"
  using assms by auto

lemma eint_minus_distl:
  assumes "(b::eint) \<noteq> d"
  shows "b*c - d*c = (b-d)*c"
  using assms apply(induction c, induction b, induction d)
  apply (metis add_diff_cancel_eint distrib_right eint.distinct(2) eint_add_cancel_fact nat_mult_not_infty)
    apply simp
      apply simp
        by (simp add: mult.commute times_eint_def)

lemma eint_minus_distr:
  assumes "(b::eint) \<noteq> d"
  shows "c*(b - d) = c*b - c*d"
  by (metis assms eint_minus_distl mult.commute)

lemma eint_int_minus_distr:
"(eint n)*c - (eint m)*c = eint (n - m) * c"
  by (metis add.right_neutral distrib_right eint_add_left_cancel eint_minus_distl idiff_eint_eint
      idiff_infinity idiff_self infinity_ne_i0 nat_mult_not_infty not_eint_eq times_eint_simps(4))

lemma eint_2_minus_1_mult[simp]:
"2*(b::eint) - b = b"
proof -
  have "\<forall>e. (\<infinity>::eint) * e = \<infinity>"
  by (simp add: times_eint_def)
  then show ?thesis
    by (metis add_diff_cancel_eint idiff_infinity mult.commute mult_eSuc_right' mult_one_right one_add_one one_eint_def plus_eint_simps(1))
qed

lemma eint_minus_comm:
"(d::eint) + b - c = d - c + b"
apply(induction c )
  apply (metis add.assoc add_diff_cancel_eint eint.distinct(2) eint_add_cancel_fact)
    apply(induction d)
    apply (metis distrib_left eint2_cases eint_minus_distl i1_ne_infinity idiff_infinity_right
           mult_one_left plus_eq_infty_iff_eint sum_infinity_imp_summand_infinity times_eint_simps(3))
      apply(induction b)
        apply simp
          by simp

lemma ge_plus_pos_imp_gt:
  assumes "(c::eint) \<noteq>\<infinity>"
  assumes "(b::eint) > 0"
  assumes "d \<ge> c + b"
  shows "d > c"
  using assms apply(induction d, induction c)
  apply (metis add.comm_neutral assms(2) eint_add_left_cancel_less less_le_trans)
   apply blast
    by simp

lemma eint_minus_ineq:
  assumes "(c::eint) \<noteq>\<infinity>"
  assumes "b \<ge> d"
  shows "b - c \<ge> d - c"
  by (metis add_left_mono antisym assms(1) assms(2) eint_add_cancel_fact linear)

lemma eint_minus_ineq':
  assumes "(c::eint) \<noteq>\<infinity>"
  assumes "b \<ge> d"
  assumes "(e::eint) > 0"
  assumes "e \<noteq> \<infinity>"
  shows "e*(b - c) \<ge> e*(d - c)"
  using assms eint_minus_ineq
  by (metis eint_mult_mono' eq_iff less_le mult.commute)

lemma eint_minus_ineq'':
  assumes "(c::eint) \<noteq>\<infinity>"
  assumes "b \<ge> d"
  assumes "(e::eint) > 0"
  assumes "e \<noteq> \<infinity>"
  shows "e*(b - c) \<ge> e*d - e*c"
  using assms eint_minus_ineq'
  proof -
    have "\<forall>e. (0::eint) + e = e"
      by simp
    then have f1: "e * 0 = 0"
      by (metis add_diff_cancel_eint assms(4) idiff_self mult_eSuc_right' mult_one_right)
    have "\<infinity> \<noteq> c * e"
      using assms(1) assms(4) eint_pos_times_is_pos by auto
    then show ?thesis
      using f1 by (metis assms(1) assms(2) assms(3) assms(4) eint_minus_distl eint_minus_ineq' idiff_self mult.commute)
  qed

lemma eint_min_ineq:
  assumes "(b::eint) \<ge> min c d"
  assumes "c > e"
  assumes "d > e"
  shows "b > e"
  by (meson assms(1) assms(2) assms(3) less_le_trans min_le_iff_disj)

lemma eint_plus_times:
  assumes "(d::eint) \<ge> 0"
  assumes "(b::eint) \<ge> c + (eint k)*d"
  assumes "k \<ge> l"
  shows "b \<ge> c + l*d"
proof-
  have "k*d \<ge> l*d"
    by (smt assms(1) assms(3) eint_mult_mono' eint_ord_simps(2) eq_iff times_eint_simps(4))
  thus ?thesis
    by (meson add_mono_thms_linordered_semiring(2) assms(2) order_subst2)
qed
end


theory Chapter12_2_PatternMatching
imports Chapter12_1_Language Utilities
begin

type_synonym substitution = "expr list"

primrec apply_subst :: "substitution => expr => expr"
where "apply_subst [] e = e"
    | "apply_subst (s # sig) e = apply_subst sig (subst (mult_insert (length sig) s) first e)"

inductive matches :: "patn => expr => substitution => bool"
where [simp]: "matches VarPat e [e]"
    | [simp]: "matches WildPat e []"
    | [simp]: "matches TrivPat Triv []"
    | [simp]: "matches p1 e1 s1 ==> matches p2 e2 s2 ==>
                  matches (PairPat p1 p2) (Pair e1 e2) (s1 @ s2)"
    | [simp]: "matches p e s ==> matches (InLPat p) (InL t t' e) s"
    | [simp]: "matches p e s ==> matches (InRPat p) (InR t t' e) s"

inductive_cases [elim!]: "matches VarPat e s"
inductive_cases [elim!]: "matches WildPat e s"
inductive_cases [elim!]: "matches TrivPat e s"
inductive_cases [elim!]: "matches (PairPat p1 p2) e s"
inductive_cases [elim!]: "matches (InLPat p) e s"
inductive_cases [elim!]: "matches (InRPat p) e s"

inductive no_match :: "patn => expr => bool"
where "e ~= Triv ==> no_match TrivPat e"
    | "no_match p1 e1 ==> no_match (PairPat p1 p2) (Pair e1 e2)"
    | "no_match p2 e2 ==> no_match (PairPat p1 p2) (Pair e1 e2)"
    | "~ (EX e1 e2. e = Pair e1 e2) ==> no_match (PairPat p1 p2) e"
    | "no_match p e ==> no_match (InLPat p) (InL t t' e)"
    | "~ (EX e' t1 t2. e = InL t1 t2 e') ==> no_match (InLPat p) e"
    | "no_match p e ==> no_match (InRPat p) (InR t t' e)"
    | "~ (EX e' t1 t2. e = InR t1 t2 e') ==> no_match (InRPat p) e"

datatype constraint =
  Truth
| Falsity
| And constraint constraint
| Or constraint constraint
| InLCon constraint
| InRCon constraint
| TrivCon
| PairCon constraint constraint

primrec patn_constraint :: "patn => constraint"
where "patn_constraint VarPat = Truth"
    | "patn_constraint WildPat = Truth"
    | "patn_constraint TrivPat = TrivCon"
    | "patn_constraint (PairPat p1 p2) = PairCon (patn_constraint p1) (patn_constraint p2)"
    | "patn_constraint (InLPat p) = InLCon (patn_constraint p)"
    | "patn_constraint (InRPat p) = InRCon (patn_constraint p)"

fun rule_constraint :: "rule => constraint"
where "rule_constraint (Rule p e) = patn_constraint p"

primrec rules_constraint :: "rule list => constraint"
where "rules_constraint [] = Falsity"
    | "rules_constraint (r # rs) = Or (rule_constraint r) (rules_constraint rs)"

inductive satisfies :: "expr => constraint => bool"
where [simp]: "satisfies e Truth"
    | [simp]: "satisfies e c1 ==> satisfies e c2 ==> satisfies e (And c1 c2)"
    | [simp]: "satisfies e c1 ==> satisfies e (Or c1 c2)"
    | [simp]: "satisfies e c2 ==> satisfies e (Or c1 c2)"
    | [simp]: "satisfies e c ==> satisfies (InL t t' e) (InLCon c)"
    | [simp]: "satisfies e c ==> satisfies (InR t t' e) (InRCon c)"
    | [simp]: "satisfies Triv TrivCon"
    | [simp]: "satisfies e1 c1 ==> satisfies e2 c2 ==> satisfies (Pair e1 e2) (PairCon c1 c2)"

inductive_cases [elim!]: "satisfies e Truth"
inductive_cases [elim!]: "satisfies e Falsity"
inductive_cases [elim!]: "satisfies e (And c1 c2)"
inductive_cases [elim!]: "satisfies e (Or c1 c2)"
inductive_cases [elim!]: "satisfies e (InLCon c)"
inductive_cases [elim!]: "satisfies e (InRCon c)"
inductive_cases [elim!]: "satisfies e TrivCon"
inductive_cases [elim!]: "satisfies e (PairCon c1 c2)"

primrec negate :: "constraint => constraint"
where "negate Truth = Falsity"
    | "negate Falsity = Truth"
    | "negate (And c1 c2) = Or (negate c1) (negate c2)"
    | "negate (Or c1 c2) = And (negate c1) (negate c2)"
    | "negate (InLCon c) = Or (InLCon (negate c)) (InRCon Truth)"
    | "negate (InRCon c) = Or (InRCon (negate c)) (InLCon Truth)"
    | "negate TrivCon = Falsity"
    | "negate (PairCon c1 c2) = Or (PairCon (negate c1) c2)
                                   (Or (PairCon c1 (negate c2))
                                       (PairCon (negate c1) (negate c2)))"

primrec and_count :: "constraint => nat"
where "and_count Truth = 1"
    | "and_count Falsity = 1"
    | "and_count (And c1 c2) = and_count c1 + and_count c2 + 1"
    | "and_count (Or c1 c2) = and_count c1 + and_count c2"
    | "and_count (InLCon c) = and_count c"
    | "and_count (InRCon c) = and_count c"
    | "and_count TrivCon = 1"
    | "and_count (PairCon c1 c2) = and_count c1 + and_count c2"

primrec collect_inls :: "constraint => constraint option"
where "collect_inls Truth = Some Truth"
    | "collect_inls Falsity = Some Falsity"
    | "collect_inls (And c1 c2) = (case collect_inls c1 of
          None => None
        | Some c1' => case collect_inls c2 of
            None => None
          | Some c2' => Some (And c1' c2'))"
    | "collect_inls (Or c1 c2) = (case collect_inls c1 of
          None => None
        | Some c1' => case collect_inls c2 of
            None => None
          | Some c2' => Some (Or c1' c2'))"
    | "collect_inls (InLCon c) = Some c"
    | "collect_inls (InRCon c) = None"
    | "collect_inls TrivCon = None"
    | "collect_inls (PairCon c1 c2) = None"

primrec collect_inrs :: "constraint => constraint option"
where "collect_inrs Truth = Some Truth"
    | "collect_inrs Falsity = Some Falsity"
    | "collect_inrs (And c1 c2) = (case collect_inrs c1 of
          None => None
        | Some c1' => case collect_inrs c2 of
            None => None
          | Some c2' => Some (And c1' c2'))"
    | "collect_inrs (Or c1 c2) = (case collect_inrs c1 of
          None => None
        | Some c1' => case collect_inrs c2 of
            None => None
          | Some c2' => Some (Or c1' c2'))"
    | "collect_inrs (InLCon c) = None"
    | "collect_inrs (InRCon c) = Some c"
    | "collect_inrs TrivCon = None"
    | "collect_inrs (PairCon c1 c2) = None"

function is_incon :: "constraint list => bool"
where "is_incon [] = False"
    | "is_incon (Truth # cs) = is_incon cs"
    | "is_incon (Falsity # cs) = True"
    | "is_incon (And c1 c2 # cs) = is_incon (c1 # c2 # cs)"
    | "is_incon (Or c1 c2 # cs) = (is_incon (c1 # cs) & is_incon (c2 # cs))"
    | "is_incon (InLCon c # cs) = (case collect_map collect_inls cs of
          None => True
        | Some ils => is_incon (c # ils))"
    | "is_incon (InRCon c # cs) = (case collect_map collect_inrs cs of
          None => True
        | Some ils => is_incon (c # ils))"
    | "is_incon (TrivCon # cs) = is_incon cs"
    | "is_incon (PairCon c1 c2 # cs) = undefined"
by pat_completeness auto

definition satisfies_all :: "constraint => bool"
where "satisfies_all c = is_incon [negate c]"

lemma [simp]: "rules_constraint (insert_rules n rs) = rules_constraint rs"
by (induction rs, simp_all)

lemma [simp]: "rule_constraint (subst_rule n e r) = rule_constraint r"
by (induction r, simp_all)

lemma [simp]: "rules_constraint (subst_rules n e rs) = rules_constraint rs"
by (induction rs, simp_all)

lemma [simp]: "satisfies e (patn_constraint p) ==> (EX s. matches p e s)"
proof (induction p arbitrary: e)
case WildPat
  thus ?case by (metis matches.intros(2))
next case VarPat
  thus ?case by (metis matches.intros(1))
next case TrivPat
  hence "e = Triv" by auto
  thus ?case by (metis matches.intros(3))
next case (PairPat p1 p2)
  hence "EX e1 e2. e = Pair e1 e2 & satisfies e1 (patn_constraint p1)
                                  & satisfies e2 (patn_constraint p2)" by auto
  with PairPat show ?case by (metis (full_types) matches.intros(4))
next case (InLPat p)
  hence "EX e' t t'. e = InL t t' e' & satisfies e' (patn_constraint p)" by auto
  with InLPat show ?case by (metis matches.intros(5))
next case (InRPat p)
  hence "EX e' t t'. e = InR t t' e' & satisfies e' (patn_constraint p)" by auto
  with InRPat show ?case by (metis matches.intros(6))
qed

lemma [simp]: "~ satisfies e (patn_constraint p) ==> no_match p e"
proof (induction p arbitrary: e)
case WildPat
  thus ?case by simp
next case VarPat
  thus ?case by simp
next case TrivPat
  hence "e ~= Triv" by auto
  thus ?case by (metis no_match.intros(1))
next case (PairPat p1 p2)
  hence "~ (EX e1 e2. e = Pair e1 e2) |
           (EX e1 e2. e = Pair e1 e2 & (~ satisfies e1 (patn_constraint p1) |
                                        ~ satisfies e2 (patn_constraint p2)))" by auto
  thus ?case by (metis PairPat(1) PairPat(2) no_match.intros(2) no_match.intros(3) no_match.intros(4))
next case (InLPat p)
  hence "~ (EX e' t t'. e = InL t t' e') |
           (EX e' t t'. e = InL t t' e' & ~ satisfies e' (patn_constraint p))" by auto
  with InLPat show ?case by (metis no_match.intros(5) no_match.intros(6))
next case (InRPat p)
  hence "~ (EX e' t t'. e = InR t t' e') |
           (EX e' t t'. e = InR t t' e' & ~ satisfies e' (patn_constraint p))" by auto
  with InRPat show ?case by (metis no_match.intros(7) no_match.intros(8))
qed

lemma [elim!]: "satisfies e (Or r1 r2) ==> ~ satisfies e r1 ==> satisfies e r2"
by (induction e "Or r1 r2" rule: satisfies.induct, simp_all)

lemma [simp]: "size (collect_inls c) <= size c"
proof (induction c)
case Truth
  thus ?case by simp
next case Falsity
  thus ?case by simp
next case (And c1 c2)
  thus ?case by (cases "collect_inls c1", simp, cases "collect_inls c2", fastforce+)
next case (Or c1 c2)
  thus ?case by (cases "collect_inls c1", simp, cases "collect_inls c2", fastforce+)
next case InLCon
  thus ?case by simp
next case InRCon
  thus ?case by simp
next case TrivCon
  thus ?case by simp
next case PairCon
  thus ?case by simp
qed

lemma [simp]: "collect_inls c = Some c' ==> and_count c' <= and_count c"
proof (induction c arbitrary: c')
case Truth
  thus ?case by simp
next case Falsity
  thus ?case by simp
next case (And c1 c2)
  thus ?case by (cases "collect_inls c1", simp, cases "collect_inls c2", fastforce+)
next case (Or c1 c2)
  thus ?case by (cases "collect_inls c1", simp, cases "collect_inls c2", fastforce+)
next case InLCon
  thus ?case by simp
next case InRCon
  thus ?case by simp
next case TrivCon
  thus ?case by simp
next case PairCon
  thus ?case by simp
qed

lemma [simp]: "size (collect_inrs c) <= size c"
proof (induction c)
case Truth
  thus ?case by simp
next case Falsity
  thus ?case by simp
next case (And c1 c2)
  thus ?case by (cases "collect_inrs c1", simp, cases "collect_inrs c2", fastforce+)
next case (Or c1 c2)
  thus ?case by (cases "collect_inrs c1", simp, cases "collect_inrs c2", fastforce+)
next case InLCon
  thus ?case by simp
next case InRCon
  thus ?case by simp
next case TrivCon
  thus ?case by simp
next case PairCon
  thus ?case by simp
qed

lemma [simp]: "collect_inrs c = Some c' ==> and_count c' <= and_count c"
proof (induction c arbitrary: c')
case Truth
  thus ?case by simp
next case Falsity
  thus ?case by simp
next case (And c1 c2)
  thus ?case by (cases "collect_inrs c1", simp, cases "collect_inrs c2", fastforce+)
next case (Or c1 c2)
  thus ?case by (cases "collect_inrs c1", simp, cases "collect_inrs c2", fastforce+)
next case InLCon
  thus ?case by simp
next case InRCon
  thus ?case by simp
next case TrivCon
  thus ?case by simp
next case PairCon
  thus ?case by simp
qed

termination is_incon
proof (relation "measures [mapsum and_count, mapsum size]", auto)
  fix cs a
  assume "collect_map collect_inls cs = Some a"
     and "\<not> mapsum and_count a < mapsum and_count cs"
  show "mapsum and_count a = mapsum and_count cs" by simp sorry
next
  fix cs a
  assume "collect_map collect_inls cs = Some a"
     and "\<not> mapsum and_count a < mapsum and_count cs"
  show "mapsum size a < Nat.Suc (mapsum size cs)" by simp sorry
next
  fix cs a
  assume "collect_map collect_inrs cs = Some a"
     and "\<not> mapsum and_count a < mapsum and_count cs"
  show "mapsum and_count a = mapsum and_count cs" by simp sorry
next
  fix cs a
  assume "collect_map collect_inrs cs = Some a"
     and "\<not> mapsum and_count a < mapsum and_count cs"
  show "mapsum size a < Nat.Suc (mapsum size cs)" by simp sorry
qed

lemma [simp]: "satisfies_all c ==> satisfies e c"
apply (induction c arbitrary: e)
apply (simp_all add: satisfies_all_def)
by (simp add: satisfies_all_def) sorry

end


(*  Title:      HOL/Analysis/Lebesgue_Integral_Substitution.thy
    Author:     Manuel Eberl

    Provides lemmas for integration by substitution for the basic integral types.
    Note that the substitution function must have a nonnegative derivative.
    This could probably be weakened somehow.
*)

section \<open>Integration by Substition\<close>

theory Lebesgue_Integral_Substitution
imports Interval_Integral
begin

lemma nn_integral_substitution_aux:
  fixes f :: "real \<Rightarrow> ennreal"
  assumes Mf: "f \<in> borel_measurable borel"
  assumes nonnegf: "\<And>x. f x \<ge> 0"
  assumes derivg: "\<And>x. x \<in> {a..b} \<Longrightarrow> (g has_real_derivative g' x) (at x)"
  assumes contg': "continuous_on {a..b} g'"
  assumes derivg_nonneg: "\<And>x. x \<in> {a..b} \<Longrightarrow> g' x \<ge> 0"
  assumes "a < b"
  shows "(\<integral>\<^sup>+x. f x * indicator {g a..g b} x \<partial>lborel) =
             (\<integral>\<^sup>+x. f (g x) * g' x * indicator {a..b} x \<partial>lborel)"
proof-
  from \<open>a < b\<close> have [simp]: "a \<le> b" by simp
  from derivg have contg: "continuous_on {a..b} g" by (rule has_real_derivative_imp_continuous_on)
  from this and contg' have Mg: "set_borel_measurable borel {a..b} g" and
                             Mg': "set_borel_measurable borel {a..b} g'"
      by (simp_all only: set_measurable_continuous_on_ivl)
  from derivg have derivg': "\<And>x. x \<in> {a..b} \<Longrightarrow> (g has_vector_derivative g' x) (at x)"
    by (simp only: has_field_derivative_iff_has_vector_derivative)

  have real_ind[simp]: "\<And>A x. enn2real (indicator A x) = indicator A x"
      by (auto split: split_indicator)
  have ennreal_ind[simp]: "\<And>A x. ennreal (indicator A x) = indicator A x"
      by (auto split: split_indicator)
  have [simp]: "\<And>x A. indicator A (g x) = indicator (g -` A) x"
      by (auto split: split_indicator)

  from derivg derivg_nonneg have monog: "\<And>x y. a \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> y \<le> b \<Longrightarrow> g x \<le> g y"
    by (rule deriv_nonneg_imp_mono) simp_all
  with monog have [simp]: "g a \<le> g b" by (auto intro: mono_onD)

  show ?thesis
  proof (induction rule: borel_measurable_induct[OF Mf, case_names cong set mult add sup])
    case (cong f1 f2)
    from cong.hyps(3) have "f1 = f2" by auto
    with cong show ?case by simp
  next
    case (set A)
    from set.hyps show ?case
    proof (induction rule: borel_set_induct)
      case empty
      thus ?case by simp
    next
      case (interval c d)
      {
        fix u v :: real assume asm: "{u..v} \<subseteq> {g a..g b}" "u \<le> v"

        obtain u' v' where u'v': "{a..b} \<inter> g-`{u..v} = {u'..v'}" "u' \<le> v'" "g u' = u" "g v' = v"
             using asm by (rule_tac continuous_interval_vimage_Int[OF contg monog, of u v]) simp_all
        hence "{u'..v'} \<subseteq> {a..b}" "{u'..v'} \<subseteq> g -` {u..v}" by blast+
        with u'v'(2) have "u' \<in> g -` {u..v}" "v' \<in> g -` {u..v}" by auto
        from u'v'(1) have [simp]: "{a..b} \<inter> g -` {u..v} \<in> sets borel" by simp

        have A: "continuous_on {min u' v'..max u' v'} g'"
            by (simp only: u'v' max_absorb2 min_absorb1)
               (intro continuous_on_subset[OF contg'], insert u'v', auto)
        have "\<And>x. x \<in> {u'..v'} \<Longrightarrow> (g has_real_derivative g' x) (at x within {u'..v'})"
           using asm by (intro has_field_derivative_subset[OF derivg] set_mp[OF \<open>{u'..v'} \<subseteq> {a..b}\<close>]) auto
        hence B: "\<And>x. min u' v' \<le> x \<Longrightarrow> x \<le> max u' v' \<Longrightarrow>
                      (g has_vector_derivative g' x) (at x within {min u' v'..max u' v'})"
            by (simp only: u'v' max_absorb2 min_absorb1)
               (auto simp: has_field_derivative_iff_has_vector_derivative)
        have "integrable lborel (\<lambda>x. indicator ({a..b} \<inter> g -` {u..v}) x *\<^sub>R g' x)"
          by (rule set_integrable_subset[OF borel_integrable_atLeastAtMost'[OF contg']]) simp_all
        hence "(\<integral>\<^sup>+x. ennreal (g' x) * indicator ({a..b} \<inter> g-` {u..v}) x \<partial>lborel) =
                   LBINT x:{a..b} \<inter> g-`{u..v}. g' x"
          by (subst nn_integral_eq_integral[symmetric])
             (auto intro!: derivg_nonneg nn_integral_cong split: split_indicator)
        also from interval_integral_FTC_finite[OF A B]
            have "LBINT x:{a..b} \<inter> g-`{u..v}. g' x = v - u"
                by (simp add: u'v' interval_integral_Icc \<open>u \<le> v\<close>)
        finally have "(\<integral>\<^sup>+ x. ennreal (g' x) * indicator ({a..b} \<inter> g -` {u..v}) x \<partial>lborel) =
                           ennreal (v - u)" .
      } note A = this

      have "(\<integral>\<^sup>+x. indicator {c..d} (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel) =
               (\<integral>\<^sup>+ x. ennreal (g' x) * indicator ({a..b} \<inter> g -` {c..d}) x \<partial>lborel)"
        by (intro nn_integral_cong) (simp split: split_indicator)
      also have "{a..b} \<inter> g-`{c..d} = {a..b} \<inter> g-`{max (g a) c..min (g b) d}"
        using \<open>a \<le> b\<close> \<open>c \<le> d\<close>
        by (auto intro!: monog intro: order.trans)
      also have "(\<integral>\<^sup>+ x. ennreal (g' x) * indicator ... x \<partial>lborel) =
        (if max (g a) c \<le> min (g b) d then min (g b) d - max (g a) c else 0)"
         using \<open>c \<le> d\<close> by (simp add: A)
      also have "... = (\<integral>\<^sup>+ x. indicator ({g a..g b} \<inter> {c..d}) x \<partial>lborel)"
        by (subst nn_integral_indicator) (auto intro!: measurable_sets Mg simp:)
      also have "... = (\<integral>\<^sup>+ x. indicator {c..d} x * indicator {g a..g b} x \<partial>lborel)"
        by (intro nn_integral_cong) (auto split: split_indicator)
      finally show ?case ..

      next

      case (compl A)
      note \<open>A \<in> sets borel\<close>[measurable]
      from emeasure_mono[of "A \<inter> {g a..g b}" "{g a..g b}" lborel]
      have [simp]: "emeasure lborel (A \<inter> {g a..g b}) \<noteq> top" by (auto simp: top_unique)
      have [simp]: "g -` A \<inter> {a..b} \<in> sets borel"
        by (rule set_borel_measurable_sets[OF Mg]) auto
      have [simp]: "g -` (-A) \<inter> {a..b} \<in> sets borel"
        by (rule set_borel_measurable_sets[OF Mg]) auto

      have "(\<integral>\<^sup>+x. indicator (-A) x * indicator {g a..g b} x \<partial>lborel) =
                (\<integral>\<^sup>+x. indicator (-A \<inter> {g a..g b}) x \<partial>lborel)"
        by (rule nn_integral_cong) (simp split: split_indicator)
      also from compl have "... = emeasure lborel ({g a..g b} - A)" using derivg_nonneg
        by (simp add: vimage_Compl diff_eq Int_commute[of "-A"])
      also have "{g a..g b} - A = {g a..g b} - A \<inter> {g a..g b}" by blast
      also have "emeasure lborel ... = g b - g a - emeasure lborel (A \<inter> {g a..g b})"
             using \<open>A \<in> sets borel\<close> by (subst emeasure_Diff) (auto simp: )
     also have "emeasure lborel (A \<inter> {g a..g b}) =
                    \<integral>\<^sup>+x. indicator A x * indicator {g a..g b} x \<partial>lborel"
       using \<open>A \<in> sets borel\<close>
       by (subst nn_integral_indicator[symmetric], simp, intro nn_integral_cong)
          (simp split: split_indicator)
      also have "... = \<integral>\<^sup>+ x. indicator (g-`A \<inter> {a..b}) x * ennreal (g' x * indicator {a..b} x) \<partial>lborel" (is "_ = ?I")
        by (subst compl.IH, intro nn_integral_cong) (simp split: split_indicator)
      also have "g b - g a = LBINT x:{a..b}. g' x" using derivg'
        by (intro integral_FTC_atLeastAtMost[symmetric])
           (auto intro: continuous_on_subset[OF contg'] has_field_derivative_subset[OF derivg]
                 has_vector_derivative_at_within)
      also have "ennreal ... = \<integral>\<^sup>+ x. g' x * indicator {a..b} x \<partial>lborel"
        using borel_integrable_atLeastAtMost'[OF contg']
        by (subst nn_integral_eq_integral)
           (simp_all add: mult.commute derivg_nonneg split: split_indicator)
      also have Mg'': "(\<lambda>x. indicator (g -` A \<inter> {a..b}) x * ennreal (g' x * indicator {a..b} x))
                            \<in> borel_measurable borel" using Mg'
        by (intro borel_measurable_times_ennreal borel_measurable_indicator)
           (simp_all add: mult.commute)
      have le: "(\<integral>\<^sup>+x. indicator (g-`A \<inter> {a..b}) x * ennreal (g' x * indicator {a..b} x) \<partial>lborel) \<le>
                        (\<integral>\<^sup>+x. ennreal (g' x) * indicator {a..b} x \<partial>lborel)"
         by (intro nn_integral_mono) (simp split: split_indicator add: derivg_nonneg)
      note integrable = borel_integrable_atLeastAtMost'[OF contg']
      with le have notinf: "(\<integral>\<^sup>+x. indicator (g-`A \<inter> {a..b}) x * ennreal (g' x * indicator {a..b} x) \<partial>lborel) \<noteq> top"
          by (auto simp: real_integrable_def nn_integral_set_ennreal mult.commute top_unique)
      have "(\<integral>\<^sup>+ x. g' x * indicator {a..b} x \<partial>lborel) - ?I =
                  \<integral>\<^sup>+ x. ennreal (g' x * indicator {a..b} x) -
                        indicator (g -` A \<inter> {a..b}) x * ennreal (g' x * indicator {a..b} x) \<partial>lborel"
        apply (intro nn_integral_diff[symmetric])
        apply (insert Mg', simp add: mult.commute) []
        apply (insert Mg'', simp) []
        apply (simp split: split_indicator add: derivg_nonneg)
        apply (rule notinf)
        apply (simp split: split_indicator add: derivg_nonneg)
        done
      also have "... = \<integral>\<^sup>+ x. indicator (-A) (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel"
        by (intro nn_integral_cong) (simp split: split_indicator)
      finally show ?case .

    next
      case (union f)
      then have [simp]: "\<And>i. {a..b} \<inter> g -` f i \<in> sets borel"
        by (subst Int_commute, intro set_borel_measurable_sets[OF Mg]) auto
      have "g -` (\<Union>i. f i) \<inter> {a..b} = (\<Union>i. {a..b} \<inter> g -` f i)" by auto
      hence "g -` (\<Union>i. f i) \<inter> {a..b} \<in> sets borel" by (auto simp del: UN_simps)

      have "(\<integral>\<^sup>+x. indicator (\<Union>i. f i) x * indicator {g a..g b} x \<partial>lborel) =
                \<integral>\<^sup>+x. indicator (\<Union>i. {g a..g b} \<inter> f i) x \<partial>lborel"
          by (intro nn_integral_cong) (simp split: split_indicator)
      also from union have "... = emeasure lborel (\<Union>i. {g a..g b} \<inter> f i)" by simp
      also from union have "... = (\<Sum>i. emeasure lborel ({g a..g b} \<inter> f i))"
        by (intro suminf_emeasure[symmetric]) (auto simp: disjoint_family_on_def)
      also from union have "... = (\<Sum>i. \<integral>\<^sup>+x. indicator ({g a..g b} \<inter> f i) x \<partial>lborel)" by simp
      also have "(\<lambda>i. \<integral>\<^sup>+x. indicator ({g a..g b} \<inter> f i) x \<partial>lborel) =
                           (\<lambda>i. \<integral>\<^sup>+x. indicator (f i) x * indicator {g a..g b} x \<partial>lborel)"
        by (intro ext nn_integral_cong) (simp split: split_indicator)
      also from union.IH have "(\<Sum>i. \<integral>\<^sup>+x. indicator (f i) x * indicator {g a..g b} x \<partial>lborel) =
          (\<Sum>i. \<integral>\<^sup>+ x. indicator (f i) (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel)" by simp
      also have "(\<lambda>i. \<integral>\<^sup>+ x. indicator (f i) (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel) =
                         (\<lambda>i. \<integral>\<^sup>+ x. ennreal (g' x * indicator {a..b} x) * indicator ({a..b} \<inter> g -` f i) x \<partial>lborel)"
        by (intro ext nn_integral_cong) (simp split: split_indicator)
      also have "(\<Sum>i. ... i) = \<integral>\<^sup>+ x. (\<Sum>i. ennreal (g' x * indicator {a..b} x) * indicator ({a..b} \<inter> g -` f i) x) \<partial>lborel"
        using Mg'
        apply (intro nn_integral_suminf[symmetric])
        apply (rule borel_measurable_times_ennreal, simp add: mult.commute)
        apply (rule borel_measurable_indicator, subst sets_lborel)
        apply (simp_all split: split_indicator add: derivg_nonneg)
        done
      also have "(\<lambda>x i. ennreal (g' x * indicator {a..b} x) * indicator ({a..b} \<inter> g -` f i) x) =
                      (\<lambda>x i. ennreal (g' x * indicator {a..b} x) * indicator (g -` f i) x)"
        by (intro ext) (simp split: split_indicator)
      also have "(\<integral>\<^sup>+ x. (\<Sum>i. ennreal (g' x * indicator {a..b} x) * indicator (g -` f i) x) \<partial>lborel) =
                     \<integral>\<^sup>+ x. ennreal (g' x * indicator {a..b} x) * (\<Sum>i. indicator (g -` f i) x) \<partial>lborel"
        by (intro nn_integral_cong) (auto split: split_indicator simp: derivg_nonneg)
      also from union have "(\<lambda>x. \<Sum>i. indicator (g -` f i) x :: ennreal) = (\<lambda>x. indicator (\<Union>i. g -` f i) x)"
        by (intro ext suminf_indicator) (auto simp: disjoint_family_on_def)
      also have "(\<integral>\<^sup>+x. ennreal (g' x * indicator {a..b} x) * ... x \<partial>lborel) =
                    (\<integral>\<^sup>+x. indicator (\<Union>i. f i) (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel)"
       by (intro nn_integral_cong) (simp split: split_indicator)
      finally show ?case .
  qed

next
  case (mult f c)
    note Mf[measurable] = \<open>f \<in> borel_measurable borel\<close>
    let ?I = "indicator {a..b}"
    have "(\<lambda>x. f (g x * ?I x) * ennreal (g' x * ?I x)) \<in> borel_measurable borel" using Mg Mg'
      by (intro borel_measurable_times_ennreal measurable_compose[OF _ Mf])
         (simp_all add: mult.commute)
    also have "(\<lambda>x. f (g x * ?I x) * ennreal (g' x * ?I x)) = (\<lambda>x. f (g x) * ennreal (g' x) * ?I x)"
      by (intro ext) (simp split: split_indicator)
    finally have Mf': "(\<lambda>x. f (g x) * ennreal (g' x) * ?I x) \<in> borel_measurable borel" .
    with mult show ?case
      by (subst (1 2 3) mult_ac, subst (1 2) nn_integral_cmult) (simp_all add: mult_ac)

next
  case (add f2 f1)
    let ?I = "indicator {a..b}"
    {
      fix f :: "real \<Rightarrow> ennreal" assume Mf: "f \<in> borel_measurable borel"
      have "(\<lambda>x. f (g x * ?I x) * ennreal (g' x * ?I x)) \<in> borel_measurable borel" using Mg Mg'
        by (intro borel_measurable_times_ennreal measurable_compose[OF _ Mf])
           (simp_all add:  mult.commute)
      also have "(\<lambda>x. f (g x * ?I x) * ennreal (g' x * ?I x)) = (\<lambda>x. f (g x) * ennreal (g' x) * ?I x)"
        by (intro ext) (simp split: split_indicator)
      finally have "(\<lambda>x. f (g x) * ennreal (g' x) * ?I x) \<in> borel_measurable borel" .
    } note Mf' = this[OF \<open>f1 \<in> borel_measurable borel\<close>] this[OF \<open>f2 \<in> borel_measurable borel\<close>]

    have "(\<integral>\<^sup>+ x. (f1 x + f2 x) * indicator {g a..g b} x \<partial>lborel) =
             (\<integral>\<^sup>+ x. f1 x * indicator {g a..g b} x + f2 x * indicator {g a..g b} x \<partial>lborel)"
      by (intro nn_integral_cong) (simp split: split_indicator)
    also from add have "... = (\<integral>\<^sup>+ x. f1 (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel) +
                                (\<integral>\<^sup>+ x. f2 (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel)"
      by (simp_all add: nn_integral_add)
    also from add have "... = (\<integral>\<^sup>+ x. f1 (g x) * ennreal (g' x) * indicator {a..b} x +
                                      f2 (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel)"
      by (intro nn_integral_add[symmetric])
         (auto simp add: Mf' derivg_nonneg split: split_indicator)
    also have "... = \<integral>\<^sup>+ x. (f1 (g x) + f2 (g x)) * ennreal (g' x) * indicator {a..b} x \<partial>lborel"
      by (intro nn_integral_cong) (simp split: split_indicator add: distrib_right)
    finally show ?case .

next
  case (sup F)
  {
    fix i
    let ?I = "indicator {a..b}"
    have "(\<lambda>x. F i (g x * ?I x) * ennreal (g' x * ?I x)) \<in> borel_measurable borel" using Mg Mg'
      by (rule_tac borel_measurable_times_ennreal, rule_tac measurable_compose[OF _ sup.hyps(1)])
         (simp_all add: mult.commute)
    also have "(\<lambda>x. F i (g x * ?I x) * ennreal (g' x * ?I x)) = (\<lambda>x. F i (g x) * ennreal (g' x) * ?I x)"
      by (intro ext) (simp split: split_indicator)
     finally have "... \<in> borel_measurable borel" .
  } note Mf' = this

    have "(\<integral>\<^sup>+x. (SUP i. F i x) * indicator {g a..g b} x \<partial>lborel) =
               \<integral>\<^sup>+x. (SUP i. F i x* indicator {g a..g b} x) \<partial>lborel"
      by (intro nn_integral_cong) (simp split: split_indicator)
    also from sup have "... = (SUP i. \<integral>\<^sup>+x. F i x* indicator {g a..g b} x \<partial>lborel)"
      by (intro nn_integral_monotone_convergence_SUP)
         (auto simp: incseq_def le_fun_def split: split_indicator)
    also from sup have "... = (SUP i. \<integral>\<^sup>+x. F i (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel)"
      by simp
    also from sup have "... =  \<integral>\<^sup>+x. (SUP i. F i (g x) * ennreal (g' x) * indicator {a..b} x) \<partial>lborel"
      by (intro nn_integral_monotone_convergence_SUP[symmetric])
         (auto simp: incseq_def le_fun_def derivg_nonneg Mf' split: split_indicator
               intro!: mult_right_mono)
    also from sup have "... = \<integral>\<^sup>+x. (SUP i. F i (g x)) * ennreal (g' x) * indicator {a..b} x \<partial>lborel"
      by (subst mult.assoc, subst mult.commute, subst SUP_mult_left_ennreal)
         (auto split: split_indicator simp: derivg_nonneg mult_ac)
    finally show ?case by simp
  qed
qed

lemma nn_integral_substitution:
  fixes f :: "real \<Rightarrow> real"
  assumes Mf[measurable]: "set_borel_measurable borel {g a..g b} f"
  assumes derivg: "\<And>x. x \<in> {a..b} \<Longrightarrow> (g has_real_derivative g' x) (at x)"
  assumes contg': "continuous_on {a..b} g'"
  assumes derivg_nonneg: "\<And>x. x \<in> {a..b} \<Longrightarrow> g' x \<ge> 0"
  assumes "a \<le> b"
  shows "(\<integral>\<^sup>+x. f x * indicator {g a..g b} x \<partial>lborel) =
             (\<integral>\<^sup>+x. f (g x) * g' x * indicator {a..b} x \<partial>lborel)"
proof (cases "a = b")
  assume "a \<noteq> b"
  with \<open>a \<le> b\<close> have "a < b" by auto
  let ?f' = "\<lambda>x. f x * indicator {g a..g b} x"

  from derivg derivg_nonneg have monog: "\<And>x y. a \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> y \<le> b \<Longrightarrow> g x \<le> g y"
    by (rule deriv_nonneg_imp_mono) simp_all
  have bounds: "\<And>x. x \<ge> a \<Longrightarrow> x \<le> b \<Longrightarrow> g x \<ge> g a" "\<And>x. x \<ge> a \<Longrightarrow> x \<le> b \<Longrightarrow> g x \<le> g b"
    by (auto intro: monog)

  from derivg_nonneg have nonneg:
    "\<And>f x. x \<ge> a \<Longrightarrow> x \<le> b \<Longrightarrow> g' x \<noteq> 0 \<Longrightarrow> f x * ennreal (g' x) \<ge> 0 \<Longrightarrow> f x \<ge> 0"
    by (force simp: field_simps)
  have nonneg': "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> \<not> 0 \<le> f (g x) \<Longrightarrow> 0 \<le> f (g x) * g' x \<Longrightarrow> g' x = 0"
    by (metis atLeastAtMost_iff derivg_nonneg eq_iff mult_eq_0_iff mult_le_0_iff)

  have "(\<integral>\<^sup>+x. f x * indicator {g a..g b} x \<partial>lborel) =
            (\<integral>\<^sup>+x. ennreal (?f' x) * indicator {g a..g b} x \<partial>lborel)"
    by (intro nn_integral_cong)
       (auto split: split_indicator split_max simp: zero_ennreal.rep_eq ennreal_neg)
  also have "... = \<integral>\<^sup>+ x. ?f' (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel" using Mf
    by (subst nn_integral_substitution_aux[OF _ _ derivg contg' derivg_nonneg \<open>a < b\<close>])
       (auto simp add: mult.commute)
  also have "... = \<integral>\<^sup>+ x. f (g x) * ennreal (g' x) * indicator {a..b} x \<partial>lborel"
    by (intro nn_integral_cong) (auto split: split_indicator simp: max_def dest: bounds)
  also have "... = \<integral>\<^sup>+x. ennreal (f (g x) * g' x * indicator {a..b} x) \<partial>lborel"
    by (intro nn_integral_cong) (auto simp: mult.commute derivg_nonneg ennreal_mult' split: split_indicator)
  finally show ?thesis .
qed auto

lemma integral_substitution:
  assumes integrable: "set_integrable lborel {g a..g b} f"
  assumes derivg: "\<And>x. x \<in> {a..b} \<Longrightarrow> (g has_real_derivative g' x) (at x)"
  assumes contg': "continuous_on {a..b} g'"
  assumes derivg_nonneg: "\<And>x. x \<in> {a..b} \<Longrightarrow> g' x \<ge> 0"
  assumes "a \<le> b"
  shows "set_integrable lborel {a..b} (\<lambda>x. f (g x) * g' x)"
    and "(LBINT x. f x * indicator {g a..g b} x) = (LBINT x. f (g x) * g' x * indicator {a..b} x)"
proof-
  from derivg have contg: "continuous_on {a..b} g" by (rule has_real_derivative_imp_continuous_on)
  with contg' have Mg: "set_borel_measurable borel {a..b} g"
    and Mg': "set_borel_measurable borel {a..b} g'"
    by (simp_all only: set_measurable_continuous_on_ivl)
  from derivg derivg_nonneg have monog: "\<And>x y. a \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> y \<le> b \<Longrightarrow> g x \<le> g y"
    by (rule deriv_nonneg_imp_mono) simp_all

  have "(\<lambda>x. ennreal (f x) * indicator {g a..g b} x) =
           (\<lambda>x. ennreal (f x * indicator {g a..g b} x))"
    by (intro ext) (simp split: split_indicator)
  with integrable have M1: "(\<lambda>x. f x * indicator {g a..g b} x) \<in> borel_measurable borel"
    unfolding real_integrable_def by (force simp: mult.commute)
  from integrable have M2: "(\<lambda>x. -f x * indicator {g a..g b} x) \<in> borel_measurable borel"
    unfolding real_integrable_def by (force simp: mult.commute)

  have "LBINT x. (f x :: real) * indicator {g a..g b} x =
          enn2real (\<integral>\<^sup>+ x. ennreal (f x) * indicator {g a..g b} x \<partial>lborel) -
          enn2real (\<integral>\<^sup>+ x. ennreal (- (f x)) * indicator {g a..g b} x \<partial>lborel)" using integrable
    by (subst real_lebesgue_integral_def) (simp_all add: nn_integral_set_ennreal mult.commute)
  also have *: "(\<integral>\<^sup>+x. ennreal (f x) * indicator {g a..g b} x \<partial>lborel) =
      (\<integral>\<^sup>+x. ennreal (f x * indicator {g a..g b} x) \<partial>lborel)"
    by (intro nn_integral_cong) (simp split: split_indicator)
  also from M1 * have A: "(\<integral>\<^sup>+ x. ennreal (f x * indicator {g a..g b} x) \<partial>lborel) =
                            (\<integral>\<^sup>+ x. ennreal (f (g x) * g' x * indicator {a..b} x) \<partial>lborel)"
    by (subst nn_integral_substitution[OF _ derivg contg' derivg_nonneg \<open>a \<le> b\<close>])
       (auto simp: nn_integral_set_ennreal mult.commute)
  also have **: "(\<integral>\<^sup>+ x. ennreal (- (f x)) * indicator {g a..g b} x \<partial>lborel) =
      (\<integral>\<^sup>+ x. ennreal (- (f x) * indicator {g a..g b} x) \<partial>lborel)"
    by (intro nn_integral_cong) (simp split: split_indicator)
  also from M2 ** have B: "(\<integral>\<^sup>+ x. ennreal (- (f x) * indicator {g a..g b} x) \<partial>lborel) =
        (\<integral>\<^sup>+ x. ennreal (- (f (g x)) * g' x * indicator {a..b} x) \<partial>lborel)"
    by (subst nn_integral_substitution[OF _ derivg contg' derivg_nonneg \<open>a \<le> b\<close>])
       (auto simp: nn_integral_set_ennreal mult.commute)

  also {
    from integrable have Mf: "set_borel_measurable borel {g a..g b} f"
      unfolding real_integrable_def by simp
    from borel_measurable_times[OF measurable_compose[OF Mg Mf] Mg']
      have "(\<lambda>x. f (g x * indicator {a..b} x) * indicator {g a..g b} (g x * indicator {a..b} x) *
                     (g' x * indicator {a..b} x)) \<in> borel_measurable borel"  (is "?f \<in> _")
      by (simp add: mult.commute)
    also have "?f = (\<lambda>x. f (g x) * g' x * indicator {a..b} x)"
      using monog by (intro ext) (auto split: split_indicator)
    finally show "set_integrable lborel {a..b} (\<lambda>x. f (g x) * g' x)"
      using A B integrable unfolding real_integrable_def
      by (simp_all add: nn_integral_set_ennreal mult.commute)
  } note integrable' = this

  have "enn2real (\<integral>\<^sup>+ x. ennreal (f (g x) * g' x * indicator {a..b} x) \<partial>lborel) -
                  enn2real (\<integral>\<^sup>+ x. ennreal (-f (g x) * g' x * indicator {a..b} x) \<partial>lborel) =
                (LBINT x. f (g x) * g' x * indicator {a..b} x)" using integrable'
    by (subst real_lebesgue_integral_def) (simp_all add: field_simps)
  finally show "(LBINT x. f x * indicator {g a..g b} x) =
                     (LBINT x. f (g x) * g' x * indicator {a..b} x)" .
qed

lemma interval_integral_substitution:
  assumes integrable: "set_integrable lborel {g a..g b} f"
  assumes derivg: "\<And>x. x \<in> {a..b} \<Longrightarrow> (g has_real_derivative g' x) (at x)"
  assumes contg': "continuous_on {a..b} g'"
  assumes derivg_nonneg: "\<And>x. x \<in> {a..b} \<Longrightarrow> g' x \<ge> 0"
  assumes "a \<le> b"
  shows "set_integrable lborel {a..b} (\<lambda>x. f (g x) * g' x)"
    and "(LBINT x=g a..g b. f x) = (LBINT x=a..b. f (g x) * g' x)"
  apply (rule integral_substitution[OF assms], simp, simp)
  apply (subst (1 2) interval_integral_Icc, fact)
  apply (rule deriv_nonneg_imp_mono[OF derivg derivg_nonneg], simp, simp, fact)
  using integral_substitution(2)[OF assms]
  apply (simp add: mult.commute)
  done

lemma set_borel_integrable_singleton[simp]:
  "set_integrable lborel {x} (f :: real \<Rightarrow> real)"
  by (subst integrable_discrete_difference[where X="{x}" and g="\<lambda>_. 0"]) auto

end


theory Env
  imports Main "HOL-Library.Library"
begin

section \<open>Generic lemmas\<close>

lemma map_of_list_allI:
  assumes "\<And>k v. f k = Some v \<Longrightarrow> P (k, v)" and
    "\<And>k v. map_of kvs k = Some v \<Longrightarrow> f k = Some v" and
    "distinct (map fst kvs)"
  shows "list_all P kvs"
  using assms(2-)
proof (induction kvs)
  case Nil
  then show ?case by simp
next
  case (Cons kv kvs)
  from Cons.prems(1) have "f (fst kv) = Some (snd kv)"
    by simp
  hence"P kv"
    using assms(1)
    by (cases kv; simp)
  moreover have "list_all P kvs"
    using Cons.IH Cons.prems
    by (metis Some_eq_map_of_iff distinct.simps(2) list.set_intros(2) list.simps(9))
  ultimately show ?case by simp
qed

section \<open>Environment\<close>

locale env =
  fixes
    empty :: 'env and
    get :: "'env \<Rightarrow> 'key \<Rightarrow> 'val option" and
    add :: "'env \<Rightarrow> 'key \<Rightarrow> 'val \<Rightarrow> 'env" and
    to_list :: "'env \<Rightarrow> ('key \<times> 'val) list"
  assumes
    get_empty: "get empty x = None" and
    get_add_eq: "get (add e x v) x = Some v" and
    get_add_neq: "x \<noteq> y \<Longrightarrow> get (add e x v) y = get e y" and
    to_list_correct: "map_of (to_list e) = get e" and
    to_list_distinct: "distinct (map fst (to_list e))"

begin

declare get_empty[simp]
declare get_add_eq[simp]
declare get_add_neq[simp]

definition singleton where
  "singleton \<equiv> add empty"

fun add_list :: "'env \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> 'env" where
  "add_list e [] = e" |
  "add_list e (x # xs) = add (add_list e xs) (fst x) (snd x)"

definition from_list :: "('key \<times> 'val) list \<Rightarrow> 'env" where
  "from_list \<equiv> add_list empty"

lemma from_list_correct: "get (from_list xs) = map_of xs"
proof (induction xs)
  case Nil
  then show ?case
    using get_empty by (simp add: from_list_def)
next
  case (Cons x xs)
  show ?case
    using get_add_eq get_add_neq Cons.IH by (auto simp: from_list_def)
qed

lemma from_list_Nil[simp]: "from_list [] = empty"
  by (simp add: from_list_def)

lemma get_from_list_to_list: "get (from_list (to_list e)) = get e"
proof
  fix x
  show "get (from_list (to_list e)) x = get e x"
    unfolding from_list_correct
    unfolding to_list_correct
    by (rule refl)
qed

lemma to_list_list_allI:
  assumes "\<And>k v. get e k = Some v \<Longrightarrow> P (k, v)"
  shows "list_all P (to_list e)"
proof (rule map_of_list_allI[of "get e"])
  fix k v
  show "get e k = Some v \<Longrightarrow> P (k, v)"
    using assms by simp
next
  fix k v
  show "map_of (to_list e) k = Some v \<Longrightarrow> get e k = Some v"
    unfolding to_list_correct by assumption
next
  show "distinct (map fst (to_list e))"
    by (rule to_list_distinct)
qed

definition map_entry where
  "map_entry e k f \<equiv> case get e k of None \<Rightarrow> e | Some v \<Rightarrow> add e k (f v)"

lemma get_map_entry_eq[simp]: "get (map_entry e k f) k = map_option f (get e k)"
  unfolding map_entry_def
  by (cases "get e k") simp_all

lemma get_map_entry_neq[simp]: "x \<noteq> y \<Longrightarrow> get (map_entry e x f) y = get e y"
  unfolding map_entry_def
  by (cases "get e x") simp_all

lemma dom_map_entry[simp]: "dom (get (map_entry e k f)) = dom (get e)"
  unfolding dom_def
  apply (rule Collect_cong)
  by (metis None_eq_map_option_iff get_map_entry_eq get_map_entry_neq)

lemma get_map_entry_conv:
  "get (map_entry e x f) y = map_option (\<lambda>v. if x = y then f v else  v) (get e y)"
  unfolding map_entry_def
  by (cases "get e x"; cases "x = y"; simp add: option.map_ident)

lemma map_option_comp_map_entry:
  assumes "\<forall>x \<in> ran (get e). f (g x) = f x"
  shows "map_option f \<circ> get (map_entry e k g) = map_option f \<circ> get e"
proof (intro ext)
  fix x
  show "(map_option f \<circ> get (map_entry e k g)) x = (map_option f \<circ> get e) x"
  proof (cases "k = x")
    case True
    thus ?thesis
      using assms(1)
      by (auto simp: get_map_entry_eq option.map_comp intro!: map_option_cong ranI)
  next
    case False
    then show ?thesis
      by (simp add: get_map_entry_neq)
  qed
qed

lemma map_option_comp_get_add:
  assumes "k \<in> dom (get e)" and "\<forall>x \<in> ran (get e). f v = f x"
  shows "map_option f \<circ> get (add e k v) = map_option f \<circ> get e"
proof (intro ext)
  fix x
  show "(map_option f \<circ> get (add e k v)) x = (map_option f \<circ> get e) x"
  proof (cases "x = k")
    case True
    show ?thesis
    proof (cases "get e x")
      case None
      thus ?thesis
        using True assms(1) by auto
    next
      case (Some v')
      thus ?thesis
        using True assms(2) by (auto intro: ranI)
    qed
  next
    case False
    thus ?thesis by simp
  qed
qed

end

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_SSortCount
  imports "../../Test_Base"
begin

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

fun ssortminimum1 :: "int => int list => int" where
  "ssortminimum1 x (nil2) = x"
| "ssortminimum1 x (cons2 y1 ys1) =
     (if y1 <= x then ssortminimum1 y1 ys1 else ssortminimum1 x ys1)"

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

(*fun did not finish the proof*)
function ssort :: "int list => int list" where
  "ssort (nil2) = nil2"
| "ssort (cons2 y ys) =
     (let m :: int = ssortminimum1 y ys
     in cons2
          m
          (ssort
             (deleteBy
                (% (z :: int) => % (x2 :: int) => (z = x2)) m (cons2 y ys))))"
  by pat_completeness auto

fun count :: "'a => 'a list => int" where
  "count x (nil2) = 0"
| "count x (cons2 z ys) =
     (if (x = z) then 1 + (count x ys) else count x ys)"

theorem property0 :
  "((count x (ssort xs)) = (count x xs))"
  oops

end