section \<open>Deterministic Automata\<close>

theory Deterministic
imports
  "../Transition_Systems/Transition_System"
  "../Transition_Systems/Transition_System_Extra"
  "../Transition_Systems/Transition_System_Construction"
  "../Basic/Degeneralization"
begin

  locale automaton =
    fixes automaton :: "'label set \<Rightarrow> 'state \<Rightarrow> ('label \<Rightarrow> 'state \<Rightarrow> 'state) \<Rightarrow> 'condition \<Rightarrow> 'automaton"
    fixes alphabet initial transition condition
    assumes automaton[simp]: "automaton (alphabet A) (initial A) (transition A) (condition A) = A"
    assumes alphabet[simp]: "alphabet (automaton a i t c) = a"
    assumes initial[simp]: "initial (automaton a i t c) = i"
    assumes transition[simp]: "transition (automaton a i t c) = t"
    assumes condition[simp]: "condition (automaton a i t c) = c"
  begin

    (* TODO: is there a way to use defines without renaming the constants? *)
    sublocale transition_system_initial
      "transition A" "\<lambda> a p. a \<in> alphabet A" "\<lambda> p. p = initial A"
      for A
      defines path' = path and run' = run and reachable' = reachable and nodes' = nodes
      by this

    lemma path_alt_def: "path A w p \<longleftrightarrow> w \<in> lists (alphabet A)"
    proof
      show "w \<in> lists (alphabet A)" if "path A w p" using that by (induct arbitrary: p) (auto)
      show "path A w p" if "w \<in> lists (alphabet A)" using that by (induct arbitrary: p) (auto)
    qed
    lemma run_alt_def: "run A w p \<longleftrightarrow> w \<in> streams (alphabet A)"
    proof
      show "w \<in> streams (alphabet A)" if "run A w p"
        using that by (coinduction arbitrary: w p) (force elim: run.cases)
      show "run A w p" if "w \<in> streams (alphabet A)"
        using that by (coinduction arbitrary: w p) (force elim: streams.cases)
    qed

  end

  locale automaton_path =
    automaton automaton alphabet initial transition condition
    for automaton :: "'label set \<Rightarrow> 'state \<Rightarrow> ('label \<Rightarrow> 'state \<Rightarrow> 'state) \<Rightarrow> 'condition \<Rightarrow> 'automaton"
    and alphabet initial transition condition
    +
    fixes test :: "'condition \<Rightarrow> 'label list \<Rightarrow> 'state list \<Rightarrow> 'state \<Rightarrow> bool"
  begin

    definition language :: "'automaton \<Rightarrow> 'label list set" where
      "language A \<equiv> {w. path A w (initial A) \<and> test (condition A) w (states A w (initial A)) (initial A)}"

    lemma language[intro]:
      assumes "path A w (initial A)" "test (condition A) w (states A w (initial A)) (initial A)"
      shows "w \<in> language A"
      using assms unfolding language_def by auto

    lemma language_alphabet: "language A \<subseteq> lists (alphabet A)" using path_alt_def by auto

  end

  locale automaton_run =
    automaton automaton alphabet initial transition condition
    for automaton :: "'label set \<Rightarrow> 'state \<Rightarrow> ('label \<Rightarrow> 'state \<Rightarrow> 'state) \<Rightarrow> 'condition \<Rightarrow> 'automaton"
    and alphabet initial transition condition
    +
    fixes test :: "'condition \<Rightarrow> 'label stream \<Rightarrow> 'state stream \<Rightarrow> 'state \<Rightarrow> bool"
  begin

    definition language :: "'automaton \<Rightarrow> 'label stream set" where
      "language A \<equiv> {w. run A w (initial A) \<and> test (condition A) w (trace A w (initial A)) (initial A)}"

    lemma language[intro]:
      assumes "run A w (initial A)" "test (condition A) w (trace A w (initial A)) (initial A)"
      shows "w \<in> language A"
      using assms unfolding language_def by auto
    lemma language_elim[elim]:
      assumes "w \<in> language A"
      obtains "run A w (initial A)" "test (condition A) w (trace A w (initial A)) (initial A)"
      using assms unfolding language_def by auto

    lemma language_alphabet: "language A \<subseteq> streams (alphabet A)" using run_alt_def by auto

  end

  locale automaton_degeneralization =
    a: automaton automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 +
    b: automaton automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
    for automaton\<^sub>1 :: "'label set \<Rightarrow> 'state \<Rightarrow> ('label \<Rightarrow> 'state \<Rightarrow> 'state) \<Rightarrow> 'item pred gen \<Rightarrow> 'automaton\<^sub>1"
    and alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
    and automaton\<^sub>2 :: "'label set \<Rightarrow> 'state degen \<Rightarrow> ('label \<Rightarrow> 'state degen \<Rightarrow> 'state degen) \<Rightarrow> 'item_degen pred \<Rightarrow> 'automaton\<^sub>2"
    and alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
    +
    fixes item :: "'state \<times> 'label \<times> 'state \<Rightarrow> 'item"
    fixes translate :: "'item_degen \<Rightarrow> 'item degen"
  begin

    definition degeneralize :: "'automaton\<^sub>1 \<Rightarrow> 'automaton\<^sub>2" where
      "degeneralize A \<equiv> automaton\<^sub>2
        (alphabet\<^sub>1 A)
        (initial\<^sub>1 A, 0)
        (\<lambda> a (p, k). (transition\<^sub>1 A a p, count (condition\<^sub>1 A) (item (p, a, transition\<^sub>1 A a p)) k))
        (degen (condition\<^sub>1 A) \<circ> translate)"

    lemma degeneralize_simps[simp]:
      "alphabet\<^sub>2 (degeneralize A) = alphabet\<^sub>1 A"
      "initial\<^sub>2 (degeneralize A) = (initial\<^sub>1 A, 0)"
      "transition\<^sub>2 (degeneralize A) a (p, k) =
        (transition\<^sub>1 A a p, count (condition\<^sub>1 A) (item (p, a, transition\<^sub>1 A a p)) k)"
      "condition\<^sub>2 (degeneralize A) = degen (condition\<^sub>1 A) \<circ> translate"
      unfolding degeneralize_def by auto

    lemma degeneralize_target[simp]: "b.target (degeneralize A) w (p, k) =
      (a.target A w p, fold (count (condition\<^sub>1 A) \<circ> item) (p # a.states A w p || w || a.states A w p) k)"
      by (induct w arbitrary: p k) (auto)
    lemma degeneralize_states[simp]: "b.states (degeneralize A) w (p, k) =
      a.states A w p || scan (count (condition\<^sub>1 A) \<circ> item) (p # a.states A w p || w || a.states A w p) k"
      by (induct w arbitrary: p k) (auto)
    lemma degeneralize_trace[simp]: "b.trace (degeneralize A) w (p, k) =
      a.trace A w p ||| sscan (count (condition\<^sub>1 A) \<circ> item) (p ## a.trace A w p ||| w ||| a.trace A w p) k"
      by (coinduction arbitrary: w p k) (auto, metis sscan.code)

    lemma degeneralize_path[iff]: "b.path (degeneralize A) w (p, k) \<longleftrightarrow> a.path A w p"
      unfolding a.path_alt_def b.path_alt_def by simp
    lemma degeneralize_run[iff]: "b.run (degeneralize A) w (p, k) \<longleftrightarrow> a.run A w p"
      unfolding a.run_alt_def b.run_alt_def by simp

    lemma degeneralize_reachable_fst[simp]: "fst ` b.reachable (degeneralize A) (p, k) = a.reachable A p"
      unfolding a.reachable_alt_def b.reachable_alt_def image_def by simp
    lemma degeneralize_reachable_snd_empty[simp]:
      assumes "condition\<^sub>1 A = []"
      shows "snd ` b.reachable (degeneralize A) (p, k) = {k}"
    proof -
      have "snd ql = k" if "ql \<in> b.reachable (degeneralize A) (p, k)" for ql
        using that assms by induct auto
      then show ?thesis by auto
    qed
    lemma degeneralize_reachable_empty[simp]:
      assumes "condition\<^sub>1 A = []"
      shows "b.reachable (degeneralize A) (p, k) = a.reachable A p \<times> {k}"
      using degeneralize_reachable_fst degeneralize_reachable_snd_empty assms
      by (metis prod_singleton(2))
    lemma degeneralize_reachable_snd:
      "snd ` b.reachable (degeneralize A) (p, k) \<subseteq> insert k {0 ..< length (condition\<^sub>1 A)}"
      by (cases "condition\<^sub>1 A = []") (auto)
    lemma degeneralize_reachable:
      "b.reachable (degeneralize A) (p, k) \<subseteq> a.reachable A p \<times> insert k {0 ..< length (condition\<^sub>1 A)}"
      by (cases "condition\<^sub>1 A = []") (auto 0 3)

    lemma degeneralize_nodes_fst[simp]: "fst ` b.nodes (degeneralize A) = a.nodes A"
      unfolding a.nodes_alt_def b.nodes_alt_def by simp
    lemma degeneralize_nodes_snd_empty:
      assumes "condition\<^sub>1 A = []"
      shows "snd ` b.nodes (degeneralize A) = {0}"
      using assms unfolding b.nodes_alt_def by auto
    lemma degeneralize_nodes_empty:
      assumes "condition\<^sub>1 A = []"
      shows "b.nodes (degeneralize A) = a.nodes A \<times> {0}"
      using assms unfolding b.nodes_alt_def by auto
    lemma degeneralize_nodes_snd:
      "snd ` b.nodes (degeneralize A) \<subseteq> insert 0 {0 ..< length (condition\<^sub>1 A)}"
      using degeneralize_reachable_snd unfolding b.nodes_alt_def by auto
    lemma degeneralize_nodes:
      "b.nodes (degeneralize A) \<subseteq> a.nodes A \<times> insert 0 {0 ..< length (condition\<^sub>1 A)}"
      using degeneralize_reachable unfolding a.nodes_alt_def b.nodes_alt_def by simp

    lemma degeneralize_nodes_finite[iff]: "finite (b.nodes (degeneralize A)) \<longleftrightarrow> finite (a.nodes A)"
    proof
      show "finite (a.nodes A)" if "finite (b.nodes (degeneralize A))"
        using that by (auto simp flip: degeneralize_nodes_fst)
      show "finite (b.nodes (degeneralize A))" if "finite (a.nodes A)"
        using finite_subset degeneralize_nodes that by blast
    qed
    lemma degeneralize_nodes_card: "card (b.nodes (degeneralize A)) \<le>
      max 1 (length (condition\<^sub>1 A)) * card (a.nodes A)"
    proof (cases "finite (a.nodes A)")
      case True
      have "card (b.nodes (degeneralize A)) \<le> card (a.nodes A \<times> insert 0 {0 ..< length (condition\<^sub>1 A)})"
        using degeneralize_nodes True by (blast intro: card_mono)
      also have "\<dots> = card (insert 0 {0 ..< length (condition\<^sub>1 A)}) * card (a.nodes A)"
        unfolding card_cartesian_product by simp
      also have "card (insert 0 {0 ..< length (condition\<^sub>1 A)}) = max 1 (length (condition\<^sub>1 A))"
        by (simp add: card_insert_if Suc_leI max_absorb2)
      finally show ?thesis by this
    next
      case False
      then have "card (a.nodes A) = 0" "card (b.nodes (degeneralize A)) = 0" by auto
      then show ?thesis by simp
    qed

  end

  locale automaton_degeneralization_run =
    automaton_degeneralization
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      item translate +
    a: automaton_run automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_run automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and item translate
    +
    assumes test[iff]: "test\<^sub>2 (degen cs \<circ> translate) w
      (r ||| sscan (count cs \<circ> item) (p ## r ||| w ||| r) k) (p, k) \<longleftrightarrow> test\<^sub>1 cs w r p"
  begin

    lemma degeneralize_language[simp]: "b.language (degeneralize A) = a.language A" by force

  end

  locale automaton_product =
    a: automaton automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 +
    b: automaton automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 +
    c: automaton automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3
    for automaton\<^sub>1 :: "'label set \<Rightarrow> 'state\<^sub>1 \<Rightarrow> ('label \<Rightarrow> 'state\<^sub>1 \<Rightarrow> 'state\<^sub>1) \<Rightarrow> 'condition\<^sub>1 \<Rightarrow> 'automaton\<^sub>1"
    and alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
    and automaton\<^sub>2 :: "'label set \<Rightarrow> 'state\<^sub>2 \<Rightarrow> ('label \<Rightarrow> 'state\<^sub>2 \<Rightarrow> 'state\<^sub>2) \<Rightarrow> 'condition\<^sub>2 \<Rightarrow> 'automaton\<^sub>2"
    and alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
    and automaton\<^sub>3 :: "'label set \<Rightarrow> 'state\<^sub>1 \<times> 'state\<^sub>2 \<Rightarrow> ('label \<Rightarrow> 'state\<^sub>1 \<times> 'state\<^sub>2 \<Rightarrow> 'state\<^sub>1 \<times> 'state\<^sub>2) \<Rightarrow> 'condition\<^sub>3 \<Rightarrow> 'automaton\<^sub>3"
    and alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3
    +
    fixes condition :: "'condition\<^sub>1 \<Rightarrow> 'condition\<^sub>2 \<Rightarrow> 'condition\<^sub>3"
  begin

    definition product :: "'automaton\<^sub>1 \<Rightarrow> 'automaton\<^sub>2 \<Rightarrow> 'automaton\<^sub>3" where
      "product A B \<equiv> automaton\<^sub>3
        (alphabet\<^sub>1 A \<inter> alphabet\<^sub>2 B)
        (initial\<^sub>1 A, initial\<^sub>2 B)
        (\<lambda> a (p, q). (transition\<^sub>1 A a p, transition\<^sub>2 B a q))
        (condition (condition\<^sub>1 A) (condition\<^sub>2 B))"

    lemma product_simps[simp]:
      "alphabet\<^sub>3 (product A B) = alphabet\<^sub>1 A \<inter> alphabet\<^sub>2 B"
      "initial\<^sub>3 (product A B) = (initial\<^sub>1 A, initial\<^sub>2 B)"
      "transition\<^sub>3 (product A B) a (p, q) = (transition\<^sub>1 A a p, transition\<^sub>2 B a q)"
      "condition\<^sub>3 (product A B) = condition (condition\<^sub>1 A) (condition\<^sub>2 B)"
      unfolding product_def by auto

    lemma product_target[simp]: "c.target (product A B) w (p, q) = (a.target A w p, b.target B w q)"
      by (induct w arbitrary: p q) (auto)
    lemma product_states[simp]: "c.states (product A B) w (p, q) = a.states A w p || b.states B w q"
      by (induct w arbitrary: p q) (auto)
    lemma product_trace[simp]: "c.trace (product A B) w (p, q) = a.trace A w p ||| b.trace B w q"
      by (coinduction arbitrary: w p q) (auto)

    lemma product_path[iff]: "c.path (product A B) w (p, q) \<longleftrightarrow> a.path A w p \<and> b.path B w q"
      unfolding a.path_alt_def b.path_alt_def c.path_alt_def by simp
    lemma product_run[iff]: "c.run (product A B) w (p, q) \<longleftrightarrow> a.run A w p \<and> b.run B w q"
      unfolding a.run_alt_def b.run_alt_def c.run_alt_def by simp

    lemma product_reachable[simp]: "c.reachable (product A B) (p, q) \<subseteq> a.reachable A p \<times> b.reachable B q"
      unfolding c.reachable_alt_def by auto
    lemma product_nodes[simp]: "c.nodes (product A B) \<subseteq> a.nodes A \<times> b.nodes B"
      unfolding a.nodes_alt_def b.nodes_alt_def c.nodes_alt_def by auto
    lemma product_reachable_fst[simp]:
      assumes "alphabet\<^sub>1 A \<subseteq> alphabet\<^sub>2 B"
      shows "fst ` c.reachable (product A B) (p, q) = a.reachable A p"
      using assms
      unfolding a.reachable_alt_def a.path_alt_def
      unfolding b.reachable_alt_def b.path_alt_def
      unfolding c.reachable_alt_def c.path_alt_def
      by auto force
    lemma product_reachable_snd[simp]:
      assumes "alphabet\<^sub>1 A \<supseteq> alphabet\<^sub>2 B"
      shows "snd ` c.reachable (product A B) (p, q) = b.reachable B q"
      using assms
      unfolding a.reachable_alt_def a.path_alt_def
      unfolding b.reachable_alt_def b.path_alt_def
      unfolding c.reachable_alt_def c.path_alt_def
      by auto force
    lemma product_nodes_fst[simp]:
      assumes "alphabet\<^sub>1 A \<subseteq> alphabet\<^sub>2 B"
      shows "fst ` c.nodes (product A B) = a.nodes A"
      using assms product_reachable_fst
      unfolding a.nodes_alt_def b.nodes_alt_def c.nodes_alt_def
      by fastforce
    lemma product_nodes_snd[simp]:
      assumes "alphabet\<^sub>1 A \<supseteq> alphabet\<^sub>2 B"
      shows "snd ` c.nodes (product A B) = b.nodes B"
      using assms product_reachable_snd
      unfolding a.nodes_alt_def b.nodes_alt_def c.nodes_alt_def
      by fastforce

    lemma product_nodes_finite[intro]:
      assumes "finite (a.nodes A)" "finite (b.nodes B)"
      shows "finite (c.nodes (product A B))"
    proof (rule finite_subset)
      show "c.nodes (product A B) \<subseteq> a.nodes A \<times> b.nodes B" using product_nodes by this
      show "finite (a.nodes A \<times> b.nodes B)" using assms by simp
    qed
    lemma product_nodes_finite_strong[iff]:
      assumes "alphabet\<^sub>1 A = alphabet\<^sub>2 B"
      shows "finite (c.nodes (product A B)) \<longleftrightarrow> finite (a.nodes A) \<and> finite (b.nodes B)"
    proof safe
      show "finite (a.nodes A)" if "finite (c.nodes (product A B))"
        using product_nodes_fst assms that by (metis finite_imageI equalityD1)
      show "finite (b.nodes B)" if "finite (c.nodes (product A B))"
        using product_nodes_snd assms that by (metis finite_imageI equalityD2)
      show "finite (c.nodes (product A B))" if "finite (a.nodes A)" "finite (b.nodes B)"
        using that by rule
    qed
    lemma product_nodes_card[intro]:
      assumes "finite (a.nodes A)" "finite (b.nodes B)"
      shows "card (c.nodes (product A B)) \<le> card (a.nodes A) * card (b.nodes B)"
    proof -
      have "card (c.nodes (product A B)) \<le> card (a.nodes A \<times> b.nodes B)"
      proof (rule card_mono)
        show "finite (a.nodes A \<times> b.nodes B)" using assms by simp
        show "c.nodes (product A B) \<subseteq> a.nodes A \<times> b.nodes B" using product_nodes by this
      qed
      also have "\<dots> = card (a.nodes A) * card (b.nodes B)" using card_cartesian_product by this
      finally show ?thesis by this
    qed
    lemma product_nodes_card_strong[intro]:
      assumes "alphabet\<^sub>1 A = alphabet\<^sub>2 B"
      shows "card (c.nodes (product A B)) \<le> card (a.nodes A) * card (b.nodes B)"
    proof (cases "finite (a.nodes A) \<and> finite (b.nodes B)")
      case True
      show ?thesis using True by auto
    next
      case False
      have 1: "card (c.nodes (product A B)) = 0" using False assms by simp
      have 2: "card (a.nodes A) * card (b.nodes B) = 0" using False by auto
      show ?thesis using 1 2 by simp
    qed

  end

  locale automaton_intersection_path =
    automaton_product
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3
      condition +
    a: automaton_path automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_path automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2 +
    c: automaton_path automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3 test\<^sub>3
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3 test\<^sub>3
    and condition
    +
    assumes test[iff]: "length r = length s \<Longrightarrow>
      test\<^sub>3 (condition c\<^sub>1 c\<^sub>2) w (r || s) (p, q) \<longleftrightarrow> test\<^sub>1 c\<^sub>1 w r p \<and> test\<^sub>2 c\<^sub>2 w s q"
  begin

    lemma product_language[simp]: "c.language (product A B) = a.language A \<inter> b.language B" by force

  end

  locale automaton_union_path =
    automaton_product
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3
      condition +
    a: automaton_path automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_path automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2 +
    c: automaton_path automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3 test\<^sub>3
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3 test\<^sub>3
    and condition
    +
    assumes test[iff]: "length r = length s \<Longrightarrow>
      test\<^sub>3 (condition c\<^sub>1 c\<^sub>2) w (r || s) (p, q) \<longleftrightarrow> test\<^sub>1 c\<^sub>1 w r p \<or> test\<^sub>2 c\<^sub>2 w s q"
  begin

    lemma product_language[simp]:
      assumes "alphabet\<^sub>1 A = alphabet\<^sub>2 B"
      shows "c.language (product A B) = a.language A \<union> b.language B"
      using assms by (force simp: a.path_alt_def b.path_alt_def)

  end

  locale automaton_intersection_run =
    automaton_product
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3
      condition +
    a: automaton_run automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_run automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2 +
    c: automaton_run automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3 test\<^sub>3
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3 test\<^sub>3
    and condition
    +
    assumes test[iff]: "test\<^sub>3 (condition c\<^sub>1 c\<^sub>2) w (r ||| s) (p, q) \<longleftrightarrow> test\<^sub>1 c\<^sub>1 w r p \<and> test\<^sub>2 c\<^sub>2 w s q"
  begin

    lemma product_language[simp]: "c.language (product A B) = a.language A \<inter> b.language B" by force

  end

  locale automaton_union_run =
    automaton_product
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3
      condition +
    a: automaton_run automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_run automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2 +
    c: automaton_run automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3 test\<^sub>3
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and automaton\<^sub>3 alphabet\<^sub>3 initial\<^sub>3 transition\<^sub>3 condition\<^sub>3 test\<^sub>3
    and condition
    +
    assumes test[iff]: "test\<^sub>3 (condition c\<^sub>1 c\<^sub>2) w (r ||| s) (p, q) \<longleftrightarrow> test\<^sub>1 c\<^sub>1 w r p \<or> test\<^sub>2 c\<^sub>2 w s q"
  begin

    lemma product_language[simp]:
      assumes "alphabet\<^sub>1 A = alphabet\<^sub>2 B"
      shows "c.language (product A B) = a.language A \<union> b.language B"
      using assms by (force simp: a.run_alt_def b.run_alt_def)

  end

  (* TODO: complete this in analogy to the pair case *)
  locale automaton_product_list =
    a: automaton automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 +
    b: automaton automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
    for automaton\<^sub>1 :: "'label set \<Rightarrow> 'state \<Rightarrow> ('label \<Rightarrow> 'state \<Rightarrow> 'state) \<Rightarrow> 'condition\<^sub>1 \<Rightarrow> 'automaton\<^sub>1"
    and alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
    and automaton\<^sub>2 :: "'label set \<Rightarrow> 'state list \<Rightarrow> ('label \<Rightarrow> 'state list \<Rightarrow> 'state list) \<Rightarrow> 'condition\<^sub>2 \<Rightarrow> 'automaton\<^sub>2"
    and alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
    +
    fixes condition :: "'condition\<^sub>1 list \<Rightarrow> 'condition\<^sub>2"
  begin

    definition product :: "'automaton\<^sub>1 list \<Rightarrow> 'automaton\<^sub>2" where
      "product AA \<equiv> automaton\<^sub>2
        (\<Inter> (alphabet\<^sub>1 ` set AA))
        (map initial\<^sub>1 AA)
        (\<lambda> a ps. map2 (\<lambda> A p. transition\<^sub>1 A a p) AA ps)
        (condition (map condition\<^sub>1 AA))"

    lemma product_simps[simp]:
      "alphabet\<^sub>2 (product AA) = \<Inter> (alphabet\<^sub>1 ` set AA)"
      "initial\<^sub>2 (product AA) = map initial\<^sub>1 AA"
      "transition\<^sub>2 (product AA) a ps = map2 (\<lambda> A p. transition\<^sub>1 A a p) AA ps"
      "condition\<^sub>2 (product AA) = condition (map condition\<^sub>1 AA)"
      unfolding product_def by auto

    (* TODO: get rid of indices, express this using stranspose and listset *)
    lemma product_trace_smap:
      assumes "length ps = length AA" "k < length AA"
      shows "smap (\<lambda> ps. ps ! k) (b.trace (product AA) w ps) = a.trace (AA ! k) w (ps ! k)"
      using assms by (coinduction arbitrary: w ps) (force)

    lemma product_nodes: "b.nodes (product AA) \<subseteq> listset (map a.nodes AA)"
    proof
      show "ps \<in> listset (map a.nodes AA)" if "ps \<in> b.nodes (product AA)" for ps
        using that by (induct) (auto simp: listset_member list_all2_conv_all_nth)
    qed

    lemma product_nodes_finite[intro]:
      assumes "list_all (finite \<circ> a.nodes) AA"
      shows "finite (b.nodes (product AA))"
      using list.pred_map product_nodes assms by (blast dest: finite_subset)
    lemma product_nodes_card:
      assumes "list_all (finite \<circ> a.nodes) AA"
      shows "card (b.nodes (product AA)) \<le> prod_list (map (card \<circ> a.nodes) AA)"
    proof -
      have "card (b.nodes (product AA)) \<le> card (listset (map a.nodes AA))"
        using list.pred_map product_nodes assms by (blast intro: card_mono)
      also have "\<dots> = prod_list (map (card \<circ> a.nodes) AA)" by simp
      finally show ?thesis by this
    qed

  end

  locale automaton_intersection_list_run =
    automaton_product_list
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      condition +
    a: automaton_run automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_run automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and condition
    +
    assumes test[iff]: "test\<^sub>2 (condition cs) w rs ps \<longleftrightarrow>
      (\<forall> k < length cs. test\<^sub>1 (cs ! k) w (smap (\<lambda> ps. ps ! k) rs) (ps ! k))"
  begin

    lemma product_language[simp]: "b.language (product AA) = \<Inter> (a.language ` set AA)"
      unfolding a.language_def b.language_def
      unfolding a.run_alt_def b.run_alt_def streams_iff_sset
      by (fastforce simp: set_conv_nth product_trace_smap)

  end

  locale automaton_union_list_run =
    automaton_product_list
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      condition +
    a: automaton_run automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_run automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and condition
    +
    assumes test[iff]: "test\<^sub>2 (condition cs) w rs ps \<longleftrightarrow>
      (\<exists> k < length cs. test\<^sub>1 (cs ! k) w (smap (\<lambda> ps. ps ! k) rs) (ps ! k))"
  begin

    lemma product_language[simp]:
      assumes "\<Inter> (alphabet\<^sub>1 ` set AA) = \<Union> (alphabet\<^sub>1 ` set AA)"
      shows "b.language (product AA) = \<Union> (a.language ` set AA)"
      using assms
      unfolding a.language_def b.language_def
      unfolding a.run_alt_def b.run_alt_def streams_iff_sset
      by (fastforce simp: set_conv_nth product_trace_smap)

  end

  locale automaton_complement =
    a: automaton automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 +
    b: automaton automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
    for automaton\<^sub>1 :: "'label set \<Rightarrow> 'state \<Rightarrow> ('label \<Rightarrow> 'state \<Rightarrow> 'state) \<Rightarrow> 'condition\<^sub>1 \<Rightarrow> 'automaton\<^sub>1"
    and alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
    and automaton\<^sub>2 :: "'label set \<Rightarrow> 'state \<Rightarrow> ('label \<Rightarrow> 'state \<Rightarrow> 'state) \<Rightarrow> 'condition\<^sub>2 \<Rightarrow> 'automaton\<^sub>2"
    and alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
    +
    fixes condition :: "'condition\<^sub>1 \<Rightarrow> 'condition\<^sub>2"
  begin

    definition complement :: "'automaton\<^sub>1 \<Rightarrow> 'automaton\<^sub>2" where
      "complement A \<equiv> automaton\<^sub>2 (alphabet\<^sub>1 A) (initial\<^sub>1 A) (transition\<^sub>1 A) (condition (condition\<^sub>1 A))"

    lemma combine_simps[simp]:
      "alphabet\<^sub>2 (complement A) = alphabet\<^sub>1 A"
      "initial\<^sub>2 (complement A) = initial\<^sub>1 A"
      "transition\<^sub>2 (complement A) = transition\<^sub>1 A"
      "condition\<^sub>2 (complement A) = condition (condition\<^sub>1 A)"
      unfolding complement_def by auto

  end

  locale automaton_complement_path =
    automaton_complement
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      condition +
    a: automaton_path automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_path automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and condition
    +
    assumes test[iff]: "test\<^sub>2 (condition c) w r p \<longleftrightarrow> \<not> test\<^sub>1 c w r p"
  begin

    lemma complement_language[simp]: "b.language (complement A) = lists (alphabet\<^sub>1 A) - a.language A"
      unfolding a.language_def b.language_def a.path_alt_def b.path_alt_def by auto

  end

  locale automaton_complement_run =
    automaton_complement
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      condition +
    a: automaton_run automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_run automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and condition
    +
    assumes test[iff]: "test\<^sub>2 (condition c) w r p \<longleftrightarrow> \<not> test\<^sub>1 c w r p"
  begin

    lemma complement_language[simp]: "b.language (complement A) = streams (alphabet\<^sub>1 A) - a.language A"
      unfolding a.language_def b.language_def a.run_alt_def b.run_alt_def by auto

  end

end


section \<open>Formalized Proof \label{sec:proof}\<close>

theory SortKeys
  imports Data "HOL-Library.List_Lexorder" "HOL-Library.Product_Lexorder"
begin

datatype sort_dir =
  Left |
  Right
derive linorder sort_dir

lemma sort_dir_less_def [simp]: "(x < y) = (x = Left \<and> y = Right)"
  by (cases x, case_tac [!] y, simp_all add:less_sort_dir_def)

datatype 'a sort_key =
  NonFinal "('a \<times> sort_dir)" "'a sort_key" |
  Final 'a

type_synonym 'id position = "'id sort_key extended"

fun embed_dir where "embed_dir (x,Left) = (x, 0)" | "embed_dir (x,Right) = (x, Suc (Suc 0))"

lemma embed_dir_inj [simp]: "(embed_dir x = embed_dir y) = (x = y)"
  by (cases x, cases y, case_tac [!] "snd x", case_tac [!] "snd y", simp+)

lemma embed_dir_mono [simp]: "(embed_dir x < embed_dir y) = (x < y)"
  by (cases x, cases y, case_tac [!] "snd x", case_tac [!] "snd y", (simp add:less_sort_dir_def)+)

fun sort_key_embedding :: "'a sort_key \<Rightarrow> ('a \<times> nat) list"
  where
   "sort_key_embedding (NonFinal x y) = embed_dir x#(sort_key_embedding y)" |
   "sort_key_embedding (Final i) = [(i, Suc 0)]"

lemma sort_key_embedding_injective:
  "sort_key_embedding x = sort_key_embedding y \<Longrightarrow> x = y"
  apply (induct x arbitrary: y)
  apply (metis embed_dir_inj list.distinct(1) list.inject sort_key.exhaust
      sort_key_embedding.simps)
  by (metis fst_conv list.distinct(1) list.inject sort_key.exhaust
      sort_key_embedding.simps)

instantiation sort_key :: (ord) ord
begin
definition sort_key_less_eq_def [simp]:
  "(x :: ('a :: ord) sort_key) \<le> y \<longleftrightarrow>
    (sort_key_embedding x \<le> sort_key_embedding y)"

definition sort_key_less_def [simp]:
  "(x :: ('a :: ord) sort_key) < y \<longleftrightarrow>
    (sort_key_embedding x < sort_key_embedding y)"

instance ..
end

instantiation sort_key :: (order) order
begin
instance by (intro_classes, simp_all add: less_le_not_le sort_key_embedding_injective)
end

instantiation sort_key :: (linorder) linorder
begin
instance by (intro_classes, meson less_imp_le not_le sort_key_less_eq_def)
end

end


section\<open>The general Rasiowa-Sikorski lemma\<close>
theory Rasiowa_Sikorski imports Forcing_Notions Pointed_DC begin

context countable_generic
begin

lemma RS_relation:
  assumes "p\<in>P" "n\<in>nat"
  shows "\<exists>y\<in>P. \<langle>p,y\<rangle> \<in> (\<lambda>m\<in>nat. {\<langle>x,y\<rangle>\<in>P\<times>P. y\<preceq>x \<and> y\<in>\<D>`(pred(m))})`n"
proof -
  from seq_of_denses \<open>n\<in>nat\<close>
  have "dense(\<D> ` pred(n))" by simp
  with \<open>p\<in>P\<close>
  have "\<exists>d\<in>\<D> ` Arith.pred(n). d\<preceq> p"
    unfolding dense_def by simp
  then obtain d where 3: "d \<in> \<D> ` Arith.pred(n) \<and> d\<preceq> p"
    by blast
  from countable_subs_of_P \<open>n\<in>nat\<close>
  have "\<D> ` Arith.pred(n) \<in> Pow(P)"
    by (blast dest:apply_funtype intro:pred_type)
  then
  have "\<D> ` Arith.pred(n) \<subseteq> P"
    by (rule PowD)
  with 3
  have "d \<in> P \<and> d\<preceq> p \<and> d \<in> \<D> ` Arith.pred(n)"
    by auto
  with \<open>p\<in>P\<close> \<open>n\<in>nat\<close>
  show ?thesis by auto
qed

lemma DC_imp_RS_sequence:
  assumes "p\<in>P"
  shows "\<exists>f. f: nat\<rightarrow>P \<and> f ` 0 = p \<and>
     (\<forall>n\<in>nat. f ` succ(n)\<preceq> f ` n \<and> f ` succ(n) \<in> \<D> ` n)"
proof -
  let ?S="(\<lambda>m\<in>nat. {\<langle>x,y\<rangle>\<in>P\<times>P. y\<preceq>x \<and> y\<in>\<D>`(pred(m))})"
  have "\<forall>x\<in>P. \<forall>n\<in>nat. \<exists>y\<in>P. \<langle>x,y\<rangle> \<in> ?S`n"
    using RS_relation by (auto)
  then
  have "\<forall>a\<in>P. (\<exists>f \<in> nat\<rightarrow>P. f`0 = a \<and> (\<forall>n \<in> nat. \<langle>f`n,f`succ(n)\<rangle>\<in>?S`succ(n)))"
    using sequence_DC by (blast)
  with \<open>p\<in>P\<close>
  show ?thesis by auto
qed

theorem rasiowa_sikorski:
  "p\<in>P \<Longrightarrow> \<exists>G. p\<in>G \<and> D_generic(G)"
  using RS_sequence_imp_rasiowa_sikorski by (auto dest:DC_imp_RS_sequence)

end (* countable_generic *)

end


theory Hidden
imports "List-Index.List_Index"
begin

definition hidden :: "'a list \<Rightarrow> nat \<Rightarrow> bool" where
"hidden xs i  \<equiv>  i < size xs \<and> xs!i \<in> set(drop (i+1) xs)"

lemma hidden_last_index: "x \<in> set xs \<Longrightarrow> hidden (xs @ [x]) (last_index xs x)"
apply(auto simp add: hidden_def nth_append rev_nth[symmetric])
apply(drule last_index_less[OF _ le_refl])
apply simp
done

lemma hidden_inacc: "hidden xs i \<Longrightarrow> last_index xs x \<noteq> i"
by(auto simp add: hidden_def last_index_drop last_index_less_size_conv)

lemma fun_upds_apply:
 "(m(xs[\<mapsto>]ys)) x =
  (let xs' = take (size ys) xs
   in if x \<in> set xs' then Some(ys ! last_index xs' x) else m x)"
apply(induct xs arbitrary: m ys)
 apply (simp add: Let_def)
apply(case_tac ys)
 apply (simp add:Let_def)
apply (simp add: Let_def last_index_Cons)
done

lemma map_upds_apply_eq_Some:
  "((m(xs[\<mapsto>]ys)) x = Some y) =
  (let xs' = take (size ys) xs
   in if x \<in> set xs' then ys ! last_index xs' x = y else m x = Some y)"
by(simp add:fun_upds_apply Let_def)

lemma map_upds_upd_conv_last_index:
  "\<lbrakk>x \<in> set xs; size xs \<le> size ys \<rbrakk>
  \<Longrightarrow> m(xs[\<mapsto>]ys)(x\<mapsto>y) = m(xs[\<mapsto>]ys[last_index xs x := y])"
apply(rule ext)
apply(simp add:fun_upds_apply eq_sym_conv Let_def)
done

end


(* Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Matrices for given marginals\<close>

text \<open>This theory derives from the finite max-flow min-cut theorem the existence of
matrices with given marginals based on a proof by Georg Kellerer \cite{Kellerer1961MA}.\<close>

theory Matrix_For_Marginals
  imports MFMC_Misc "HOL-Library.Diagonal_Subsequence" MFMC_Finite
begin

lemma bounded_matrix_for_marginals_finite:
  fixes f g :: "nat \<Rightarrow> real"
    and n :: nat
    and R :: "(nat \<times> nat) set"
  assumes eq_sum: "sum f {..n} = sum g {..n}"
    and le: "\<And>X. X \<subseteq> {..n} \<Longrightarrow> sum f X \<le> sum g (R `` X)"
    and f_nonneg: "\<And>x. 0 \<le> f x"
    and g_nonneg: "\<And>y. 0 \<le> g y"
    and R: "R \<subseteq> {..n} \<times> {..n}"
  obtains h :: "nat \<Rightarrow> nat \<Rightarrow> real"
    where "\<And>x y. \<lbrakk> x \<le> n; y \<le> n \<rbrakk> \<Longrightarrow> 0 \<le> h x y"
    and "\<And>x y. \<lbrakk> 0 < h x y; x \<le> n; y \<le> n \<rbrakk> \<Longrightarrow> (x, y) \<in> R"
    and "\<And>x. x \<le> n \<Longrightarrow> f x = sum (h x) {..n}"
    and "\<And>y. y \<le> n \<Longrightarrow> g y = sum (\<lambda>x. h x y) {..n}"
proof(cases "\<exists>x\<le>n. f x > 0")
  case False
  hence f: "f x = 0" if "x \<le> n" for x using f_nonneg[of x] that by(auto simp add: not_less)
  hence "sum g {..n} = 0" using eq_sum by simp
  hence "g y = 0" if "y \<le> n" for y using g_nonneg that by(simp add: sum_nonneg_eq_0_iff)
  with f show thesis by(auto intro!: that[of "\<lambda>_ _. 0"])
next
  case True
  then obtain x0 where x0: "x0 \<le> n" "f x0 > 0" by blast

  define R' where "R' = R \<inter> {x. f x > 0} \<times> {y. g y > 0}"

  have [simp]: "finite (R `` A)" for A
  proof -
    have "R `` A \<subseteq> {..n}" using R by auto
    thus ?thesis by(rule finite_subset) auto
  qed

  have R': "R' \<subseteq> {..n} \<times> {..n}" using R by(auto simp add: R'_def)
  have R'': "R' `` A \<subseteq> {..n}" for A using R by(auto simp add: R'_def)
  have [simp]: "finite (R' `` A)" for A using R''[of A]
    by(rule finite_subset) auto

  have hop: "\<exists>y0\<le>n. (x0, y0) \<in> R \<and> g y0 > 0" if x0: "x0 \<le> n" "f x0 > 0" for x0
  proof(rule ccontr)
    assume "\<not> ?thesis"
    then have "g y0 = 0" if "(x0, y0) \<in> R" "y0 \<le> n" for y0 using g_nonneg[of y0] that by auto
    moreover from R have "R `` {x0} \<subseteq> {..n}" by auto
    ultimately have "sum g (R `` {x0}) = 0"
      using g_nonneg by(auto intro!: sum_nonneg_eq_0_iff[THEN iffD2])
    moreover have "{x0} \<subseteq> {..n}" using x0 by auto
    from le[OF this] x0 have "R `` {x0} \<noteq> {}" "sum g (R `` {x0}) > 0" by auto
    ultimately show False by simp
  qed
  then obtain y0 where y0: "y0 \<le> n" "(x0, y0) \<in> R'" "g y0 > 0" using x0 by(auto simp add: R'_def)

  define LARGE where "LARGE = sum f {..n} + 1"
  have "1 \<le> LARGE" using f_nonneg by(simp add: LARGE_def sum_nonneg)
  hence [simp]: "LARGE \<noteq> 0" "0 \<noteq> LARGE" "0 < LARGE" "0 \<le> LARGE" by simp_all

  define s where "s = 2 * n + 2"
  define t where "t = 2 * n + 3"
  define c where "c = (\<lambda>(x, y).
     if x = s \<and> y \<le> n then f y
     else if x \<le> n \<and> n < y \<and> y \<le> 2 * n + 1 \<and> (x, y - n - 1) \<in> R' then LARGE
     else if n < x \<and> x \<le> 2 * n + 1 \<and> y = t then g (x - n - 1)
     else 0)"

  have st [simp]: "\<not> s \<le> n" "\<not> s \<le> Suc (2 * n)" "s \<noteq> t" "t \<noteq> s" "\<not> t \<le> n" "\<not> t \<le> Suc (2 * n)"
    by(simp_all add: s_def t_def)

  have c_simps: "c (x, y) =
    (if x = s \<and> y \<le> n then f y
     else if x \<le> n \<and> n < y \<and> y \<le> 2 * n + 1 \<and> (x, y - n - 1) \<in> R' then LARGE
     else if n < x \<and> x \<le> 2 * n + 1 \<and> y = t then g (x - n - 1)
     else 0)"
    for x y by(simp add: c_def)
  have cs [simp]: "c (s, y) = (if y \<le> n then f y else 0)"
    and ct [simp]: "c (x, t) = (if n < x \<and> x \<le> 2 * n + 1 then g (x - n - 1) else 0)"
    for x y by(auto simp add: c_simps)

  interpret Graph c .
  note [simp del] = zero_cap_simp

  interpret Network c s t
  proof
    have "(s, x0) \<in> E" using x0 by(simp add: E_def)
    thus "s \<in> V" by(auto simp add: V_def)

    have "(y0 + n + 1, t) \<in> E" using y0 by(simp add: E_def)
    thus "t \<in> V" by(auto simp add: V_def)

    show "s \<noteq> t" by simp
    show "\<forall>u v. 0 \<le> c (u, v)" by(simp add: c_simps f_nonneg g_nonneg max_def)
    show "\<forall>u. (u, s) \<notin> E" by(simp add: E_def c_simps)
    show "\<forall>u. (t, u) \<notin> E" by(simp add: E_def c_simps)
    show "\<forall>u v. (u, v) \<in> E \<longrightarrow> (v, u) \<notin> E" by(simp add: E_def c_simps)

    have "isPath s [(s, x0), (x0, y0 + n + 1), (y0 + n + 1, t)] t"
      using x0 y0 by(auto simp add: E_def c_simps)
    hence st: "connected s t" by(auto simp add: connected_def simp del: isPath.simps)

    show "\<forall>v\<in>V. connected s v \<and> connected v t"
    proof(intro strip)
      fix v
      assume v: "v \<in> V"
      hence "v \<le> 2 * n + 3" by(auto simp add: V_def E_def c_simps t_def s_def split: if_split_asm)
      then consider (left) "v \<le> n" | (right) "n < v" "v \<le> 2 * n + 1" | (s) "v = s" | (t) "v = t"
        by(fastforce simp add: s_def t_def)
      then show "connected s v \<and> connected v t"
      proof cases
        case left
        have sv: "(s, v) \<in> E" using v left
          by(fastforce simp add: E_def V_def c_simps max_def R'_def split: if_split_asm)
        hence "connected s v" by(auto simp add: connected_def intro!: exI[where x="[(s, v)]"])
        moreover from sv left f_nonneg[of v] have "f v > 0" by(simp add: E_def)
        from hop[OF left this] obtain v' where "(v, v') \<in> R" "v' \<le> n" "g v' > 0" by auto
        hence "isPath v [(v, v' + n + 1), (v' + n + 1, t)] t" using left \<open>f v > 0\<close>
          by(auto simp add: E_def c_simps R'_def)
        hence "connected v t" by(auto simp add: connected_def simp del: isPath.simps)
        ultimately show ?thesis ..
      next
        case right
        hence vt: "(v, t) \<in> E" using v by(auto simp add: V_def E_def c_simps max_def R'_def split: if_split_asm)
        hence "connected v t" by(auto simp add: connected_def intro!: exI[where x="[(v, t)]"])
        moreover
        have *: "g (v - n - 1) > 0" using vt g_nonneg[of "v - n - 1"] right by(simp add: E_def )
        have "\<exists>v'\<le>n. (v', v - n - 1) \<in> R \<and> f v' > 0"
        proof(rule ccontr)
          assume "\<not> ?thesis"
          hence zero: "\<lbrakk> v' \<le> n; (v', v - n - 1) \<in> R \<rbrakk> \<Longrightarrow> f v' = 0" for v' using f_nonneg[of v'] by auto
          have "sum f {..n} = sum f {x. x \<le> n \<and> x \<notin> R^-1 `` {v - n - 1}}"
            by(rule sum.mono_neutral_cong_right)(auto dest: zero)
          also have "\<dots> \<le> sum g (R `` {x. x \<le> n \<and> x \<notin> R^-1 `` {v - n - 1}})" by(rule le) auto
          also have "\<dots> \<le> sum g ({..n} - {v - n - 1})"
            by(rule sum_mono2)(use R in \<open>auto simp add: g_nonneg\<close>)
          also have "\<dots> = sum g {..n} - g (v - n - 1)" using right by(subst sum_diff) auto
          also have "\<dots> < sum g {..n}" using * by simp
          also have "\<dots> = sum f {..n}" by(simp add: eq_sum)
          finally show False by simp
        qed
        then obtain v' where "v' \<le> n" "(v', v - n - 1) \<in> R" "f v' > 0" by auto
        with right * have "isPath s [(s, v'), (v', v)] v" by(auto simp add: E_def c_simps R'_def)
        hence "connected s v" by(auto simp add: connected_def simp del: isPath.simps)
        ultimately show ?thesis by blast
      qed(simp_all add: st)
    qed

    have "reachableNodes s \<subseteq> V" using \<open>s \<in> V\<close> by(rule reachable_ss_V)
    also have "V \<subseteq> {..2 * n + 3}"
      by(clarsimp simp add: V_def E_def)(simp_all add: c_simps s_def t_def split: if_split_asm)
    finally show "finite (reachableNodes s)" by(rule finite_subset) simp
  qed

  interpret h: NFlow c s t max_flow by(rule max_flow)
  let ?h = "\<lambda>x y. max_flow (x, y + n + 1)"
  from max_flow(2)[THEN h.fofu_II_III] obtain C where C: "NCut c s t C"
    and eq: "h.val = NCut.cap c C" by blast
  interpret C: NCut c s t C using C .

  have "sum c (outgoing s) = sum (\<lambda>(_, x). f x) (Pair s ` {..n})"
    by(rule sum.mono_neutral_cong_left)(auto simp add: outgoing_def E_def)
  also have "\<dots> = sum f {..n}" by(subst sum.reindex)(auto simp add: inj_on_def)
  finally have out: "sum c (outgoing s) = sum f {..n}" .

  have no_leaving: "(\<lambda>y. y + n + 1) ` (R' `` (C \<inter> {..n})) \<subseteq> C"
  proof(rule ccontr)
    assume "\<not> ?thesis"
    then obtain x y where *: "(x, y) \<in> R'" "x \<le> n" "x \<in> C" "y + n + 1 \<notin> C" by auto
    then have xy: "(x, y + n + 1) \<in> E" "y \<le> n" "c (x, y + n + 1) = LARGE"
      using R by(auto simp add: E_def c_simps R'_def)

    have "h.val \<le> sum f {..n}" using h.val_bounded(2) out by simp
    also have "\<dots> < sum c {(x, y + n + 1)}" using xy * by(simp add: LARGE_def)
    also have "\<dots> \<le> C.cap" using * xy unfolding C.cap_def
      by(intro sum_mono2[OF finite_outgoing'])(auto simp add: outgoing'_def cap_non_negative)
    also have "\<dots> = h.val" by(simp add: eq)
    finally show False by simp
  qed

  have "C.cap \<le> sum f {..n}" using out h.val_bounded(2) eq by simp
  then have cap: "C.cap = sum f {..n}"
  proof(rule antisym)
    let ?L = "{x. x \<le> n \<and> x \<in> C \<and> f x > 0}"
    let ?R = "(\<lambda>y. y + n + 1) ` (R' `` ?L)"
    have "sum f {..n} = sum f ?L + sum f ({..n} - ?L)" by(subst sum_diff) auto
    also have "sum f ?L \<le> sum g (R `` ?L)" by(rule le) auto
    also have "\<dots> = sum g (R' `` ?L)" using g_nonneg
      by(intro sum.mono_neutral_cong_right)(auto 4 3 simp add: R'_def Image_iff intro: antisym)
    also have "\<dots> = sum c ((\<lambda>y. (y + n + 1, t)) ` (R' `` ?L))" using R
      by(subst sum.reindex)(auto intro!: sum.cong simp add: inj_on_def R'_def)
    also have "sum f ({..n} - ?L) = sum c (Pair s ` ({..n} - ?L))" by(simp add: sum.reindex inj_on_def)
    also have "sum c ((\<lambda>y. (y + n + 1, t)) ` (R' `` ?L)) + \<dots> =
      sum c (((\<lambda>y. (y + n + 1, t)) ` (R' `` ?L)) \<union> (Pair s ` ({..n} - ?L)))"
      by(subst sum.union_disjoint) auto
    also have "\<dots> \<le> sum c (((\<lambda>y. (y + n + 1, t)) ` (R' `` ?L)) \<union> (Pair s ` ({..n} - ?L)) \<union> {(x, t) | x. x \<in> C \<and> n < x \<and> x \<le> 2 * n + 1})"
      by(rule sum_mono2)(auto simp add: g_nonneg)
    also have "(((\<lambda>y. (y + n + 1, t)) ` (R' `` ?L)) \<union> (Pair s ` ({..n} - ?L)) \<union> {(x, t) | x. x \<in> C \<and> n < x \<and> x \<le> 2 * n + 1}) = (Pair s ` ({..n} - ?L)) \<union>  {(x, t) | x. x \<in> C \<and> n < x \<and> x \<le> 2 * n + 1}"
      using no_leaving R' by(fastforce simp add: Image_iff intro: rev_image_eqI)
    also have "sum c \<dots> = sum c (outgoing' C)" using C.s_in_cut C.t_ni_cut f_nonneg no_leaving
      apply(intro sum.mono_neutral_cong_right)
      apply(auto simp add: outgoing'_def E_def intro: le_neq_trans)
      apply(fastforce simp add: c_simps Image_iff intro: rev_image_eqI split: if_split_asm)+
      done
    also have "\<dots> = C.cap" by(simp add: C.cap_def)
    finally show "sum f {..n} \<le> \<dots>" by simp
  qed

  show thesis
  proof
    show "0 \<le> ?h x y" for x y by(rule h.f_non_negative)
    show "(x, y) \<in> R" if "0 < ?h x y" "x \<le> n" "y \<le> n" for x y
      using h.capacity_const[rule_format, of "(x, y + n + 1)"] that
      by(simp add: c_simps R'_def split: if_split_asm)

    have sum_h: "sum (?h x) {..n} = max_flow (s, x)" if "x \<le> n" for x
    proof -
      have "sum (?h x) {..n} = sum max_flow (Pair x ` ((+) (n + 1)) ` {..n})"
        by(simp add: sum.reindex add.commute inj_on_def)
      also have "\<dots> = sum max_flow (outgoing x)" using that
        apply(intro sum.mono_neutral_cong_right)
        apply(auto simp add: outgoing_def E_def)
        subgoal for y by(auto 4 3 simp add: c_simps max_def split: if_split_asm intro: rev_image_eqI[where x="y - n - 1"])
        done
      also have "\<dots> = sum max_flow (incoming x)" using that by(subst h.conservation) auto
      also have "\<dots> = sum max_flow {(s, x)}" using that
        by(intro sum.mono_neutral_cong_left; auto simp add: incoming_def E_def; simp add: c_simps split: if_split_asm)
      finally show ?thesis by simp
    qed
    hence le: "sum (?h x) {..n} \<le> f x" if "x \<le> n" for x
      using sum_h[OF that] h.capacity_const[rule_format, of "(s, x)"] that by simp
    moreover have "f x \<le> sum (?h x) {..n}" if "x \<le> n" for x
    proof(rule ccontr)
      assume "\<not> ?thesis"
      hence "sum (?h x) {..n} < f x" by simp
      hence "sum (\<lambda>x. (sum (?h x) {..n})) {..n} < sum f {..n}"
        using le that by(intro sum_strict_mono_ex1) auto
      also have "sum (\<lambda>x. (sum (?h x) {..n})) {..n} = sum max_flow (Pair s ` {..n})"
        using sum_h by(simp add: sum.reindex inj_on_def)
      also have "\<dots> = sum max_flow (outgoing s)"
        by(rule sum.mono_neutral_right)(auto simp add: outgoing_def E_def)
      also have "\<dots> = sum f {..n}" using eq cap by(simp add: h.val_alt)
      finally show False by simp
    qed
    ultimately show "f x = sum (?h x) {..n}" if "x \<le> n" for x using that by(auto intro: antisym)

    have sum_h': "sum (\<lambda>x. ?h x y) {..n} = max_flow (y + n + 1, t)" if "y \<le> n" for y
    proof -
      have "sum (\<lambda>x. ?h x y) {..n} = sum max_flow ((\<lambda>x. (x, y + n + 1)) ` {..n})"
        by(simp add: sum.reindex inj_on_def)
      also have "\<dots> = sum max_flow (incoming (y + n + 1))" using that
        apply(intro sum.mono_neutral_cong_right)
        apply(auto simp add: incoming_def E_def)
        apply(auto simp add: c_simps t_def split: if_split_asm)
        done
      also have "\<dots> = sum max_flow (outgoing (y + n + 1))"
        using that by(subst h.conservation)(auto simp add: s_def t_def)
      also have "\<dots> = sum max_flow {(y + n + 1, t)}" using that
        by(intro sum.mono_neutral_cong_left; auto simp add: outgoing_def E_def; simp add: s_def c_simps split: if_split_asm)
      finally show ?thesis by simp
    qed
    hence le': "sum (\<lambda>x. ?h x y) {..n} \<le> g y" if "y \<le> n" for y
      using sum_h'[OF that] h.capacity_const[rule_format, of "(y + n + 1, t)"] that by simp
    moreover have "g y \<le> sum (\<lambda>x. ?h x y) {..n}" if "y \<le> n" for y
    proof(rule ccontr)
      assume "\<not> ?thesis"
      hence "sum (\<lambda>x. ?h x y) {..n} < g y" by simp
      hence "sum (\<lambda>y. (sum (\<lambda>x. ?h x y) {..n})) {..n} < sum g {..n}"
        using le' that by(intro sum_strict_mono_ex1) auto
      also have "sum (\<lambda>y. (sum (\<lambda>x. ?h x y) {..n})) {..n} = sum max_flow ((\<lambda>y. (y + n + 1, t)) ` {..n})"
        using sum_h' by(simp add: sum.reindex inj_on_def)
      also have "\<dots> = sum max_flow (incoming t)"
        apply(rule sum.mono_neutral_right)
        apply simp
        apply(auto simp add: incoming_def E_def cong: rev_conj_cong)
        subgoal for u by(auto intro: rev_image_eqI[where x="u - n - 1"])
        done
      also have "\<dots> = sum max_flow (outgoing s)" by(rule h.inflow_t_outflow_s)
      also have "\<dots> = sum f {..n}" using eq cap by(simp add: h.val_alt)
      finally show False using eq_sum by simp
    qed
    ultimately show "g y = sum (\<lambda>x. ?h x y) {..n}" if "y \<le> n" for y using that by(auto intro: antisym)
  qed
qed

lemma convergent_bounded_family_nat:
  fixes f :: "nat \<Rightarrow> nat \<Rightarrow> real"
  assumes bounded: "\<And>x. bounded (range (\<lambda>n. f n x))"
  obtains k where "strict_mono k" "\<And>x. convergent (\<lambda>n. f (k n) x)"
proof -
  interpret subseqs "\<lambda>x k. convergent (\<lambda>n. f (k n) x)"
  proof(unfold_locales)
    fix x and s :: "nat \<Rightarrow> nat"
    have "bounded (range (\<lambda>n. f (s n) x))" using bounded by(rule bounded_subset) auto
    from bounded_imp_convergent_subsequence[OF this]
    show "\<exists>r. strict_mono r \<and> convergent (\<lambda>n. f ((s \<circ> r) n) x)"
      by(auto simp add: o_def convergent_def)
  qed
  { fix k
    have "convergent (\<lambda>n. f ((diagseq \<circ> (+) (Suc k)) n) k)"
      by(rule diagseq_holds)(auto dest: convergent_subseq_convergent simp add: o_def)
    hence "convergent (\<lambda>n. f (diagseq n) k)" unfolding o_def
      by(subst (asm) add.commute)(simp only: convergent_ignore_initial_segment[where f="\<lambda>x. f (diagseq x) k"])
  } with subseq_diagseq show ?thesis ..
qed

lemma convergent_bounded_family:
  fixes f :: "nat \<Rightarrow> 'a \<Rightarrow> real"
  assumes bounded: "\<And>x. x \<in> A \<Longrightarrow> bounded (range (\<lambda>n. f n x))"
  and A: "countable A"
  obtains k where "strict_mono k" "\<And>x. x \<in> A \<Longrightarrow> convergent (\<lambda>n. f (k n) x)"
proof(cases "A = {}")
  case False
  define f' where "f' n x = f n (from_nat_into A x)" for n x
  have "bounded (range (\<lambda>n. f' n x))" for x
    unfolding f'_def using from_nat_into[OF False] by(rule bounded)
  then obtain k where k: "strict_mono k"
    and conv: "convergent (\<lambda>n. f' (k n) x)" for x
    by(rule convergent_bounded_family_nat) iprover
  have "convergent (\<lambda>n. f (k n) x)" if "x \<in> A" for x
    using conv[of "to_nat_on A x"] A that by(simp add: f'_def)
  with k show thesis ..
next
  case True
  with strict_mono_id show thesis by(blast intro!: that)
qed

abbreviation zero_on :: "('a \<Rightarrow> 'b :: zero) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b"
where "zero_on f \<equiv> override_on f (\<lambda>_. 0)"

lemma zero_on_le [simp]: fixes f :: "'a \<Rightarrow> 'b :: {preorder, zero}" shows
  "zero_on f X x \<le> f x \<longleftrightarrow> (x \<in> X \<longrightarrow> 0 \<le> f x)"
by(auto simp add: override_on_def)

lemma zero_on_nonneg: fixes f :: "'a \<Rightarrow> 'b :: {preorder, zero}" shows
  "0 \<le> zero_on f X x \<longleftrightarrow> (x \<notin> X \<longrightarrow> 0 \<le> f x)"
by(auto simp add: override_on_def)

lemma sums_zero_on:
  fixes f :: "nat \<Rightarrow> 'a::real_normed_vector"
  assumes f: "f sums s"
    and X: "finite X"
  shows "zero_on f X sums (s - sum f X)"
proof -
  have "(\<lambda>x. if x \<in> X then f x else 0) sums sum (\<lambda>x. f x) X" using X by(rule sums_If_finite_set)
  from sums_diff[OF f this] show ?thesis
    by(simp add: sum_negf override_on_def if_distrib cong del: if_weak_cong)
qed

lemma
  fixes f :: "nat \<Rightarrow> 'a::real_normed_vector"
  assumes f: "summable f"
  and X: "finite X"
  shows summable_zero_on [simp]: "summable (zero_on f X)" (is ?thesis1)
  and suminf_zero_on: "suminf (zero_on f X) = suminf f - sum f X" (is ?thesis2)
proof -
  from f obtain s where "f sums s" unfolding summable_def ..
  with sums_zero_on[OF this X] show ?thesis1 ?thesis2
    by(auto simp add: summable_def sums_unique[symmetric])
qed

lemma summable_zero_on_nonneg:
  fixes f :: "nat \<Rightarrow> 'a :: {ordered_comm_monoid_add,linorder_topology,conditionally_complete_linorder}"
  assumes f: "summable f"
  and nonneg: "\<And>x. 0 \<le> f x"
  shows "summable (zero_on f X)"
proof(rule summableI_nonneg_bounded)
  fix n
  have "sum (zero_on f X) {..<n} \<le> sum f {..<n}" by(rule sum_mono)(simp add: nonneg)
  also have "\<dots> \<le> suminf f" using f by(rule sum_le_suminf)(auto simp add: nonneg)
  finally show "sum (zero_on f X) {..<n} \<le> suminf f" .
qed(simp add: zero_on_nonneg nonneg)

lemma zero_on_ennreal [simp]: "zero_on (\<lambda>x. ennreal (f x)) A = (\<lambda>x. ennreal (zero_on f A x))"
by(simp add: override_on_def fun_eq_iff)

lemma sum_lessThan_conv_atMost_nat:
  fixes f :: "nat \<Rightarrow> 'b :: ab_group_add"
  shows "sum f {..<n} = sum f {..n} - f n"
by (metis Groups.add_ac(2) add_diff_cancel_left' lessThan_Suc_atMost sum.lessThan_Suc)

lemma Collect_disjoint_atLeast:
  "Collect P \<inter> {x..} = {} \<longleftrightarrow> (\<forall>y\<ge>x. \<not> P y)"
by(auto simp add: atLeast_def)

lemma bounded_matrix_for_marginals_nat:
  fixes f g :: "nat \<Rightarrow> real"
    and R :: "(nat \<times> nat) set"
    and s :: real
  assumes sum_f: "f sums s" and sum_g: "g sums s"
    and f_nonneg: "\<And>x. 0 \<le> f x" and g_nonneg: "\<And>y. 0 \<le> g y"
    and f_le_g: "\<And>X. suminf (zero_on f (- X)) \<le> suminf (zero_on g (- R `` X))"
  obtains h :: "nat \<Rightarrow> nat \<Rightarrow> real"
    where "\<And>x y. 0 \<le> h x y"
    and "\<And>x y. 0 < h x y \<Longrightarrow> (x, y) \<in> R"
    and "\<And>x. h x sums f x"
    and "\<And>y. (\<lambda>x. h x y) sums g y"
proof -
  have summ_f: "summable f" and summ_g: "summable g" and sum_fg: "suminf f = suminf g"
    using sum_f sum_g by(auto simp add: summable_def sums_unique[symmetric])

  have summ_zf: "summable (zero_on f A)" for A
    using summ_f f_nonneg by(rule summable_zero_on_nonneg)
  have summ_zg: "summable (zero_on g A)" for A
    using summ_g g_nonneg by(rule summable_zero_on_nonneg)

  define f' :: "nat \<Rightarrow> nat \<Rightarrow> real"
    where "f' n x = (if x \<le> n then f x else if x = Suc n then \<Sum> k. f (k + (n + 1)) else 0)" for n x
  define g' :: "nat \<Rightarrow> nat \<Rightarrow> real"
    where "g' n y = (if y \<le> n then g y else if y = Suc n then \<Sum> k. g (k + (n + 1)) else 0)" for n y
  define R' :: "nat \<Rightarrow> (nat \<times> nat) set"
    where "R' n =
      R \<inter> {..n} \<times> {..n} \<union>
      {(n + 1, y) | y. \<exists>x'>n. (x', y) \<in> R \<and> y \<le> n} \<union>
      {(x, n + 1) | x. \<exists>y'>n. (x, y') \<in> R \<and> x \<le> n} \<union>
      (if \<exists>x>n. \<exists>y>n. (x, y) \<in> R then {(n + 1, n + 1)} else {})"
    for n
  have R'_simps [simplified, simp]:
    "\<lbrakk> x \<le> n; y \<le> n \<rbrakk> \<Longrightarrow> (x, y) \<in> R' n \<longleftrightarrow> (x, y) \<in> R"
    "y \<le> n \<Longrightarrow> (n + 1, y) \<in> R' n \<longleftrightarrow> (\<exists>x'>n. (x', y) \<in> R)"
    "x \<le> n \<Longrightarrow> (x, n + 1) \<in> R' n \<longleftrightarrow> (\<exists>y'>n. (x, y') \<in> R)"
    "(n + 1, n + 1) \<in> R' n \<longleftrightarrow> (\<exists>x'>n. \<exists>y'>n. (x', y') \<in> R)"
    "x > n + 1 \<or> y > n + 1 \<Longrightarrow> (x, y) \<notin> R' n"
    for x y n by(auto simp add: R'_def)

  have R'_cases: thesis if "(x, y) \<in> R' n"
    and "\<lbrakk> x \<le> n; y \<le> n; (x, y) \<in> R \<rbrakk> \<Longrightarrow> thesis"
    and "\<And>x'. \<lbrakk> x = n + 1; y \<le> n; n < x'; (x', y) \<in> R \<rbrakk> \<Longrightarrow> thesis"
    and "\<And>y'. \<lbrakk> x \<le> n; y = n + 1; n < y'; (x, y') \<in> R \<rbrakk> \<Longrightarrow> thesis"
    and "\<And>x' y'. \<lbrakk> x = n + 1; y = n + 1; n < x'; n < y'; (x', y') \<in> R \<rbrakk> \<Longrightarrow> thesis"
    for thesis x y n using that by(auto simp add: R'_def split: if_split_asm)

  have R'_intros:
    "\<lbrakk> (x, y) \<in> R; x \<le> n; y \<le> n \<rbrakk> \<Longrightarrow> (x, y) \<in> R' n"
    "\<lbrakk> (x', y) \<in> R; n < x'; y \<le> n \<rbrakk> \<Longrightarrow> (n + 1, y) \<in> R' n"
    "\<lbrakk> (x, y') \<in> R; x \<le> n; n < y' \<rbrakk> \<Longrightarrow> (x, n + 1) \<in> R' n"
    "\<lbrakk> (x', y') \<in> R; n < x'; n < y' \<rbrakk> \<Longrightarrow> (n + 1, n + 1) \<in> R' n"
    for n x y x' y' by(auto)

  have Image_R':
    "R' n `` X = (R `` (X \<inter> {..n})) \<inter> {..n} \<union>
    (if n + 1 \<in> X then (R `` {n+1..}) \<inter> {..n} else {}) \<union>
    (if (R `` (X \<inter> {..n})) \<inter> {n+1..} = {} then {} else {n + 1}) \<union>
    (if n + 1 \<in> X \<and> (R `` {n+1..}) \<inter> {n+1..} \<noteq> {} then {n + 1} else {})" for n X
    apply(simp add: Image_def)
    apply(safe elim!: R'_cases; auto simp add: Collect_disjoint_atLeast intro: R'_intros simp add: Suc_le_eq dest: Suc_le_lessD)
    apply(metis R'_simps(4) R'_intros(3) Suc_eq_plus1)+
    done

  { fix n
    have "sum (f' n) {..n + 1} = sum (g' n) {..n + 1}" using sum_fg
      unfolding f'_def g'_def suminf_minus_initial_segment[OF summ_f] suminf_minus_initial_segment[OF summ_g]
      by(simp)(metis (no_types, hide_lams) add.commute add.left_inverse atLeast0AtMost atLeast0LessThan atLeastLessThanSuc_atLeastAtMost minus_add_distrib sum.lessThan_Suc uminus_add_conv_diff)
    moreover have "sum (f' n) X \<le> sum (g' n) (R' n `` X)" if "X \<subseteq> {..n + 1}" for X
    proof -
      from that have [simp]: "finite X" by(rule finite_subset) simp
      define X' where "X' \<equiv> if n + 1 \<in> X then X \<union> {n+1..} else X"

      define Y' where "Y' \<equiv> if R `` X' \<inter> {n+1..} = {} then R `` X' else R `` X' \<union> {n+1..}"

      have "sum (f' n) X = sum (f' n) (X - {n + 1}) + (if n + 1 \<in> X then f' n (n + 1) else 0)"
        by(simp add: sum.remove)
      also have "sum (f' n) (X - {n + 1}) = sum f (X - {n + 1})" using that
        by(intro sum.cong)(auto simp add: f'_def)
      also have "\<dots> + (if n + 1 \<in> X then f' n (n + 1) else 0) = suminf (zero_on f (- X'))"
      proof(cases "n + 1 \<in> X")
        case True
        with sum_f that show ?thesis
          apply(simp add: summable_def X'_def f'_def suminf_zero_on[OF sums_summable] del: One_nat_def)
          apply(subst suminf_minus_initial_segment[OF summ_f])
          apply(simp add: algebra_simps)
          apply(subst sum.union_disjoint[symmetric])
          apply(auto simp add: sum_lessThan_conv_atMost_nat intro!: sum.cong)
          done
      next
        case False
        with sum_f show ?thesis
          by(simp add: X'_def suminf_finite[where N=X])
      qed
      also have "\<dots> \<le> suminf (zero_on g (- R `` X'))" by(rule f_le_g)
      also have "\<dots> \<le> suminf (zero_on g (- Y'))"
        by(rule suminf_le[OF _ summ_zg summ_zg])(clarsimp simp add: override_on_def g_nonneg Y'_def summ_zg)
      also have "\<dots> = suminf (\<lambda>k. zero_on g (- Y') (k + (n + 1))) + sum (zero_on g (- Y')) {..n}"
        by(subst suminf_split_initial_segment[OF summ_zg, of _ "n + 1"])(simp add: sum_lessThan_conv_atMost_nat)
      also have "sum (zero_on g (- Y')) {..n} = sum g (Y' \<inter> {..n})"
        by(rule sum.mono_neutral_cong_right)(auto simp add: override_on_def)
      also have "\<dots> = sum (g' n) (Y' \<inter> {..n})"
        by(rule sum.cong)(auto simp add: g'_def)
      also have "suminf (\<lambda>k. zero_on g (- Y') (k + (n + 1))) \<le> (if R `` X' \<inter> {n+1..} = {} then 0 else g' n (n + 1))"
        apply(clarsimp simp add: Y'_def g'_def simp del: One_nat_def)
        apply(subst suminf_eq_zero_iff[THEN iffD2])
        apply(auto simp del: One_nat_def simp add: summable_iff_shift summ_zg zero_on_nonneg g_nonneg)
        apply(auto simp add: override_on_def)
        done
      also have "\<dots> + sum (g' n) (Y' \<inter> {..n}) = sum (g' n) (R' n `` X)"
        using that by(fastforce simp add: Image_R' Y'_def X'_def atMost_Suc intro: sum.cong[OF _ refl])
      finally show ?thesis by simp
    qed
    moreover have "\<And>x. 0 \<le> f' n x" "\<And>y. 0 \<le> g' n y"
      by(auto simp add: f'_def g'_def f_nonneg g_nonneg summable_iff_shift summ_f summ_g intro!: suminf_nonneg simp del: One_nat_def)
    moreover have "R' n \<subseteq> {..n+1} \<times> {..n+1}"
      by(auto elim!: R'_cases)
    ultimately obtain h
      where "\<And>x y. \<lbrakk> x \<le> n + 1; y \<le> n + 1\<rbrakk> \<Longrightarrow> 0 \<le> h x y"
      and "\<And>x y. \<lbrakk> 0 < h x y; x \<le> n + 1; y \<le> n + 1\<rbrakk> \<Longrightarrow> (x, y) \<in> R' n"
      and "\<And>x. x \<le> n + 1 \<Longrightarrow> f' n x = sum (h x) {..n + 1}"
      and "\<And>y. y \<le> n + 1 \<Longrightarrow> g' n y = sum (\<lambda>x. h x y) {..n + 1}"
      by(rule bounded_matrix_for_marginals_finite) blast+
    hence "\<exists>h. (\<forall>x y. x \<le> n + 1 \<longrightarrow> y \<le> n + 1 \<longrightarrow> 0 \<le> h x y) \<and>
       (\<forall>x y. 0 < h x y \<longrightarrow> x \<le> n + 1 \<longrightarrow> y \<le> n + 1 \<longrightarrow> (x, y) \<in> R' n) \<and>
       (\<forall>x. x \<le> n + 1 \<longrightarrow> f' n x = sum (h x) {..n + 1}) \<and>
       (\<forall>y. y \<le> n + 1 \<longrightarrow> g' n y = sum (\<lambda>x. h x y) {..n + 1})" by blast }
  hence "\<exists>h. \<forall>n. (\<forall>x y. x \<le> n + 1 \<longrightarrow> y \<le> n + 1 \<longrightarrow> 0 \<le> h n x y) \<and>
       (\<forall>x y. 0 < h n x y \<longrightarrow> x \<le> n + 1 \<longrightarrow> y \<le> n + 1 \<longrightarrow> (x, y) \<in> R' n) \<and>
       (\<forall>x. x \<le> n + 1 \<longrightarrow> f' n x = sum (h n x) {..n + 1}) \<and>
       (\<forall>y. y \<le> n + 1 \<longrightarrow> g' n y = sum (\<lambda>x. h n x y) {..n + 1})"
    by(subst choice_iff[symmetric]) blast
  then obtain h where h_nonneg: "\<And>n x y. \<lbrakk> x \<le> n + 1; y \<le> n + 1\<rbrakk> \<Longrightarrow> 0 \<le> h n x y"
    and h_R: "\<And>n x y. \<lbrakk> 0 < h n x y; x \<le> n + 1; y \<le> n + 1\<rbrakk> \<Longrightarrow> (x, y) \<in> R' n"
    and h_f: "\<And>n x. x \<le> n + 1 \<Longrightarrow> f' n x = sum (h n x) {..n + 1}"
    and h_g: "\<And>n y. y \<le> n + 1 \<Longrightarrow> g' n y = sum (\<lambda>x. h n x y) {..n + 1}"
    apply(rule exE)
    subgoal for h by(erule meta_allE[of _ h]) blast
    done

  define h' :: "nat \<Rightarrow> nat \<times> nat \<Rightarrow> real"
    where "h' n = (\<lambda>(x, y). if x \<le> n \<and> y \<le> n then h n x y else 0)" for n
  have h'_nonneg: "h' n xy \<ge> 0" for n xy by(simp add: h'_def h_nonneg split: prod.split)

  have "h' n xy \<le> s" for n xy
  proof(cases xy)
    case [simp]: (Pair x y)
    consider (le) "x \<le> n" "y \<le> n" | (beyond) "x > n \<or> y > n" by fastforce
    then show ?thesis
    proof cases
      case le
      have "h' n xy = h n x y" by(simp add: h'_def le)
      also have "\<dots> \<le> h n x y + sum (h n x) {..<y} + sum (h n x) {y<..n + 1}"
        using h_nonneg le by(auto intro!: sum_nonneg add_nonneg_nonneg)
      also have "\<dots> = sum (h n x) {..y} +  sum (h n x) {y<..n + 1}"
        by(simp add: sum_lessThan_conv_atMost_nat)
      also have "\<dots> = sum (h n x) {..n+1}" using le
        by(subst sum.union_disjoint[symmetric])(auto simp del: One_nat_def intro!: sum.cong)
      also have "\<dots> = f' n x" using le by(simp add: h_f)
      also have "\<dots> = f x" using le by(simp add: f'_def)
      also have "\<dots> = suminf (zero_on f (- {x}))"
        by(subst suminf_finite[where N="{x}"]) simp_all
      also have "\<dots> \<le> suminf f"
        by(rule suminf_le)(auto simp add: f_nonneg summ_zf summ_f)
      also have "\<dots> = s" using sum_f by(simp add: sums_unique[symmetric])
      finally show ?thesis .
    next
      case beyond
      then have "h' n xy = 0" by(auto simp add: h'_def)
      also have "0 \<le> s" using summ_f by(simp add: sums_unique[OF sum_f] suminf_nonneg f_nonneg)
      finally show ?thesis .
    qed
  qed
  then have "bounded (range (\<lambda>n. h' n x))" for x unfolding bounded_def
    by(intro exI[of _ 0] exI[of _ s]; simp add: h'_nonneg)
  from convergent_bounded_family[OF this, of UNIV "%x. x"] obtain k
    where k: "strict_mono k" and conv: "\<And>xy. convergent (\<lambda>n. h' (k n) xy)" by auto

  define H :: "nat \<Rightarrow> nat \<Rightarrow> real"
    where "H x y = lim (\<lambda>n. h' (k n) (x, y))" for x y

  have H: "(\<lambda>n. h' (k n) (x, y)) \<longlonglongrightarrow> H x y" for x y
    unfolding H_def using conv[of "(x, y)"] by(simp add: convergent_LIMSEQ_iff)

  show thesis
  proof(rule that)
    show H_nonneg: "0 \<le> H x y" for x y using H[of x y] by(rule LIMSEQ_le_const)(simp add: h'_nonneg)
    show "(x, y) \<in> R" if "0 < H x y" for x y
    proof(rule ccontr)
      assume "(x, y) \<notin> R"
      hence "h' n (x, y) = 0" for n using h_nonneg[of x n y] h_R[of n x y]
        by(fastforce simp add: h'_def)
      hence "H x y = 0" using H[of x y] by(simp add: LIMSEQ_const_iff)
      with that show False by simp
   qed
   show "H x sums f x" for x unfolding sums_iff
   proof
     have sum_H: "sum (H x) {..<m} \<le> f x" for m
     proof -
       have "sum (\<lambda>y. h' (k n) (x, y)) {..<m} \<le> f x" for n
       proof(cases "x \<le> k n")
         case True
         from k have "n \<le> k n" by(rule seq_suble)
         have "sum (\<lambda>y. h' (k n) (x, y)) {..<m} = sum (\<lambda>y. h' (k n) (x, y)) {..<min m (k n + 1)}"
           by(rule sum.mono_neutral_right)(auto simp add: h'_def min_def)
         also have "\<dots> \<le> sum (\<lambda>y. h (k n) x y) {..k n + 1}" using True
           by(intro sum_le_included[where i="id"])(auto simp add: h'_def h_nonneg)
         also have "\<dots> = f' (k n) x" using h_f True by simp
         also have "\<dots> = f x" using True by(simp add: f'_def)
         finally show ?thesis .
       qed(simp add: f_nonneg h'_def)
       then show ?thesis by -((rule LIMSEQ_le_const2 tendsto_sum H)+, simp)
     qed
     with H_nonneg show summ_H: "summable (H x)" by(rule summableI_nonneg_bounded)
     hence "suminf (H x) \<le> f x" using sum_H by(rule suminf_le_const)
     moreover
     have "(\<lambda>m. sum (H x) {..<m} + suminf (\<lambda>n. g (n + m))) \<longlonglongrightarrow> suminf (H x) + 0"
       by(rule tendsto_intros summable_LIMSEQ summ_H suminf_exist_split2 summ_g)+
     hence "f x \<le> suminf (H x) + 0"
     proof(rule LIMSEQ_le_const)
       have "f x \<le> sum (H x) {..<m} + suminf (\<lambda>n. g (n + m))" for m
       proof -
         have "(\<lambda>n. sum (\<lambda>y. h' (k n) (x, y)) {..<m} + suminf (\<lambda>i. g (i + m))) \<longlonglongrightarrow> sum (H x) {..<m} + suminf (\<lambda>i. g (i + m))"
           by(rule tendsto_intros H)+
         moreover have "\<exists>N. \<forall>n\<ge>N. f x \<le> sum (\<lambda>y. h' (k n) (x, y)) {..<m} + suminf (\<lambda>i. g (i + m))"
         proof(intro exI strip)
           fix n
           assume "max x m \<le> n"
           with seq_suble[OF k, of n] have x: "x \<le> k n" and m: "m \<le> k n" by auto
           have "f x = f' (k n) x" using x by(simp add: f'_def)
           also have "\<dots> = sum (h (k n) x) {..k n + 1}" using x by(simp add: h_f)
           also have "\<dots> = sum (h (k n) x) {..<m} + sum (h (k n) x) {m..k n + 1}"
             using x m by(subst sum.union_disjoint[symmetric])(auto intro!: sum.cong simp del: One_nat_def)
           also have "sum (h (k n) x) {..<m} = sum (\<lambda>y. h' (k n) (x, y)) {..<m}"
             using x m by(auto simp add: h'_def)
           also have "sum (h (k n) x) {m..k n + 1} = sum (\<lambda>y. sum (\<lambda>x. h (k n) x y) {x}) {m..k n + 1}" by simp
           also have "\<dots> \<le> sum (\<lambda>y. sum (\<lambda>x. h (k n) x y) {..k n + 1}) {m..k n + 1}" using x
             by(intro sum_mono sum_mono2)(auto simp add: h_nonneg)
           also have "\<dots> = sum (g' (k n)) {m..k n + 1}" by(simp add: h_g del: One_nat_def)
           also have "\<dots> = sum g {m..k n} + suminf (\<lambda>i. g (i + (k n + 1)))" using m by(simp add: g'_def)
           also have "\<dots> = suminf (\<lambda>i. g (i + m))" using m
             apply(subst (2) suminf_split_initial_segment[where k="k n + 1 - m"])
             apply(simp_all add: summable_iff_shift summ_g)
             apply(rule sum.reindex_cong[OF _ _ refl])
             apply(simp_all add: Suc_diff_le lessThan_Suc_atMost)
             apply(safe; clarsimp)
             subgoal for x by(rule image_eqI[where x="x - m"]) auto
             subgoal by auto
             done
           finally show "f x \<le> sum (\<lambda>y. h' (k n) (x, y)) {..<m} + \<dots>" by simp
         qed
         ultimately show ?thesis by(rule LIMSEQ_le_const)
       qed
       thus "\<exists>N. \<forall>n\<ge>N. f x \<le> sum (H x) {..<n} + (\<Sum>i. g (i + n))" by auto
     qed
     ultimately show "suminf (H x) = f x" by simp
   qed
   show "(\<lambda>x. H x y) sums g y" for y unfolding sums_iff
   proof
     have sum_H: "sum (\<lambda>x. H x y) {..<m} \<le> g y" for m
     proof -
       have "sum (\<lambda>x. h' (k n) (x, y)) {..<m} \<le> g y" for n
       proof(cases "y \<le> k n")
         case True
         from k have "n \<le> k n" by(rule seq_suble)
         have "sum (\<lambda>x. h' (k n) (x, y)) {..<m} = sum (\<lambda>x. h' (k n) (x, y)) {..<min m (k n + 1)}"
           by(rule sum.mono_neutral_right)(auto simp add: h'_def min_def)
         also have "\<dots> \<le> sum (\<lambda>x. h (k n) x y) {..k n + 1}" using True
           by(intro sum_le_included[where i="id"])(auto simp add: h'_def h_nonneg)
         also have "\<dots> = g' (k n) y" using h_g True by simp
         also have "\<dots> = g y" using True by(simp add: g'_def)
         finally show ?thesis .
       qed(simp add: g_nonneg h'_def)
       then show ?thesis by -((rule LIMSEQ_le_const2 tendsto_sum H)+, simp)
     qed
     with H_nonneg show summ_H: "summable (\<lambda>x. H x  y)" by(rule summableI_nonneg_bounded)
     hence "suminf (\<lambda>x. H x y) \<le> g y" using sum_H by(rule suminf_le_const)
     moreover
     have "(\<lambda>m. sum (\<lambda>x. H x y) {..<m} + suminf (\<lambda>n. f (n + m))) \<longlonglongrightarrow> suminf (\<lambda>x. H x y) + 0"
       by(rule tendsto_intros summable_LIMSEQ summ_H suminf_exist_split2 summ_f)+
     hence "g y \<le> suminf (\<lambda>x. H x y) + 0"
     proof(rule LIMSEQ_le_const)
       have "g y \<le> sum (\<lambda>x. H x y) {..<m} + suminf (\<lambda>n. f (n + m))" for m
       proof -
         have "(\<lambda>n. sum (\<lambda>x. h' (k n) (x, y)) {..<m} + suminf (\<lambda>i. f (i + m))) \<longlonglongrightarrow> sum (\<lambda>x. H x y) {..<m} + suminf (\<lambda>i. f (i + m))"
           by(rule tendsto_intros H)+
         moreover have "\<exists>N. \<forall>n\<ge>N. g y \<le> sum (\<lambda>x. h' (k n) (x, y)) {..<m} + suminf (\<lambda>i. f (i + m))"
         proof(intro exI strip)
           fix n
           assume "max y m \<le> n"
           with seq_suble[OF k, of n] have y: "y \<le> k n" and m: "m \<le> k n" by auto
           have "g y = g' (k n) y" using y by(simp add: g'_def)
           also have "\<dots> = sum (\<lambda>x. h (k n) x y) {..k n + 1}" using y by(simp add: h_g)
           also have "\<dots> = sum (\<lambda>x. h (k n) x y) {..<m} + sum (\<lambda>x. h (k n) x y) {m..k n + 1}"
             using y m by(subst sum.union_disjoint[symmetric])(auto intro!: sum.cong simp del: One_nat_def)
           also have "sum (\<lambda>x. h (k n) x y) {..<m} = sum (\<lambda>x. h' (k n) (x, y)) {..<m}"
             using y m by(auto simp add: h'_def)
           also have "sum (\<lambda>x. h (k n) x y) {m..k n + 1} = sum (\<lambda>x. sum (\<lambda>y. h (k n) x y) {y}) {m..k n + 1}" by simp
           also have "\<dots> \<le> sum (\<lambda>x. sum (\<lambda>y. h (k n) x y) {..k n + 1}) {m..k n + 1}" using y
             by(intro sum_mono sum_mono2)(auto simp add: h_nonneg)
           also have "\<dots> = sum (f' (k n)) {m..k n + 1}" by(simp add: h_f del: One_nat_def)
           also have "\<dots> = sum f {m..k n} + suminf (\<lambda>i. f (i + (k n + 1)))" using m by(simp add: f'_def)
           also have "\<dots> = suminf (\<lambda>i. f (i + m))" using m
             apply(subst (2) suminf_split_initial_segment[where k="k n + 1 - m"])
             apply(simp_all add: summable_iff_shift summ_f)
             apply(rule sum.reindex_cong[OF _ _ refl])
             apply(simp_all add: Suc_diff_le lessThan_Suc_atMost)
             apply(safe; clarsimp)
             subgoal for x by(rule image_eqI[where x="x - m"]) auto
             subgoal by auto
             done
           finally show "g y \<le> sum (\<lambda>x. h' (k n) (x, y)) {..<m} + \<dots>" by simp
         qed
         ultimately show ?thesis by(rule LIMSEQ_le_const)
       qed
       thus "\<exists>N. \<forall>n\<ge>N. g y \<le> sum (\<lambda>x. H x y) {..<n} + (\<Sum>i. f (i + n))" by auto
     qed
     ultimately show "suminf (\<lambda>x. H x y) = g y" by simp
   qed
  qed
qed

lemma bounded_matrix_for_marginals_ennreal:
  assumes sum_eq: "(\<Sum>\<^sup>+ x\<in>A. f x) = (\<Sum>\<^sup>+ y\<in>B. g y)"
    and finite: "(\<Sum>\<^sup>+ x\<in>B. g x) \<noteq> \<top>"
    and le: "\<And>X. X \<subseteq> A \<Longrightarrow> (\<Sum>\<^sup>+ x\<in>X. f x) \<le> (\<Sum>\<^sup>+ y\<in>R `` X. g y)"
    and countable [simp]: "countable A" "countable B"
    and R: "R \<subseteq> A \<times> B"
  obtains h where "\<And>x y. 0 < h x y \<Longrightarrow> (x, y) \<in> R"
    and "\<And>x y. h x y \<noteq> \<top>"
    and "\<And>x. x \<in> A \<Longrightarrow> (\<Sum>\<^sup>+ y\<in>B. h x y) = f x"
    and "\<And>y. y \<in> B \<Longrightarrow> (\<Sum>\<^sup>+ x\<in>A. h x y) = g y"
proof -
  have fin_g [simp]: "g y \<noteq> \<top>" if "y \<in> B" for y using finite
    by(rule neq_top_trans)(rule nn_integral_ge_point[OF that])
  have fin_f [simp]: "f x \<noteq> \<top>" if "x \<in> A" for x using finite unfolding sum_eq[symmetric]
    by(rule neq_top_trans)(rule nn_integral_ge_point[OF that])

  define f' where "f' x = (if x \<in> to_nat_on A ` A then enn2real (f (from_nat_into A x)) else 0)" for x
  define g' where "g' y = (if y \<in> to_nat_on B ` B then enn2real (g (from_nat_into B y)) else 0)" for y
  define s where "s = enn2real (\<Sum>\<^sup>+ x\<in>B. g x)"
  define R' where "R' = map_prod (to_nat_on A) (to_nat_on B) ` R"

  have f'_nonneg: "f' x \<ge> 0" for x by(simp add: f'_def)
  have g'_nonneg: "g' y \<ge> 0" for y by(simp add: g'_def)

  have "(\<Sum>\<^sup>+ x. f' x) = (\<Sum>\<^sup>+ x\<in>to_nat_on A ` A. f' x)"
    by(auto simp add: nn_integral_count_space_indicator f'_def intro!: nn_integral_cong)
  also have "\<dots> = (\<Sum>\<^sup>+ x\<in>A. f x)"
    by(subst nn_integral_count_space_reindex)(auto simp add: inj_on_to_nat_on f'_def ennreal_enn2real_if intro!: nn_integral_cong)
  finally have sum_f': "(\<Sum>\<^sup>+ x. f' x) = (\<Sum>\<^sup>+ x\<in>A. f x)" .

  have "(\<Sum>\<^sup>+ y. g' y) = (\<Sum>\<^sup>+ y\<in>to_nat_on B ` B. g' y)"
    by(auto simp add: nn_integral_count_space_indicator g'_def intro!: nn_integral_cong)
  also have "\<dots> = (\<Sum>\<^sup>+ y\<in>B. g y)"
    by(subst nn_integral_count_space_reindex)(auto simp add: inj_on_to_nat_on g'_def ennreal_enn2real_if intro!: nn_integral_cong)
  finally have sum_g': "(\<Sum>\<^sup>+ y. g' y) = (\<Sum>\<^sup>+ y\<in>B. g y)" .

  have summ_f': "summable f'"
  proof(rule summableI_nonneg_bounded)
    show "sum f' {..<n} \<le> enn2real (\<Sum>\<^sup>+ x. f' x)" for n
    proof -
      have "sum f' {..<n} = enn2real (\<Sum>\<^sup>+ x\<in>{..<n}. f' x)"
        by(simp add: nn_integral_count_space_finite f'_nonneg sum_nonneg)
      also have "enn2real (\<Sum>\<^sup>+ x\<in>{..<n}. f' x) \<le> enn2real (\<Sum>\<^sup>+ x. f' x)" using finite sum_eq[symmetric]
        by(auto simp add: nn_integral_count_space_indicator sum_f'[symmetric] less_top intro!: nn_integral_mono enn2real_mono split: split_indicator)
      finally show ?thesis .
    qed
  qed(rule f'_nonneg)
  have suminf_f': "suminf f' = enn2real (\<Sum>\<^sup>+ y. f' y)"
    by(simp add: nn_integral_count_space_nat suminf_ennreal2[OF f'_nonneg summ_f'] suminf_nonneg[OF summ_f'] f'_nonneg)
  with summ_f' sum_f' sum_eq have sums_f: "f' sums s" by(simp add: s_def sums_iff)
  moreover
  have summ_g': "summable g'"
  proof(rule summableI_nonneg_bounded)
    show "sum g' {..<n} \<le> enn2real (\<Sum>\<^sup>+ y. g' y)" for n
    proof -
      have "sum g' {..<n} = enn2real (\<Sum>\<^sup>+ y\<in>{..<n}. g' y)"
        by(simp add: nn_integral_count_space_finite g'_nonneg sum_nonneg)
      also have "enn2real (\<Sum>\<^sup>+ y\<in>{..<n}. g' y) \<le> enn2real (\<Sum>\<^sup>+ y. g' y)" using finite
        by(auto simp add: nn_integral_count_space_indicator sum_g'[symmetric] less_top intro!: nn_integral_mono enn2real_mono split: split_indicator)
      finally show ?thesis .
    qed
  qed(rule g'_nonneg)
  have suminf_g': "suminf g' = enn2real (\<Sum>\<^sup>+ y. g' y)"
    by(simp add: nn_integral_count_space_nat suminf_ennreal2[OF g'_nonneg summ_g'] suminf_nonneg[OF summ_g'] g'_nonneg)
  with summ_g' sum_g' have sums_g: "g' sums s" by(simp add: s_def sums_iff)
  moreover note f'_nonneg g'_nonneg
  moreover have "suminf (zero_on f' (- X)) \<le> suminf (zero_on g' (- R' `` X))" for X
  proof -
    define X' where "X' = from_nat_into A ` (X \<inter> to_nat_on A ` A)"
    have X': "to_nat_on A ` X' = X \<inter> (to_nat_on A ` A)"
      by(auto 4 3 simp add: X'_def intro: rev_image_eqI)

    have "ennreal (suminf (zero_on f' (- X))) = suminf (zero_on (\<lambda>x. ennreal (f' x)) (- X))"
      by(simp add: suminf_ennreal2 zero_on_nonneg f'_nonneg summable_zero_on_nonneg summ_f')
    also have "\<dots> = (\<Sum>\<^sup>+ x\<in>X. f' x)"
      by(auto simp add: nn_integral_count_space_nat[symmetric] nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ x\<in>to_nat_on A ` X'. f' x)" using X'
      by(auto simp add: nn_integral_count_space_indicator f'_def intro!: nn_integral_cong split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ x \<in> X'. f x)"
      by(subst nn_integral_count_space_reindex)(auto simp add: X'_def inj_on_def f'_def ennreal_enn2real_if intro!: nn_integral_cong)
    also have "\<dots> \<le> (\<Sum>\<^sup>+ y \<in> R `` X'. g y)" by(rule le)(auto simp add: X'_def)
    also have "\<dots> = (\<Sum>\<^sup>+ y \<in> to_nat_on B ` (R `` X'). g' y)" using R fin_g
      by(subst nn_integral_count_space_reindex)(auto 4 3 simp add: X'_def inj_on_def g'_def ennreal_enn2real_if simp del: fin_g intro!: nn_integral_cong from_nat_into dest: to_nat_on_inj[THEN iffD1, rotated -1])
    also have "to_nat_on B ` (R `` X') = R' `` X" using R
      by(auto 4 4 simp add: X'_def R'_def Image_iff intro: rev_image_eqI rev_bexI intro!: imageI)
    also have "(\<Sum>\<^sup>+ y\<in>\<dots>. g' y) = suminf (zero_on (\<lambda>y. ennreal (g' y)) (- \<dots>))"
      by(auto simp add: nn_integral_count_space_nat[symmetric] nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
    also have "\<dots> = ennreal (suminf (zero_on g' (- R' `` X)))"
      by(simp add: suminf_ennreal2 zero_on_nonneg g'_nonneg summable_zero_on_nonneg summ_g')
    finally show ?thesis
      by(simp add: suminf_nonneg summable_zero_on_nonneg[OF summ_g' g'_nonneg] zero_on_nonneg g'_nonneg)
  qed
  ultimately obtain h' where h'_nonneg: "\<And>x y. 0 \<le> h' x y"
    and dom_h': "\<And>x y. 0 < h' x y \<Longrightarrow> (x, y) \<in> R'"
    and h'_f: "\<And>x. h' x sums f' x"
    and h'_g: "\<And>y. (\<lambda>x. h' x y) sums g' y"
    by(rule bounded_matrix_for_marginals_nat) blast

  define h where "h x y = ennreal (if x \<in> A \<and> y \<in> B then h' (to_nat_on A x) (to_nat_on B y) else 0)" for x y
  show ?thesis
  proof
    show "(x, y) \<in> R" if "0 < h x y" for x y
      using that dom_h'[of "to_nat_on A x" "to_nat_on B y"] R
      by(auto simp add: h_def R'_def dest: to_nat_on_inj[THEN iffD1, rotated -1] split: if_split_asm)
    show "h x y \<noteq> \<top>" for x y by(simp add: h_def)

    fix x
    assume x: "x \<in> A"
    have "(\<Sum>\<^sup>+ y\<in>B. h x y) = (\<Sum>\<^sup>+ y\<in>to_nat_on B ` B. h' (to_nat_on A x) y)"
      by(subst nn_integral_count_space_reindex)(auto simp add: inj_on_to_nat_on h_def x intro!: nn_integral_cong)
    also have "\<dots> = (\<Sum>\<^sup>+ y. h' (to_nat_on A x) y)" using dom_h'[of "to_nat_on A x"] h'_nonneg R
      by(fastforce intro!: nn_integral_cong intro: rev_image_eqI simp add: nn_integral_count_space_indicator R'_def less_le split: split_indicator)
    also have "\<dots> = ennreal (suminf (h' (to_nat_on A x)))"
      by(simp add: nn_integral_count_space_nat suminf_ennreal_eq[OF _ h'_f] h'_nonneg)
    also have "\<dots> = ennreal (f' (to_nat_on A x))" using h'_f[of "to_nat_on A x"] by(simp add: sums_iff)
    also have "\<dots> = f x" using x by(simp add: f'_def ennreal_enn2real_if)
    finally show "(\<Sum>\<^sup>+ y\<in>B. h x y) = f x" .
  next
    fix y
    assume y: "y \<in> B"
    have "(\<Sum>\<^sup>+ x\<in>A. h x y) = (\<Sum>\<^sup>+ x\<in>to_nat_on A ` A. h' x (to_nat_on B y))"
      by(subst nn_integral_count_space_reindex)(auto simp add: inj_on_to_nat_on h_def y intro!: nn_integral_cong)
    also have "\<dots> = (\<Sum>\<^sup>+ x. h' x (to_nat_on B y))" using dom_h'[of _ "to_nat_on B y"] h'_nonneg R
      by(fastforce intro!: nn_integral_cong intro: rev_image_eqI simp add: nn_integral_count_space_indicator R'_def less_le split: split_indicator)
    also have "\<dots> = ennreal (suminf (\<lambda>x. h' x (to_nat_on B y)))"
      by(simp add: nn_integral_count_space_nat suminf_ennreal_eq[OF _ h'_g] h'_nonneg)
    also have "\<dots> = ennreal (g' (to_nat_on B y))" using h'_g[of "to_nat_on B y"] by(simp add: sums_iff)
    also have "\<dots> = g y" using y by(simp add: g'_def ennreal_enn2real_if)
    finally show "(\<Sum>\<^sup>+ x\<in>A. h x y) = g y" .
  qed
qed

end


theory Ex08
imports
  "~~/src/HOL/IMP/Sec_Typing"
  "~~/src/HOL/IMP/Com"
  "~~/src/HOL/IMP/Def_Init_Exp"
  "~~/src/HOL/IMP/Def_Init"
  "~~/src/HOL/IMP/Vars"
begin

subsection {* Ex 08.1: Security type system: bottom-up with subsumption *}

inductive sec_type2' :: "com \<Rightarrow> level \<Rightarrow> bool" ("(\<turnstile>' _ : _)" [0,0] 50) where
Skip2':
  "\<turnstile>' SKIP : l" |
Assign2':
  "sec x \<ge> sec a \<Longrightarrow> \<turnstile>' x ::= a : sec x" |
Semi2':
  "\<lbrakk> \<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l \<rbrakk> \<Longrightarrow> \<turnstile>' c\<^sub>1 ;; c\<^sub>2 : l" |
If2':
  "\<lbrakk> sec b \<le> l;  \<turnstile>' c\<^sub>1 : l;  \<turnstile>' c\<^sub>2 : l \<rbrakk>
  \<Longrightarrow> \<turnstile>' IF b THEN c\<^sub>1 ELSE c\<^sub>2 : l" |
While2':
  "\<lbrakk> sec b \<le> l;  \<turnstile>' c : l \<rbrakk> \<Longrightarrow> \<turnstile>' WHILE b DO c : l" |
Subsumption2':
  "\<lbrakk> \<turnstile>' c : l; l' \<le> l \<rbrakk> \<Longrightarrow> \<turnstile>' c : l'"

lemma
  assumes "\<turnstile> c : l"
  shows "\<turnstile>' c : l"
  using assms
  apply (induction)
  apply (auto intro: sec_type2'.intros)
  apply (metis Semi2' Subsumption2' min.cobounded1 min.cobounded2)
  by (metis If2' Subsumption2' min.cobounded2 min.commute min_def)

lemma "\<turnstile>' c : l \<Longrightarrow> \<exists>l' \<ge> l. \<turnstile> c : l'"
  apply(induction rule: sec_type2'.induct)
  apply(force intro: sec_type2.intros)
  apply (metis Assign2 order_refl)
  apply (metis Seq2 inf_greatest inf_nat_def)
  apply (metis If2 le_trans min.boundedI)
  apply (metis While2 le_trans)
  by (metis le_trans)

section {* Ex 08.2: Initialization-Sensitive Small Step Semantics *}

inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "aval a s = Some i \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := Some i))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s = Some True \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "bval b s = Some False \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

inductive
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool"  (infix "\<rightarrow>*" 55)  where
refl:  "cs \<rightarrow>* cs" |
step:  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<rightarrow>* cs'' \<Longrightarrow> cs \<rightarrow>* cs''"

lemmas small_steps_induct = small_steps.induct[split_format(complete)]

subsection "Definite Initialization Analysis"

fun AA :: "com \<Rightarrow> vname set" where
  "AA SKIP = {}" |
  "AA (x ::= a) = {x}" |
  "AA (c1;;c2) = AA c1 \<union> AA c2" |
  "AA (IF _ THEN c1 ELSE c2) = AA c1 \<inter> AA c2" |
  "AA (WHILE b DO c) = {}"

fun D :: "vname set \<Rightarrow> com \<Rightarrow> bool" where
  "D A SKIP = True" |
  "D A (x ::= a) \<longleftrightarrow> vars a \<subseteq> A" |
  "D A (c1;;c2) \<longleftrightarrow> D A c1 \<and> D (A \<union> AA c1) c2" |
  "D A (IF b THEN c1 ELSE c2) \<longleftrightarrow> vars b \<subseteq> A \<and> D A c1 \<and> D A c2 " |
  "D A (WHILE b DO c) \<longleftrightarrow> vars b \<subseteq> A \<and> D A c"

subsection "Soundness wrt Small Steps"

theorem progress:
"D (dom s) c \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists> cs'. (c,s) \<rightarrow> cs'"
  apply (induction c arbitrary: s)
  apply (auto intro: small_step.intros)
  apply (metis aval_Some small_step.Assign)
  apply (force intro: small_step.intros)
  by (metis (full_types) bval_Some small_step.IfFalse small_step.IfTrue)

lemma D_incr: "(c,s) \<rightarrow> (c',s') \<Longrightarrow> dom s \<union> AA c \<subseteq> dom s' \<union> AA c'"
  apply (induction rule: small_step_induct)
  by auto

lemma D_mono: "A \<subseteq> A' \<Longrightarrow> D A c \<Longrightarrow> D A' c"
  apply (induction c arbitrary: A A')
  apply (auto)
  by (metis sup.absorb2 sup.left_commute sup_assoc sup_ge2)

theorem D_preservation:
"(c,s) \<rightarrow> (c',s') \<Longrightarrow> D (dom s) c \<Longrightarrow> D (dom s') c'"
  apply (induction rule: small_step_induct)
  apply (auto)
  by (auto intro: D_mono dest: D_mono D_incr)

theorem D_sound:
"(c,s) \<rightarrow>* (c',s') \<Longrightarrow> D (dom s) c \<Longrightarrow> c' \<noteq> SKIP
 \<Longrightarrow> \<exists>cs''. (c',s') \<rightarrow> cs''"
  apply(induction rule: small_steps_induct)
  apply (metis progress)
  by (metis D_preservation)

end