(* Title: thys/TM_Playground.thy
   Author: Franz Regensburger (FABR) 02/2022
 *)

theory TM_Playground
  imports
    StrongCopyTM
begin

(* Playground *)

(* ad numerals *)

value "[1::nat,2,3,4] ! 0"
value "[1::nat,2,3,4] ! 1"

value "<2::nat>"
value "tape_of (2::nat)"

value "<(0::nat,1::nat)>"
value "tape_of_nat_prod (0::nat,1::nat)"

value "<([0,1::nat],[0,1::nat])>"
value "tape_of_nat_prod ([0,1::nat],[0,1::nat])"

value "tape_of_nat_list [2,0,3::nat]"
value "<[2,0,3::nat]>"

(* ad fetch function *)

lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 0 Bk = (Nop , 0)" by auto
lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 0 Oc = (Nop , 0)" by auto

lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 1 Bk = (R , 3)" by auto
lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 1 Oc = (WB, 2)" by auto

lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 3 Bk = (WO, 0)"
  by (simp add: numeral_eqs_upto_12)

lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 3 Oc = (WB, 2)"
  by (simp add: numeral_eqs_upto_12)

(* fetch last instruction of program, which is explicitly given by the instr list *)
lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 4 Bk = (L, 8)"
  by (simp add: numeral_eqs_upto_12)

(* fetch instruction outside of explicitly given instr list *)
lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 4 Oc = (Nop, 0)"
  by (simp add: numeral_eqs_upto_12)

lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 10 Bk = (Nop, 0)"
  by (simp add: numeral_eqs_upto_12)

lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 10 Oc = (Nop, 0)"
  by (simp add: numeral_eqs_upto_12)

(* ad Hoare triples *)

(* This result can be validated by a simple test run *)
lemma
  "\<lbrace>\<lambda>(l1, r1). (l1,r1) = ([], [Oc,Oc] )\<rbrace> tm_weak_copy \<lbrace>\<lambda>(l0,r0). \<exists>k l. (l0,r0) = (Bk \<up> k, [Oc,Oc,Bk,Oc,Oc] @ Bk \<up> l)\<rbrace>"
proof -
  have "\<lbrace>\<lambda>tap. tap = ([], <[1::nat]>) \<rbrace> tm_weak_copy \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd [1::nat], hd [1::nat]]> @ Bk \<up> l) \<rbrace>"
    by (simp add: tm_weak_copy_correct5)
  then have "\<lbrace>\<lambda>tap. tap = ([], <[1::nat]>) \<rbrace> tm_weak_copy \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[1::nat, 1::nat]> @ Bk \<up> l) \<rbrace>"
    by force
  moreover have "<[1::nat]> = [Oc,Oc]"
    by (simp add: tape_of_list_def tape_of_nat_def)
  moreover have "<[1::nat, 1::nat]> = [Oc,Oc,Bk,Oc,Oc]"
    by (simp add: tape_of_list_def tape_of_nat_def)
  ultimately have "\<lbrace>\<lambda>tap. tap = ([], <[1::nat]>) \<rbrace> tm_weak_copy \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd [1::nat], hd [1::nat]]> @ Bk \<up> l) \<rbrace>"
    by simp
  then show ?thesis
    by (smt Hoare_haltI Hoare_halt_E0 \<open><[1, 1]> = [Oc, Oc, Bk, Oc, Oc]\<close> \<open><[1]> = [Oc, Oc]\<close>
        case_prodD case_prodI holds_for.simps is_final_eq list.discI list.inject list.sel(1)
        not_Cons_self2 tape_of_list_def tape_of_nat_def tape_of_nat_list.elims tape_of_nat_list.simps(3))
qed

(* However, this general result can never be validated by testing. It must be verified by a proof *)
lemma
  "\<forall>n. \<lbrace>\<lambda>tap. tap = ([], Oc\<up>(n+1))\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k,  Oc\<up>(n+1) @ [Bk] @ Oc\<up>(n+1) @ Bk \<up> l) \<rbrace>"
proof
  fix n
  have "\<lbrace>\<lambda>tap. tap = ([], <[n::nat]>)\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[n, n]> @ Bk \<up> l) \<rbrace>"
    by (rule tm_weak_copy_correct5)
  moreover have "<[n::nat]> =  Oc\<up>(Suc n)"
    by (simp add: tape_of_list_def tape_of_nat_def)
  moreover have "<[n, n]> =  Oc\<up>(Suc n) @ [Bk] @ Oc\<up>(Suc n)"
    by (simp add: tape_of_list_def tape_of_nat_def)
  ultimately have X: "\<lbrace>\<lambda>tap. tap = ([], Oc\<up>(Suc n))\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k,  Oc\<up>(Suc n) @ [Bk] @ Oc\<up>(Suc n) @ Bk \<up> l) \<rbrace>"
    by simp
  show "\<lbrace>\<lambda>tap. tap = ([], Oc\<up>(n+1))\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k,  Oc\<up>(n+1) @ [Bk] @ Oc\<up>(n+1) @ Bk \<up> l) \<rbrace>" using X by auto
qed

end


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

section\<open>Cardinal Numbers Without the Axiom of Choice\<close>

theory Cardinal imports OrderType Finite Nat Sum begin

definition
  (*least ordinal operator*)
   Least    :: "(i\<Rightarrow>o) \<Rightarrow> i"    (binder \<open>\<mu> \<close> 10)  where
     "Least(P) \<equiv> THE i. Ord(i) \<and> P(i) \<and> (\<forall>j. j<i \<longrightarrow> \<not>P(j))"

definition
  eqpoll   :: "[i,i] \<Rightarrow> o"     (infixl \<open>\<approx>\<close> 50)  where
    "A \<approx> B \<equiv> \<exists>f. f \<in> bij(A,B)"

definition
  lepoll   :: "[i,i] \<Rightarrow> o"     (infixl \<open>\<lesssim>\<close> 50)  where
    "A \<lesssim> B \<equiv> \<exists>f. f \<in> inj(A,B)"

definition
  lesspoll :: "[i,i] \<Rightarrow> o"     (infixl \<open>\<prec>\<close> 50)  where
    "A \<prec> B \<equiv> A \<lesssim> B \<and> \<not>(A \<approx> B)"

definition
  cardinal :: "i\<Rightarrow>i"           (\<open>|_|\<close>)  where
    "|A| \<equiv> (\<mu> i. i \<approx> A)"

definition
  Finite   :: "i\<Rightarrow>o"  where
    "Finite(A) \<equiv> \<exists>n\<in>nat. A \<approx> n"

definition
  Card     :: "i\<Rightarrow>o"  where
    "Card(i) \<equiv> (i = |i|)"

subsection\<open>The Schroeder-Bernstein Theorem\<close>
text\<open>See Davey and Priestly, page 106\<close>

(** Lemma: Banach's Decomposition Theorem **)

lemma decomp_bnd_mono: "bnd_mono(X, \<lambda>W. X - g``(Y - f``W))"
by (rule bnd_monoI, blast+)

lemma Banach_last_equation:
    "g \<in> Y->X
     \<Longrightarrow> g``(Y - f`` lfp(X, \<lambda>W. X - g``(Y - f``W))) =
         X - lfp(X, \<lambda>W. X - g``(Y - f``W))"
apply (rule_tac P = "\<lambda>u. v = X-u" for v
       in decomp_bnd_mono [THEN lfp_unfold, THEN ssubst])
apply (simp add: double_complement  fun_is_rel [THEN image_subset])
done

lemma decomposition:
     "\<lbrakk>f \<in> X->Y;  g \<in> Y->X\<rbrakk> \<Longrightarrow>
      \<exists>XA XB YA YB. (XA \<inter> XB = 0) \<and> (XA \<union> XB = X) \<and>
                      (YA \<inter> YB = 0) \<and> (YA \<union> YB = Y) \<and>
                      f``XA=YA \<and> g``YB=XB"
apply (intro exI conjI)
apply (rule_tac [6] Banach_last_equation)
apply (rule_tac [5] refl)
apply (assumption |
       rule  Diff_disjoint Diff_partition fun_is_rel image_subset lfp_subset)+
done

lemma schroeder_bernstein:
    "\<lbrakk>f \<in> inj(X,Y);  g \<in> inj(Y,X)\<rbrakk> \<Longrightarrow> \<exists>h. h \<in> bij(X,Y)"
apply (insert decomposition [of f X Y g])
apply (simp add: inj_is_fun)
apply (blast intro!: restrict_bij bij_disjoint_Un intro: bij_converse_bij)
(* The instantiation of exI to @{term"restrict(f,XA) \<union> converse(restrict(g,YB))"}
   is forced by the context\<And>*)
done

(** Equipollence is an equivalence relation **)

lemma bij_imp_eqpoll: "f \<in> bij(A,B) \<Longrightarrow> A \<approx> B"
  unfolding eqpoll_def
apply (erule exI)
done

(*A \<approx> A*)
lemmas eqpoll_refl = id_bij [THEN bij_imp_eqpoll, simp]

lemma eqpoll_sym: "X \<approx> Y \<Longrightarrow> Y \<approx> X"
  unfolding eqpoll_def
apply (blast intro: bij_converse_bij)
done

lemma eqpoll_trans [trans]:
    "\<lbrakk>X \<approx> Y;  Y \<approx> Z\<rbrakk> \<Longrightarrow> X \<approx> Z"
  unfolding eqpoll_def
apply (blast intro: comp_bij)
done

(** Le-pollence is a partial ordering **)

lemma subset_imp_lepoll: "X<=Y \<Longrightarrow> X \<lesssim> Y"
  unfolding lepoll_def
apply (rule exI)
apply (erule id_subset_inj)
done

lemmas lepoll_refl = subset_refl [THEN subset_imp_lepoll, simp]

lemmas le_imp_lepoll = le_imp_subset [THEN subset_imp_lepoll]

lemma eqpoll_imp_lepoll: "X \<approx> Y \<Longrightarrow> X \<lesssim> Y"
by (unfold eqpoll_def bij_def lepoll_def, blast)

lemma lepoll_trans [trans]: "\<lbrakk>X \<lesssim> Y;  Y \<lesssim> Z\<rbrakk> \<Longrightarrow> X \<lesssim> Z"
  unfolding lepoll_def
apply (blast intro: comp_inj)
done

lemma eq_lepoll_trans [trans]: "\<lbrakk>X \<approx> Y;  Y \<lesssim> Z\<rbrakk> \<Longrightarrow> X \<lesssim> Z"
 by (blast intro: eqpoll_imp_lepoll lepoll_trans)

lemma lepoll_eq_trans [trans]: "\<lbrakk>X \<lesssim> Y;  Y \<approx> Z\<rbrakk> \<Longrightarrow> X \<lesssim> Z"
 by (blast intro: eqpoll_imp_lepoll lepoll_trans)

(*Asymmetry law*)
lemma eqpollI: "\<lbrakk>X \<lesssim> Y;  Y \<lesssim> X\<rbrakk> \<Longrightarrow> X \<approx> Y"
  unfolding lepoll_def eqpoll_def
apply (elim exE)
apply (rule schroeder_bernstein, assumption+)
done

lemma eqpollE:
    "\<lbrakk>X \<approx> Y; \<lbrakk>X \<lesssim> Y; Y \<lesssim> X\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (blast intro: eqpoll_imp_lepoll eqpoll_sym)

lemma eqpoll_iff: "X \<approx> Y \<longleftrightarrow> X \<lesssim> Y \<and> Y \<lesssim> X"
by (blast intro: eqpollI elim!: eqpollE)

lemma lepoll_0_is_0: "A \<lesssim> 0 \<Longrightarrow> A = 0"
  unfolding lepoll_def inj_def
apply (blast dest: apply_type)
done

(*@{term"0 \<lesssim> Y"}*)
lemmas empty_lepollI = empty_subsetI [THEN subset_imp_lepoll]

lemma lepoll_0_iff: "A \<lesssim> 0 \<longleftrightarrow> A=0"
by (blast intro: lepoll_0_is_0 lepoll_refl)

lemma Un_lepoll_Un:
    "\<lbrakk>A \<lesssim> B; C \<lesssim> D; B \<inter> D = 0\<rbrakk> \<Longrightarrow> A \<union> C \<lesssim> B \<union> D"
  unfolding lepoll_def
apply (blast intro: inj_disjoint_Un)
done

(*A \<approx> 0 \<Longrightarrow> A=0*)
lemmas eqpoll_0_is_0 = eqpoll_imp_lepoll [THEN lepoll_0_is_0]

lemma eqpoll_0_iff: "A \<approx> 0 \<longleftrightarrow> A=0"
by (blast intro: eqpoll_0_is_0 eqpoll_refl)

lemma eqpoll_disjoint_Un:
    "\<lbrakk>A \<approx> B;  C \<approx> D;  A \<inter> C = 0;  B \<inter> D = 0\<rbrakk>
     \<Longrightarrow> A \<union> C \<approx> B \<union> D"
  unfolding eqpoll_def
apply (blast intro: bij_disjoint_Un)
done

subsection\<open>lesspoll: contributions by Krzysztof Grabczewski\<close>

lemma lesspoll_not_refl: "\<not> (i \<prec> i)"
by (simp add: lesspoll_def)

lemma lesspoll_irrefl [elim!]: "i \<prec> i \<Longrightarrow> P"
by (simp add: lesspoll_def)

lemma lesspoll_imp_lepoll: "A \<prec> B \<Longrightarrow> A \<lesssim> B"
by (unfold lesspoll_def, blast)

lemma lepoll_well_ord: "\<lbrakk>A \<lesssim> B; well_ord(B,r)\<rbrakk> \<Longrightarrow> \<exists>s. well_ord(A,s)"
  unfolding lepoll_def
apply (blast intro: well_ord_rvimage)
done

lemma lepoll_iff_leqpoll: "A \<lesssim> B \<longleftrightarrow> A \<prec> B | A \<approx> B"
  unfolding lesspoll_def
apply (blast intro!: eqpollI elim!: eqpollE)
done

lemma inj_not_surj_succ:
  assumes fi: "f \<in> inj(A, succ(m))" and fns: "f \<notin> surj(A, succ(m))"
  shows "\<exists>f. f \<in> inj(A,m)"
proof -
  from fi [THEN inj_is_fun] fns
  obtain y where y: "y \<in> succ(m)" "\<And>x. x\<in>A \<Longrightarrow> f ` x \<noteq> y"
    by (auto simp add: surj_def)
  show ?thesis
    proof
      show "(\<lambda>z\<in>A. if f`z = m then y else f`z) \<in> inj(A, m)" using y fi
        by (simp add: inj_def)
           (auto intro!: if_type [THEN lam_type] intro: Pi_type dest: apply_funtype)
      qed
qed

(** Variations on transitivity **)

lemma lesspoll_trans [trans]:
      "\<lbrakk>X \<prec> Y; Y \<prec> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
  unfolding lesspoll_def
apply (blast elim!: eqpollE intro: eqpollI lepoll_trans)
done

lemma lesspoll_trans1 [trans]:
      "\<lbrakk>X \<lesssim> Y; Y \<prec> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
  unfolding lesspoll_def
apply (blast elim!: eqpollE intro: eqpollI lepoll_trans)
done

lemma lesspoll_trans2 [trans]:
      "\<lbrakk>X \<prec> Y; Y \<lesssim> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
  unfolding lesspoll_def
apply (blast elim!: eqpollE intro: eqpollI lepoll_trans)
done

lemma eq_lesspoll_trans [trans]:
      "\<lbrakk>X \<approx> Y; Y \<prec> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
  by (blast intro: eqpoll_imp_lepoll lesspoll_trans1)

lemma lesspoll_eq_trans [trans]:
      "\<lbrakk>X \<prec> Y; Y \<approx> Z\<rbrakk> \<Longrightarrow> X \<prec> Z"
  by (blast intro: eqpoll_imp_lepoll lesspoll_trans2)

(** \<mu> -- the least number operator [from HOL/Univ.ML] **)

lemma Least_equality:
    "\<lbrakk>P(i);  Ord(i);  \<And>x. x<i \<Longrightarrow> \<not>P(x)\<rbrakk> \<Longrightarrow> (\<mu> x. P(x)) = i"
  unfolding Least_def
apply (rule the_equality, blast)
apply (elim conjE)
apply (erule Ord_linear_lt, assumption, blast+)
done

lemma LeastI:
  assumes P: "P(i)" and i: "Ord(i)" shows "P(\<mu> x. P(x))"
proof -
  { from i have "P(i) \<Longrightarrow> P(\<mu> x. P(x))"
      proof (induct i rule: trans_induct)
        case (step i)
        show ?case
          proof (cases "P(\<mu> a. P(a))")
            case True thus ?thesis .
          next
            case False
            hence "\<And>x. x \<in> i \<Longrightarrow> \<not>P(x)" using step
              by blast
            hence "(\<mu> a. P(a)) = i" using step
              by (blast intro: Least_equality ltD)
            thus ?thesis using step.prems
              by simp
          qed
      qed
  }
  thus ?thesis using P .
qed

text\<open>The proof is almost identical to the one above!\<close>
lemma Least_le:
  assumes P: "P(i)" and i: "Ord(i)" shows "(\<mu> x. P(x)) \<le> i"
proof -
  { from i have "P(i) \<Longrightarrow> (\<mu> x. P(x)) \<le> i"
      proof (induct i rule: trans_induct)
        case (step i)
        show ?case
          proof (cases "(\<mu> a. P(a)) \<le> i")
            case True thus ?thesis .
          next
            case False
            hence "\<And>x. x \<in> i \<Longrightarrow> \<not> (\<mu> a. P(a)) \<le> i" using step
              by blast
            hence "(\<mu> a. P(a)) = i" using step
              by (blast elim: ltE intro: ltI Least_equality lt_trans1)
            thus ?thesis using step
              by simp
          qed
      qed
  }
  thus ?thesis using P .
qed

(*\<mu> really is the smallest*)
lemma less_LeastE: "\<lbrakk>P(i);  i < (\<mu> x. P(x))\<rbrakk> \<Longrightarrow> Q"
apply (rule Least_le [THEN [2] lt_trans2, THEN lt_irrefl], assumption+)
apply (simp add: lt_Ord)
done

(*Easier to apply than LeastI: conclusion has only one occurrence of P*)
lemma LeastI2:
    "\<lbrakk>P(i);  Ord(i);  \<And>j. P(j) \<Longrightarrow> Q(j)\<rbrakk> \<Longrightarrow> Q(\<mu> j. P(j))"
by (blast intro: LeastI )

(*If there is no such P then \<mu> is vacuously 0*)
lemma Least_0:
    "\<lbrakk>\<not> (\<exists>i. Ord(i) \<and> P(i))\<rbrakk> \<Longrightarrow> (\<mu> x. P(x)) = 0"
  unfolding Least_def
apply (rule the_0, blast)
done

lemma Ord_Least [intro,simp,TC]: "Ord(\<mu> x. P(x))"
proof (cases "\<exists>i. Ord(i) \<and> P(i)")
  case True
  then obtain i where "P(i)" "Ord(i)"  by auto
  hence " (\<mu> x. P(x)) \<le> i"  by (rule Least_le)
  thus ?thesis
    by (elim ltE)
next
  case False
  hence "(\<mu> x. P(x)) = 0"  by (rule Least_0)
  thus ?thesis
    by auto
qed

subsection\<open>Basic Properties of Cardinals\<close>

(*Not needed for simplification, but helpful below*)
lemma Least_cong: "(\<And>y. P(y) \<longleftrightarrow> Q(y)) \<Longrightarrow> (\<mu> x. P(x)) = (\<mu> x. Q(x))"
by simp

(*Need AC to get @{term"X \<lesssim> Y \<Longrightarrow> |X| \<le> |Y|"};  see well_ord_lepoll_imp_cardinal_le
  Converse also requires AC, but see well_ord_cardinal_eqE*)
lemma cardinal_cong: "X \<approx> Y \<Longrightarrow> |X| = |Y|"
  unfolding eqpoll_def cardinal_def
apply (rule Least_cong)
apply (blast intro: comp_bij bij_converse_bij)
done

(*Under AC, the premise becomes trivial; one consequence is ||A|| = |A|*)
lemma well_ord_cardinal_eqpoll:
  assumes r: "well_ord(A,r)" shows "|A| \<approx> A"
proof (unfold cardinal_def)
  show "(\<mu> i. i \<approx> A) \<approx> A"
    by (best intro: LeastI Ord_ordertype ordermap_bij bij_converse_bij bij_imp_eqpoll r)
qed

(* @{term"Ord(A) \<Longrightarrow> |A| \<approx> A"} *)
lemmas Ord_cardinal_eqpoll = well_ord_Memrel [THEN well_ord_cardinal_eqpoll]

lemma Ord_cardinal_idem: "Ord(A) \<Longrightarrow> ||A|| = |A|"
 by (rule Ord_cardinal_eqpoll [THEN cardinal_cong])

lemma well_ord_cardinal_eqE:
  assumes woX: "well_ord(X,r)" and woY: "well_ord(Y,s)" and eq: "|X| = |Y|"
shows "X \<approx> Y"
proof -
  have "X \<approx> |X|" by (blast intro: well_ord_cardinal_eqpoll [OF woX] eqpoll_sym)
  also have "... = |Y|" by (rule eq)
  also have "... \<approx> Y" by (rule well_ord_cardinal_eqpoll [OF woY])
  finally show ?thesis .
qed

lemma well_ord_cardinal_eqpoll_iff:
     "\<lbrakk>well_ord(X,r);  well_ord(Y,s)\<rbrakk> \<Longrightarrow> |X| = |Y| \<longleftrightarrow> X \<approx> Y"
by (blast intro: cardinal_cong well_ord_cardinal_eqE)

(** Observations from Kunen, page 28 **)

lemma Ord_cardinal_le: "Ord(i) \<Longrightarrow> |i| \<le> i"
  unfolding cardinal_def
apply (erule eqpoll_refl [THEN Least_le])
done

lemma Card_cardinal_eq: "Card(K) \<Longrightarrow> |K| = K"
  unfolding Card_def
apply (erule sym)
done

(* Could replace the  @{term"\<not>(j \<approx> i)"}  by  @{term"\<not>(i \<preceq> j)"}. *)
lemma CardI: "\<lbrakk>Ord(i);  \<And>j. j<i \<Longrightarrow> \<not>(j \<approx> i)\<rbrakk> \<Longrightarrow> Card(i)"
  unfolding Card_def cardinal_def
apply (subst Least_equality)
apply (blast intro: eqpoll_refl)+
done

lemma Card_is_Ord: "Card(i) \<Longrightarrow> Ord(i)"
  unfolding Card_def cardinal_def
apply (erule ssubst)
apply (rule Ord_Least)
done

lemma Card_cardinal_le: "Card(K) \<Longrightarrow> K \<le> |K|"
apply (simp (no_asm_simp) add: Card_is_Ord Card_cardinal_eq)
done

lemma Ord_cardinal [simp,intro!]: "Ord(|A|)"
  unfolding cardinal_def
apply (rule Ord_Least)
done

text\<open>The cardinals are the initial ordinals.\<close>
lemma Card_iff_initial: "Card(K) \<longleftrightarrow> Ord(K) \<and> (\<forall>j. j<K \<longrightarrow> \<not> j \<approx> K)"
proof -
  { fix j
    assume K: "Card(K)" "j \<approx> K"
    assume "j < K"
    also have "... = (\<mu> i. i \<approx> K)" using K
      by (simp add: Card_def cardinal_def)
    finally have "j < (\<mu> i. i \<approx> K)" .
    hence "False" using K
      by (best dest: less_LeastE)
  }
  then show ?thesis
    by (blast intro: CardI Card_is_Ord)
qed

lemma lt_Card_imp_lesspoll: "\<lbrakk>Card(a); i<a\<rbrakk> \<Longrightarrow> i \<prec> a"
  unfolding lesspoll_def
apply (drule Card_iff_initial [THEN iffD1])
apply (blast intro!: leI [THEN le_imp_lepoll])
done

lemma Card_0: "Card(0)"
apply (rule Ord_0 [THEN CardI])
apply (blast elim!: ltE)
done

lemma Card_Un: "\<lbrakk>Card(K);  Card(L)\<rbrakk> \<Longrightarrow> Card(K \<union> L)"
apply (rule Ord_linear_le [of K L])
apply (simp_all add: subset_Un_iff [THEN iffD1]  Card_is_Ord le_imp_subset
                     subset_Un_iff2 [THEN iffD1])
done

(*Infinite unions of cardinals?  See Devlin, Lemma 6.7, page 98*)

lemma Card_cardinal [iff]: "Card(|A|)"
proof (unfold cardinal_def)
  show "Card(\<mu> i. i \<approx> A)"
    proof (cases "\<exists>i. Ord (i) \<and> i \<approx> A")
      case False thus ?thesis           \<comment> \<open>degenerate case\<close>
        by (simp add: Least_0 Card_0)
    next
      case True                         \<comment> \<open>real case: \<^term>\<open>A\<close> is isomorphic to some ordinal\<close>
      then obtain i where i: "Ord(i)" "i \<approx> A" by blast
      show ?thesis
        proof (rule CardI [OF Ord_Least], rule notI)
          fix j
          assume j: "j < (\<mu> i. i \<approx> A)"
          assume "j \<approx> (\<mu> i. i \<approx> A)"
          also have "... \<approx> A" using i by (auto intro: LeastI)
          finally have "j \<approx> A" .
          thus False
            by (rule less_LeastE [OF _ j])
        qed
    qed
qed

(*Kunen's Lemma 10.5*)
lemma cardinal_eq_lemma:
  assumes i:"|i| \<le> j" and j: "j \<le> i" shows "|j| = |i|"
proof (rule eqpollI [THEN cardinal_cong])
  show "j \<lesssim> i" by (rule le_imp_lepoll [OF j])
next
  have Oi: "Ord(i)" using j by (rule le_Ord2)
  hence "i \<approx> |i|"
    by (blast intro: Ord_cardinal_eqpoll eqpoll_sym)
  also have "... \<lesssim> j"
    by (blast intro: le_imp_lepoll i)
  finally show "i \<lesssim> j" .
qed

lemma cardinal_mono:
  assumes ij: "i \<le> j" shows "|i| \<le> |j|"
using Ord_cardinal [of i] Ord_cardinal [of j]
proof (cases rule: Ord_linear_le)
  case le thus ?thesis .
next
  case ge
  have i: "Ord(i)" using ij
    by (simp add: lt_Ord)
  have ci: "|i| \<le> j"
    by (blast intro: Ord_cardinal_le ij le_trans i)
  have "|i| = ||i||"
    by (auto simp add: Ord_cardinal_idem i)
  also have "... = |j|"
    by (rule cardinal_eq_lemma [OF ge ci])
  finally have "|i| = |j|" .
  thus ?thesis by simp
qed

text\<open>Since we have \<^term>\<open>|succ(nat)| \<le> |nat|\<close>, the converse of \<open>cardinal_mono\<close> fails!\<close>
lemma cardinal_lt_imp_lt: "\<lbrakk>|i| < |j|;  Ord(i);  Ord(j)\<rbrakk> \<Longrightarrow> i < j"
apply (rule Ord_linear2 [of i j], assumption+)
apply (erule lt_trans2 [THEN lt_irrefl])
apply (erule cardinal_mono)
done

lemma Card_lt_imp_lt: "\<lbrakk>|i| < K;  Ord(i);  Card(K)\<rbrakk> \<Longrightarrow> i < K"
  by (simp (no_asm_simp) add: cardinal_lt_imp_lt Card_is_Ord Card_cardinal_eq)

lemma Card_lt_iff: "\<lbrakk>Ord(i);  Card(K)\<rbrakk> \<Longrightarrow> (|i| < K) \<longleftrightarrow> (i < K)"
by (blast intro: Card_lt_imp_lt Ord_cardinal_le [THEN lt_trans1])

lemma Card_le_iff: "\<lbrakk>Ord(i);  Card(K)\<rbrakk> \<Longrightarrow> (K \<le> |i|) \<longleftrightarrow> (K \<le> i)"
by (simp add: Card_lt_iff Card_is_Ord Ord_cardinal not_lt_iff_le [THEN iff_sym])

(*Can use AC or finiteness to discharge first premise*)
lemma well_ord_lepoll_imp_cardinal_le:
  assumes wB: "well_ord(B,r)" and AB: "A \<lesssim> B"
  shows "|A| \<le> |B|"
using Ord_cardinal [of A] Ord_cardinal [of B]
proof (cases rule: Ord_linear_le)
  case le thus ?thesis .
next
  case ge
  from lepoll_well_ord [OF AB wB]
  obtain s where s: "well_ord(A, s)" by blast
  have "B  \<approx> |B|" by (blast intro: wB eqpoll_sym well_ord_cardinal_eqpoll)
  also have "... \<lesssim> |A|" by (rule le_imp_lepoll [OF ge])
  also have "... \<approx> A" by (rule well_ord_cardinal_eqpoll [OF s])
  finally have "B \<lesssim> A" .
  hence "A \<approx> B" by (blast intro: eqpollI AB)
  hence "|A| = |B|" by (rule cardinal_cong)
  thus ?thesis by simp
qed

lemma lepoll_cardinal_le: "\<lbrakk>A \<lesssim> i; Ord(i)\<rbrakk> \<Longrightarrow> |A| \<le> i"
apply (rule le_trans)
apply (erule well_ord_Memrel [THEN well_ord_lepoll_imp_cardinal_le], assumption)
apply (erule Ord_cardinal_le)
done

lemma lepoll_Ord_imp_eqpoll: "\<lbrakk>A \<lesssim> i; Ord(i)\<rbrakk> \<Longrightarrow> |A| \<approx> A"
by (blast intro: lepoll_cardinal_le well_ord_Memrel well_ord_cardinal_eqpoll dest!: lepoll_well_ord)

lemma lesspoll_imp_eqpoll: "\<lbrakk>A \<prec> i; Ord(i)\<rbrakk> \<Longrightarrow> |A| \<approx> A"
  unfolding lesspoll_def
apply (blast intro: lepoll_Ord_imp_eqpoll)
done

lemma cardinal_subset_Ord: "\<lbrakk>A<=i; Ord(i)\<rbrakk> \<Longrightarrow> |A| \<subseteq> i"
apply (drule subset_imp_lepoll [THEN lepoll_cardinal_le])
apply (auto simp add: lt_def)
apply (blast intro: Ord_trans)
done

subsection\<open>The finite cardinals\<close>

lemma cons_lepoll_consD:
 "\<lbrakk>cons(u,A) \<lesssim> cons(v,B);  u\<notin>A;  v\<notin>B\<rbrakk> \<Longrightarrow> A \<lesssim> B"
apply (unfold lepoll_def inj_def, safe)
apply (rule_tac x = "\<lambda>x\<in>A. if f`x=v then f`u else f`x" in exI)
apply (rule CollectI)
(*Proving it's in the function space A->B*)
apply (rule if_type [THEN lam_type])
apply (blast dest: apply_funtype)
apply (blast elim!: mem_irrefl dest: apply_funtype)
(*Proving it's injective*)
apply (simp (no_asm_simp))
apply blast
done

lemma cons_eqpoll_consD: "\<lbrakk>cons(u,A) \<approx> cons(v,B);  u\<notin>A;  v\<notin>B\<rbrakk> \<Longrightarrow> A \<approx> B"
apply (simp add: eqpoll_iff)
apply (blast intro: cons_lepoll_consD)
done

(*Lemma suggested by Mike Fourman*)
lemma succ_lepoll_succD: "succ(m) \<lesssim> succ(n) \<Longrightarrow> m \<lesssim> n"
  unfolding succ_def
apply (erule cons_lepoll_consD)
apply (rule mem_not_refl)+
done

lemma nat_lepoll_imp_le:
     "m \<in> nat \<Longrightarrow> n \<in> nat \<Longrightarrow> m \<lesssim> n \<Longrightarrow> m \<le> n"
proof (induct m arbitrary: n rule: nat_induct)
  case 0 thus ?case by (blast intro!: nat_0_le)
next
  case (succ m)
  show ?case  using \<open>n \<in> nat\<close>
    proof (cases rule: natE)
      case 0 thus ?thesis using succ
        by (simp add: lepoll_def inj_def)
    next
      case (succ n') thus ?thesis using succ.hyps \<open> succ(m) \<lesssim> n\<close>
        by (blast intro!: succ_leI dest!: succ_lepoll_succD)
    qed
qed

lemma nat_eqpoll_iff: "\<lbrakk>m \<in> nat; n \<in> nat\<rbrakk> \<Longrightarrow> m \<approx> n \<longleftrightarrow> m = n"
apply (rule iffI)
apply (blast intro: nat_lepoll_imp_le le_anti_sym elim!: eqpollE)
apply (simp add: eqpoll_refl)
done

(*The object of all this work: every natural number is a (finite) cardinal*)
lemma nat_into_Card:
  assumes n: "n \<in> nat" shows "Card(n)"
proof (unfold Card_def cardinal_def, rule sym)
  have "Ord(n)" using n  by auto
  moreover
  { fix i
    assume "i < n" "i \<approx> n"
    hence False using n
      by (auto simp add: lt_nat_in_nat [THEN nat_eqpoll_iff])
  }
  ultimately show "(\<mu> i. i \<approx> n) = n" by (auto intro!: Least_equality)
qed

lemmas cardinal_0 = nat_0I [THEN nat_into_Card, THEN Card_cardinal_eq, iff]
lemmas cardinal_1 = nat_1I [THEN nat_into_Card, THEN Card_cardinal_eq, iff]

(*Part of Kunen's Lemma 10.6*)
lemma succ_lepoll_natE: "\<lbrakk>succ(n) \<lesssim> n;  n \<in> nat\<rbrakk> \<Longrightarrow> P"
by (rule nat_lepoll_imp_le [THEN lt_irrefl], auto)

lemma nat_lepoll_imp_ex_eqpoll_n:
     "\<lbrakk>n \<in> nat;  nat \<lesssim> X\<rbrakk> \<Longrightarrow> \<exists>Y. Y \<subseteq> X \<and> n \<approx> Y"
  unfolding lepoll_def eqpoll_def
apply (fast del: subsetI subsetCE
            intro!: subset_SIs
            dest!: Ord_nat [THEN [2] OrdmemD, THEN [2] restrict_inj]
            elim!: restrict_bij
                   inj_is_fun [THEN fun_is_rel, THEN image_subset])
done

(** \<lesssim>, \<prec> and natural numbers **)

lemma lepoll_succ: "i \<lesssim> succ(i)"
  by (blast intro: subset_imp_lepoll)

lemma lepoll_imp_lesspoll_succ:
  assumes A: "A \<lesssim> m" and m: "m \<in> nat"
  shows "A \<prec> succ(m)"
proof -
  { assume "A \<approx> succ(m)"
    hence "succ(m) \<approx> A" by (rule eqpoll_sym)
    also have "... \<lesssim> m" by (rule A)
    finally have "succ(m) \<lesssim> m" .
    hence False by (rule succ_lepoll_natE) (rule m) }
  moreover have "A \<lesssim> succ(m)" by (blast intro: lepoll_trans A lepoll_succ)
  ultimately show ?thesis by (auto simp add: lesspoll_def)
qed

lemma lesspoll_succ_imp_lepoll:
     "\<lbrakk>A \<prec> succ(m); m \<in> nat\<rbrakk> \<Longrightarrow> A \<lesssim> m"
  unfolding lesspoll_def lepoll_def eqpoll_def bij_def
apply (auto dest: inj_not_surj_succ)
done

lemma lesspoll_succ_iff: "m \<in> nat \<Longrightarrow> A \<prec> succ(m) \<longleftrightarrow> A \<lesssim> m"
by (blast intro!: lepoll_imp_lesspoll_succ lesspoll_succ_imp_lepoll)

lemma lepoll_succ_disj: "\<lbrakk>A \<lesssim> succ(m);  m \<in> nat\<rbrakk> \<Longrightarrow> A \<lesssim> m | A \<approx> succ(m)"
apply (rule disjCI)
apply (rule lesspoll_succ_imp_lepoll)
prefer 2 apply assumption
apply (simp (no_asm_simp) add: lesspoll_def)
done

lemma lesspoll_cardinal_lt: "\<lbrakk>A \<prec> i; Ord(i)\<rbrakk> \<Longrightarrow> |A| < i"
apply (unfold lesspoll_def, clarify)
apply (frule lepoll_cardinal_le, assumption)
apply (blast intro: well_ord_Memrel well_ord_cardinal_eqpoll [THEN eqpoll_sym]
             dest: lepoll_well_ord  elim!: leE)
done

subsection\<open>The first infinite cardinal: Omega, or nat\<close>

(*This implies Kunen's Lemma 10.6*)
lemma lt_not_lepoll:
  assumes n: "n<i" "n \<in> nat" shows "\<not> i \<lesssim> n"
proof -
  { assume i: "i \<lesssim> n"
    have "succ(n) \<lesssim> i" using n
      by (elim ltE, blast intro: Ord_succ_subsetI [THEN subset_imp_lepoll])
    also have "... \<lesssim> n" by (rule i)
    finally have "succ(n) \<lesssim> n" .
    hence False  by (rule succ_lepoll_natE) (rule n) }
  thus ?thesis by auto
qed

text\<open>A slightly weaker version of \<open>nat_eqpoll_iff\<close>\<close>
lemma Ord_nat_eqpoll_iff:
  assumes i: "Ord(i)" and n: "n \<in> nat" shows "i \<approx> n \<longleftrightarrow> i=n"
using i nat_into_Ord [OF n]
proof (cases rule: Ord_linear_lt)
  case lt
  hence  "i \<in> nat" by (rule lt_nat_in_nat) (rule n)
  thus ?thesis by (simp add: nat_eqpoll_iff n)
next
  case eq
  thus ?thesis by (simp add: eqpoll_refl)
next
  case gt
  hence  "\<not> i \<lesssim> n" using n  by (rule lt_not_lepoll)
  hence  "\<not> i \<approx> n" using n  by (blast intro: eqpoll_imp_lepoll)
  moreover have "i \<noteq> n" using \<open>n<i\<close> by auto
  ultimately show ?thesis by blast
qed

lemma Card_nat: "Card(nat)"
proof -
  { fix i
    assume i: "i < nat" "i \<approx> nat"
    hence "\<not> nat \<lesssim> i"
      by (simp add: lt_def lt_not_lepoll)
    hence False using i
      by (simp add: eqpoll_iff)
  }
  hence "(\<mu> i. i \<approx> nat) = nat" by (blast intro: Least_equality eqpoll_refl)
  thus ?thesis
    by (auto simp add: Card_def cardinal_def)
qed

(*Allows showing that |i| is a limit cardinal*)
lemma nat_le_cardinal: "nat \<le> i \<Longrightarrow> nat \<le> |i|"
apply (rule Card_nat [THEN Card_cardinal_eq, THEN subst])
apply (erule cardinal_mono)
done

lemma n_lesspoll_nat: "n \<in> nat \<Longrightarrow> n \<prec> nat"
  by (blast intro: Ord_nat Card_nat ltI lt_Card_imp_lesspoll)

subsection\<open>Towards Cardinal Arithmetic\<close>
(** Congruence laws for successor, cardinal addition and multiplication **)

(*Congruence law for  cons  under equipollence*)
lemma cons_lepoll_cong:
    "\<lbrakk>A \<lesssim> B;  b \<notin> B\<rbrakk> \<Longrightarrow> cons(a,A) \<lesssim> cons(b,B)"
apply (unfold lepoll_def, safe)
apply (rule_tac x = "\<lambda>y\<in>cons (a,A) . if y=a then b else f`y" in exI)
apply (rule_tac d = "\<lambda>z. if z \<in> B then converse (f) `z else a" in lam_injective)
apply (safe elim!: consE')
   apply simp_all
apply (blast intro: inj_is_fun [THEN apply_type])+
done

lemma cons_eqpoll_cong:
     "\<lbrakk>A \<approx> B;  a \<notin> A;  b \<notin> B\<rbrakk> \<Longrightarrow> cons(a,A) \<approx> cons(b,B)"
by (simp add: eqpoll_iff cons_lepoll_cong)

lemma cons_lepoll_cons_iff:
     "\<lbrakk>a \<notin> A;  b \<notin> B\<rbrakk> \<Longrightarrow> cons(a,A) \<lesssim> cons(b,B)  \<longleftrightarrow>  A \<lesssim> B"
by (blast intro: cons_lepoll_cong cons_lepoll_consD)

lemma cons_eqpoll_cons_iff:
     "\<lbrakk>a \<notin> A;  b \<notin> B\<rbrakk> \<Longrightarrow> cons(a,A) \<approx> cons(b,B)  \<longleftrightarrow>  A \<approx> B"
by (blast intro: cons_eqpoll_cong cons_eqpoll_consD)

lemma singleton_eqpoll_1: "{a} \<approx> 1"
  unfolding succ_def
apply (blast intro!: eqpoll_refl [THEN cons_eqpoll_cong])
done

lemma cardinal_singleton: "|{a}| = 1"
apply (rule singleton_eqpoll_1 [THEN cardinal_cong, THEN trans])
apply (simp (no_asm) add: nat_into_Card [THEN Card_cardinal_eq])
done

lemma not_0_is_lepoll_1: "A \<noteq> 0 \<Longrightarrow> 1 \<lesssim> A"
apply (erule not_emptyE)
apply (rule_tac a = "cons (x, A-{x}) " in subst)
apply (rule_tac [2] a = "cons(0,0)" and P= "\<lambda>y. y \<lesssim> cons (x, A-{x})" in subst)
prefer 3 apply (blast intro: cons_lepoll_cong subset_imp_lepoll, auto)
done

(*Congruence law for  succ  under equipollence*)
lemma succ_eqpoll_cong: "A \<approx> B \<Longrightarrow> succ(A) \<approx> succ(B)"
  unfolding succ_def
apply (simp add: cons_eqpoll_cong mem_not_refl)
done

(*Congruence law for + under equipollence*)
lemma sum_eqpoll_cong: "\<lbrakk>A \<approx> C;  B \<approx> D\<rbrakk> \<Longrightarrow> A+B \<approx> C+D"
  unfolding eqpoll_def
apply (blast intro!: sum_bij)
done

(*Congruence law for * under equipollence*)
lemma prod_eqpoll_cong:
    "\<lbrakk>A \<approx> C;  B \<approx> D\<rbrakk> \<Longrightarrow> A*B \<approx> C*D"
  unfolding eqpoll_def
apply (blast intro!: prod_bij)
done

lemma inj_disjoint_eqpoll:
    "\<lbrakk>f \<in> inj(A,B);  A \<inter> B = 0\<rbrakk> \<Longrightarrow> A \<union> (B - range(f)) \<approx> B"
  unfolding eqpoll_def
apply (rule exI)
apply (rule_tac c = "\<lambda>x. if x \<in> A then f`x else x"
            and d = "\<lambda>y. if y \<in> range (f) then converse (f) `y else y"
       in lam_bijective)
apply (blast intro!: if_type inj_is_fun [THEN apply_type])
apply (simp (no_asm_simp) add: inj_converse_fun [THEN apply_funtype])
apply (safe elim!: UnE')
   apply (simp_all add: inj_is_fun [THEN apply_rangeI])
apply (blast intro: inj_converse_fun [THEN apply_type])+
done

subsection\<open>Lemmas by Krzysztof Grabczewski\<close>

(*New proofs using cons_lepoll_cons. Could generalise from succ to cons.*)

text\<open>If \<^term>\<open>A\<close> has at most \<^term>\<open>n+1\<close> elements and \<^term>\<open>a \<in> A\<close>
      then \<^term>\<open>A-{a}\<close> has at most \<^term>\<open>n\<close>.\<close>
lemma Diff_sing_lepoll:
      "\<lbrakk>a \<in> A;  A \<lesssim> succ(n)\<rbrakk> \<Longrightarrow> A - {a} \<lesssim> n"
  unfolding succ_def
apply (rule cons_lepoll_consD)
apply (rule_tac [3] mem_not_refl)
apply (erule cons_Diff [THEN ssubst], safe)
done

text\<open>If \<^term>\<open>A\<close> has at least \<^term>\<open>n+1\<close> elements then \<^term>\<open>A-{a}\<close> has at least \<^term>\<open>n\<close>.\<close>
lemma lepoll_Diff_sing:
  assumes A: "succ(n) \<lesssim> A" shows "n \<lesssim> A - {a}"
proof -
  have "cons(n,n) \<lesssim> A" using A
    by (unfold succ_def)
  also have "... \<lesssim> cons(a, A-{a})"
    by (blast intro: subset_imp_lepoll)
  finally have "cons(n,n) \<lesssim> cons(a, A-{a})" .
  thus ?thesis
    by (blast intro: cons_lepoll_consD mem_irrefl)
qed

lemma Diff_sing_eqpoll: "\<lbrakk>a \<in> A; A \<approx> succ(n)\<rbrakk> \<Longrightarrow> A - {a} \<approx> n"
by (blast intro!: eqpollI
          elim!: eqpollE
          intro: Diff_sing_lepoll lepoll_Diff_sing)

lemma lepoll_1_is_sing: "\<lbrakk>A \<lesssim> 1; a \<in> A\<rbrakk> \<Longrightarrow> A = {a}"
apply (frule Diff_sing_lepoll, assumption)
apply (drule lepoll_0_is_0)
apply (blast elim: equalityE)
done

lemma Un_lepoll_sum: "A \<union> B \<lesssim> A+B"
  unfolding lepoll_def
apply (rule_tac x = "\<lambda>x\<in>A \<union> B. if x\<in>A then Inl (x) else Inr (x)" in exI)
apply (rule_tac d = "\<lambda>z. snd (z)" in lam_injective)
apply force
apply (simp add: Inl_def Inr_def)
done

lemma well_ord_Un:
     "\<lbrakk>well_ord(X,R); well_ord(Y,S)\<rbrakk> \<Longrightarrow> \<exists>T. well_ord(X \<union> Y, T)"
by (erule well_ord_radd [THEN Un_lepoll_sum [THEN lepoll_well_ord]],
    assumption)

(*Krzysztof Grabczewski*)
lemma disj_Un_eqpoll_sum: "A \<inter> B = 0 \<Longrightarrow> A \<union> B \<approx> A + B"
  unfolding eqpoll_def
apply (rule_tac x = "\<lambda>a\<in>A \<union> B. if a \<in> A then Inl (a) else Inr (a)" in exI)
apply (rule_tac d = "\<lambda>z. case (\<lambda>x. x, \<lambda>x. x, z)" in lam_bijective)
apply auto
done

subsection \<open>Finite and infinite sets\<close>

lemma eqpoll_imp_Finite_iff: "A \<approx> B \<Longrightarrow> Finite(A) \<longleftrightarrow> Finite(B)"
  unfolding Finite_def
apply (blast intro: eqpoll_trans eqpoll_sym)
done

lemma Finite_0 [simp]: "Finite(0)"
  unfolding Finite_def
apply (blast intro!: eqpoll_refl nat_0I)
done

lemma Finite_cons: "Finite(x) \<Longrightarrow> Finite(cons(y,x))"
  unfolding Finite_def
apply (case_tac "y \<in> x")
apply (simp add: cons_absorb)
apply (erule bexE)
apply (rule bexI)
apply (erule_tac [2] nat_succI)
apply (simp (no_asm_simp) add: succ_def cons_eqpoll_cong mem_not_refl)
done

lemma Finite_succ: "Finite(x) \<Longrightarrow> Finite(succ(x))"
  unfolding succ_def
apply (erule Finite_cons)
done

lemma lepoll_nat_imp_Finite:
  assumes A: "A \<lesssim> n" and n: "n \<in> nat" shows "Finite(A)"
proof -
  have "A \<lesssim> n \<Longrightarrow> Finite(A)" using n
    proof (induct n)
      case 0
      hence "A = 0" by (rule lepoll_0_is_0)
      thus ?case by simp
    next
      case (succ n)
      hence "A \<lesssim> n \<or> A \<approx> succ(n)" by (blast dest: lepoll_succ_disj)
      thus ?case using succ by (auto simp add: Finite_def)
    qed
  thus ?thesis using A .
qed

lemma lesspoll_nat_is_Finite:
     "A \<prec> nat \<Longrightarrow> Finite(A)"
  unfolding Finite_def
apply (blast dest: ltD lesspoll_cardinal_lt
                   lesspoll_imp_eqpoll [THEN eqpoll_sym])
done

lemma lepoll_Finite:
  assumes Y: "Y \<lesssim> X" and X: "Finite(X)" shows "Finite(Y)"
proof -
  obtain n where n: "n \<in> nat" "X \<approx> n" using X
    by (auto simp add: Finite_def)
  have "Y \<lesssim> X"         by (rule Y)
  also have "... \<approx> n"  by (rule n)
  finally have "Y \<lesssim> n" .
  thus ?thesis using n by (simp add: lepoll_nat_imp_Finite)
qed

lemmas subset_Finite = subset_imp_lepoll [THEN lepoll_Finite]

lemma Finite_cons_iff [iff]: "Finite(cons(y,x)) \<longleftrightarrow> Finite(x)"
by (blast intro: Finite_cons subset_Finite)

lemma Finite_succ_iff [iff]: "Finite(succ(x)) \<longleftrightarrow> Finite(x)"
by (simp add: succ_def)

lemma Finite_Int: "Finite(A) | Finite(B) \<Longrightarrow> Finite(A \<inter> B)"
by (blast intro: subset_Finite)

lemmas Finite_Diff = Diff_subset [THEN subset_Finite]

lemma nat_le_infinite_Ord:
      "\<lbrakk>Ord(i);  \<not> Finite(i)\<rbrakk> \<Longrightarrow> nat \<le> i"
  unfolding Finite_def
apply (erule Ord_nat [THEN [2] Ord_linear2])
prefer 2 apply assumption
apply (blast intro!: eqpoll_refl elim!: ltE)
done

lemma Finite_imp_well_ord:
    "Finite(A) \<Longrightarrow> \<exists>r. well_ord(A,r)"
  unfolding Finite_def eqpoll_def
apply (blast intro: well_ord_rvimage bij_is_inj well_ord_Memrel nat_into_Ord)
done

lemma succ_lepoll_imp_not_empty: "succ(x) \<lesssim> y \<Longrightarrow> y \<noteq> 0"
by (fast dest!: lepoll_0_is_0)

lemma eqpoll_succ_imp_not_empty: "x \<approx> succ(n) \<Longrightarrow> x \<noteq> 0"
by (fast elim!: eqpoll_sym [THEN eqpoll_0_is_0, THEN succ_neq_0])

lemma Finite_Fin_lemma [rule_format]:
     "n \<in> nat \<Longrightarrow> \<forall>A. (A\<approx>n \<and> A \<subseteq> X) \<longrightarrow> A \<in> Fin(X)"
apply (induct_tac n)
apply (rule allI)
apply (fast intro!: Fin.emptyI dest!: eqpoll_imp_lepoll [THEN lepoll_0_is_0])
apply (rule allI)
apply (rule impI)
apply (erule conjE)
apply (rule eqpoll_succ_imp_not_empty [THEN not_emptyE], assumption)
apply (frule Diff_sing_eqpoll, assumption)
apply (erule allE)
apply (erule impE, fast)
apply (drule subsetD, assumption)
apply (drule Fin.consI, assumption)
apply (simp add: cons_Diff)
done

lemma Finite_Fin: "\<lbrakk>Finite(A); A \<subseteq> X\<rbrakk> \<Longrightarrow> A \<in> Fin(X)"
by (unfold Finite_def, blast intro: Finite_Fin_lemma)

lemma Fin_lemma [rule_format]: "n \<in> nat \<Longrightarrow> \<forall>A. A \<approx> n \<longrightarrow> A \<in> Fin(A)"
apply (induct_tac n)
apply (simp add: eqpoll_0_iff, clarify)
apply (subgoal_tac "\<exists>u. u \<in> A")
apply (erule exE)
apply (rule Diff_sing_eqpoll [elim_format])
prefer 2 apply assumption
apply assumption
apply (rule_tac b = A in cons_Diff [THEN subst], assumption)
apply (rule Fin.consI, blast)
apply (blast intro: subset_consI [THEN Fin_mono, THEN subsetD])
(*Now for the lemma assumed above*)
  unfolding eqpoll_def
apply (blast intro: bij_converse_bij [THEN bij_is_fun, THEN apply_type])
done

lemma Finite_into_Fin: "Finite(A) \<Longrightarrow> A \<in> Fin(A)"
  unfolding Finite_def
apply (blast intro: Fin_lemma)
done

lemma Fin_into_Finite: "A \<in> Fin(U) \<Longrightarrow> Finite(A)"
by (fast intro!: Finite_0 Finite_cons elim: Fin_induct)

lemma Finite_Fin_iff: "Finite(A) \<longleftrightarrow> A \<in> Fin(A)"
by (blast intro: Finite_into_Fin Fin_into_Finite)

lemma Finite_Un: "\<lbrakk>Finite(A); Finite(B)\<rbrakk> \<Longrightarrow> Finite(A \<union> B)"
by (blast intro!: Fin_into_Finite Fin_UnI
          dest!: Finite_into_Fin
          intro: Un_upper1 [THEN Fin_mono, THEN subsetD]
                 Un_upper2 [THEN Fin_mono, THEN subsetD])

lemma Finite_Un_iff [simp]: "Finite(A \<union> B) \<longleftrightarrow> (Finite(A) \<and> Finite(B))"
by (blast intro: subset_Finite Finite_Un)

text\<open>The converse must hold too.\<close>
lemma Finite_Union: "\<lbrakk>\<forall>y\<in>X. Finite(y);  Finite(X)\<rbrakk> \<Longrightarrow> Finite(\<Union>(X))"
apply (simp add: Finite_Fin_iff)
apply (rule Fin_UnionI)
apply (erule Fin_induct, simp)
apply (blast intro: Fin.consI Fin_mono [THEN [2] rev_subsetD])
done

(* Induction principle for Finite(A), by Sidi Ehmety *)
lemma Finite_induct [case_names 0 cons, induct set: Finite]:
"\<lbrakk>Finite(A); P(0);
    \<And>x B.   \<lbrakk>Finite(B); x \<notin> B; P(B)\<rbrakk> \<Longrightarrow> P(cons(x, B))\<rbrakk>
 \<Longrightarrow> P(A)"
apply (erule Finite_into_Fin [THEN Fin_induct])
apply (blast intro: Fin_into_Finite)+
done

(*Sidi Ehmety.  The contrapositive says \<not>Finite(A) \<Longrightarrow> \<not>Finite(A-{a}) *)
lemma Diff_sing_Finite: "Finite(A - {a}) \<Longrightarrow> Finite(A)"
  unfolding Finite_def
apply (case_tac "a \<in> A")
apply (subgoal_tac [2] "A-{a}=A", auto)
apply (rule_tac x = "succ (n) " in bexI)
apply (subgoal_tac "cons (a, A - {a}) = A \<and> cons (n, n) = succ (n) ")
apply (drule_tac a = a and b = n in cons_eqpoll_cong)
apply (auto dest: mem_irrefl)
done

(*Sidi Ehmety.  And the contrapositive of this says
   \<lbrakk>\<not>Finite(A); Finite(B)\<rbrakk> \<Longrightarrow> \<not>Finite(A-B) *)
lemma Diff_Finite [rule_format]: "Finite(B) \<Longrightarrow> Finite(A-B) \<longrightarrow> Finite(A)"
apply (erule Finite_induct, auto)
apply (case_tac "x \<in> A")
 apply (subgoal_tac [2] "A-cons (x, B) = A - B")
apply (subgoal_tac "A - cons (x, B) = (A - B) - {x}", simp)
apply (drule Diff_sing_Finite, auto)
done

lemma Finite_RepFun: "Finite(A) \<Longrightarrow> Finite(RepFun(A,f))"
by (erule Finite_induct, simp_all)

lemma Finite_RepFun_iff_lemma [rule_format]:
     "\<lbrakk>Finite(x); \<And>x y. f(x)=f(y) \<Longrightarrow> x=y\<rbrakk>
      \<Longrightarrow> \<forall>A. x = RepFun(A,f) \<longrightarrow> Finite(A)"
apply (erule Finite_induct)
 apply clarify
 apply (case_tac "A=0", simp)
 apply (blast del: allE, clarify)
apply (subgoal_tac "\<exists>z\<in>A. x = f(z)")
 prefer 2 apply (blast del: allE elim: equalityE, clarify)
apply (subgoal_tac "B = {f(u) . u \<in> A - {z}}")
 apply (blast intro: Diff_sing_Finite)
apply (thin_tac "\<forall>A. P(A) \<longrightarrow> Finite(A)" for P)
apply (rule equalityI)
 apply (blast intro: elim: equalityE)
apply (blast intro: elim: equalityCE)
done

text\<open>I don't know why, but if the premise is expressed using meta-connectives
then  the simplifier cannot prove it automatically in conditional rewriting.\<close>
lemma Finite_RepFun_iff:
     "(\<forall>x y. f(x)=f(y) \<longrightarrow> x=y) \<Longrightarrow> Finite(RepFun(A,f)) \<longleftrightarrow> Finite(A)"
by (blast intro: Finite_RepFun Finite_RepFun_iff_lemma [of _ f])

lemma Finite_Pow: "Finite(A) \<Longrightarrow> Finite(Pow(A))"
apply (erule Finite_induct)
apply (simp_all add: Pow_insert Finite_Un Finite_RepFun)
done

lemma Finite_Pow_imp_Finite: "Finite(Pow(A)) \<Longrightarrow> Finite(A)"
apply (subgoal_tac "Finite({{x} . x \<in> A})")
 apply (simp add: Finite_RepFun_iff )
apply (blast intro: subset_Finite)
done

lemma Finite_Pow_iff [iff]: "Finite(Pow(A)) \<longleftrightarrow> Finite(A)"
by (blast intro: Finite_Pow Finite_Pow_imp_Finite)

lemma Finite_cardinal_iff:
  assumes i: "Ord(i)" shows "Finite(|i|) \<longleftrightarrow> Finite(i)"
  by (auto simp add: Finite_def) (blast intro: eqpoll_trans eqpoll_sym Ord_cardinal_eqpoll [OF i])+

(*Krzysztof Grabczewski's proof that the converse of a finite, well-ordered
  set is well-ordered.  Proofs simplified by lcp. *)

lemma nat_wf_on_converse_Memrel: "n \<in> nat \<Longrightarrow> wf[n](converse(Memrel(n)))"
proof (induct n rule: nat_induct)
  case 0 thus ?case by (blast intro: wf_onI)
next
  case (succ x)
  hence wfx: "\<And>Z. Z = 0 \<or> (\<exists>z\<in>Z. \<forall>y. z \<in> y \<and> z \<in> x \<and> y \<in> x \<and> z \<in> x \<longrightarrow> y \<notin> Z)"
    by (simp add: wf_on_def wf_def)  \<comment> \<open>not easy to erase the duplicate \<^term>\<open>z \<in> x\<close>!\<close>
  show ?case
    proof (rule wf_onI)
      fix Z u
      assume Z: "u \<in> Z" "\<forall>z\<in>Z. \<exists>y\<in>Z. \<langle>y, z\<rangle> \<in> converse(Memrel(succ(x)))"
      show False
        proof (cases "x \<in> Z")
          case True thus False using Z
            by (blast elim: mem_irrefl mem_asym)
          next
          case False thus False using wfx [of Z] Z
            by blast
        qed
    qed
qed

lemma nat_well_ord_converse_Memrel: "n \<in> nat \<Longrightarrow> well_ord(n,converse(Memrel(n)))"
apply (frule Ord_nat [THEN Ord_in_Ord, THEN well_ord_Memrel])
apply (simp add: well_ord_def tot_ord_converse nat_wf_on_converse_Memrel)
done

lemma well_ord_converse:
     "\<lbrakk>well_ord(A,r);
        well_ord(ordertype(A,r), converse(Memrel(ordertype(A, r))))\<rbrakk>
      \<Longrightarrow> well_ord(A,converse(r))"
apply (rule well_ord_Int_iff [THEN iffD1])
apply (frule ordermap_bij [THEN bij_is_inj, THEN well_ord_rvimage], assumption)
apply (simp add: rvimage_converse converse_Int converse_prod
                 ordertype_ord_iso [THEN ord_iso_rvimage_eq])
done

lemma ordertype_eq_n:
  assumes r: "well_ord(A,r)" and A: "A \<approx> n" and n: "n \<in> nat"
  shows "ordertype(A,r) = n"
proof -
  have "ordertype(A,r) \<approx> A"
    by (blast intro: bij_imp_eqpoll bij_converse_bij ordermap_bij r)
  also have "... \<approx> n" by (rule A)
  finally have "ordertype(A,r) \<approx> n" .
  thus ?thesis
    by (simp add: Ord_nat_eqpoll_iff Ord_ordertype n r)
qed

lemma Finite_well_ord_converse:
    "\<lbrakk>Finite(A);  well_ord(A,r)\<rbrakk> \<Longrightarrow> well_ord(A,converse(r))"
  unfolding Finite_def
apply (rule well_ord_converse, assumption)
apply (blast dest: ordertype_eq_n intro!: nat_well_ord_converse_Memrel)
done

lemma nat_into_Finite: "n \<in> nat \<Longrightarrow> Finite(n)"
  by (auto simp add: Finite_def intro: eqpoll_refl)

lemma nat_not_Finite: "\<not> Finite(nat)"
proof -
  { fix n
    assume n: "n \<in> nat" "nat \<approx> n"
    have "n \<in> nat"    by (rule n)
    also have "... = n" using n
      by (simp add: Ord_nat_eqpoll_iff Ord_nat)
    finally have "n \<in> n" .
    hence False
      by (blast elim: mem_irrefl)
  }
  thus ?thesis
    by (auto simp add: Finite_def)
qed

end


(*  Title:      HOL/Quickcheck_Examples/Quickcheck_Narrowing_Examples.thy
    Author:     Lukas Bulwahn
    Copyright   2011 TU Muenchen
*)

section {* Examples for narrowing-based testing  *}

theory Quickcheck_Narrowing_Examples
imports Main
begin

declare [[quickcheck_timeout = 3600]]

subsection {* Minimalistic examples *}

lemma
  "x = y"
quickcheck[tester = narrowing, finite_types = false, default_type = int, expect = counterexample]
oops

lemma
  "x = y"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

subsection {* Simple examples with existentials *}

lemma
  "\<exists> y :: nat. \<forall> x. x = y"
quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops
(*
lemma
  "\<exists> y :: int. \<forall> x. x = y"
quickcheck[tester = narrowing, size = 2]
oops
*)
lemma
  "x > 1 --> (\<exists>y :: nat. x < y & y <= 1)"
quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma
  "x > 2 --> (\<exists>y :: nat. x < y & y <= 2)"
quickcheck[tester = narrowing, finite_types = false, size = 10]
oops

lemma
  "\<forall> x. \<exists> y :: nat. x > 3 --> (y < x & y > 3)"
quickcheck[tester = narrowing, finite_types = false, size = 7]
oops

text {* A false conjecture derived from an partial copy-n-paste of @{thm not_distinct_decomp} *}
lemma
  "~ distinct ws ==> EX xs ys zs y. ws = xs @ [y] @ ys @ [y]"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

text {* A false conjecture derived from theorems @{thm split_list_first} and @{thm split_list_last} *}
lemma
  "x : set xs ==> EX ys zs. xs = ys @ x # zs & x ~: set zs & x ~: set ys"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

text {* A false conjecture derived from @{thm map_eq_Cons_conv} with a typo *}
lemma
  "(map f xs = y # ys) = (EX z zs. xs = z' # zs & f z = y & map f zs = ys)"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

lemma "a # xs = ys @ [a] ==> EX zs. xs = zs @ [a] & ys = a#zs"
quickcheck[narrowing, expect = counterexample]
quickcheck[exhaustive, random, expect = no_counterexample]
oops

subsection {* Simple list examples *}

lemma "rev xs = xs"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, expect = counterexample]
oops

lemma "rev xs = xs"
quickcheck[tester = narrowing, finite_types = false, default_type = int, expect = counterexample]
oops

lemma "rev xs = xs"
  quickcheck[tester = narrowing, finite_types = true, expect = counterexample]
oops

subsection {* Simple examples with functions *}

lemma "map f xs = map g xs"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma "map f xs = map f ys ==> xs = ys"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma
  "list_all2 P (rev xs) (rev ys) = list_all2 P xs (rev ys)"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma "map f xs = F f xs"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

lemma "map f xs = F f xs"
  quickcheck[tester = narrowing, finite_types = false, expect = counterexample]
oops

(* requires some work...*)
(*
lemma "R O S = S O R"
  quickcheck[tester = narrowing, size = 2]
oops
*)

subsection {* Simple examples with inductive predicates *}

inductive even where
  "even 0" |
  "even n ==> even (Suc (Suc n))"

code_pred even .

lemma "even (n - 2) ==> even n"
quickcheck[narrowing, expect = counterexample]
oops

subsection {* AVL Trees *}

datatype 'a tree = ET |  MKT 'a "'a tree" "'a tree" nat

primrec set_of :: "'a tree \<Rightarrow> 'a set"
where
"set_of ET = {}" |
"set_of (MKT n l r h) = insert n (set_of l \<union> set_of r)"

primrec height :: "'a tree \<Rightarrow> nat"
where
"height ET = 0" |
"height (MKT x l r h) = max (height l) (height r) + 1"

primrec avl :: "'a tree \<Rightarrow> bool"
where
"avl ET = True" |
"avl (MKT x l r h) =
 ((height l = height r \<or> height l = 1+height r \<or> height r = 1+height l) \<and>
  h = max (height l) (height r) + 1 \<and> avl l \<and> avl r)"

primrec is_ord :: "('a::order) tree \<Rightarrow> bool"
where
"is_ord ET = True" |
"is_ord (MKT n l r h) =
 ((\<forall>n' \<in> set_of l. n' < n) \<and> (\<forall>n' \<in> set_of r. n < n') \<and> is_ord l \<and> is_ord r)"

primrec is_in :: "('a::order) \<Rightarrow> 'a tree \<Rightarrow> bool"
where
 "is_in k ET = False" |
 "is_in k (MKT n l r h) = (if k = n then True else
                           if k < n then (is_in k l)
                           else (is_in k r))"

primrec ht :: "'a tree \<Rightarrow> nat"
where
"ht ET = 0" |
"ht (MKT x l r h) = h"

definition
 mkt :: "'a \<Rightarrow> 'a tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"mkt x l r = MKT x l r (max (ht l) (ht r) + 1)"

(* replaced MKT lrn lrl lrr by MKT lrr lrl *)
fun l_bal where
"l_bal(n, MKT ln ll lr h, r) =
 (if ht ll < ht lr
  then case lr of ET \<Rightarrow> ET (* impossible *)
                | MKT lrn lrr lrl lrh \<Rightarrow>
                  mkt lrn (mkt ln ll lrl) (mkt n lrr r)
  else mkt ln ll (mkt n lr r))"

fun r_bal where
"r_bal(n, l, MKT rn rl rr h) =
 (if ht rl > ht rr
  then case rl of ET \<Rightarrow> ET (* impossible *)
                | MKT rln rll rlr h \<Rightarrow> mkt rln (mkt n l rll) (mkt rn rlr rr)
  else mkt rn (mkt n l rl) rr)"

primrec insrt :: "'a::order \<Rightarrow> 'a tree \<Rightarrow> 'a tree"
where
"insrt x ET = MKT x ET ET 1" |
"insrt x (MKT n l r h) =
   (if x=n
    then MKT n l r h
    else if x<n
         then let l' = insrt x l; hl' = ht l'; hr = ht r
              in if hl' = 2+hr then l_bal(n,l',r)
                 else MKT n l' r (1 + max hl' hr)
         else let r' = insrt x r; hl = ht l; hr' = ht r'
              in if hr' = 2+hl then r_bal(n,l,r')
                 else MKT n l r' (1 + max hl hr'))"

subsubsection {* Necessary setup for code generation *}

primrec set_of'
where
  "set_of' ET = []"
| "set_of' (MKT n l r h) = n # (set_of' l @ set_of' r)"

lemma set_of':
  "set (set_of' t) = set_of t"
by (induct t) auto

lemma is_ord_mkt:
  "is_ord (MKT n l r h) = ((ALL n': set (set_of' l). n' < n) & (ALL n': set (set_of' r). n < n') & is_ord l & is_ord r)"
by (simp add: set_of')

declare is_ord.simps(1)[code] is_ord_mkt[code]

subsubsection {* Invalid Lemma due to typo in @{const l_bal} *}

lemma is_ord_l_bal:
 "\<lbrakk> is_ord(MKT (x :: nat) l r h); height l = height r + 2 \<rbrakk> \<Longrightarrow> is_ord(l_bal(x,l,r))"
quickcheck[tester = narrowing, finite_types = false, default_type = nat, size = 6, expect = counterexample]
oops

subsection {* Examples with hd and last *}

lemma
  "hd (xs @ ys) = hd ys"
quickcheck[narrowing, expect = counterexample]
oops

lemma
  "last(xs @ ys) = last xs"
quickcheck[narrowing, expect = counterexample]
oops

subsection {* Examples with underspecified/partial functions *}

lemma
  "xs = [] ==> hd xs \<noteq> x"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma
  "xs = [] ==> hd xs = x"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma "xs = [] ==> hd xs = x ==> x = y"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma
  "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"
quickcheck[narrowing, expect = no_counterexample]
oops

lemma
  "hd (map f xs) = f (hd xs)"
quickcheck[narrowing, expect = no_counterexample]
oops

end


(*
   Theory: Lebesgue_Integral_Substitution.thy
   Authors: 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.
*)

header {* Integration by Substition *}

theory Lebesgue_Integral_Substitution
imports PDF_Misc Interval_Integral
begin

lemma deriv_nonneg_imp_mono:
  assumes deriv: "\<And>x. x \<in> {a..b} \<Longrightarrow> (g has_real_derivative g' x) (at x)"
  assumes nonneg: "\<And>x. x \<in> {a..b} \<Longrightarrow> g' x \<ge> 0"
  assumes ab: "a \<le> b"
  shows "g a \<le> g b"
proof (cases "a < b")
  assume "a < b"
  from deriv have "\<forall>x. x \<ge> a \<and> x \<le> b \<longrightarrow> (g has_real_derivative g' x) (at x)" by simp
  from MVT2[OF `a < b` this] and deriv
    obtain \<xi> where \<xi>_ab: "\<xi> > a" "\<xi> < b" and g_ab: "g b - g a = (b - a) * g' \<xi>" by blast
  from \<xi>_ab ab nonneg have "(b - a) * g' \<xi> \<ge> 0" by simp
  with g_ab show ?thesis by simp
qed (insert ab, simp)

lemma continuous_interval_vimage_Int:
  assumes "continuous_on {a::real..b} g" and mono: "\<And>x y. a \<le> x \<Longrightarrow> x \<le> y \<Longrightarrow> y \<le> b \<Longrightarrow> g x \<le> g y"
  assumes "a \<le> b" "(c::real) \<le> d" "{c..d} \<subseteq> {g a..g b}"
  obtains c' d' where "{a..b} \<inter> g -` {c..d} = {c'..d'}" "c' \<le> d'" "g c' = c" "g d' = d"
proof-
    let ?A = "{a..b} \<inter> g -` {c..d}"
    from IVT'[of g a c b, OF _ _ `a \<le> b` assms(1)] assms(4,5)
         obtain c'' where c'': "c'' \<in> ?A" "g c'' = c" by auto
    from IVT'[of g a d b, OF _ _ `a \<le> b` assms(1)] assms(4,5)
         obtain d'' where d'': "d'' \<in> ?A" "g d'' = d" by auto
    hence [simp]: "?A \<noteq> {}" by blast

    def c' \<equiv> "Inf ?A" and d' \<equiv> "Sup ?A"
    have "?A \<subseteq> {c'..d'}" unfolding c'_def d'_def
        by (intro subsetI) (auto intro: cInf_lower cSup_upper)
    moreover from assms have "closed ?A"
        using continuous_on_closed_vimage[of "{a..b}" g] by (subst Int_commute) simp
    hence c'd'_in_set: "c' \<in> ?A" "d' \<in> ?A" unfolding c'_def d'_def
        by ((intro closed_contains_Inf closed_contains_Sup, simp_all)[])+
    hence "{c'..d'} \<subseteq> ?A" using assms
        by (intro subsetI)
           (auto intro!: order_trans[of c "g c'" "g x" for x] order_trans[of "g x" "g d'" d for x]
                 intro!: mono)
    moreover have "c' \<le> d'" using c'd'_in_set(2) unfolding c'_def by (intro cInf_lower) auto
    moreover have "g c' \<le> c" "g d' \<ge> d"
      apply (insert c'' d'' c'd'_in_set)
      apply (subst c''(2)[symmetric])
      apply (auto simp: c'_def intro!: mono cInf_lower c'') []
      apply (subst d''(2)[symmetric])
      apply (auto simp: d'_def intro!: mono cSup_upper d'') []
      done
    with c'd'_in_set have "g c' = c" "g d' = d" by auto
    ultimately show ?thesis using that by blast
qed

lemma nn_integral_substitution_aux:
  fixes f :: "real \<Rightarrow> ereal"
  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 `a < b` 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. real (indicator A x :: ereal) = indicator A x"
      by (auto split: split_indicator)
  have ereal_ind[simp]: "\<And>A x. ereal (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 nonnegf, 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 `{u'..v'} \<subseteq> {a..b}`]) 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. ereal (g' x) * indicator ({a..b} \<inter> g-` {u..v}) x \<partial>lborel) =
                   LBINT x:{a..b} \<inter> g-`{u..v}. g' x"
          by (subst ereal_ind[symmetric], subst times_ereal.simps, subst nn_integral_eq_integral)
             (auto intro: measurable_sets Mg simp: derivg_nonneg mult.commute 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 `u \<le> v`)
        finally have "(\<integral>\<^sup>+ x. ereal (g' x) * indicator ({a..b} \<inter> g -` {u..v}) x \<partial>lborel) =
                           ereal (v - u)" .
      } note A = this

      have "(\<integral>\<^sup>+x. indicator {c..d} (g x) * ereal (g' x) * indicator {a..b} x \<partial>lborel) =
               (\<integral>\<^sup>+ x. ereal (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 `a \<le> b` `c \<le> d`
        by (auto intro!: monog intro: order.trans)
      also have "(\<integral>\<^sup>+ x. ereal (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 `c \<le> d` 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)
      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> \<infinity>" by auto
      have [simp]: "g -` A \<inter> {a..b} \<in> sets borel"
          by (intro continuous_on_ivl_vimage_sets_borel[OF contg] compl `a \<le> b`)
      have [simp]: "g -` (-A) \<inter> {a..b} \<in> sets borel"
          by (intro continuous_on_ivl_vimage_sets_borel[OF contg] compl `a \<le> b` borel_comp)

      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 `A \<in> sets borel` by (subst emeasure_Diff) (auto simp: real_of_ereal_minus)
     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 `A \<in> sets borel`
       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 * ereal (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 "ereal ... = \<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 * ereal (g' x * indicator {a..b} x))
                            \<in> borel_measurable borel" using Mg'
        by (intro borel_measurable_ereal_times borel_measurable_indicator)
           (simp_all add: mult.commute)
      have le: "(\<integral>\<^sup>+x. indicator (g-`A \<inter> {a..b}) x * ereal (g' x * indicator {a..b} x) \<partial>lborel) \<le>
                        (\<integral>\<^sup>+x. ereal (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 * ereal (g' x * indicator {a..b} x) \<partial>lborel) \<noteq> \<infinity>"
          by (auto simp: real_integrable_def nn_integral_set_ereal mult.commute)
      have "(\<integral>\<^sup>+ x. g' x * indicator {a..b} x \<partial>lborel) - ?I =
                  \<integral>\<^sup>+ x. ereal (g' x * indicator {a..b} x) -
                        indicator (g -` A \<inter> {a..b}) x * ereal (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) * ereal (g' x) * indicator {a..b} x \<partial>lborel"
        by (intro nn_integral_cong) (simp split: split_indicator)
      finally show ?case .

    next
      case (union f)
      have [simp]: "\<And>i. {a..b} \<inter> g -` f i \<in> sets borel"
          by (subst Int_commute, intro continuous_on_ivl_vimage_sets_borel[OF contg]) (auto intro: union)
      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) * ereal (g' x) * indicator {a..b} x \<partial>lborel)" by simp
      also have "(\<lambda>i. \<integral>\<^sup>+ x. indicator (f i) (g x) * ereal (g' x) * indicator {a..b} x \<partial>lborel) =
                         (\<lambda>i. \<integral>\<^sup>+ x. ereal (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. ereal (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_ereal_times, simp add: borel_measurable_ereal 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. ereal (g' x * indicator {a..b} x) * indicator ({a..b} \<inter> g -` f i) x) =
                      (\<lambda>x i. ereal (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. ereal (g' x * indicator {a..b} x) * indicator (g -` f i) x) \<partial>lborel) =
                     \<integral>\<^sup>+ x. ereal (g' x * indicator {a..b} x) * (\<Sum>i. indicator (g -` f i) x) \<partial>lborel"
        by (intro nn_integral_cong suminf_cmult_ereal) (auto split: split_indicator simp: derivg_nonneg)
      also from union have "(\<lambda>x. \<Sum>i. indicator (g -` f i) x :: ereal) = (\<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. ereal (g' x * indicator {a..b} x) * ... x \<partial>lborel) =
                    (\<integral>\<^sup>+x. indicator (\<Union>i. f i) (g x) * ereal (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] = `f \<in> borel_measurable borel`
    let ?I = "indicator {a..b}"
    have "(\<lambda>x. f (g x * ?I x) * ereal (g' x * ?I x)) \<in> borel_measurable borel" using Mg Mg'
      by (intro borel_measurable_ereal_times measurable_compose[OF _ Mf])
         (simp_all add: borel_measurable_ereal mult.commute)
    also have "(\<lambda>x. f (g x * ?I x) * ereal (g' x * ?I x)) = (\<lambda>x. f (g x) * ereal (g' x) * ?I x)"
      by (intro ext) (simp split: split_indicator)
    finally have Mf': "(\<lambda>x. f (g x) * ereal (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> ereal" assume Mf: "f \<in> borel_measurable borel"
      have "(\<lambda>x. f (g x * ?I x) * ereal (g' x * ?I x)) \<in> borel_measurable borel" using Mg Mg'
        by (intro borel_measurable_ereal_times measurable_compose[OF _ Mf])
           (simp_all add: borel_measurable_ereal mult.commute)
      also have "(\<lambda>x. f (g x * ?I x) * ereal (g' x * ?I x)) = (\<lambda>x. f (g x) * ereal (g' x) * ?I x)"
        by (intro ext) (simp split: split_indicator)
      finally have "(\<lambda>x. f (g x) * ereal (g' x) * ?I x) \<in> borel_measurable borel" .
    } note Mf' = this[OF `f1 \<in> borel_measurable borel`] this[OF `f2 \<in> borel_measurable borel`]
    from add have not_neginf: "\<And>x. f1 x \<noteq> -\<infinity>" "\<And>x. f2 x \<noteq> -\<infinity>"
      by (metis Infty_neq_0(1) ereal_0_le_uminus_iff ereal_infty_less_eq(1))+

    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) * ereal (g' x) * indicator {a..b} x \<partial>lborel) +
                                (\<integral>\<^sup>+ x. f2 (g x) * ereal (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) * ereal (g' x) * indicator {a..b} x +
                                      f2 (g x) * ereal (g' x) * indicator {a..b} x \<partial>lborel)"
      by (intro nn_integral_add[symmetric])
         (auto simp add: Mf' derivg_nonneg split: split_indicator)
    also from not_neginf have "... = \<integral>\<^sup>+ x. (f1 (g x) + f2 (g x)) * ereal (g' x) * indicator {a..b} x \<partial>lborel"
      by (intro nn_integral_cong) (simp split: split_indicator add: ereal_distrib)
    finally show ?case .

next
  case (sup F)
  {
    fix i
    let ?I = "indicator {a..b}"
    have "(\<lambda>x. F i (g x * ?I x) * ereal (g' x * ?I x)) \<in> borel_measurable borel" using Mg Mg'
      by (rule_tac borel_measurable_ereal_times, rule_tac measurable_compose[OF _ sup.hyps(1)])
         (simp_all add: mult.commute)
    also have "(\<lambda>x. F i (g x * ?I x) * ereal (g' x * ?I x)) = (\<lambda>x. F i (g x) * ereal (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) * ereal (g' x) * indicator {a..b} x \<partial>lborel)"
      by simp
    also from sup have "... =  \<integral>\<^sup>+x. (SUP i. F i (g x) * ereal (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!: ereal_mult_right_mono)
    also from sup have "... = \<integral>\<^sup>+x. (SUP i. F i (g x)) * ereal (g' x) * indicator {a..b} x \<partial>lborel"
      by (subst mult.assoc, subst mult.commute, subst SUP_ereal_cmult)
         (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 `a \<le> b` have "a < b" by auto
  let ?f' = "\<lambda>x. max 0 (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 * ereal (g' x) \<ge> 0 \<Longrightarrow> f x \<ge> 0"
    by (force simp: ereal_zero_le_0_iff 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. ereal (?f' x) * indicator {g a..g b} x \<partial>lborel)"
    by (subst nn_integral_max_0[symmetric], intro nn_integral_cong)
       (auto split: split_indicator simp: zero_ereal_def)
  also have "... = \<integral>\<^sup>+ x. ?f' (g x) * ereal (g' x) * indicator {a..b} x \<partial>lborel" using Mf
    by (subst nn_integral_substitution_aux[OF _ _ derivg contg' derivg_nonneg `a < b`])
       (auto simp add: zero_ereal_def mult.commute)
  also have "... = \<integral>\<^sup>+ x. max 0 (f (g x)) * ereal (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. max 0 (f (g x) * ereal (g' x) * indicator {a..b} x) \<partial>lborel"
    by (intro nn_integral_cong)
       (auto simp: max_def derivg_nonneg split: split_indicator intro!: nonneg')
  also have "... = \<integral>\<^sup>+ x. f (g x) * ereal (g' x) * indicator {a..b} x \<partial>lborel"
    by (rule nn_integral_max_0)
  also have "... = \<integral>\<^sup>+x. ereal (f (g x) * g' x * indicator {a..b} x) \<partial>lborel"
    by (intro nn_integral_cong) (simp 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)
  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 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. ereal (f x) * indicator {g a..g b} x) =
           (\<lambda>x. ereal (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)
  have "(\<lambda>x. ereal (-f x) * indicator {g a..g b} x) =
           (\<lambda>x. -ereal (f x * indicator {g a..g b} x))"
    by (intro ext) (simp split: split_indicator)
  with 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 =
          real (\<integral>\<^sup>+ x. ereal (f x) * indicator {g a..g b} x \<partial>lborel) -
          real (\<integral>\<^sup>+ x. ereal (- (f x)) * indicator {g a..g b} x \<partial>lborel)" using integrable
    by (subst real_lebesgue_integral_def) (simp_all add: nn_integral_set_ereal mult.commute)
  also have "(\<integral>\<^sup>+x. ereal (f x) * indicator {g a..g b} x \<partial>lborel) =
               (\<integral>\<^sup>+x. ereal (f x * indicator {g a..g b} x) \<partial>lborel)"
    by (intro nn_integral_cong) (simp split: split_indicator)
  also with M1 have A: "(\<integral>\<^sup>+ x. ereal (f x * indicator {g a..g b} x) \<partial>lborel) =
                            (\<integral>\<^sup>+ x. ereal (f (g x) * g' x * indicator {a..b} x) \<partial>lborel)"
    by (subst nn_integral_substitution[OF _ derivg contg' derivg_nonneg `a \<le> b`])
       (auto simp: nn_integral_set_ereal mult.commute)
  also have "(\<integral>\<^sup>+ x. ereal (- (f x)) * indicator {g a..g b} x \<partial>lborel) =
               (\<integral>\<^sup>+ x. ereal (- (f x) * indicator {g a..g b} x) \<partial>lborel)"
    by (intro nn_integral_cong) (simp split: split_indicator)
  also with M2 have B: "(\<integral>\<^sup>+ x. ereal (- (f x) * indicator {g a..g b} x) \<partial>lborel) =
                            (\<integral>\<^sup>+ x. ereal (- (f (g x)) * g' x * indicator {a..b} x) \<partial>lborel)"
    by (subst nn_integral_substitution[OF _ derivg contg' derivg_nonneg `a \<le> b`])
       (auto simp: nn_integral_set_ereal 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_ereal mult.commute)
  } note integrable' = this

  have "real (\<integral>\<^sup>+ x. ereal (f (g x) * g' x * indicator {a..b} x) \<partial>lborel) -
                  real (\<integral>\<^sup>+ x. ereal (-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)"
proof-
  have A: "\<And>g. (\<integral>\<^sup>+y. ereal (g (f y * indicator {x} y)) \<partial>lborel) = (\<integral>\<^sup>+(y::real). g 0 \<partial>lborel)"
    by (intro nn_integral_cong_AE AE_I'[of "{x}"] finite_imp_null_set_lborel)
       (auto split: split_indicator)
  have "(\<lambda>y. f x * indicator {x} y) \<in> borel_measurable borel" by simp
  also have "(\<lambda>y. f x * indicator {x} y) = (\<lambda>y. f y * indicator {x} y)"
    by (intro ext) (simp split: split_indicator)
  finally show ?thesis unfolding real_integrable_def
    by (auto simp: A[of "\<lambda>x. x"] A[of uminus] mult.commute)
qed

lemma emeasure_density_distr_interval:
  fixes h :: "real \<Rightarrow> real" and g :: "real \<Rightarrow> real" and g' :: "real \<Rightarrow> real"
  assumes [simp]: "a \<le> b"
  assumes Mf[measurable]: "f \<in> borel_measurable borel"
  assumes Mg[measurable]: "g \<in> borel_measurable borel"
  assumes Mg'[measurable]: "g' \<in> borel_measurable borel"
  assumes Mh[measurable]: "h \<in> borel_measurable borel"
  assumes prob: "subprob_space (density lborel f)"
  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 mono: "strict_mono_on g {a..b}" and inv: "\<And>x. h x \<in> {a..b} \<Longrightarrow> g (h x) = x"
  assumes range: "{a..b} \<subseteq> range h"
  shows "emeasure (distr (density lborel f) lborel h) {a..b} =
             emeasure (density lborel (\<lambda>x. f (g x) * g' x)) {a..b}"
proof (cases "a < b")
  assume "a < b"
  from mono have inj: "inj_on g {a..b}" by (rule strict_mono_on_imp_inj_on)
  from mono have mono': "mono_on g {a..b}" by (rule strict_mono_on_imp_mono_on)
  from mono' derivg have "\<And>x. x \<in> {a<..<b} \<Longrightarrow> g' x \<ge> 0"
    by (rule mono_on_imp_deriv_nonneg) (auto simp: interior_atLeastAtMost_real)
  from contg' this have derivg_nonneg: "\<And>x. x \<in> {a..b} \<Longrightarrow> g' x \<ge> 0"
    by (rule continuous_ge_on_Iii) (simp_all add: `a < b`)

  from derivg have contg: "continuous_on {a..b} g" by (rule has_real_derivative_imp_continuous_on)
  have A: "h -` {a..b} = {g a..g b}"
  proof (intro equalityI subsetI)
    fix x assume x: "x \<in> h -` {a..b}"
    hence "g (h x) \<in> {g a..g b}" by (auto intro: mono_onD[OF mono'])
    with inv and x show "x \<in> {g a..g b}" by simp
  next
    fix y assume y: "y \<in> {g a..g b}"
    with IVT'[OF _ _ _ contg, of y] obtain x where "x \<in> {a..b}" "y = g x" by auto
    with range and inv show "y \<in> h -` {a..b}" by auto
  qed

  have prob': "subprob_space (distr (density lborel f) lborel h)"
    by (rule subprob_space.subprob_space_distr[OF prob]) (simp_all add: Mh)
  have B: "emeasure (distr (density lborel f) lborel h) {a..b} =
            \<integral>\<^sup>+x. f x * indicator (h -` {a..b}) x \<partial>lborel"
    by (subst emeasure_distr) (simp_all add: emeasure_density Mf Mh measurable_sets_borel[OF Mh])
  also note A
  also have "emeasure (distr (density lborel f) lborel h) {a..b} \<le> 1"
    by (rule subprob_space.subprob_measure_le_1) (rule prob')
  hence "emeasure (distr (density lborel f) lborel h) {a..b} \<noteq> \<infinity>" by auto
  with assms have "(\<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)"
    by (intro nn_integral_substitution_aux)
       (auto simp: derivg_nonneg A B emeasure_density mult.commute `a < b`)
  also have "... = emeasure (density lborel (\<lambda>x. f (g x) * g' x)) {a..b}"
    by (simp add: emeasure_density)
  finally show ?thesis .
next
  assume "\<not>a < b"
  with `a \<le> b` have [simp]: "b = a" by (simp add: not_less del: `a \<le> b`)
  from inv and range have "h -` {a} = {g a}" by auto
  thus ?thesis by (simp_all add: emeasure_distr emeasure_density measurable_sets_borel[OF Mh])
qed

end