theory Digraph_Isomorphism imports
  Arc_Walk
  Digraph
  Digraph_Component
begin

section {* Isomorphisms of Digraphs *}

record ('a,'b,'aa,'bb) digraph_isomorphism =
  iso_verts :: "'a \<Rightarrow> 'aa"
  iso_arcs :: "'b \<Rightarrow> 'bb"
  iso_head :: "'bb \<Rightarrow> 'aa"
  iso_tail :: "'bb \<Rightarrow> 'aa"

definition (in pre_digraph) digraph_isomorphism :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> bool" where
  "digraph_isomorphism hom \<equiv>
    wf_digraph G \<and>
    inj_on (iso_verts hom) (verts G) \<and>
    inj_on (iso_arcs hom) (arcs G) \<and>
    (\<forall>a \<in> arcs G.
    iso_verts hom (tail G a) = iso_tail hom (iso_arcs hom a) \<and>
    iso_verts hom (head G a) = iso_head hom (iso_arcs hom a))"

definition (in pre_digraph) inv_iso :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> ('aa,'bb,'a,'b) digraph_isomorphism" where
  "inv_iso hom \<equiv> \<lparr>
    iso_verts = the_inv_into (verts G) (iso_verts hom),
    iso_arcs = the_inv_into (arcs G) (iso_arcs hom),
    iso_head = head G,
    iso_tail = tail G
    \<rparr>"

definition app_iso
    :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> ('aa,'bb) pre_digraph" where
  "app_iso hom G \<equiv> \<lparr> verts = iso_verts hom ` verts G, arcs = iso_arcs hom ` arcs G,
    tail = iso_tail hom, head = iso_head hom \<rparr>"

definition digraph_iso :: "('a,'b) pre_digraph \<Rightarrow> ('c,'d) pre_digraph \<Rightarrow> bool"  where
  "digraph_iso G H \<equiv> \<exists>f. pre_digraph.digraph_isomorphism G f \<and> H = app_iso f G"

lemma verts_app_iso: "verts (app_iso hom G) = iso_verts hom ` verts G"
  and arcs_app_iso: "arcs (app_iso hom G) = iso_arcs hom `arcs G"
  and tail_app_iso: "tail (app_iso hom G) = iso_tail hom"
  and head_app_iso: "head (app_iso hom G) = iso_head hom"
  by (auto simp: app_iso_def)

lemmas app_iso_simps[simp] = verts_app_iso arcs_app_iso tail_app_iso head_app_iso

context pre_digraph begin

lemma
  assumes "digraph_isomorphism hom"
  shows iso_verts_inv_iso: "\<And>u. u \<in> verts G \<Longrightarrow> iso_verts (inv_iso hom) (iso_verts hom u) = u"
    and iso_arcs_inv_iso: "\<And>a. a \<in> arcs G \<Longrightarrow> iso_arcs (inv_iso hom) (iso_arcs hom a) = a"
    and iso_verts_iso_inv: "\<And>u. u \<in> verts (app_iso hom G) \<Longrightarrow> iso_verts hom (iso_verts (inv_iso hom) u) = u"
    and iso_arcs_iso_inv: "\<And>a. a \<in> arcs (app_iso hom G) \<Longrightarrow> iso_arcs hom (iso_arcs (inv_iso hom) a) = a"
    and iso_tail_inv_iso: "iso_tail (inv_iso hom) = tail G"
    and iso_head_inv_iso: "iso_head (inv_iso hom) = head G"
    and verts_app_inv_iso:"iso_verts (inv_iso hom) ` iso_verts hom ` verts G = verts G"
    and arcs_app_inv_iso:"iso_arcs (inv_iso hom) ` iso_arcs hom ` arcs G = arcs G"
  using assms by (auto simp: inv_iso_def digraph_isomorphism_def the_inv_into_f_f)

lemmas iso_inv_simps[simp] =
   iso_verts_inv_iso iso_verts_iso_inv
   iso_arcs_inv_iso iso_arcs_iso_inv
   verts_app_inv_iso arcs_app_inv_iso
   iso_tail_inv_iso iso_head_inv_iso

lemma app_iso_inv[simp]:
  assumes "digraph_isomorphism hom"
  shows "app_iso (inv_iso hom) (app_iso hom G) = G"
  using assms by (intro pre_digraph.equality) (auto intro: rev_image_eqI)

lemma iso_verts_eq_iff[simp]:
  assumes "digraph_isomorphism hom" "u \<in> verts G" "v \<in> verts G"
  shows "iso_verts hom u = iso_verts hom v \<longleftrightarrow> u = v"
  using assms by (auto simp: digraph_isomorphism_def dest: inj_onD)

lemma iso_arcs_eq_iff[simp]:
  assumes "digraph_isomorphism hom" "e1 \<in> arcs G" "e2 \<in> arcs G"
  shows "iso_arcs hom e1 = iso_arcs hom e2 \<longleftrightarrow> e1 = e2"
  using assms by (auto simp: digraph_isomorphism_def dest: inj_onD)

lemma
  assumes "digraph_isomorphism hom" "e \<in> arcs G"
  shows iso_verts_tail: "iso_tail hom (iso_arcs hom e) = iso_verts hom (tail G e)"
    and iso_verts_head: "iso_head hom (iso_arcs hom e) = iso_verts hom (head G e)"
  using assms unfolding digraph_isomorphism_def by auto

lemma digraph_isomorphism_inj_on_arcs:
  "digraph_isomorphism hom \<Longrightarrow> inj_on (iso_arcs hom) (arcs G)"
  by (auto simp: digraph_isomorphism_def)

lemma digraph_isomorphism_inj_on_verts:
  "digraph_isomorphism hom \<Longrightarrow> inj_on (iso_verts hom) (verts G)"
  by (auto simp: digraph_isomorphism_def)

end

lemma (in wf_digraph) wf_digraphI_app_iso[intro?]:
  assumes "digraph_isomorphism hom"
  shows "wf_digraph (app_iso hom G)"
proof unfold_locales
  fix e assume "e \<in> arcs (app_iso hom G)"
  then obtain e' where e': "e' \<in> arcs G" "iso_arcs hom e' = e"
    by auto
  then have "iso_verts hom (head G e') \<in> verts (app_iso hom G)"
      "iso_verts hom (tail G e') \<in> verts (app_iso hom G)"
    by auto
  then show "tail (app_iso hom G) e \<in> verts (app_iso hom G)"
      "head (app_iso hom G) e \<in> verts (app_iso hom G)"
    using e' assms by (auto simp: iso_verts_tail iso_verts_head)
qed

lemma (in fin_digraph) fin_digraphI_app_iso[intro?]:
  assumes "digraph_isomorphism hom"
  shows "fin_digraph (app_iso hom G)"
proof -
  interpret H: wf_digraph "app_iso hom G" using assms ..
  show ?thesis by unfold_locales auto
qed

context wf_digraph begin

lemma digraph_isomorphism_invI:
  assumes "digraph_isomorphism hom" shows "pre_digraph.digraph_isomorphism (app_iso hom G) (inv_iso hom)"
proof (unfold pre_digraph.digraph_isomorphism_def, safe)
  show "inj_on (iso_verts (inv_iso hom)) (verts (app_iso hom G))"
      "inj_on (iso_arcs (inv_iso hom)) (arcs (app_iso hom G))"
    using assms unfolding pre_digraph.digraph_isomorphism_def inv_iso_def
    by (auto intro: inj_on_the_inv_into)
next
  show "wf_digraph (app_iso hom G)" using assms ..
next
  fix a assume "a \<in> arcs (app_iso hom G)"
  then obtain b where B: "a = iso_arcs hom b" "b \<in> arcs G"
    by auto

  with assms have [simp]:
      "iso_tail hom (iso_arcs hom b) = iso_verts hom (tail G b)"
      "iso_head hom (iso_arcs hom b) = iso_verts hom (head G b)"
      "inj_on (iso_arcs hom) (arcs G)"
      "inj_on (iso_verts hom) (verts G)"
    by (auto simp: digraph_isomorphism_def)

  from B show "iso_verts (inv_iso hom) (tail (app_iso hom G) a)
      = iso_tail (inv_iso hom) (iso_arcs (inv_iso hom) a)"
    by (auto simp: inv_iso_def the_inv_into_f_f)
  from B show "iso_verts (inv_iso hom) (head (app_iso hom G) a)
      = iso_head (inv_iso hom) (iso_arcs (inv_iso hom) a)"
    by (auto simp: inv_iso_def the_inv_into_f_f)
qed

lemma awalk_app_isoI:
  assumes "awalk u p v" and hom: "digraph_isomorphism hom"
  shows "pre_digraph.awalk (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from assms show ?thesis
    by (induct p arbitrary: u)
       (auto simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)
qed

lemma awalk_app_isoD:
  assumes w: "pre_digraph.awalk (app_iso hom G) u p v" and hom: "digraph_isomorphism hom"
  shows "awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from assms show ?thesis
    by (induct p arbitrary: u)
       (force simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)+
qed

lemma awalk_verts_app_iso_eq:
  assumes "digraph_isomorphism hom" and "awalk u p v"
  shows "pre_digraph.awalk_verts (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p)
    = map (iso_verts hom) (awalk_verts u p)"
  using assms
  by (induct p arbitrary: u)
     (auto simp: pre_digraph.awalk_verts.simps iso_verts_head iso_verts_tail awalk_Cons_iff)

(*
lemma awalk_verts_app_iso_eq':
  assumes hom: "digraph_isomorphism hom" and w: "pre_digraph.awalk (app_iso hom G) u p v"
  shows "pre_digraph.awalk_verts (app_iso hom G) u p
    = map (iso_verts hom) (awalk_verts (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p))"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  have w': "awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
    using w hom by (rule awalk_app_isoD)
  have "pre_digraph.awalk_verts (app_iso hom G) u p =
      pre_digraph.awalk_verts (app_iso hom G) (iso_verts hom (iso_verts (inv_iso hom) u)) (map (iso_arcs hom) (map (iso_arcs (inv_iso hom)) p))"
    using hom w by (auto simp add: o_def set_mp cong: map_cong)
  also have "\<dots> = map (iso_verts hom) (awalk_verts (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p))"
    using hom w' by (rule awalk_verts_app_iso_eq)
  finally show ?thesis .
qed
*)

lemma in_arcs_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "in_arcs (app_iso hom G) (iso_verts hom u) = iso_arcs hom ` in_arcs G u"
  using assms unfolding in_arcs_def by (auto simp: iso_verts_head)

lemma out_arcs_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "out_arcs (app_iso hom G) (iso_verts hom u) = iso_arcs hom ` out_arcs G u"
  using assms unfolding out_arcs_def by (auto simp: iso_verts_tail)

lemma in_degree_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "in_degree (app_iso hom G) (iso_verts hom u) = in_degree G u"
  unfolding in_degree_def in_arcs_app_iso_eq[OF assms]
proof (rule card_image)
  from assms show "inj_on (iso_arcs hom) (in_arcs G u)"
    unfolding digraph_isomorphism_def by - (rule subset_inj_on, auto)
qed

lemma out_degree_app_iso_eq:
  assumes "digraph_isomorphism hom" and "u \<in> verts G"
  shows "out_degree (app_iso hom G) (iso_verts hom u) = out_degree G u"
  unfolding out_degree_def out_arcs_app_iso_eq[OF assms]
proof (rule card_image)
  from assms show "inj_on (iso_arcs hom) (out_arcs G u)"
    unfolding digraph_isomorphism_def by - (rule subset_inj_on, auto)
qed

lemma in_arcs_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "in_arcs (app_iso hom G) u = iso_arcs hom ` in_arcs G (iso_verts (inv_iso hom) u)"
  using assms in_arcs_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemma out_arcs_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "out_arcs (app_iso hom G) u = iso_arcs hom ` out_arcs G (iso_verts (inv_iso hom) u)"
  using assms out_arcs_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemma in_degree_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "in_degree (app_iso hom G) u = in_degree G (iso_verts (inv_iso hom) u)"
  using assms in_degree_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemma out_degree_app_iso_eq':
  assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
  shows "out_degree (app_iso hom G) u = out_degree G (iso_verts (inv_iso hom) u)"
  using assms out_degree_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

lemmas app_iso_eq =
  awalk_verts_app_iso_eq
  arcs_ends_app_iso_eq
  in_arcs_app_iso_eq'
  out_arcs_app_iso_eq'
  in_degree_app_iso_eq'
  out_degree_app_iso_eq'

lemma reachableI_app_iso:
  assumes r: "u \<rightarrow>\<^sup>* v" and hom: "digraph_isomorphism hom"
  shows "(iso_verts hom u) \<rightarrow>\<^sup>*\<^bsub>app_iso hom G\<^esub> (iso_verts hom v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from r obtain p where "awalk u p v" by (auto simp: reachable_awalk)
  then have "H.awalk (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
    using hom by (rule awalk_app_isoI)
  then show ?thesis by (auto simp: H.reachable_awalk)
qed

lemma awalk_app_iso_eq:
  assumes hom: "digraph_isomorphism hom"
  assumes "u \<in> iso_verts hom ` verts G" "v \<in> iso_verts hom ` verts G" "set p \<subseteq> iso_arcs hom ` arcs G"
  shows "pre_digraph.awalk (app_iso hom G) u p v
    \<longleftrightarrow> awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..
  from assms show ?thesis
    by (induct p arbitrary: u)
       (auto simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)
qed

lemma reachable_app_iso_eq:
  assumes hom: "digraph_isomorphism hom"
  assumes "u \<in> iso_verts hom ` verts G" "v \<in> iso_verts hom ` verts G"
  shows "u \<rightarrow>\<^sup>*\<^bsub>app_iso hom G\<^esub> v \<longleftrightarrow> iso_verts (inv_iso hom) u \<rightarrow>\<^sup>* iso_verts (inv_iso hom) v" (is "?L \<longleftrightarrow> ?R")
proof -
  interpret H: wf_digraph "app_iso hom G" using hom ..

  show ?thesis
  proof
    assume ?L
    then obtain p where "H.awalk u p v" by (auto simp: H.reachable_awalk)
    moreover
    then have "set p \<subseteq> iso_arcs hom ` arcs G" by (simp add: H.awalk_def)
    ultimately
    show ?R using assms by (auto simp: awalk_app_iso_eq reachable_awalk)
  next
    assume ?R
    then obtain p0 where "awalk (iso_verts (inv_iso hom) u) p0 (iso_verts (inv_iso hom) v)"
      by (auto simp: reachable_awalk)
    moreover
    then have "set p0 \<subseteq> arcs G" by (simp add: awalk_def)
    def p \<equiv> "map (iso_arcs hom) p0"
    have "set p \<subseteq> iso_arcs hom ` arcs G" "p0 = map (iso_arcs (inv_iso hom)) p"
      using \<open>set p0 \<subseteq> _\<close> hom by (auto simp: p_def map_idI subsetD)
    ultimately
    show ?L using assms by (auto simp: awalk_app_iso_eq[symmetric] H.reachable_awalk)
  qed
qed

lemma connectedI_app_iso:
  assumes c: "connected G" and hom: "digraph_isomorphism hom"
  shows "connected (app_iso hom G)"
proof -
  have *: "symcl (arcs_ends (app_iso hom G)) = (\<lambda>(u,v). (iso_verts hom u, iso_verts hom v)) ` symcl (arcs_ends G)"
    using hom by (auto simp add: app_iso_eq symcl_def)
  { fix u v assume "(u,v) \<in> rtrancl_on (verts G) (symcl (arcs_ends G))"
    then have "(iso_verts hom u, iso_verts hom v) \<in> rtrancl_on (verts (app_iso hom G)) (symcl (arcs_ends (app_iso hom G)))"
    proof induct
      case (step x y)
      have "(iso_verts hom x, iso_verts hom y)
          \<in> rtrancl_on (verts (app_iso hom G)) (symcl (arcs_ends (app_iso hom G)))"
        using step by (rule_tac rtrancl_on_into_rtrancl_on[where b="iso_verts hom x"]) (auto simp: *)
      then show ?case
        by (rule rtrancl_on_trans) (rule step)
    qed auto }
  with c show ?thesis unfolding connected_conv by auto
qed

end

lemma digraph_iso_swap:
  assumes "wf_digraph G" "digraph_iso G H" shows "digraph_iso H G"
proof -
  from assms obtain f where "pre_digraph.digraph_isomorphism G f" "H = app_iso f G"
    unfolding digraph_iso_def by auto
  then have "pre_digraph.digraph_isomorphism H (pre_digraph.inv_iso G f)" "app_iso (pre_digraph.inv_iso G f) H = G"
    using assms by (simp_all add: wf_digraph.digraph_isomorphism_invI pre_digraph.app_iso_inv)
  then show ?thesis unfolding digraph_iso_def by auto
qed

definition
  o_iso :: "('c,'d,'e,'f) digraph_isomorphism \<Rightarrow> ('a,'b,'c,'d) digraph_isomorphism \<Rightarrow> ('a,'b,'e,'f) digraph_isomorphism"
where
  "o_iso hom2 hom1 = \<lparr>
    iso_verts = iso_verts hom2 o iso_verts hom1,
    iso_arcs = iso_arcs hom2 o iso_arcs hom1,
    iso_head = iso_head hom2,
    iso_tail = iso_tail hom2
    \<rparr>"

lemma digraph_iso_trans[trans]:
  assumes "digraph_iso G H" "digraph_iso H I" shows "digraph_iso G I"
proof -
  from assms obtain hom1 where "pre_digraph.digraph_isomorphism G hom1" "H = app_iso hom1 G"
    by (auto simp: digraph_iso_def)
  moreover
  from assms obtain hom2 where "pre_digraph.digraph_isomorphism H hom2" "I = app_iso hom2 H"
    by (auto simp: digraph_iso_def)
  ultimately
  have "pre_digraph.digraph_isomorphism G (o_iso hom2 hom1)" "I = app_iso (o_iso hom2 hom1) G"
    apply (auto simp: o_iso_def app_iso_def pre_digraph.digraph_isomorphism_def)
    apply (rule comp_inj_on)
    apply auto
    apply (rule comp_inj_on)
    apply auto
    done
  then show ?thesis by (auto simp: digraph_iso_def)
qed

lemma (in pre_digraph) digraph_isomorphism_subgraphI:
  assumes "digraph_isomorphism hom"
  assumes "subgraph H G"
  shows "pre_digraph.digraph_isomorphism H hom"
  using assms by (auto simp: pre_digraph.digraph_isomorphism_def subgraph_def compatible_def intro: subset_inj_on)

(* XXX move *)
lemma (in wf_digraph) verts_app_inv_iso_subgraph:
  assumes hom: "digraph_isomorphism hom" and "V \<subseteq> verts G"
  shows "iso_verts (inv_iso hom) ` iso_verts hom ` V = V"
proof -
  have "\<And>x. x \<in> V \<Longrightarrow> iso_verts (inv_iso hom) (iso_verts hom x) = x"
    using assms by auto
  then show ?thesis by (auto simp: image_image cong: image_cong)
qed

(* XXX move *)
lemma (in wf_digraph) arcs_app_inv_iso_subgraph:
  assumes hom: "digraph_isomorphism hom" and "A \<subseteq> arcs G"
  shows "iso_arcs (inv_iso hom) ` iso_arcs hom ` A = A"
proof -
  have "\<And>x. x \<in> A \<Longrightarrow> iso_arcs (inv_iso hom) (iso_arcs hom x) = x"
    using assms by auto
  then show ?thesis by (auto simp: image_image cong: image_cong)
qed

(* XXX move *)
lemma (in pre_digraph) app_iso_inv_subgraph[simp]:
  assumes "digraph_isomorphism hom" "subgraph H G"
  shows "app_iso (inv_iso hom) (app_iso hom H) = H"
proof -
  from assms interpret wf_digraph G by auto
  have "\<And>u. u \<in> verts H \<Longrightarrow> u \<in> verts G" "\<And>a. a \<in> arcs H \<Longrightarrow> a \<in> arcs G"
    using assms by auto
  with assms show ?thesis
    by (intro pre_digraph.equality) (auto simp: verts_app_inv_iso_subgraph
      arcs_app_inv_iso_subgraph compatible_def)
qed

lemma (in wf_digraph) app_iso_iso_inv_subgraph[simp]:
  assumes "digraph_isomorphism hom"
  assumes subg: "subgraph H (app_iso hom G)"
  shows "app_iso hom (app_iso (inv_iso hom) H) = H"
proof -
  have "\<And>u. u \<in> verts H \<Longrightarrow> u \<in> iso_verts hom ` verts G" "\<And>a. a \<in> arcs H \<Longrightarrow> a \<in> iso_arcs hom ` arcs G"
    using assms by (auto simp: subgraph_def)
  with assms show ?thesis
    by (intro pre_digraph.equality) (auto simp: compatible_def image_image cong: image_cong)
qed

lemma (in pre_digraph) subgraph_app_isoI':
  assumes hom: "digraph_isomorphism hom"
  assumes subg: "subgraph H H'" "subgraph H' G"
  shows "subgraph (app_iso hom H) (app_iso hom H')"
proof -
  have "subgraph H G" using subg by (rule subgraph_trans)
  then have "pre_digraph.digraph_isomorphism H hom" "pre_digraph.digraph_isomorphism H' hom"
    using assms by (auto intro: digraph_isomorphism_subgraphI)
  then show ?thesis
    using assms by (auto simp: subgraph_def wf_digraph.wf_digraphI_app_iso compatible_def
      intro: digraph_isomorphism_subgraphI)
qed

lemma (in pre_digraph) subgraph_app_isoI:
  assumes "digraph_isomorphism hom"
  assumes "subgraph H G"
  shows "subgraph (app_iso hom H) (app_iso hom G)"
  using assms by (auto intro: subgraph_app_isoI' wf_digraph.subgraph_refl)

lemma (in pre_digraph) app_iso_eq_conv:
  assumes "digraph_isomorphism hom"
  assumes "subgraph H1 G" "subgraph H2 G"
  shows "app_iso hom H1 = app_iso hom H2 \<longleftrightarrow> H1 = H2" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  then have "app_iso (inv_iso hom) (app_iso hom H1) = app_iso (inv_iso hom) (app_iso hom H2)"
    by simp
  with assms show ?R by auto
qed simp

lemma in_arcs_app_iso_cases:
  assumes "a \<in> arcs (app_iso hom G)"
  obtains a0 where "a = iso_arcs hom a0" "a0 \<in> arcs G"
  using assms by auto

lemma in_verts_app_iso_cases:
  assumes "v \<in> verts (app_iso hom G)"
  obtains v0 where "v = iso_verts hom v0" "v0 \<in> verts G"
  using assms by auto

lemma (in wf_digraph) max_subgraph_iso:
  assumes hom: "digraph_isomorphism hom"
  assumes subg: "subgraph H (app_iso hom G)"
  shows "pre_digraph.max_subgraph (app_iso hom G) P H
    \<longleftrightarrow> max_subgraph (P o app_iso hom) (app_iso (inv_iso hom) H)"
proof -
  have hom_inv: "pre_digraph.digraph_isomorphism (app_iso hom G) (inv_iso hom)"
    using hom by (rule digraph_isomorphism_invI)
  interpret aG: wf_digraph "app_iso hom G" using hom ..

  have *: "subgraph (app_iso (inv_iso hom) H) G"
    using hom pre_digraph.subgraph_app_isoI'[OF hom_inv subg aG.subgraph_refl] by simp
  def H0 \<equiv> "app_iso (inv_iso hom) H"
  then have H0: "H = app_iso hom H0" "subgraph H0 G"
    using hom subg \<open>subgraph _ G\<close> by (auto simp: )

  show ?thesis (is "?L \<longleftrightarrow> ?R")
  proof
    assume ?L then show ?R using assms H0
      by (auto simp: max_subgraph_def aG.max_subgraph_def pre_digraph.subgraph_app_isoI'
        subgraph_refl pre_digraph.app_iso_eq_conv)
  next
    assume ?R
    then show ?L
      using assms hom_inv pre_digraph.subgraph_app_isoI[OF hom_inv]
      apply (auto simp: max_subgraph_def aG.max_subgraph_def)
      apply (erule allE[of _ "app_iso (inv_iso hom) H'" for H'])
      apply (auto simp: pre_digraph.subgraph_app_isoI' pre_digraph.app_iso_eq_conv)
      done
  qed
qed

lemma (in pre_digraph) max_subgraph_cong:
  assumes "H = H'" "\<And>H''. subgraph H' H'' \<Longrightarrow> subgraph H'' G \<Longrightarrow> P H'' = P' H''"
  shows "max_subgraph P H = max_subgraph P' H'"
  using assms by (auto simp: max_subgraph_def intro: wf_digraph.subgraph_refl)

lemma (in pre_digraph) inj_on_app_iso:
  assumes hom: "digraph_isomorphism hom"
  assumes "S \<subseteq> {H. subgraph H G}"
  shows "inj_on (app_iso hom) S"
  using assms by (intro inj_onI) (subst (asm) app_iso_eq_conv, auto)

subsection \<open>Graph Invariants\<close>

context
  fixes G hom assumes hom: "pre_digraph.digraph_isomorphism G hom"
begin

  interpretation wf_digraph G using hom by (auto simp: pre_digraph.digraph_isomorphism_def)

  lemma card_verts_iso[simp]: "card (iso_verts hom ` verts G) = card (verts G)"
    using hom by (intro card_image digraph_isomorphism_inj_on_verts)

  lemma card_arcs_iso[simp]: "card (iso_arcs hom ` arcs G) = card (arcs G)"
    using hom by (intro card_image digraph_isomorphism_inj_on_arcs)

  lemma strongly_connected_iso[simp]: "strongly_connected (app_iso hom G) \<longleftrightarrow> strongly_connected G"
    using hom by (auto simp: strongly_connected_def reachable_app_iso_eq)

  lemma subgraph_strongly_connected_iso:
    assumes "subgraph H G"
    shows "strongly_connected (app_iso hom H) \<longleftrightarrow> strongly_connected H"
  proof -
    interpret H: wf_digraph H using \<open>subgraph H G\<close> ..
    have "H.digraph_isomorphism hom" using hom assms by (rule digraph_isomorphism_subgraphI)
    then show ?thesis
      using assms by (auto simp: strongly_connected_def H.reachable_app_iso_eq)
  qed

  lemma sccs_iso[simp]: "pre_digraph.sccs (app_iso hom G) = app_iso hom ` sccs" (is "?L = ?R")
  proof (intro set_eqI iffI)
    fix x assume "x \<in> ?L"
    then have "subgraph x (app_iso hom G)"
      by (auto simp: pre_digraph.sccs_def)
    then show "x \<in> ?R"
      using \<open>x \<in> ?L\<close> hom by (auto simp: pre_digraph.sccs_altdef2 max_subgraph_iso
        subgraph_strongly_connected_iso cong: max_subgraph_cong  intro: rev_image_eqI)
  next
    fix x assume "x \<in> ?R"
    then obtain x0 where "x0 \<in> sccs" "x = app_iso hom x0" by auto
    then show "x \<in> ?L"
      using hom by (auto simp: pre_digraph.sccs_altdef2 max_subgraph_iso subgraph_app_isoI
        subgraphI_max_subgraph subgraph_strongly_connected_iso cong: max_subgraph_cong)
  qed

  lemma card_sccs_iso[simp]: "card (app_iso hom ` sccs) = card sccs"
    apply (rule card_image)
    using hom
    apply (rule inj_on_app_iso)
    apply auto
    done

end

end


(*
Theory: Interval_Integral.thy
Authors: Jeremy Avigad, Johannes Hölzl, Luke Serafin

Lebesgue integral over an interval (with endpoints possibly +-\<infinity>)
*)

theory Interval_Integral
  imports Probability Set_Integral
begin

definition "einterval a b = {x. a < ereal x \<and> ereal x < b}"

lemma einterval_eq[simp]:
  shows einterval_eq_Icc: "einterval (ereal a) (ereal b) = {a <..< b}"
    and einterval_eq_Ici: "einterval (ereal a) \<infinity> = {a <..}"
    and einterval_eq_Iic: "einterval (- \<infinity>) (ereal b) = {..< b}"
    and einterval_eq_UNIV: "einterval (- \<infinity>) \<infinity> = UNIV"
  by (auto simp: einterval_def)

lemma einterval_same: "einterval a a = {}"
  by (auto simp add: einterval_def)

lemma einterval_iff: "x \<in> einterval a b \<longleftrightarrow> a < ereal x \<and> ereal x < b"
  by (simp add: einterval_def)

lemma einterval_nonempty: "a < b \<Longrightarrow> \<exists>c. c \<in> einterval a b"
  by (cases a b rule: ereal2_cases, auto simp: einterval_def intro!: dense gt_ex lt_ex)

lemma open_einterval[simp]: "open (einterval a b)"
  by (cases a b rule: ereal2_cases)
     (auto simp: einterval_def intro!: open_Collect_conj open_Collect_less continuous_intros)

lemma borel_einterval[measurable]: "einterval a b \<in> sets borel"
  unfolding einterval_def by measurable

(*
    Approximating a (possibly infinite) interval
*)

lemma filterlim_sup1: "(LIM x F. f x :> G1) \<Longrightarrow> (LIM x F. f x :> (sup G1 G2))"
 unfolding filterlim_def by (auto intro: le_supI1)

lemma ereal_incseq_approx:
  fixes a b :: ereal
  assumes "a < b"
  obtains X :: "nat \<Rightarrow> real" where
    "incseq X" "\<And>i. a < X i" "\<And>i. X i < b" "X ----> b"
proof (cases b)
  case PInf
  with `a < b` have "a = -\<infinity> \<or> (\<exists>r. a = ereal r)"
    by (cases a) auto
  moreover have " (\<lambda>x. ereal (real (Suc x))) ----> \<infinity>"
    using natceiling_le_eq by (subst LIMSEQ_Suc_iff) (auto simp: Lim_PInfty)
  moreover have "\<And>r. (\<lambda>x. ereal (r + real (Suc x))) ----> \<infinity>"
    apply (subst LIMSEQ_Suc_iff)
    apply (subst Lim_PInfty)
    apply (metis add.commute diff_le_eq natceiling_le_eq ereal_less_eq(3))
    done
  ultimately show thesis
    by (intro that[of "\<lambda>i. real a + Suc i"])
       (auto simp: incseq_def PInf)
next
  case (real b')
  def d \<equiv> "b' - (if a = -\<infinity> then b' - 1 else real a)"
  with `a < b` have a': "0 < d"
    by (cases a) (auto simp: real)
  moreover
  have "\<And>i r. r < b' \<Longrightarrow> (b' - r) * 1 < (b' - r) * real (Suc (Suc i))"
    by (intro mult_strict_left_mono) auto
  with `a < b` a' have "\<And>i. a < ereal (b' - d / real (Suc (Suc i)))"
    by (cases a) (auto simp: real d_def field_simps)
  moreover have "(\<lambda>i. b' - d / Suc (Suc i)) ----> b'"
    apply (subst filterlim_sequentially_Suc)
    apply (subst filterlim_sequentially_Suc)
    apply (rule tendsto_eq_intros)
    apply (auto intro!: tendsto_divide_0[OF tendsto_const] filterlim_sup1
                simp: at_infinity_eq_at_top_bot filterlim_real_sequentially)
    done
  ultimately show thesis
    by (intro that[of "\<lambda>i. b' - d / Suc (Suc i)"])
       (auto simp add: real incseq_def intro!: divide_left_mono)
qed (insert `a < b`, auto)

lemma ereal_decseq_approx:
  fixes a b :: ereal
  assumes "a < b"
  obtains X :: "nat \<Rightarrow> real" where
    "decseq X" "\<And>i. a < X i" "\<And>i. X i < b" "X ----> a"
proof -
  have "-b < -a" using `a < b` by simp
  from ereal_incseq_approx[OF this] guess X .
  then show thesis
    apply (intro that[of "\<lambda>i. - X i"])
    apply (auto simp add: uminus_ereal.simps[symmetric] decseq_def incseq_def
                simp del: uminus_ereal.simps)
    apply (metis ereal_minus_less_minus ereal_uminus_uminus ereal_Lim_uminus)+
    done
qed

lemma einterval_Icc_approximation:
  fixes a b :: ereal
  assumes "a < b"
  obtains u l :: "nat \<Rightarrow> real" where
    "einterval a b = (\<Union>i. {l i .. u i})"
    "incseq u" "decseq l" "\<And>i. l i < u i" "\<And>i. a < l i" "\<And>i. u i < b"
    "l ----> a" "u ----> b"
proof -
  from dense[OF `a < b`] obtain c where "a < c" "c < b" by safe
  from ereal_incseq_approx[OF `c < b`] guess u . note u = this
  from ereal_decseq_approx[OF `a < c`] guess l . note l = this
  { fix i from less_trans[OF `l i < c` `c < u i`] have "l i < u i" by simp }
  have "einterval a b = (\<Union>i. {l i .. u i})"
  proof (auto simp: einterval_iff)
    fix x assume "a < ereal x" "ereal x < b"
    have "eventually (\<lambda>i. ereal (l i) < ereal x) sequentially"
      using l(4) `a < ereal x` by (rule order_tendstoD)
    moreover
    have "eventually (\<lambda>i. ereal x < ereal (u i)) sequentially"
      using u(4) `ereal x< b` by (rule order_tendstoD)
    ultimately have "eventually (\<lambda>i. l i < x \<and> x < u i) sequentially"
      by eventually_elim auto
    then show "\<exists>i. l i \<le> x \<and> x \<le> u i"
      by (auto intro: less_imp_le simp: eventually_sequentially)
  next
    fix x i assume "l i \<le> x" "x \<le> u i"
    with `a < ereal (l i)` `ereal (u i) < b`
    show "a < ereal x" "ereal x < b"
      by (auto simp del: ereal_less_eq(3) simp add: ereal_less_eq(3)[symmetric])
  qed
  show thesis
    by (intro that) fact+
qed

(* TODO: in this definition, it would be more natural if einterval a b included a and b when
   they are real. *)
definition interval_lebesgue_integral :: "real measure \<Rightarrow> ereal \<Rightarrow> ereal \<Rightarrow> (real \<Rightarrow> 'a) \<Rightarrow> 'a::{banach, second_countable_topology}" where
  "interval_lebesgue_integral M a b f =
    (if a \<le> b then (LINT x:einterval a b|M. f x) else - (LINT x:einterval b a|M. f x))"

syntax
  "_ascii_interval_lebesgue_integral" :: "pttrn \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real measure \<Rightarrow> real \<Rightarrow> real"
  ("(5LINT _=_.._|_. _)" [0,60,60,61,100] 60)

translations
  "LINT x=a..b|M. f" == "CONST interval_lebesgue_integral M a b (\<lambda>x. f)"

definition interval_lebesgue_integrable :: "real measure \<Rightarrow> ereal \<Rightarrow> ereal \<Rightarrow> (real \<Rightarrow> 'a::{banach, second_countable_topology}) \<Rightarrow> bool" where
  "interval_lebesgue_integrable M a b f =
    (if a \<le> b then set_integrable M (einterval a b) f else set_integrable M (einterval b a) f)"

syntax
  "_ascii_interval_lebesgue_borel_integral" :: "pttrn \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real"
  ("(4LBINT _=_.._. _)" [0,60,60,61] 60)

translations
  "LBINT x=a..b. f" == "CONST interval_lebesgue_integral CONST lborel a b (\<lambda>x. f)"

(*
    Basic properties of integration over an interval.
*)

lemma interval_lebesgue_integral_cong:
  "a \<le> b \<Longrightarrow> (\<And>x. x \<in> einterval a b \<Longrightarrow> f x = g x) \<Longrightarrow> einterval a b \<in> sets M \<Longrightarrow>
    interval_lebesgue_integral M a b f = interval_lebesgue_integral M a b g"
  by (auto intro: set_lebesgue_integral_cong simp: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_cong_AE:
  "f \<in> borel_measurable M \<Longrightarrow> g \<in> borel_measurable M \<Longrightarrow>
    a \<le> b \<Longrightarrow> AE x \<in> einterval a b in M. f x = g x \<Longrightarrow> einterval a b \<in> sets M \<Longrightarrow>
    interval_lebesgue_integral M a b f = interval_lebesgue_integral M a b g"
  by (auto intro: set_lebesgue_integral_cong_AE simp: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_add [intro, simp]:
  fixes M a b f
  assumes "interval_lebesgue_integrable M a b f" "interval_lebesgue_integrable M a b g"
  shows "interval_lebesgue_integrable M a b (\<lambda>x. f x + g x)" and
    "interval_lebesgue_integral M a b (\<lambda>x. f x + g x) =
   interval_lebesgue_integral M a b f + interval_lebesgue_integral M a b g"
using assms by (auto simp add: interval_lebesgue_integral_def interval_lebesgue_integrable_def
    field_simps)

lemma interval_lebesgue_integral_diff [intro, simp]:
  fixes M a b f
  assumes "interval_lebesgue_integrable M a b f"
    "interval_lebesgue_integrable M a b g"
  shows "interval_lebesgue_integrable M a b (\<lambda>x. f x - g x)" and
    "interval_lebesgue_integral M a b (\<lambda>x. f x - g x) =
   interval_lebesgue_integral M a b f - interval_lebesgue_integral M a b g"
using assms by (auto simp add: interval_lebesgue_integral_def interval_lebesgue_integrable_def
    field_simps)

lemma interval_lebesgue_integrable_mult_right [intro, simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, second_countable_topology}"
  shows "(c \<noteq> 0 \<Longrightarrow> interval_lebesgue_integrable M a b f) \<Longrightarrow>
    interval_lebesgue_integrable M a b (\<lambda>x. c * f x)"
  by (simp add: interval_lebesgue_integrable_def)

lemma interval_lebesgue_integrable_mult_left [intro, simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, second_countable_topology}"
  shows "(c \<noteq> 0 \<Longrightarrow> interval_lebesgue_integrable M a b f) \<Longrightarrow>
    interval_lebesgue_integrable M a b (\<lambda>x. f x * c)"
  by (simp add: interval_lebesgue_integrable_def)

lemma interval_lebesgue_integrable_divide [intro, simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, field_inverse_zero, second_countable_topology}"
  shows "(c \<noteq> 0 \<Longrightarrow> interval_lebesgue_integrable M a b f) \<Longrightarrow>
    interval_lebesgue_integrable M a b (\<lambda>x. f x / c)"
  by (simp add: interval_lebesgue_integrable_def)

lemma interval_lebesgue_integral_mult_right [simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, second_countable_topology}"
  shows "interval_lebesgue_integral M a b (\<lambda>x. c * f x) =
    c * interval_lebesgue_integral M a b f"
  by (simp add: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_mult_left [simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, second_countable_topology}"
  shows "interval_lebesgue_integral M a b (\<lambda>x. f x * c) =
    interval_lebesgue_integral M a b f * c"
  by (simp add: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_divide [simp]:
  fixes M a b c and f :: "real \<Rightarrow> 'a::{banach, real_normed_field, field_inverse_zero, second_countable_topology}"
  shows "interval_lebesgue_integral M a b (\<lambda>x. f x / c) =
    interval_lebesgue_integral M a b f / c"
  by (simp add: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_uminus:
  "interval_lebesgue_integral M a b (\<lambda>x. - f x) = - interval_lebesgue_integral M a b f"
  by (auto simp add: interval_lebesgue_integral_def interval_lebesgue_integrable_def)

lemma interval_lebesgue_integral_of_real:
  "interval_lebesgue_integral M a b (\<lambda>x. complex_of_real (f x)) =
    of_real (interval_lebesgue_integral M a b f)"
  unfolding interval_lebesgue_integral_def
  by (auto simp add: interval_lebesgue_integral_def set_integral_complex_of_real)

lemma interval_lebesgue_integral_le_eq:
  fixes a b f
  assumes "a \<le> b"
  shows "interval_lebesgue_integral M a b f = (LINT x : einterval a b | M. f x)"
using assms by (auto simp add: interval_lebesgue_integral_def)

lemma interval_lebesgue_integral_gt_eq:
  fixes a b f
  assumes "a > b"
  shows "interval_lebesgue_integral M a b f = -(LINT x : einterval b a | M. f x)"
using assms by (auto simp add: interval_lebesgue_integral_def less_imp_le einterval_def)

lemma interval_lebesgue_integral_gt_eq':
  fixes a b f
  assumes "a > b"
  shows "interval_lebesgue_integral M a b f = - interval_lebesgue_integral M b a f"
using assms by (auto simp add: interval_lebesgue_integral_def less_imp_le einterval_def)

lemma interval_integral_endpoints_same [simp]: "(LBINT x=a..a. f x) = 0"
  by (simp add: interval_lebesgue_integral_def einterval_same)

lemma interval_integral_endpoints_reverse: "(LBINT x=a..b. f x) = -(LBINT x=b..a. f x)"
  by (cases a b rule: linorder_cases) (auto simp: interval_lebesgue_integral_def einterval_same)

lemma interval_integrable_endpoints_reverse:
  "interval_lebesgue_integrable lborel a b f \<longleftrightarrow>
    interval_lebesgue_integrable lborel b a f"
  by (cases a b rule: linorder_cases) (auto simp: interval_lebesgue_integrable_def einterval_same)

lemma interval_integral_reflect:
  "(LBINT x=a..b. f x) = (LBINT x=-b..-a. f (-x))"
proof (induct a b rule: linorder_wlog)
  case (sym a b) then show ?case
    by (auto simp add: interval_lebesgue_integral_def interval_integrable_endpoints_reverse
             split: split_if_asm)
next
  case (le a b) then show ?case
    unfolding interval_lebesgue_integral_def
    by (subst set_integral_reflect)
       (auto simp: interval_lebesgue_integrable_def einterval_iff
                   ereal_uminus_le_reorder ereal_uminus_less_reorder not_less
                   uminus_ereal.simps[symmetric]
             simp del: uminus_ereal.simps
             intro!: integral_cong
             split: split_indicator)
qed

(*
    Basic properties of integration over an interval wrt lebesgue measure.
*)

lemma interval_integral_zero [simp]:
  fixes a b :: ereal
  shows"LBINT x=a..b. 0 = 0"
using assms unfolding interval_lebesgue_integral_def einterval_eq
by simp

lemma interval_integral_const [intro, simp]:
  fixes a b c :: real
  shows "interval_lebesgue_integrable lborel a b (\<lambda>x. c)" and "LBINT x=a..b. c = c * (b - a)"
using assms unfolding interval_lebesgue_integral_def interval_lebesgue_integrable_def einterval_eq
by (auto simp add:  less_imp_le field_simps measure_def)

lemma interval_integral_cong_AE:
  assumes [measurable]: "f \<in> borel_measurable borel" "g \<in> borel_measurable borel"
  assumes "AE x \<in> einterval (min a b) (max a b) in lborel. f x = g x"
  shows "interval_lebesgue_integral lborel a b f = interval_lebesgue_integral lborel a b g"
  using assms
proof (induct a b rule: linorder_wlog)
  case (sym a b) then show ?case
    by (simp add: min.commute max.commute interval_integral_endpoints_reverse[of a b])
next
  case (le a b) then show ?case
    by (auto simp: interval_lebesgue_integral_def max_def min_def
             intro!: set_lebesgue_integral_cong_AE)
qed

lemma interval_integral_cong:
  assumes "\<And>x. x \<in> einterval (min a b) (max a b) \<Longrightarrow> f x = g x"
  shows "interval_lebesgue_integral lborel a b f = interval_lebesgue_integral lborel a b g"
  using assms
proof (induct a b rule: linorder_wlog)
  case (sym a b) then show ?case
    by (simp add: min.commute max.commute interval_integral_endpoints_reverse[of a b])
next
  case (le a b) then show ?case
    by (auto simp: interval_lebesgue_integral_def max_def min_def
             intro!: set_lebesgue_integral_cong)
qed

lemma interval_lebesgue_integrable_cong_AE:
    "f \<in> borel_measurable lborel \<Longrightarrow> g \<in> borel_measurable lborel \<Longrightarrow>
    AE x \<in> einterval (min a b) (max a b) in lborel. f x = g x \<Longrightarrow>
    interval_lebesgue_integrable lborel a b f = interval_lebesgue_integrable lborel a b g"
  apply (simp add: interval_lebesgue_integrable_def )
  apply (intro conjI impI set_integrable_cong_AE)
  apply (auto simp: min_def max_def)
  done

lemma interval_integrable_abs_iff:
  fixes f :: "real \<Rightarrow> real"
  shows  "f \<in> borel_measurable lborel \<Longrightarrow>
    interval_lebesgue_integrable lborel a b (\<lambda>x. \<bar>f x\<bar>) = interval_lebesgue_integrable lborel a b f"
  unfolding interval_lebesgue_integrable_def
  by (subst (1 2) set_integrable_abs_iff') simp_all

lemma interval_integral_Icc:
  fixes a b :: real
  shows "a \<le> b \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {a..b}. f x)"
  by (auto intro!: set_integral_discrete_difference[where X="{a, b}"]
           simp add: interval_lebesgue_integral_def)

lemma interval_integral_Icc':
  "a \<le> b \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {x. a \<le> ereal x \<and> ereal x \<le> b}. f x)"
  by (auto intro!: set_integral_discrete_difference[where X="{real a, real b}"]
           simp add: interval_lebesgue_integral_def einterval_iff)

lemma interval_integral_Ioc:
  "a \<le> b \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {a<..b}. f x)"
  by (auto intro!: set_integral_discrete_difference[where X="{a, b}"]
           simp add: interval_lebesgue_integral_def einterval_iff)

(* TODO: other versions as well? *) (* Yes: I need the Icc' version. *)
lemma interval_integral_Ioc':
  "a \<le> b \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {x. a < ereal x \<and> ereal x \<le> b}. f x)"
  by (auto intro!: set_integral_discrete_difference[where X="{real a, real b}"]
           simp add: interval_lebesgue_integral_def einterval_iff)

lemma interval_integral_Ico:
  "a \<le> b \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {a..<b}. f x)"
  by (auto intro!: set_integral_discrete_difference[where X="{a, b}"]
           simp add: interval_lebesgue_integral_def einterval_iff)

lemma interval_integral_Ioi:
  "\<bar>a\<bar> < \<infinity> \<Longrightarrow> (LBINT x=a..\<infinity>. f x) = (LBINT x : {real a <..}. f x)"
  by (auto simp add: interval_lebesgue_integral_def einterval_iff)

lemma interval_integral_Ioo:
  "a \<le> b \<Longrightarrow> \<bar>a\<bar> < \<infinity> ==> \<bar>b\<bar> < \<infinity> \<Longrightarrow> (LBINT x=a..b. f x) = (LBINT x : {real a <..< real b}. f x)"
  by (auto simp add: interval_lebesgue_integral_def einterval_iff)

lemma interval_integral_discrete_difference:
  fixes f :: "real \<Rightarrow> 'b::{banach, second_countable_topology}" and a b :: ereal
  assumes "countable X"
  and eq: "\<And>x. a \<le> b \<Longrightarrow> a < x \<Longrightarrow> x < b \<Longrightarrow> x \<notin> X \<Longrightarrow> f x = g x"
  and anti_eq: "\<And>x. b \<le> a \<Longrightarrow> b < x \<Longrightarrow> x < a \<Longrightarrow> x \<notin> X \<Longrightarrow> f x = g x"
  assumes "\<And>x. x \<in> X \<Longrightarrow> emeasure M {x} = 0" "\<And>x. x \<in> X \<Longrightarrow> {x} \<in> sets M"
  shows "interval_lebesgue_integral M a b f = interval_lebesgue_integral M a b g"
  unfolding interval_lebesgue_integral_def
  apply (intro if_cong refl arg_cong[where f="\<lambda>x. - x"] integral_discrete_difference[of X] assms)
  apply (auto simp: eq anti_eq einterval_iff split: split_indicator)
  done

lemma interval_integral_sum:
  fixes a b c :: ereal
  assumes integrable: "interval_lebesgue_integrable lborel (min a (min b c)) (max a (max b c)) f"
  shows "(LBINT x=a..b. f x) + (LBINT x=b..c. f x) = (LBINT x=a..c. f x)"
proof -
  let ?I = "\<lambda>a b. LBINT x=a..b. f x"
  { fix a b c :: ereal assume "interval_lebesgue_integrable lborel a c f" "a \<le> b" "b \<le> c"
    then have ord: "a \<le> b" "b \<le> c" "a \<le> c" and f': "set_integrable lborel (einterval a c) f"
      by (auto simp: interval_lebesgue_integrable_def)
    then have f: "set_borel_measurable borel (einterval a c) f"
      by (drule_tac borel_measurable_integrable) simp
    have "(LBINT x:einterval a c. f x) = (LBINT x:einterval a b \<union> einterval b c. f x)"
    proof (rule set_integral_cong_set)
      show "AE x in lborel. (x \<in> einterval a b \<union> einterval b c) = (x \<in> einterval a c)"
        using AE_lborel_singleton[of "real b"] ord
        by (cases a b c rule: ereal3_cases) (auto simp: einterval_iff)
    qed (insert ord, auto intro!: set_borel_measurable_subset[OF f] simp: einterval_iff)
    also have "\<dots> = (LBINT x:einterval a b. f x) + (LBINT x:einterval b c. f x)"
      using ord
      by (intro set_integral_Un_AE) (auto intro!: set_integrable_subset[OF f'] simp: einterval_iff not_less)
    finally have "?I a b + ?I b c = ?I a c"
      using ord by (simp add: interval_lebesgue_integral_def)
  } note 1 = this
  { fix a b c :: ereal assume "interval_lebesgue_integrable lborel a c f" "a \<le> b" "b \<le> c"
    from 1[OF this] have "?I b c + ?I a b = ?I a c"
      by (metis add.commute)
  } note 2 = this
  have 3: "\<And>a b. b \<le> a \<Longrightarrow> (LBINT x=a..b. f x) = - (LBINT x=b..a. f x)"
    by (rule interval_integral_endpoints_reverse)
  show ?thesis
    using integrable
    by (cases a b b c a c rule: linorder_le_cases[case_product linorder_le_cases linorder_cases])
       (simp_all add: min_absorb1 min_absorb2 max_absorb1 max_absorb2 field_simps 1 2 3)
qed

lemma interval_integrable_isCont:
  fixes a b and f :: "real \<Rightarrow> 'a::{banach, second_countable_topology}"
  shows "(\<And>x. min a b \<le> x \<Longrightarrow> x \<le> max a b \<Longrightarrow> isCont f x) \<Longrightarrow>
    interval_lebesgue_integrable lborel a b f"
proof (induct a b rule: linorder_wlog)
  case (le a b) then show ?case
    by (auto simp: interval_lebesgue_integrable_def
             intro!: set_integrable_subset[OF borel_integrable_compact[of "{a .. b}"]]
                     continuous_at_imp_continuous_on)
qed (auto intro: interval_integrable_endpoints_reverse[THEN iffD1])

lemma interval_integrable_continuous_on:
  fixes a b :: real and f
  assumes "a \<le> b" and "continuous_on {a..b} f"
  shows "interval_lebesgue_integrable lborel a b f"
using assms unfolding interval_lebesgue_integrable_def apply simp
  by (rule set_integrable_subset, rule borel_integrable_atLeastAtMost' [of a b], auto)

lemma interval_integral_eq_integral:
  fixes f :: "real \<Rightarrow> 'a::euclidean_space"
  shows "a \<le> b \<Longrightarrow> set_integrable lborel {a..b} f \<Longrightarrow> LBINT x=a..b. f x = integral {a..b} f"
  by (subst interval_integral_Icc, simp) (rule set_borel_integral_eq_integral)

lemma interval_integral_eq_integral':
  fixes f :: "real \<Rightarrow> 'a::euclidean_space"
  shows "a \<le> b \<Longrightarrow> set_integrable lborel (einterval a b) f \<Longrightarrow> LBINT x=a..b. f x = integral (einterval a b) f"
  by (subst interval_lebesgue_integral_le_eq, simp) (rule set_borel_integral_eq_integral)

(*
    General limit approximation arguments
*)

lemma interval_integral_Icc_approx_nonneg:
  fixes a b :: ereal
  assumes "a < b"
  fixes u l :: "nat \<Rightarrow> real"
  assumes  approx: "einterval a b = (\<Union>i. {l i .. u i})"
    "incseq u" "decseq l" "\<And>i. l i < u i" "\<And>i. a < l i" "\<And>i. u i < b"
    "l ----> a" "u ----> b"
  fixes f :: "real \<Rightarrow> real"
  assumes f_integrable: "\<And>i. set_integrable lborel {l i..u i} f"
  assumes f_nonneg: "AE x in lborel. a < ereal x \<longrightarrow> ereal x < b \<longrightarrow> 0 \<le> f x"
  assumes f_measurable: "set_borel_measurable lborel (einterval a b) f"
  assumes lbint_lim: "(\<lambda>i. LBINT x=l i.. u i. f x) ----> C"
  shows
    "set_integrable lborel (einterval a b) f"
    "(LBINT x=a..b. f x) = C"
proof -
  have 1: "\<And>i. set_integrable lborel {l i..u i} f" by (rule f_integrable)
  have 2: "AE x in lborel. mono (\<lambda>n. indicator {l n..u n} x *\<^sub>R f x)"
  proof -
     from f_nonneg have "AE x in lborel. \<forall>i. l i \<le> x \<longrightarrow> x \<le> u i \<longrightarrow> 0 \<le> f x"
      by eventually_elim
         (metis approx(5) approx(6) dual_order.strict_trans1 ereal_less_eq(3) le_less_trans)
    then show ?thesis
      apply eventually_elim
      apply (auto simp: mono_def split: split_indicator)
      apply (metis approx(3) decseqD order_trans)
      apply (metis approx(2) incseqD order_trans)
      done
  qed
  have 3: "AE x in lborel. (\<lambda>i. indicator {l i..u i} x *\<^sub>R f x) ----> indicator (einterval a b) x *\<^sub>R f x"
  proof -
    { fix x i assume "l i \<le> x" "x \<le> u i"
      then have "eventually (\<lambda>i. l i \<le> x \<and> x \<le> u i) sequentially"
        apply (auto simp: eventually_sequentially intro!: exI[of _ i])
        apply (metis approx(3) decseqD order_trans)
        apply (metis approx(2) incseqD order_trans)
        done
      then have "eventually (\<lambda>i. f x * indicator {l i..u i} x = f x) sequentially"
        by eventually_elim auto }
    then show ?thesis
      unfolding approx(1) by (auto intro!: AE_I2 Lim_eventually split: split_indicator)
  qed
  have 4: "(\<lambda>i. \<integral> x. indicator {l i..u i} x *\<^sub>R f x \<partial>lborel) ----> C"
    using lbint_lim by (simp add: interval_integral_Icc approx less_imp_le)
  have 5: "set_borel_measurable lborel (einterval a b) f" by (rule assms)
  have "(LBINT x=a..b. f x) = lebesgue_integral lborel (\<lambda>x. indicator (einterval a b) x *\<^sub>R f x)"
    using assms by (simp add: interval_lebesgue_integral_def less_imp_le)
  also have "... = C" by (rule integral_monotone_convergence [OF 1 2 3 4 5])
  finally show "(LBINT x=a..b. f x) = C" .

  show "set_integrable lborel (einterval a b) f"
    by (rule integrable_monotone_convergence[OF 1 2 3 4 5])
qed

lemma interval_integral_Icc_approx_integrable:
  fixes u l :: "nat \<Rightarrow> real" and a b :: ereal
  fixes f :: "real \<Rightarrow> 'a::{banach, second_countable_topology}"
  assumes "a < b"
  assumes  approx: "einterval a b = (\<Union>i. {l i .. u i})"
    "incseq u" "decseq l" "\<And>i. l i < u i" "\<And>i. a < l i" "\<And>i. u i < b"
    "l ----> a" "u ----> b"
  assumes f_integrable: "set_integrable lborel (einterval a b) f"
  shows "(\<lambda>i. LBINT x=l i.. u i. f x) ----> (LBINT x=a..b. f x)"
proof -
  have "(\<lambda>i. LBINT x:{l i.. u i}. f x) ----> (LBINT x:einterval a b. f x)"
  proof (rule integral_dominated_convergence)
    show "integrable lborel (\<lambda>x. norm (indicator (einterval a b) x *\<^sub>R f x))"
      by (rule integrable_norm) fact
    show "set_borel_measurable lborel (einterval a b) f"
      using f_integrable by (rule borel_measurable_integrable)
    then show "\<And>i. set_borel_measurable lborel {l i..u i} f"
      by (rule set_borel_measurable_subset) (auto simp: approx)
    show "\<And>i. AE x in lborel. norm (indicator {l i..u i} x *\<^sub>R f x) \<le> norm (indicator (einterval a b) x *\<^sub>R f x)"
      by (intro AE_I2) (auto simp: approx split: split_indicator)
    show "AE x in lborel. (\<lambda>i. indicator {l i..u i} x *\<^sub>R f x) ----> indicator (einterval a b) x *\<^sub>R f x"
    proof (intro AE_I2 tendsto_intros Lim_eventually)
      fix x
      { fix i assume "l i \<le> x" "x \<le> u i"
        with `incseq u`[THEN incseqD, of i] `decseq l`[THEN decseqD, of i]
        have "eventually (\<lambda>i. l i \<le> x \<and> x \<le> u i) sequentially"
          by (auto simp: eventually_sequentially decseq_def incseq_def intro: order_trans) }
      then show "eventually (\<lambda>xa. indicator {l xa..u xa} x = (indicator (einterval a b) x::real)) sequentially"
        using approx order_tendstoD(2)[OF `l ----> a`, of x] order_tendstoD(1)[OF `u ----> b`, of x]
        by (auto split: split_indicator)
    qed
  qed
  with `a < b` `\<And>i. l i < u i` show ?thesis
    by (simp add: interval_lebesgue_integral_le_eq[symmetric] interval_integral_Icc less_imp_le)
qed

(*
  A slightly stronger version of integral_FTC_atLeastAtMost and related facts,
  with continuous_on instead of isCont

  TODO: make the older versions corollaries of these (using continuous_at_imp_continuous_on, etc.)
*)

(*
TODO: many proofs below require inferences like

  a < ereal x \<Longrightarrow> x < y \<Longrightarrow> a < ereal y

where x and y are real. These should be better automated.
*)

(*
    The first Fundamental Theorem of Calculus

    First, for finite intervals, and then two versions for arbitrary intervals.
*)

lemma interval_integral_FTC_finite:
  fixes f F :: "real \<Rightarrow> 'a::euclidean_space" and a b :: real
  assumes f: "continuous_on {min a b..max a b} f"
  assumes F: "\<And>x. min a b \<le> x \<Longrightarrow> x \<le> max a b \<Longrightarrow> (F has_vector_derivative (f x)) (at x within
    {min a b..max a b})"
  shows "(LBINT x=a..b. f x) = F b - F a"
  apply (case_tac "a \<le> b")
  apply (subst interval_integral_Icc, simp)
  apply (rule integral_FTC_atLeastAtMost, assumption)
  apply (metis F max_def min_def)
  using f apply (simp add: min_absorb1 max_absorb2)
  apply (subst interval_integral_endpoints_reverse)
  apply (subst interval_integral_Icc, simp)
  apply (subst integral_FTC_atLeastAtMost, auto)
  apply (metis F max_def min_def)
using f by (simp add: min_absorb2 max_absorb1)

lemma interval_integral_FTC_nonneg:
  fixes f F :: "real \<Rightarrow> real" and a b :: ereal
  assumes "a < b"
  assumes F: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> DERIV F x :> f x"
  assumes f: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont f x"
  assumes f_nonneg: "AE x in lborel. a < ereal x \<longrightarrow> ereal x < b \<longrightarrow> 0 \<le> f x"
  assumes A: "((F \<circ> real) ---> A) (at_right a)"
  assumes B: "((F \<circ> real) ---> B) (at_left b)"
  shows
    "set_integrable lborel (einterval a b) f"
    "(LBINT x=a..b. f x) = B - A"
proof -
  from einterval_Icc_approximation[OF `a < b`] guess u l . note approx = this
  have [simp]: "\<And>x i. l i \<le> x \<Longrightarrow> a < ereal x"
    by (rule order_less_le_trans, rule approx, force)
  have [simp]: "\<And>x i. x \<le> u i \<Longrightarrow> ereal x < b"
    by (rule order_le_less_trans, subst ereal_less_eq(3), assumption, rule approx)
  have FTCi: "\<And>i. (LBINT x=l i..u i. f x) = F (u i) - F (l i)"
    using assms approx apply (intro interval_integral_FTC_finite)
    apply (auto simp add: less_imp_le min_def max_def
      has_field_derivative_iff_has_vector_derivative[symmetric])
    apply (rule continuous_at_imp_continuous_on, auto intro!: f)
    by (rule DERIV_subset [OF F], auto)
  have 1: "\<And>i. set_integrable lborel {l i..u i} f"
  proof -
    fix i show "set_integrable lborel {l i .. u i} f"
      using `a < l i` `u i < b`
      by (intro borel_integrable_compact f continuous_at_imp_continuous_on compact_Icc ballI)
         (auto simp del: ereal_less_eq simp add: ereal_less_eq(3)[symmetric])
  qed
  have 2: "set_borel_measurable lborel (einterval a b) f"
    by (auto simp del: real_scaleR_def intro!: set_borel_measurable_continuous
             simp: continuous_on_eq_continuous_at einterval_iff f)
  have 3: "(\<lambda>i. LBINT x=l i..u i. f x) ----> B - A"
    apply (subst FTCi)
    apply (intro tendsto_intros)
    using B approx unfolding tendsto_at_iff_sequentially comp_def
    using tendsto_at_iff_sequentially[where 'a=real]
    apply (elim allE[of _ "\<lambda>i. ereal (u i)"], auto)
    using A approx unfolding tendsto_at_iff_sequentially comp_def
    by (elim allE[of _ "\<lambda>i. ereal (l i)"], auto)
  show "(LBINT x=a..b. f x) = B - A"
    by (rule interval_integral_Icc_approx_nonneg [OF `a < b` approx 1 f_nonneg 2 3])
  show "set_integrable lborel (einterval a b) f"
    by (rule interval_integral_Icc_approx_nonneg [OF `a < b` approx 1 f_nonneg 2 3])
qed

lemma interval_integral_FTC_integrable:
  fixes f F :: "real \<Rightarrow> 'a::euclidean_space" and a b :: ereal
  assumes "a < b"
  assumes F: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> (F has_vector_derivative f x) (at x)"
  assumes f: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont f x"
  assumes f_integrable: "set_integrable lborel (einterval a b) f"
  assumes A: "((F \<circ> real) ---> A) (at_right a)"
  assumes B: "((F \<circ> real) ---> B) (at_left b)"
  shows "(LBINT x=a..b. f x) = B - A"
proof -
  from einterval_Icc_approximation[OF `a < b`] guess u l . note approx = this
  have [simp]: "\<And>x i. l i \<le> x \<Longrightarrow> a < ereal x"
    by (rule order_less_le_trans, rule approx, force)
  have [simp]: "\<And>x i. x \<le> u i \<Longrightarrow> ereal x < b"
    by (rule order_le_less_trans, subst ereal_less_eq(3), assumption, rule approx)
  have FTCi: "\<And>i. (LBINT x=l i..u i. f x) = F (u i) - F (l i)"
    using assms approx
    by (auto simp add: less_imp_le min_def max_def
             intro!: f continuous_at_imp_continuous_on interval_integral_FTC_finite
             intro: has_vector_derivative_at_within)
  have "(\<lambda>i. LBINT x=l i..u i. f x) ----> B - A"
    apply (subst FTCi)
    apply (intro tendsto_intros)
    using B approx unfolding tendsto_at_iff_sequentially comp_def
    apply (elim allE[of _ "\<lambda>i. ereal (u i)"], auto)
    using A approx unfolding tendsto_at_iff_sequentially comp_def
    by (elim allE[of _ "\<lambda>i. ereal (l i)"], auto)
  moreover have "(\<lambda>i. LBINT x=l i..u i. f x) ----> (LBINT x=a..b. f x)"
    by (rule interval_integral_Icc_approx_integrable [OF `a < b` approx f_integrable])
  ultimately show ?thesis
    by (elim LIMSEQ_unique)
qed

(*
  The second Fundamental Theorem of Calculus and existence of antiderivatives on an
  einterval.
*)

lemma interval_integral_FTC2:
  fixes a b c :: real and f :: "real \<Rightarrow> 'a::euclidean_space"
  assumes "a \<le> c" "c \<le> b"
  and contf: "continuous_on {a..b} f"
  fixes x :: real
  assumes "a \<le> x" and "x \<le> b"
  shows "((\<lambda>u. LBINT y=c..u. f y) has_vector_derivative (f x)) (at x within {a..b})"
proof -
  let ?F = "(\<lambda>u. LBINT y=a..u. f y)"
  have intf: "set_integrable lborel {a..b} f"
    by (rule borel_integrable_atLeastAtMost', rule contf)
  have "((\<lambda>u. integral {a..u} f) has_vector_derivative f x) (at x within {a..b})"
    apply (intro integral_has_vector_derivative)
    using `a \<le> x` `x \<le> b` by (intro continuous_on_subset [OF contf], auto)
  then have "((\<lambda>u. integral {a..u} f) has_vector_derivative (f x)) (at x within {a..b})"
    by simp
  then have "(?F has_vector_derivative (f x)) (at x within {a..b})"
    by (rule has_vector_derivative_weaken)
       (auto intro!: assms interval_integral_eq_integral[symmetric] set_integrable_subset [OF intf])
  then have "((\<lambda>x. (LBINT y=c..a. f y) + ?F x) has_vector_derivative (f x)) (at x within {a..b})"
    by (auto intro!: derivative_eq_intros)
  then show ?thesis
  proof (rule has_vector_derivative_weaken)
    fix u assume "u \<in> {a .. b}"
    then show "(LBINT y=c..a. f y) + (LBINT y=a..u. f y) = (LBINT y=c..u. f y)"
      using assms
      apply (intro interval_integral_sum)
      apply (auto simp add: interval_lebesgue_integrable_def simp del: real_scaleR_def)
      by (rule set_integrable_subset [OF intf], auto simp add: min_def max_def)
  qed (insert assms, auto)
qed

lemma einterval_antiderivative:
  fixes a b :: ereal and f :: "real \<Rightarrow> 'a::euclidean_space"
  assumes "a < b" and contf: "\<And>x :: real. a < x \<Longrightarrow> x < b \<Longrightarrow> isCont f x"
  shows "\<exists>F. \<forall>x :: real. a < x \<longrightarrow> x < b \<longrightarrow> (F has_vector_derivative f x) (at x)"
proof -
  from einterval_nonempty [OF `a < b`] obtain c :: real where [simp]: "a < c" "c < b"
    by (auto simp add: einterval_def)
  let ?F = "(\<lambda>u. LBINT y=c..u. f y)"
  show ?thesis
  proof (rule exI, clarsimp)
    fix x :: real
    assume [simp]: "a < x" "x < b"
    have 1: "a < min c x" by simp
    from einterval_nonempty [OF 1] obtain d :: real where [simp]: "a < d" "d < c" "d < x"
      by (auto simp add: einterval_def)
    have 2: "max c x < b" by simp
    from einterval_nonempty [OF 2] obtain e :: real where [simp]: "c < e" "x < e" "e < b"
      by (auto simp add: einterval_def)
    show "(?F has_vector_derivative f x) (at x)"
      (* TODO: factor out the next three lines to has_field_derivative_within_open *)
      unfolding has_vector_derivative_def
      apply (subst has_derivative_within_open [of _ "{d<..<e}", symmetric], auto)
      apply (subst has_vector_derivative_def [symmetric])
      apply (rule has_vector_derivative_within_subset [of _ _ _ "{d..e}"])
      apply (rule interval_integral_FTC2, auto simp add: less_imp_le)
      apply (rule continuous_at_imp_continuous_on)
      apply (auto intro!: contf)
      apply (rule order_less_le_trans, rule `a < d`, auto)
      apply (rule order_le_less_trans) prefer 2
      by (rule `e < b`, auto)
  qed
qed

(*
    The substitution theorem

    Once again, three versions: first, for finite intervals, and then two versions for
    arbitrary intervals.
*)

lemma interval_integral_substitution_finite:
  fixes a b :: real and f :: "real \<Rightarrow> 'a::euclidean_space"
  assumes "a \<le> b"
  and derivg: "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> (g has_real_derivative (g' x)) (at x within {a..b})"
  and contf : "continuous_on (g ` {a..b}) f"
  and contg': "continuous_on {a..b} g'"
  shows "LBINT x=a..b. g' x *\<^sub>R f (g x) = LBINT y=g a..g b. f y"
proof-
  have v_derivg: "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> (g has_vector_derivative (g' x)) (at x within {a..b})"
    using derivg unfolding has_field_derivative_iff_has_vector_derivative .
  then have contg [simp]: "continuous_on {a..b} g"
    by (rule continuous_on_vector_derivative) auto
  have 1: "\<And>u. min (g a) (g b) \<le> u \<Longrightarrow> u \<le> max (g a) (g b) \<Longrightarrow>
      \<exists>x\<in>{a..b}. u = g x"
    apply (case_tac "g a \<le> g b")
    apply (auto simp add: min_def max_def less_imp_le)
    apply (frule (1) IVT' [of g], auto simp add: assms)
    by (frule (1) IVT2' [of g], auto simp add: assms)
  from contg `a \<le> b` have "\<exists>c d. g ` {a..b} = {c..d} \<and> c \<le> d"
    by (elim continuous_image_closed_interval)
  then obtain c d where g_im: "g ` {a..b} = {c..d}" and "c \<le> d" by auto
  have "\<exists>F. \<forall>x\<in>{a..b}. (F has_vector_derivative (f (g x))) (at (g x) within (g ` {a..b}))"
    apply (rule exI, auto, subst g_im)
    apply (rule interval_integral_FTC2 [of c c d])
    using `c \<le> d` apply auto
    apply (rule continuous_on_subset [OF contf])
    using g_im by auto
  then guess F ..
  then have derivF: "\<And>x. a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow>
    (F has_vector_derivative (f (g x))) (at (g x) within (g ` {a..b}))" by auto
  have contf2: "continuous_on {min (g a) (g b)..max (g a) (g b)} f"
    apply (rule continuous_on_subset [OF contf])
    apply (auto simp add: image_def)
    by (erule 1)
  have contfg: "continuous_on {a..b} (\<lambda>x. f (g x))"
    by (blast intro: continuous_on_compose2 contf contg)
  have "LBINT x=a..b. g' x *\<^sub>R f (g x) = F (g b) - F (g a)"
    apply (subst interval_integral_Icc, simp add: assms)
    apply (rule integral_FTC_atLeastAtMost[of a b "\<lambda>x. F (g x)", OF `a \<le> b`])
    apply (rule vector_diff_chain_within[OF v_derivg derivF, unfolded comp_def])
    apply (auto intro!: continuous_on_scaleR contg' contfg)
    done
  moreover have "LBINT y=(g a)..(g b). f y = F (g b) - F (g a)"
    apply (rule interval_integral_FTC_finite)
    apply (rule contf2)
    apply (frule (1) 1, auto)
    apply (rule has_vector_derivative_within_subset [OF derivF])
    apply (auto simp add: image_def)
    by (rule 1, auto)
  ultimately show ?thesis by simp
qed

(* TODO: is it possible to lift the assumption here that g' is nonnegative? *)

lemma interval_integral_substitution_integrable:
  fixes f :: "real \<Rightarrow> 'a::euclidean_space" and a b u v :: ereal
  assumes "a < b"
  and deriv_g: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> DERIV g x :> g' x"
  and contf: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont f (g x)"
  and contg': "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont g' x"
  and g'_nonneg: "\<And>x. a \<le> ereal x \<Longrightarrow> ereal x \<le> b \<Longrightarrow> 0 \<le> g' x"
  and A: "((ereal \<circ> g \<circ> real) ---> A) (at_right a)"
  and B: "((ereal \<circ> g \<circ> real) ---> B) (at_left b)"
  and integrable: "set_integrable lborel (einterval a b) (\<lambda>x. g' x *\<^sub>R f (g x))"
  and integrable2: "set_integrable lborel (einterval A B) (\<lambda>x. f x)"
  shows "(LBINT x=A..B. f x) = (LBINT x=a..b. g' x *\<^sub>R f (g x))"
proof -
  from einterval_Icc_approximation[OF `a < b`] guess u l . note approx [simp] = this
  note less_imp_le [simp]
  have [simp]: "\<And>x i. l i \<le> x \<Longrightarrow> a < ereal x"
    by (rule order_less_le_trans, rule approx, force)
  have [simp]: "\<And>x i. x \<le> u i \<Longrightarrow> ereal x < b"
    by (rule order_le_less_trans, subst ereal_less_eq(3), assumption, rule approx)
  have [simp]: "\<And>i. l i < b"
    apply (rule order_less_trans) prefer 2
    by (rule approx, auto, rule approx)
  have [simp]: "\<And>i. a < u i"
    by (rule order_less_trans, rule approx, auto, rule approx)
  have [simp]: "\<And>i j. i \<le> j \<Longrightarrow> l j \<le> l i" by (rule decseqD, rule approx)
  have [simp]: "\<And>i j. i \<le> j \<Longrightarrow> u i \<le> u j" by (rule incseqD, rule approx)
  have g_nondec [simp]: "\<And>x y. a < x \<Longrightarrow> x \<le> y \<Longrightarrow> y < b \<Longrightarrow> g x \<le> g y"
    apply (erule DERIV_nonneg_imp_nondecreasing, auto)
    apply (rule exI, rule conjI, rule deriv_g)
    apply (erule order_less_le_trans, auto)
    apply (rule order_le_less_trans, subst ereal_less_eq(3), assumption, auto)
    apply (rule g'_nonneg)
    apply (rule less_imp_le, erule order_less_le_trans, auto)
    by (rule less_imp_le, rule le_less_trans, subst ereal_less_eq(3), assumption, auto)
  have "A \<le> B" and un: "einterval A B = (\<Union>i. {g(l i)<..<g(u i)})"
  proof -
    have A2: "(\<lambda>i. g (l i)) ----> A"
      using A apply (auto simp add: einterval_def tendsto_at_iff_sequentially comp_def)
      by (drule_tac x = "\<lambda>i. ereal (l i)" in spec, auto)
    hence A3: "\<And>i. g (l i) \<ge> A"
      by (intro decseq_le, auto simp add: decseq_def)
    have B2: "(\<lambda>i. g (u i)) ----> B"
      using B apply (auto simp add: einterval_def tendsto_at_iff_sequentially comp_def)
      by (drule_tac x = "\<lambda>i. ereal (u i)" in spec, auto)
    hence B3: "\<And>i. g (u i) \<le> B"
      by (intro incseq_le, auto simp add: incseq_def)
    show "A \<le> B"
      apply (rule order_trans [OF A3 [of 0]])
      apply (rule order_trans [OF _ B3 [of 0]])
      by auto
    { fix x :: real
      assume "A < x" and "x < B"
      then have "eventually (\<lambda>i. ereal (g (l i)) < x \<and> x < ereal (g (u i))) sequentially"
        apply (intro eventually_conj order_tendstoD)
        by (rule A2, assumption, rule B2, assumption)
      hence "\<exists>i. g (l i) < x \<and> x < g (u i)"
        by (simp add: eventually_sequentially, auto)
    } note AB = this
    show "einterval A B = (\<Union>i. {g(l i)<..<g(u i)})"
      apply (auto simp add: einterval_def)
      apply (erule (1) AB)
      apply (rule order_le_less_trans, rule A3, simp)
      apply (rule order_less_le_trans) prefer 2
      by (rule B3, simp)
  qed
  (* finally, the main argument *)
  {
     fix i
     have "(LBINT x=l i.. u i. g' x *\<^sub>R f (g x)) = (LBINT y=g (l i)..g (u i). f y)"
        apply (rule interval_integral_substitution_finite, auto)
        apply (rule DERIV_subset)
        unfolding has_field_derivative_iff_has_vector_derivative[symmetric]
        apply (rule deriv_g)
        apply (auto intro!: continuous_at_imp_continuous_on contf contg')
        done
  } note eq1 = this
  have "(\<lambda>i. LBINT x=l i..u i. g' x *\<^sub>R f (g x)) ----> (LBINT x=a..b. g' x *\<^sub>R f (g x))"
    apply (rule interval_integral_Icc_approx_integrable [OF `a < b` approx])
    by (rule assms)
  hence 2: "(\<lambda>i. (LBINT y=g (l i)..g (u i). f y)) ----> (LBINT x=a..b. g' x *\<^sub>R f (g x))"
    by (simp add: eq1)
  have incseq: "incseq (\<lambda>i. {g (l i)<..<g (u i)})"
    apply (auto simp add: incseq_def)
    apply (rule order_le_less_trans)
    prefer 2 apply (assumption, auto)
    by (erule order_less_le_trans, rule g_nondec, auto)
  have "(\<lambda>i. (LBINT y=g (l i)..g (u i). f y)) ----> (LBINT x = A..B. f x)"
    apply (subst interval_lebesgue_integral_le_eq, auto simp del: real_scaleR_def)
    apply (subst interval_lebesgue_integral_le_eq, rule `A \<le> B`)
    apply (subst un, rule set_integral_cont_up, auto simp del: real_scaleR_def)
    apply (rule incseq)
    apply (subst un [symmetric])
    by (rule integrable2)
  thus ?thesis by (intro LIMSEQ_unique [OF _ 2])
qed

(* TODO: the last two proofs are only slightly different. Factor out common part?
   An alternative: make the second one the main one, and then have another lemma
   that says that if f is nonnegative and all the other hypotheses hold, then it is integrable. *)

lemma interval_integral_substitution_nonneg:
  fixes f g g':: "real \<Rightarrow> real" and a b u v :: ereal
  assumes "a < b"
  and deriv_g: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> DERIV g x :> g' x"
  and contf: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont f (g x)"
  and contg': "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> isCont g' x"
  and f_nonneg: "\<And>x. a < ereal x \<Longrightarrow> ereal x < b \<Longrightarrow> 0 \<le> f (g x)" (* TODO: make this AE? *)
  and g'_nonneg: "\<And>x. a \<le> ereal x \<Longrightarrow> ereal x \<le> b \<Longrightarrow> 0 \<le> g' x"
  and A: "((ereal \<circ> g \<circ> real) ---> A) (at_right a)"
  and B: "((ereal \<circ> g \<circ> real) ---> B) (at_left b)"
  and integrable_fg: "set_integrable lborel (einterval a b) (\<lambda>x. f (g x) * g' x)"
  shows
    "set_integrable lborel (einterval A B) f"
    "(LBINT x=A..B. f x) = (LBINT x=a..b. (f (g x) * g' x))"
proof -
  from einterval_Icc_approximation[OF `a < b`] guess u l . note approx [simp] = this
  note less_imp_le [simp]
  have [simp]: "\<And>x i. l i \<le> x \<Longrightarrow> a < ereal x"
    by (rule order_less_le_trans, rule approx, force)
  have [simp]: "\<And>x i. x \<le> u i \<Longrightarrow> ereal x < b"
    by (rule order_le_less_trans, subst ereal_less_eq(3), assumption, rule approx)
  have [simp]: "\<And>i. l i < b"
    apply (rule order_less_trans) prefer 2
    by (rule approx, auto, rule approx)
  have [simp]: "\<And>i. a < u i"
    by (rule order_less_trans, rule approx, auto, rule approx)
  have [simp]: "\<And>i j. i \<le> j \<Longrightarrow> l j \<le> l i" by (rule decseqD, rule approx)
  have [simp]: "\<And>i j. i \<le> j \<Longrightarrow> u i \<le> u j" by (rule incseqD, rule approx)
  have g_nondec [simp]: "\<And>x y. a < x \<Longrightarrow> x \<le> y \<Longrightarrow> y < b \<Longrightarrow> g x \<le> g y"
    apply (erule DERIV_nonneg_imp_nondecreasing, auto)
    apply (rule exI, rule conjI, rule deriv_g)
    apply (erule order_less_le_trans, auto)
    apply (rule order_le_less_trans, subst ereal_less_eq(3), assumption, auto)
    apply (rule g'_nonneg)
    apply (rule less_imp_le, erule order_less_le_trans, auto)
    by (rule less_imp_le, rule le_less_trans, subst ereal_less_eq(3), assumption, auto)
  have "A \<le> B" and un: "einterval A B = (\<Union>i. {g(l i)<..<g(u i)})"
  proof -
    have A2: "(\<lambda>i. g (l i)) ----> A"
      using A apply (auto simp add: einterval_def tendsto_at_iff_sequentially comp_def)
      by (drule_tac x = "\<lambda>i. ereal (l i)" in spec, auto)
    hence A3: "\<And>i. g (l i) \<ge> A"
      by (intro decseq_le, auto simp add: decseq_def)
    have B2: "(\<lambda>i. g (u i)) ----> B"
      using B apply (auto simp add: einterval_def tendsto_at_iff_sequentially comp_def)
      by (drule_tac x = "\<lambda>i. ereal (u i)" in spec, auto)
    hence B3: "\<And>i. g (u i) \<le> B"
      by (intro incseq_le, auto simp add: incseq_def)
    show "A \<le> B"
      apply (rule order_trans [OF A3 [of 0]])
      apply (rule order_trans [OF _ B3 [of 0]])
      by auto
    { fix x :: real
      assume "A < x" and "x < B"
      then have "eventually (\<lambda>i. ereal (g (l i)) < x \<and> x < ereal (g (u i))) sequentially"
        apply (intro eventually_conj order_tendstoD)
        by (rule A2, assumption, rule B2, assumption)
      hence "\<exists>i. g (l i) < x \<and> x < g (u i)"
        by (simp add: eventually_sequentially, auto)
    } note AB = this
    show "einterval A B = (\<Union>i. {g(l i)<..<g(u i)})"
      apply (auto simp add: einterval_def)
      apply (erule (1) AB)
      apply (rule order_le_less_trans, rule A3, simp)
      apply (rule order_less_le_trans) prefer 2
      by (rule B3, simp)
  qed
  (* finally, the main argument *)
  {
     fix i
     have "(LBINT x=l i.. u i. g' x *\<^sub>R f (g x)) = (LBINT y=g (l i)..g (u i). f y)"
        apply (rule interval_integral_substitution_finite, auto)
        apply (rule DERIV_subset, rule deriv_g, auto)
        apply (rule continuous_at_imp_continuous_on, auto, rule contf, auto)
        by (rule continuous_at_imp_continuous_on, auto, rule contg', auto)
     then have "(LBINT x=l i.. u i. (f (g x) * g' x)) = (LBINT y=g (l i)..g (u i). f y)"
       by (simp add: ac_simps)
  } note eq1 = this
  have "(\<lambda>i. LBINT x=l i..u i. f (g x) * g' x)
      ----> (LBINT x=a..b. f (g x) * g' x)"
    apply (rule interval_integral_Icc_approx_integrable [OF `a < b` approx])
    by (rule assms)
  hence 2: "(\<lambda>i. (LBINT y=g (l i)..g (u i). f y)) ----> (LBINT x=a..b. f (g x) * g' x)"
    by (simp add: eq1)
  have incseq: "incseq (\<lambda>i. {g (l i)<..<g (u i)})"
    apply (auto simp add: incseq_def)
    apply (rule order_le_less_trans)
    prefer 2 apply assumption
    apply (rule g_nondec, auto)
    by (erule order_less_le_trans, rule g_nondec, auto)
  have img: "\<And>x i. g (l i) \<le> x \<Longrightarrow> x \<le> g (u i) \<Longrightarrow> \<exists>c \<ge> l i. c \<le> u i \<and> x = g c"
    apply (frule (1) IVT' [of g], auto)
    apply (rule continuous_at_imp_continuous_on, auto)
    by (rule DERIV_isCont, rule deriv_g, auto)
  have nonneg_f2: "\<And>x i. g (l i) \<le> x \<Longrightarrow> x \<le> g (u i) \<Longrightarrow> 0 \<le> f x"
    by (frule (1) img, auto, rule f_nonneg, auto)
  have contf_2: "\<And>x i. g (l i) \<le> x \<Longrightarrow> x \<le> g (u i) \<Longrightarrow> isCont f x"
    by (frule (1) img, auto, rule contf, auto)
  have integrable: "set_integrable lborel (\<Union>i. {g (l i)<..<g (u i)}) f"
    apply (rule pos_integrable_to_top, auto simp del: real_scaleR_def)
    apply (rule incseq)
    apply (rule nonneg_f2, erule less_imp_le, erule less_imp_le)
    apply (rule set_integrable_subset)
    apply (rule borel_integrable_atLeastAtMost')
    apply (rule continuous_at_imp_continuous_on)
    apply (clarsimp, erule (1) contf_2, auto)
    apply (erule less_imp_le)+
    using 2 unfolding interval_lebesgue_integral_def
    by auto
  thus "set_integrable lborel (einterval A B) f"
    by (simp add: un)

  have "(LBINT x=A..B. f x) = (LBINT x=a..b. g' x *\<^sub>R f (g x))"
  proof (rule interval_integral_substitution_integrable)
    show "set_integrable lborel (einterval a b) (\<lambda>x. g' x *\<^sub>R f (g x))"
      using integrable_fg by (simp add: ac_simps)
  qed fact+
  then show "(LBINT x=A..B. f x) = (LBINT x=a..b. (f (g x) * g' x))"
    by (simp add: ac_simps)
qed

syntax
"_complex_lebesgue_borel_integral" :: "pttrn \<Rightarrow> real \<Rightarrow> complex"
("(2CLBINT _. _)" [0,60] 60)

translations
"CLBINT x. f" == "CONST complex_lebesgue_integral CONST lborel (\<lambda>x. f)"

syntax
"_complex_set_lebesgue_borel_integral" :: "pttrn \<Rightarrow> real set \<Rightarrow> real \<Rightarrow> complex"
("(3CLBINT _:_. _)" [0,60,61] 60)

translations
"CLBINT x:A. f" == "CONST complex_set_lebesgue_integral CONST lborel A (\<lambda>x. f)"

abbreviation complex_interval_lebesgue_integral ::
    "real measure \<Rightarrow> ereal \<Rightarrow> ereal \<Rightarrow> (real \<Rightarrow> complex) \<Rightarrow> complex" where
  "complex_interval_lebesgue_integral M a b f \<equiv> interval_lebesgue_integral M a b f"

abbreviation complex_interval_lebesgue_integrable ::
  "real measure \<Rightarrow> ereal \<Rightarrow> ereal \<Rightarrow> (real \<Rightarrow> complex) \<Rightarrow> bool" where
  "complex_interval_lebesgue_integrable M a b f \<equiv> interval_lebesgue_integrable M a b f"

syntax
  "_ascii_complex_interval_lebesgue_borel_integral" :: "pttrn \<Rightarrow> ereal \<Rightarrow> ereal \<Rightarrow> real \<Rightarrow> complex"
  ("(4CLBINT _=_.._. _)" [0,60,60,61] 60)

translations
  "CLBINT x=a..b. f" == "CONST complex_interval_lebesgue_integral CONST lborel a b (\<lambda>x. f)"

lemma interval_integral_norm:
  fixes f :: "real \<Rightarrow> 'a :: {banach, second_countable_topology}"
  shows "interval_lebesgue_integrable lborel a b f \<Longrightarrow> a \<le> b \<Longrightarrow>
    norm (LBINT t=a..b. f t) \<le> LBINT t=a..b. norm (f t)"
  using integral_norm_bound[of lborel "\<lambda>x. indicator (einterval a b) x *\<^sub>R f x"]
  by (auto simp add: interval_lebesgue_integral_def interval_lebesgue_integrable_def)

lemma interval_integral_norm2:
  "interval_lebesgue_integrable lborel a b f \<Longrightarrow>
    norm (LBINT t=a..b. f t) \<le> abs (LBINT t=a..b. norm (f t))"
proof (induct a b rule: linorder_wlog)
  case (sym a b) then show ?case
    by (simp add: interval_integral_endpoints_reverse[of a b] interval_integrable_endpoints_reverse[of a b])
next
  case (le a b)
  then have "\<bar>LBINT t=a..b. norm (f t)\<bar> = LBINT t=a..b. norm (f t)"
    using integrable_norm[of lborel "\<lambda>x. indicator (einterval a b) x *\<^sub>R f x"]
    by (auto simp add: interval_lebesgue_integral_def interval_lebesgue_integrable_def
             intro!: integral_nonneg_AE abs_of_nonneg)
  then show ?case
    using le by (simp add: interval_integral_norm)
qed

(* TODO: should we have a library of facts like these? *)
lemma integral_cos: "t \<noteq> 0 \<Longrightarrow> LBINT x=a..b. cos (t * x) = sin (t * b) / t - sin (t * a) / t"
  apply (intro interval_integral_FTC_finite continuous_intros)
  by (auto intro!: derivative_eq_intros simp: has_field_derivative_iff_has_vector_derivative[symmetric])

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_mod_same
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun minus :: "Nat => Nat => Nat" where
"minus (Z) y = Z"
| "minus (S z) (S y2) = minus z y2"

fun lt :: "Nat => Nat => bool" where
"lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S n) (S z) = lt n z"

(*fun did not finish the proof*)
function mod2 :: "Nat => Nat => Nat" where
"mod2 x (Z) = Z"
| "mod2 x (S z) =
     (if lt x (S z) then x else mod2 (minus x (S z)) (S z))"
by pat_completeness auto

fun go :: "Nat => Nat => Nat => Nat" where
"go x y (Z) = Z"
| "go (Z) (Z) (S x2) = Z"
| "go (Z) (S x5) (S x2) = minus (S x2) (S x5)"
| "go (S x3) (Z) (S x2) = go x3 x2 (S x2)"
| "go (S x3) (S x4) (S x2) = go x3 x4 (S x2)"

fun modstructural :: "Nat => Nat => Nat" where
"modstructural x y = go x Z y"

theorem property0 :
  "((mod2 m n) = (modstructural m n))"
  oops

end


theory Pls_ac
  imports Main  "~~/src/HOL/Library/BNF_Corec" "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

primcorec pls :: "nat Stream \<Rightarrow> nat Stream \<Rightarrow> nat Stream" where
  "pls s t = SCons (plus (shd s) (shd t)) (pls (stl s) (stl t))"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"
(*hipster_obs Stream Lst obsStream pls
fins nothing *)
lemma pls_ac: "pls s (pls t u) = pls t (pls s u)"
  by hipster_coinduct_sledgehammer

end


theory Zahlenwelt
imports BeispielPerson ExecutableHelper Swap SchleierNichtwissen
begin

section\<open>Zahlenwelt Helper\<close>
text\<open>In diesem Abschnitt definieren wir Hilfsfunktionen für kommende "Zahlenwelt" Beispiele.\<close>

text\<open>Wir werden Beispiele betrachten, in denen wir Welten modellieren, in denen jeder Person eine
Zahl zugewiesen wird, Typ \<^typ>\<open>person \<Rightarrow> int\<close>.
Diese Zahl kann zum Beispiel der Besitz oder Wohlstand einer Person sein, oder das Einkommen.
Dabei ist zu beachten,
dass Gesamtbesitz und Einkommen (über einen kurzen Zeitraum) recht unterschiedliche Sachen
modellieren, jedoch den gleichen Typen in unserem Modell haben werden.

Hier sind einige Hilfsfunktionen um mit dem Typ \<^typ>\<open>person \<Rightarrow> int\<close> allgemein zu arbeiten.\<close>

text\<open>Default: Standardmäßig hat jede Person \<^term>\<open>0::int\<close>:\<close>
definition DEFAULT :: \<open>person \<Rightarrow> int\<close> ("\<euro>") where
  \<open>DEFAULT \<equiv> \<lambda>p. 0\<close>

beispiel \<open>(DEFAULT(Alice:=8, Bob:=3, Eve:= 5)) Bob = 3\<close> by eval

text\<open>Beispiel mit fancy Syntax:\<close>
beispiel \<open>(\<euro>(Alice:=8, Bob:=3, Eve:= 5)) Bob = 3\<close> by eval

text\<open>Das Beispiel liest sich wie folgt.
Die Welt @{term_type [source=true] \<open>(\<euro>(Alice:=8, Bob:=3, Eve:= 5)) :: person \<Rightarrow> int\<close>} ist eine Funktion von
\<^typ>\<open>person\<close> nach \<^typ>\<open>int\<close>.
Wir rufen diese Funktion mit den Parameter \<^const>\<open>Bob\<close> auf.
Das Ergebnis ist \<^term>\<open>3::int\<close>.\<close>

text\<open>Die Funktion @{term [source=true] \<open>(\<euro>(Alice := 4, Carol := 4))\<close>} lässt sich auch mit Hilfe folgender
Hilfsfunktionen als eine Menge von Tupeln darstellen.\<close>
beispiel \<open>show_fun (\<euro>(Alice := 4, Carol := 4)) = [(Alice, 4), (Bob, 0), (Carol, 4), (Eve, 0)]\<close> by eval
beispiel \<open>show_num_fun (\<euro>(Alice := 4, Carol := 4)) = [(Alice, 4), (Carol, 4)]\<close> by eval

text\<open>Folgende Syntaxabkürzungen erlauben es uns eine einfachere Notation einzuführen,
um den Besitz einer Person zu erhöhen oder zu verringern.\<close>
(* this can produce ambiguous parse trees. So I added those \<lbrakk>\<rbrakk> *)
abbreviation num_fun_add_syntax ("\<lbrakk>_ '(_ += _')\<rbrakk>") where
  \<open>\<lbrakk>f(p += n)\<rbrakk> \<equiv> (f(p := (f p) + n))\<close>

abbreviation num_fun_minus_syntax ("\<lbrakk>_ '(_ -= _')\<rbrakk>") where
  \<open>\<lbrakk>f(p -= n)\<rbrakk> \<equiv> (f(p := (f p) - n))\<close>

beispiel \<open>\<lbrakk>\<euro>(Alice:=8, Bob:=3, Eve:= 5)(Bob += 4)\<rbrakk> Bob = 7\<close> by eval
beispiel \<open>\<lbrakk>\<euro>(Alice:=8, Bob:=3, Eve:= 5)(Bob -= 4)\<rbrakk> Bob = -1\<close> by eval

text\<open>Erhöhen und verringern heben sich auf.\<close>
beispiel fixes n:: \<open>int\<close> shows \<open>\<lbrakk>\<lbrakk>f(p += n)\<rbrakk>(p -= n)\<rbrakk> = f\<close> by(simp)

text\<open>Folgende Funktion wählt diskriminierungsfrei
eine \<^typ>\<open>'person\<close> eindeutig anhand Ihres Besitzes aus.\<close>
definition opfer_eindeutig_nach_besitz_auswaehlen
  :: \<open>int \<Rightarrow> ('person \<Rightarrow> int) \<Rightarrow> 'person list \<Rightarrow> 'person option\<close> where
  \<open>opfer_eindeutig_nach_besitz_auswaehlen b besitz ps =
     (case filter (\<lambda>p. besitz p = b) ps
        of [opfer] \<Rightarrow> Some opfer
         | _ \<Rightarrow> None)\<close>

(*<*)
lemma case_filter_empty_some_helper:
  \<open>(case filter P ps of [] \<Rightarrow> Some a | aa # x \<Rightarrow> Map.empty x) = Some x
  \<longleftrightarrow> (\<forall>x\<in>set ps. \<not> P x) \<and> a = x\<close>
  apply(simp add: list.case_eq_if)
  using empty_filter_conv by metis

lemma case_filter_empty_some_helper2:
  \<open>(case if P a then a # filter P ps else filter P ps of
        [] \<Rightarrow> None | [opfer] \<Rightarrow> Some opfer | opfer # aa # x \<Rightarrow> Map.empty x) =
       Some x \<longleftrightarrow>
  (P a \<and> x = a \<and> filter P ps = []) \<or> (\<not>P a \<and> filter P ps = [x])\<close>
  apply(cases \<open>P a\<close>)
   apply(simp add: case_filter_empty_some_helper)
   apply(metis empty_filter_conv)
  apply(simp)
  apply(cases \<open>filter P ps\<close>)
   apply(simp)
  by(simp split: list.split)

lemma case_filter_empty_some_helper3:
  \<open>(case filter P ps of [] \<Rightarrow> None | [opfer] \<Rightarrow> Some opfer
            | opfer # aa # x \<Rightarrow> Map.empty x) =
           Some opfer
    \<longleftrightarrow>
    filter P ps = [opfer]\<close>
  by(simp split: list.split)

lemma opfer_eindeutig_nach_besitz_auswaehlen_injective:
  \<open>opfer_eindeutig_nach_besitz_auswaehlen opfer_nach_besitz besitz ps = Some opfer
  \<Longrightarrow> inj_on besitz {p \<in> set ps. besitz p = opfer_nach_besitz}\<close>
  apply(simp add: inj_on_def)
  apply(safe)
  apply(induction \<open>ps\<close>)
   apply(simp)
  apply(simp)
  apply(simp add: opfer_eindeutig_nach_besitz_auswaehlen_def)
  apply(safe)
    apply(simp_all)
    apply(simp add: case_filter_empty_some_helper; fail)
   apply(simp add: case_filter_empty_some_helper)
   apply fastforce
  apply(simp add: case_filter_empty_some_helper3)
  apply(simp add: case_filter_empty_some_helper2[of \<open>(\<lambda>p. besitz p = besitz _)\<close>])
  by (metis (mono_tags) empty_filter_conv)
(*>*)

text\<open>Folgende Hilfsdefinition definiert eindeutig das Element in einer Einelementigen Menge,
wenn dieses existiert.\<close>
definition the_single_elem :: \<open>'a set \<Rightarrow> 'a option\<close> where
  \<open>the_single_elem s \<equiv> if card s = 1 then Some (Set.the_elem s) else None\<close>

beispiel \<open>the_single_elem {a} = Some a\<close> by(simp add: the_single_elem_def)
beispiel \<open>the_single_elem {1::nat,2} = None\<close> by(simp add: the_single_elem_def)
beispiel \<open>the_single_elem {} = None\<close> by(simp add: the_single_elem_def)

text\<open>Hier sehen wir unser Shallow Embedding:
Unsere Definition \<^const>\<open>the_single_elem\<close> lässt sich komplett auf bereits existierende Konzepte
in HOL reduzieren.\<close>
lemma the_single_elem:
  \<open>the_single_elem s = (if is_singleton s then Some (Set.the_elem s) else None)\<close>
  apply(simp add: is_singleton_the_elem the_single_elem_def card_1_singleton_iff)
  by auto

(*<*)
lemma \<open>the_single_elem {a} = Some a\<close>
  by(simp add: the_single_elem_def)
lemma \<open>a \<noteq> b \<Longrightarrow> the_single_elem {a,b} = None\<close>
  by(simp add: the_single_elem_def)

lemma the_single_elem_exhaust:
  \<open>(the_single_elem S = None \<Longrightarrow> P None) \<Longrightarrow>
        (\<And>x. the_single_elem S = Some x \<Longrightarrow> P (Some x)) \<Longrightarrow> P (the_single_elem S)\<close>
apply(cases \<open>the_single_elem S\<close>)
by(auto)
(*>*)

lemma opfer_nach_besitz_induct_step_set_simp: \<open>besitz a \<noteq> opfer_nach_besitz \<Longrightarrow>
  {p. (p = a \<or> p \<in> set ps) \<and> besitz p = opfer_nach_besitz} =
    {p \<in> set ps. besitz p = opfer_nach_besitz}\<close>
  by auto

lemma opfer_eindeutig_nach_besitz_auswaehlen_the_single_elem:
  \<open>distinct ps \<Longrightarrow>
  opfer_eindeutig_nach_besitz_auswaehlen opfer_nach_besitz besitz ps =
          the_single_elem {p \<in> set ps. besitz p = opfer_nach_besitz}\<close>
proof(simp add: the_single_elem, intro conjI impI)
  show \<open>distinct ps \<Longrightarrow>
    is_singleton {p \<in> set ps. besitz p = opfer_nach_besitz} \<Longrightarrow>
    opfer_eindeutig_nach_besitz_auswaehlen opfer_nach_besitz besitz ps =
    Some (the_elem {p \<in> set ps. besitz p = opfer_nach_besitz})\<close>
    apply(induction \<open>ps\<close>)
     apply (simp add: is_singleton_altdef; fail)
    apply(simp)
    apply(simp add: opfer_eindeutig_nach_besitz_auswaehlen_def)
    apply(simp add: is_singleton_the_elem)
    apply(simp add: case_filter_empty_some_helper case_filter_empty_some_helper3)
    apply(safe)
      apply (metis (mono_tags, lifting) mem_Collect_eq singleton_iff)
     apply (metis (mono_tags, lifting) mem_Collect_eq singleton_iff)
    apply(simp add: opfer_nach_besitz_induct_step_set_simp; fail)
    done
next
  show \<open>distinct ps \<Longrightarrow>
    \<not> is_singleton {p \<in> set ps. besitz p = opfer_nach_besitz} \<Longrightarrow>
    opfer_eindeutig_nach_besitz_auswaehlen opfer_nach_besitz besitz ps = None\<close>
    apply(induction \<open>ps\<close>)
     apply(simp add: opfer_eindeutig_nach_besitz_auswaehlen_def; fail)
    apply(simp add: opfer_eindeutig_nach_besitz_auswaehlen_def)
    apply(safe)
     apply(simp split: list.split)
     apply(simp add: filter_empty_conv is_singleton_def)
     apply blast
    by(simp add: opfer_nach_besitz_induct_step_set_simp)
qed

lemma opfer_eindeutig_nach_besitz_auswaehlen_the_single_elem_enumall:
  \<open>opfer_eindeutig_nach_besitz_auswaehlen opfer_nach_besitz besitz enum_class.enum =
          the_single_elem {p. besitz p = opfer_nach_besitz}\<close>
  apply(subst opfer_eindeutig_nach_besitz_auswaehlen_the_single_elem)
  using enum_class.enum_distinct apply(simp)
  apply(simp add: enum_class.enum_UNIV)
  done

(*<*)
lemma \<open>p1 \<in> Ps \<Longrightarrow> p2 \<in> Ps \<Longrightarrow>
  {pa \<in> Ps. swap p1 p2 besitz pa = b} = {p2} \<longleftrightarrow> {pa \<in> Ps. besitz pa = b} = {p1}\<close>
  apply(simp add: singleton_set_to_all)
  by (metis swap_b swap_nothing swap_symmetric)

lemma the_elem_singleton_swap:
  \<open>p1 \<in> Ps \<Longrightarrow>
    p2 \<in> Ps \<Longrightarrow>
    the_elem {pa \<in> Ps. swap p1 p2 besitz pa = b} = p2 \<Longrightarrow>
    is_singleton {pa \<in> Ps. swap p1 p2 besitz pa = b} \<Longrightarrow>
    is_singleton {pa \<in> Ps. besitz pa = b} \<Longrightarrow> the_elem {pa \<in> Ps. besitz pa = b} = p1\<close>
  apply(simp add: is_singleton_the_elem_as_set)
  apply(elim is_singletonE)
  apply(simp add: singleton_set_to_all)
  by (metis swap_b)

lemma the_elem_singleton_swap_none:
    \<open>p1 \<in> set ps \<Longrightarrow>
    p2 \<in> set ps \<Longrightarrow>
    the_elem {pa \<in> set ps. swap p1 p2 besitz pa = p} \<noteq> p2 \<Longrightarrow>
    the_elem {pa \<in> set ps. swap p1 p2 besitz pa = p} \<noteq> p1 \<Longrightarrow>
    is_singleton {pa \<in> set ps. besitz pa = p} \<Longrightarrow>
    is_singleton {pa \<in> set ps. swap p1 p2 besitz pa = p} \<Longrightarrow>
    the_elem {pa \<in> set ps. swap p1 p2 besitz pa = p} = the_elem {pa \<in> set ps. besitz pa = p}\<close>
  apply(rule arg_cong[of _ _ \<open>the_elem\<close>])
  apply(rule Collect_cong)
  apply(elim is_singletonE)
  apply(simp add: is_singleton_the_elem_as_set)
  apply(simp add: singleton_set_to_all)
  by (metis swap_nothing)

lemma set_swap_image_pullout:
  \<open>p1 \<in> A \<Longrightarrow>
   p2 \<in> A \<Longrightarrow>
    {a \<in> A. swap p1 p2 besitz a = b} = swap p1 p2 id ` {a \<in> A. besitz a = b}\<close>
  apply(simp add: image_def)
  apply(rule Collect_cong)
  apply(safe)
    apply(rule swap_cases)
      apply(rule_tac x=\<open>p2\<close> in exI, simp add: swap_a swap_b; fail)
     apply(rule_tac x=\<open>p1\<close> in exI, simp add: swap_a swap_b; fail)
    apply(rule_tac x=\<open>a\<close> in exI, simp add: swap_a swap_b swap_nothing; fail)
   apply(rule swap_cases, simp_all add: swap_a swap_b swap_nothing)
  by (simp add: swap_fun_swap_id)

lemma is_singleton_swap:
  \<open>p1 \<in> set ps \<Longrightarrow>
   p2 \<in> set ps \<Longrightarrow>
    is_singleton {pa \<in> set ps. swap p1 p2 besitz pa = p}
    \<longleftrightarrow> is_singleton {pa \<in> set ps. besitz pa = p}\<close>
  apply(simp add: set_swap_image_pullout)
  apply(rule is_singleton_bij_image)
  by (simp add: involuntory_imp_bij swap_fun_swap_id)

lemma if_swap_person_help_same: \<open>p1 = a \<Longrightarrow>
       p2 = a \<Longrightarrow>
       (\<lambda>p. if p = a then p2 else if p = p2 then p1 else p) = id\<close>
  by auto

(*TODO: das if will in ne definition*)
lemma opfer_eindeutig_nach_besitz_auswaehlen_swap:
    \<open>p1 \<in> set ps \<Longrightarrow>
     p2 \<in> set ps \<Longrightarrow>
     distinct ps \<Longrightarrow>
  map_option
        (\<lambda>p. if p = p1 then p2 else if p = p2 then p1 else p)
        (opfer_eindeutig_nach_besitz_auswaehlen p (swap p1 p2 besitz) ps)
  = opfer_eindeutig_nach_besitz_auswaehlen p besitz ps\<close>
  apply(simp add: opfer_eindeutig_nach_besitz_auswaehlen_the_single_elem)
  apply(simp add: the_single_elem)
  apply(safe, simp_all add: swap_a swap_b swap_nothing is_singleton_swap)
    apply(rule sym)
    apply(rule the_elem_singleton_swap, simp_all)
    apply(simp add: is_singleton_swap; fail)
   apply(rule sym)
   apply(rule the_elem_singleton_swap, simp_all)
    apply(simp add: swap_symmetric; fail)
   apply(simp add: is_singleton_swap; fail)
  apply(rule the_elem_singleton_swap_none, simp_all)
  using is_singleton_swap by fast

lemma opfer_eindeutig_nach_besitz_auswaehlen_swap_alt:
  \<open>p1 \<in> set ps \<Longrightarrow>
   p2 \<in> set ps \<Longrightarrow>
   distinct ps \<Longrightarrow>
   opfer_eindeutig_nach_besitz_auswaehlen p (swap p1 p2 besitz) ps =
     map_option (\<lambda>p. if p = p1 then p2 else if p = p2 then p1 else p)
       (opfer_eindeutig_nach_besitz_auswaehlen p besitz ps)\<close>
  using opfer_eindeutig_nach_besitz_auswaehlen_swap[of \<open>p1\<close> \<open>ps\<close> \<open>p2\<close> \<open>p\<close> \<open>(swap p1 p2 besitz)\<close>, simplified swap1]
  by simp

lemma opfer_eindeutig_nach_besitz_auswaehlen_swap_enumall:
\<open>opfer_eindeutig_nach_besitz_auswaehlen p (swap p1 p2 besitz) enum_class.enum =
  map_option (\<lambda>p. if p = p1 then p2 else if p = p2 then p1 else p)
    (opfer_eindeutig_nach_besitz_auswaehlen p besitz enum_class.enum)\<close>
  apply(rule opfer_eindeutig_nach_besitz_auswaehlen_swap_alt)
  using enum_class.in_enum enum_class.enum_distinct by auto

lemma opfer_eindeutig_nach_besitz_auswaehlen_swap_None:
  \<open>opfer_eindeutig_nach_besitz_auswaehlen p (swap p1 p2 welt) enum_class.enum = None
    \<longleftrightarrow>
   opfer_eindeutig_nach_besitz_auswaehlen p welt enum_class.enum = None\<close>
  by(simp add: opfer_eindeutig_nach_besitz_auswaehlen_swap_enumall)

lemma the_single_elem_None_swap:
  \<open>the_single_elem {p. x p = a} = None \<Longrightarrow>
       the_single_elem {p. swap p1 p2 x p = a} = None\<close>
  apply(simp add: the_single_elem split: if_split_asm)
  apply(simp add: is_singleton_def)
  apply(safe)
  apply(simp add: singleton_set_to_all2)
  by (metis swap_a swap_b swap_nothing)

lemma the_single_elem_Some_Some_swap:
  \<open>the_single_elem {p. x p = a} = Some s1 \<Longrightarrow>
      the_single_elem {p. swap s1 p2 x p = a} = Some s2 \<Longrightarrow> p2 = s2\<close>
  apply(simp add: the_single_elem is_singleton_the_elem split: if_split_asm)
  by (metis empty_iff insert_iff mem_Collect_eq swap_a swap_nothing)
lemma the_single_elem_Some_ex_swap:
  \<open>the_single_elem {p. x p = a} = Some x2 \<Longrightarrow> \<exists>y. the_single_elem {p. swap p1 p2 x p = a} = Some y\<close>
  apply(case_tac \<open>the_single_elem {p. swap p1 p2 x p = a}\<close>)
   apply(simp)
  using the_single_elem_None_swap apply (metis option.distinct(1) swap2)
  by simp

lemma the_single_elem_Some_swap:
  \<open>the_single_elem {p. x p = a} = Some s \<Longrightarrow>
      the_single_elem {p. swap s p2 x p = a} = Some p2\<close>
  using the_single_elem_Some_ex_swap the_single_elem_Some_Some_swap by fastforce
(*>*)

fun stehlen :: \<open>int \<Rightarrow> int \<Rightarrow> 'person::enum \<Rightarrow> ('person \<Rightarrow> int) \<Rightarrow> ('person \<Rightarrow> int) option\<close> where
  \<open>stehlen beute opfer_nach_besitz dieb besitz =
    (case opfer_eindeutig_nach_besitz_auswaehlen opfer_nach_besitz besitz Enum.enum
       of None \<Rightarrow> None
        | Some opfer \<Rightarrow> if opfer = dieb then None else Some \<lbrakk>\<lbrakk>besitz(opfer -= beute)\<rbrakk>(dieb += beute)\<rbrakk>
    )\<close>

lemma wohlgeformte_handlungsabsicht_stehlen:
  \<open>wohlgeformte_handlungsabsicht swap welt (Handlungsabsicht (stehlen n p))\<close>
    apply(simp add: wohlgeformte_handlungsabsicht.simps)
    apply(simp add: opfer_eindeutig_nach_besitz_auswaehlen_swap_enumall)
    apply(simp add: opfer_eindeutig_nach_besitz_auswaehlen_the_single_elem_enumall)
    apply(simp add: the_single_elem)
    apply(safe)
     apply (simp add: swap_def Fun.swap_def; fail)
  by (simp add: fun_upd_twist swap_def Fun.swap_def)

(*<*)
lemma stehlen_swap_None:
  \<open>stehlen n opf p2 (swap p1 p2 welt) = None
    \<longleftrightarrow>
   stehlen n opf p1 welt = None\<close>
  apply(simp split: option.split)
  apply(simp add: opfer_eindeutig_nach_besitz_auswaehlen_swap_None)
  by(auto simp add: opfer_eindeutig_nach_besitz_auswaehlen_swap_enumall)

declare stehlen.simps[simp del]
(*>*)

definition aufsummieren :: \<open>('person::enum \<Rightarrow> int) \<Rightarrow> int\<close> where
  \<open>aufsummieren besitz = sum_list (map besitz Enum.enum)\<close>

lemma \<open>aufsummieren (besitz :: person\<Rightarrow>int) = (\<Sum>p\<leftarrow>[Alice,Bob,Carol,Eve]. besitz p)\<close>
  by(simp add: aufsummieren_def enum_person_def)

lemma \<open>aufsummieren (\<euro>(Alice := 4, Carol := 8)) = 12\<close> by eval
lemma \<open>aufsummieren (\<euro>(Alice := 4, Carol := 4)) = 8\<close> by eval

lemma aufsummieren_swap:
  \<open>aufsummieren (swap p1 p2 welt) = aufsummieren welt\<close>
  apply(simp add: aufsummieren_def)
  apply(rule sum_list_swap)
  using enum_class.in_enum enum_class.enum_distinct by auto

lemma list_not_empty_iff_has_element: \<open>as \<noteq> [] \<longleftrightarrow> (\<exists>a. a \<in> set as)\<close>
  by (simp add: ex_in_conv)

lemma enum_class_not_empty_list: \<open>enum_class.enum \<noteq> []\<close>
  using enum_class.in_enum list_not_empty_iff_has_element by blast

lemma alles_kaputt_machen_code_help:
  \<open>(\<lambda>_. Min (range x) - 1) = (\<lambda>_. min_list (map x enum_class.enum) - 1)\<close>
  apply(subst min_list_Min)
   apply(simp add: enum_class_not_empty_list; fail)
  apply(simp)
  apply(simp add: enum_UNIV)
  done

text\<open>\<^const>\<open>swap\<close> funktioniert auch auf Mengen.\<close>
lemma \<open>(swap Alice Carol id) ` {Alice, Bob} = {Carol, Bob}\<close> by eval

end