(*  Title:      Word_Type_Copies.thy
    Author:     Florian Haftmann, TU Muenchen
*)

chapter \<open>Systematic approach towards type copies of word type\<close>

theory Word_Type_Copies
  imports
    "HOL-Library.Word"
    "../Word_Lib/Most_significant_bit"
    "../Word_Lib/Least_significant_bit"
    "../Word_Lib/Generic_set_bit"
    "../Word_Lib/Bit_Comprehension"
    "Code_Target_Word_Base"
begin

text \<open>The lifting machinery is not localized, hence the abstract proofs are carried out using morphisms.\<close>

locale word_type_copy =
  fixes of_word :: \<open>'b::len word \<Rightarrow> 'a\<close>
    and word_of :: \<open>'a \<Rightarrow> 'b word\<close>
  assumes type_definition: \<open>type_definition word_of of_word UNIV\<close>
begin

lemma word_of_word:
  \<open>word_of (of_word w) = w\<close>
  using type_definition by (simp add: type_definition_def)

lemma of_word_of [code abstype]:
  \<open>of_word (word_of p) = p\<close>
    \<comment> \<open>Use an abstract type for code generation to disable pattern matching on \<^term>\<open>of_word\<close>.\<close>
  using type_definition by (simp add: type_definition_def)

lemma word_of_eqI:
  \<open>p = q\<close> if \<open>word_of p = word_of q\<close>
proof -
  from that have \<open>of_word (word_of p) = of_word (word_of q)\<close>
    by simp
  then show ?thesis
    by (simp add: of_word_of)
qed

lemma eq_iff_word_of:
  \<open>p = q \<longleftrightarrow> word_of p = word_of q\<close>
  by (auto intro: word_of_eqI)

end

bundle constraintless
begin

declaration \<open>
  let
    val cs = map (rpair NONE o fst o dest_Const)
      [\<^term>\<open>0\<close>, \<^term>\<open>(+)\<close>, \<^term>\<open>uminus\<close>, \<^term>\<open>(-)\<close>,
       \<^term>\<open>1\<close>, \<^term>\<open>(*)\<close>, \<^term>\<open>(div)\<close>, \<^term>\<open>(mod)\<close>,
       \<^term>\<open>HOL.equal\<close>, \<^term>\<open>(\<le>)\<close>, \<^term>\<open>(<)\<close>,
       \<^term>\<open>(dvd)\<close>, \<^term>\<open>of_bool\<close>, \<^term>\<open>numeral\<close>, \<^term>\<open>of_nat\<close>,
       \<^term>\<open>bit\<close>,
       \<^term>\<open>Bit_Operations.not\<close>, \<^term>\<open>Bit_Operations.and\<close>, \<^term>\<open>Bit_Operations.or\<close>, \<^term>\<open>Bit_Operations.xor\<close>, \<^term>\<open>mask\<close>,
       \<^term>\<open>push_bit\<close>, \<^term>\<open>drop_bit\<close>, \<^term>\<open>take_bit\<close>,
       \<^term>\<open>Bit_Operations.set_bit\<close>, \<^term>\<open>unset_bit\<close>, \<^term>\<open>flip_bit\<close>,
       \<^term>\<open>msb\<close>, \<^term>\<open>lsb\<close>, \<^term>\<open>size\<close>, \<^term>\<open>Generic_set_bit.set_bit\<close>, \<^term>\<open>set_bits\<close>]
  in
    K (Context.mapping I (fold Proof_Context.add_const_constraint cs))
  end
\<close>

end

locale word_type_copy_ring = word_type_copy
  opening constraintless +
  constrains word_of :: \<open>'a \<Rightarrow> 'b::len word\<close>
  assumes word_of_0 [code]: \<open>word_of 0 = 0\<close>
    and word_of_1 [code]: \<open>word_of 1 = 1\<close>
    and word_of_add [code]: \<open>word_of (p + q) = word_of p + word_of q\<close>
    and word_of_minus [code]: \<open>word_of (- p) = - (word_of p)\<close>
    and word_of_diff [code]: \<open>word_of (p - q) = word_of p - word_of q\<close>
    and word_of_mult [code]: \<open>word_of (p * q) = word_of p * word_of q\<close>
    and word_of_div [code]: \<open>word_of (p div q) = word_of p div word_of q\<close>
    and word_of_mod [code]: \<open>word_of (p mod q) = word_of p mod word_of q\<close>
    and equal_iff_word_of [code]: \<open>HOL.equal p q \<longleftrightarrow> HOL.equal (word_of p) (word_of q)\<close>
    and less_eq_iff_word_of [code]: \<open>p \<le> q \<longleftrightarrow> word_of p \<le> word_of q\<close>
    and less_iff_word_of [code]: \<open>p < q \<longleftrightarrow> word_of p < word_of q\<close>
begin

lemma of_class_comm_ring_1:
  \<open>OFCLASS('a, comm_ring_1_class)\<close>
  by standard (simp_all add: eq_iff_word_of word_of_0 word_of_1
    word_of_add word_of_minus word_of_diff word_of_mult algebra_simps)

lemma of_class_semiring_modulo:
  \<open>OFCLASS('a, semiring_modulo_class)\<close>
  by standard (simp_all add: eq_iff_word_of word_of_0 word_of_1
    word_of_add word_of_minus word_of_diff word_of_mult word_of_mod word_of_div algebra_simps
    mod_mult_div_eq)

lemma of_class_equal:
  \<open>OFCLASS('a, equal_class)\<close>
  by standard (simp add: eq_iff_word_of equal_iff_word_of equal)

lemma of_class_linorder:
  \<open>OFCLASS('a, linorder_class)\<close>
  by standard (auto simp add: eq_iff_word_of less_eq_iff_word_of less_iff_word_of)

end

locale word_type_copy_bits = word_type_copy_ring
  opening constraintless bit_operations_syntax +
  constrains word_of :: \<open>'a::{comm_ring_1, semiring_modulo, equal, linorder} \<Rightarrow> 'b::len word\<close>
  fixes signed_drop_bit :: \<open>nat \<Rightarrow> 'a \<Rightarrow> 'a\<close>
  assumes bit_eq_word_of [code]: \<open>bit p = bit (word_of p)\<close>
    and word_of_not [code]: \<open>word_of (NOT p) = NOT (word_of p)\<close>
    and word_of_and [code]: \<open>word_of (p AND q) = word_of p AND word_of q\<close>
    and word_of_or [code]: \<open>word_of (p OR q) = word_of p OR word_of q\<close>
    and word_of_xor [code]: \<open>word_of (p XOR q) = word_of p XOR word_of q\<close>
    and word_of_mask [code]: \<open>word_of (mask n) = mask n\<close>
    and word_of_push_bit [code]: \<open>word_of (push_bit n p) = push_bit n (word_of p)\<close>
    and word_of_drop_bit [code]: \<open>word_of (drop_bit n p) = drop_bit n (word_of p)\<close>
    and word_of_signed_drop_bit [code]: \<open>word_of (signed_drop_bit n p) = Word.signed_drop_bit n (word_of p)\<close>
    and word_of_take_bit [code]: \<open>word_of (take_bit n p) = take_bit n (word_of p)\<close>
    and word_of_set_bit [code]: \<open>word_of (Bit_Operations.set_bit n p) = Bit_Operations.set_bit n (word_of p)\<close>
    and word_of_unset_bit [code]: \<open>word_of (unset_bit n p) = unset_bit n (word_of p)\<close>
    and word_of_flip_bit [code]: \<open>word_of (flip_bit n p) = flip_bit n (word_of p)\<close>
begin

lemma word_of_bool:
  \<open>word_of (of_bool n) = of_bool n\<close>
  by (simp add: word_of_0 word_of_1)

lemma word_of_nat:
  \<open>word_of (of_nat n) = of_nat n\<close>
  by (induction n) (simp_all add: word_of_0 word_of_1 word_of_add)

lemma word_of_numeral [simp]:
  \<open>word_of (numeral n) = numeral n\<close>
proof -
  have \<open>word_of (of_nat (numeral n)) = of_nat (numeral n)\<close>
    by (simp only: word_of_nat)
  then show ?thesis by simp
qed

lemma word_of_power:
  \<open>word_of (p ^ n) = word_of p ^ n\<close>
  by (induction n) (simp_all add: word_of_1 word_of_mult)

lemma even_iff_word_of:
  \<open>2 dvd p \<longleftrightarrow> 2 dvd word_of p\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof
  assume ?P
  then obtain q where \<open>p = 2 * q\<close> ..
  then show ?Q by (simp add: word_of_mult)
next
  assume ?Q
  then obtain w where \<open>word_of p = 2 * w\<close> ..
  then have \<open>of_word (word_of p) = of_word (2 * w)\<close>
    by simp
  then have \<open>p = 2 * of_word w\<close>
    by (simp add: eq_iff_word_of word_of_word word_of_mult)
  then show ?P
    by simp
qed

lemma of_class_ring_bit_operations:
  \<open>OFCLASS('a, ring_bit_operations_class)\<close>
proof -
  have induct: \<open>P p\<close> if stable: \<open>(\<And>p. p div 2 = p \<Longrightarrow> P p)\<close>
      and rec: \<open>(\<And>p b. P p \<Longrightarrow> (of_bool b + 2 * p) div 2 = p \<Longrightarrow> P (of_bool b + 2 * p))\<close>
    for p :: 'a and P
  proof -
    from stable have stable': \<open>(\<And>p. word_of p div 2 = word_of p \<Longrightarrow> P p)\<close>
      by (simp add: eq_iff_word_of word_of_div)
    from rec have rec': \<open>(\<And>p b. P p \<Longrightarrow> (of_bool b + 2 * word_of p) div 2 = word_of p \<Longrightarrow> P (of_bool b + 2 * p))\<close>
      by (simp add: eq_iff_word_of word_of_add word_of_bool word_of_mult word_of_div)
    define w where \<open>w = word_of p\<close>
    then have \<open>p = of_word w\<close>
      by (simp add: of_word_of)
    also have \<open>P (of_word w)\<close>
    proof (induction w rule: bits_induct)
      case (stable w)
      show ?case
        by (rule stable') (simp add: word_of_word stable)
    next
      case (rec w b)
      have \<open>P (of_bool b + 2 * of_word w)\<close>
        by (rule rec') (simp_all add: word_of_word rec)
      also have \<open>of_bool b + 2 * of_word w = of_word (of_bool b + 2 * w)\<close>
        by (simp add: eq_iff_word_of word_of_word word_of_add word_of_1 word_of_mult word_of_0)
      finally show ?case .
    qed
    finally show \<open>P p\<close> .
  qed
  have \<open>class.semiring_parity_axioms (+) (0::'a) (*) 1 (mod)\<close>
    by standard (simp_all add: eq_iff_word_of word_of_0 word_of_1 even_iff_word_of word_of_mod even_iff_mod_2_eq_zero)
  with of_class_semiring_modulo have \<open>OFCLASS('a, semiring_parity_class)\<close>
    by (rule semiring_parity_class.intro)
  moreover have \<open>class.semiring_bits_axioms (+) (-) (0::'a) (*) 1 (div) (mod) bit\<close>
    apply (standard, fact induct)
    apply (simp_all only: eq_iff_word_of word_of_0 word_of_1 word_of_bool word_of_numeral
      word_of_add word_of_diff word_of_mult word_of_div word_of_mod word_of_power even_iff_word_of
      bit_eq_word_of push_bit_take_bit drop_bit_take_bit
      even_drop_bit_iff_not_bit
      flip: push_bit_eq_mult drop_bit_eq_div take_bit_eq_mod mask_eq_exp_minus_1)
               apply (auto simp add: ac_simps bit_simps drop_bit_exp_eq)
    done
  ultimately have \<open>OFCLASS('a, semiring_bits_class)\<close>
    by (rule semiring_bits_class.intro)
  moreover have \<open>class.semiring_bit_operations_axioms (+) (-) (*) (1::'a) (div) (mod) bit (AND) (OR) (XOR) mask Bit_Operations.set_bit unset_bit flip_bit push_bit drop_bit take_bit\<close>
    by standard
      (simp_all add: eq_iff_word_of word_of_push_bit word_of_power
      bit_eq_word_of word_of_and word_of_or word_of_xor word_of_mask word_of_diff word_of_1 bit_simps
      word_of_set_bit set_bit_eq_or word_of_unset_bit word_of_flip_bit flip_bit_eq_xor
      word_of_mult
      word_of_drop_bit word_of_div word_of_take_bit word_of_mod
      flip: mask_eq_exp_minus_1 push_bit_eq_mult drop_bit_eq_div take_bit_eq_mod)
  ultimately have \<open>OFCLASS('a, semiring_bit_operations_class)\<close>
    by (rule semiring_bit_operations_class.intro)
  moreover have \<open>OFCLASS('a, ring_parity_class)\<close>
    using \<open>OFCLASS('a, semiring_parity_class)\<close> by (rule ring_parity_class.intro) standard
  moreover have \<open>class.ring_bit_operations_axioms (+) (-) (0::'a) (*) 1 bit uminus NOT\<close>
    by standard (simp_all add: eq_iff_word_of word_of_power
      bit_eq_word_of word_of_diff word_of_1 bit_simps linorder_not_le
      word_of_not word_of_0
      word_of_minus minus_eq_not_minus_1)
  ultimately show \<open>OFCLASS('a, ring_bit_operations_class)\<close>
    by (rule ring_bit_operations_class.intro)
qed

lemma [code]:
  \<open>mask (Suc n) = push_bit n (1 :: 'a) OR mask n\<close>
  \<open>mask 0 = (0 :: 'a)\<close>
  by (simp_all add: eq_iff_word_of word_of_mask word_of_or word_of_push_bit word_of_0 word_of_1 mask_Suc_exp)

lemma [code]:
  \<open>Bit_Operations.set_bit n w = w OR push_bit n 1\<close> for w :: 'a
  by (simp add: eq_iff_word_of word_of_set_bit word_of_or word_of_push_bit word_of_1 set_bit_eq_or)

lemma [code]:
  \<open>unset_bit n w = w AND NOT (push_bit n 1)\<close> for w :: 'a
  by (simp add: eq_iff_word_of word_of_unset_bit word_of_and word_of_not word_of_push_bit word_of_1 unset_bit_eq_and_not)

lemma [code]:
  \<open>flip_bit n w = w XOR push_bit n 1\<close> for w :: 'a
  by (simp add: eq_iff_word_of word_of_flip_bit word_of_xor word_of_push_bit word_of_1 flip_bit_eq_xor)

end

locale word_type_copy_more = word_type_copy_bits +
  constrains word_of :: \<open>'a::{ring_bit_operations, equal, linorder} \<Rightarrow> 'b::len word\<close>
  fixes of_nat :: \<open>nat \<Rightarrow> 'a\<close> and nat_of :: \<open>'a \<Rightarrow> nat\<close>
    and of_int :: \<open>int \<Rightarrow> 'a\<close> and int_of :: \<open>'a \<Rightarrow> int\<close>
    and of_integer :: \<open>integer \<Rightarrow> 'a\<close> and integer_of :: \<open>'a \<Rightarrow> integer\<close>
  assumes word_of_nat_eq: \<open>word_of (of_nat n) = word_of_nat n\<close>
    and nat_of_eq_word_of: \<open>nat_of p = unat (word_of p)\<close>
    and word_of_int_eq: \<open>word_of (of_int k) = word_of_int k\<close>
    and int_of_eq_word_of: \<open>int_of p = uint (word_of p)\<close>
    and word_of_integer_eq: \<open>word_of (of_integer l) = word_of_integer l\<close>
    and integer_of_eq_word_of: \<open>integer_of p = unsigned (word_of p)\<close>
begin

lemma of_word_numeral [code_post]:
  \<open>of_word (numeral n) = numeral n\<close>
  by (simp add: eq_iff_word_of word_of_word)

lemma of_word_0 [code_post]:
  \<open>of_word 0 = 0\<close>
  by (simp add: eq_iff_word_of word_of_0 word_of_word)

lemma of_word_1 [code_post]:
  \<open>of_word 1 = 1\<close>
  by (simp add: eq_iff_word_of word_of_1 word_of_word)

text \<open>Use pretty numerals from integer for pretty printing\<close>

lemma numeral_eq_integer [code_unfold]:
  \<open>numeral n = of_integer (numeral n)\<close>
  by (simp add: eq_iff_word_of word_of_integer_eq)

lemma neg_numeral_eq_integer [code_unfold]:
  \<open>- numeral n = of_integer (- numeral n)\<close>
  by (simp add: eq_iff_word_of word_of_integer_eq word_of_minus)

end

locale word_type_copy_misc = word_type_copy_more
  opening constraintless bit_operations_syntax +
  constrains word_of :: \<open>'a::{ring_bit_operations, equal, linorder} \<Rightarrow> 'b::len word\<close>
  fixes size :: nat and set_bits_aux :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a\<close>
    assumes size_eq_length: \<open>size = LENGTH('b::len)\<close>
    and msb_iff_word_of [code]: \<open>msb p \<longleftrightarrow> msb (word_of p)\<close>
    and lsb_iff_word_of [code]: \<open>lsb p \<longleftrightarrow> lsb (word_of p)\<close>
    and size_eq_word_of: \<open>Nat.size (p :: 'a) = Nat.size (word_of p)\<close>
    and word_of_generic_set_bit [code]: \<open>word_of (Generic_set_bit.set_bit p n b) = Generic_set_bit.set_bit (word_of p) n b\<close>
    and word_of_set_bits: \<open>word_of (set_bits P) = set_bits P\<close>
    and word_of_set_bits_aux: \<open>word_of (set_bits_aux P n p) = Bit_Comprehension.set_bits_aux P n (word_of p)\<close>
begin

lemma size_eq [code]:
  \<open>Nat.size p = size\<close> for p :: 'a
  by (simp add: size_eq_length size_eq_word_of word_size)

lemma set_bits_aux_code [code]:
  \<open>set_bits_aux f n w =
  (if n = 0 then w
   else let n' = n - 1 in set_bits_aux f n' (push_bit 1 w OR (if f n' then 1 else 0)))\<close>
  by (simp add: eq_iff_word_of word_of_set_bits_aux Let_def word_of_mult word_of_or word_of_0 word_of_1 set_bits_aux_rec [of f n])

lemma set_bits_code [code]: \<open>set_bits P = set_bits_aux P size 0\<close>
  by (simp add: fun_eq_iff eq_iff_word_of word_of_set_bits word_of_set_bits_aux word_of_0 size_eq_length set_bits_conv_set_bits_aux)

lemma of_class_lsb:
  \<open>OFCLASS('a, lsb_class)\<close>
  by standard (simp add: fun_eq_iff lsb_iff_word_of even_iff_word_of lsb_odd)

lemma of_class_set_bit:
  \<open>OFCLASS('a, set_bit_class)\<close>
  by standard (simp add: eq_iff_word_of word_of_generic_set_bit bit_eq_word_of word_of_power word_of_0 bit_simps linorder_not_le)

lemma of_class_bit_comprehension:
  \<open>OFCLASS('a, bit_comprehension_class)\<close>
  by standard (simp add: eq_iff_word_of word_of_set_bits bit_eq_word_of set_bits_bit_eq)

end

end


(*  Title:      HOL/SPARK/Examples/RIPEMD-160/Hash.thy
    Author:     Fabian Immler, TU Muenchen

Verification of the RIPEMD-160 hash function
*)

theory Hash
imports RMD_Specification
begin

spark_open \<open>rmd/hash\<close>

abbreviation from_chain :: "chain \<Rightarrow> RMD.chain" where
  "from_chain c \<equiv> (
    word_of_int (h0 c),
    word_of_int (h1 c),
    word_of_int (h2 c),
    word_of_int (h3 c),
    word_of_int (h4 c))"

abbreviation to_chain :: "RMD.chain \<Rightarrow> chain" where
  "to_chain c \<equiv>
    (let (h0, h1, h2, h3, h4) = c in
      (|h0 = uint h0,
        h1 = uint h1,
        h2 = uint h2,
        h3 = uint h3,
        h4 = uint h4|))"

abbreviation round' :: "chain \<Rightarrow> block \<Rightarrow> chain" where
  "round' c b == to_chain (round (\<lambda>n. word_of_int (b (int n))) (from_chain c))"

abbreviation rounds' :: "chain \<Rightarrow> int \<Rightarrow> message \<Rightarrow> chain" where
  "rounds' h i X ==
     to_chain (rounds
      (\<lambda>n. \<lambda>m. word_of_int (X (int n) (int m)))
      (from_chain h)
      (nat i))"

abbreviation rmd_hash :: "message \<Rightarrow> int \<Rightarrow> chain" where
  "rmd_hash X i == to_chain (rmd
    (\<lambda>n. \<lambda>m. word_of_int (X (int n) (int m)))
    (nat i))"

spark_proof_functions
  round_spec = round'
  rounds = rounds'
  rmd_hash = rmd_hash

spark_vc function_hash_12
  using H1 H6
  by (simp add:
    rounds_def rmd_body_def round_def
    h_0_def h0_0_def h1_0_def h2_0_def h3_0_def h4_0_def)

lemma rounds_step:
  assumes "0 <= i"
  shows "rounds X b (Suc i) = round (X i) (rounds X b i)"
  by (simp add: rounds_def rmd_body_def)

lemma from_to_id: "from_chain (to_chain C) = C"
proof (cases C)
  fix a b c d e f::word32
  assume "C = (a, b, c, d, e)"
  thus ?thesis by (cases a) (simp add: take_bit_nat_eq_self)
qed

lemma steps_to_steps':
  "round X (foldl a b c) = round X (from_chain (to_chain (foldl a b c)))"
  unfolding from_to_id ..

lemma rounds'_step:
  assumes "0 <= i"
  shows "rounds' c (i + 1) x = round' (rounds' c i x) (x i)"
proof -
  have makesuc: "nat (i + 1) = Suc (nat i)" using assms by simp
  show ?thesis using assms
    by (simp add: makesuc rounds_def rmd_body_def steps_to_steps')
qed

spark_vc function_hash_13
proof -
  have loop_suc: "loop__1__i + 2 = (loop__1__i + 1) + 1" by simp
  have "0 <= loop__1__i + 1" using \<open>0 <= loop__1__i\<close> by simp
  show ?thesis
    unfolding loop_suc
    unfolding rounds'_step[OF \<open>0 <= loop__1__i + 1\<close>]
    unfolding H1[symmetric]
    unfolding H18 ..
qed

spark_vc function_hash_17
  unfolding rmd_def H1 rounds_def ..

spark_end

end


theory Composition
imports ComposableGC "/home/nano/Documents/IO-Automata/Simulations" "~~/src/HOL/Eisbach/Eisbach_Tools"
begin

datatype ('a,'c,'l) comp_action =
  Propose1 'c
| Propose2 'c
| Learn1 'a 'l
| Learn2 'a 'l
| Switch 'a
| ToNext 'a

definition comp_asig where
  "comp_asig \<equiv>
    \<lparr> inputs = { a . \<exists> c . a = Propose1 c \<or> a = Propose2 c},
      outputs = { a . \<exists> s p . a = Learn1 s p \<or> a = Learn2 s p \<or> a = ToNext s },
      internals = { a . \<exists> s . a = Switch s} \<rparr>"

context ComposableGC
begin

fun rn1 where
  "rn1 (Propose1 c) = Some (cgc_action.Propose c)"
| "rn1 (Switch s) = Some (cgc_action.ToNext s)"
| "rn1 (Learn1 s l) = Some (cgc_action.Learn s l)"
| "rn1 (Learn2 s l) = None"
| "rn1 (ToNext s) = None"
| "rn1 (Propose2 s) = None"

fun rn2 where
  "rn2 (Propose2 c) = Some (cgc_action.Propose c)"
| "rn2 (Switch s) = Some (cgc_action.FromPrev s)"
| "rn2 (Learn1 s l) = None"
| "rn2 (Learn2 s l) = Some (cgc_action.Learn s l)"
| "rn2 (ToNext s) = Some (cgc_action.ToNext s)"
| "rn2 (Propose1 c) = None"

fun rn3 where
  "rn3 (Propose2 c) = Some (cgc_action.Propose c)"
| "rn3 (Propose1 c) = Some (cgc_action.Propose c)"
| "rn3 (Switch s) = None"
| "rn3 (Learn1 s l) = Some (cgc_action.Learn s l)"
| "rn3 (Learn2 s l) = Some (cgc_action.Learn s l)"
| "rn3 (ToNext s) = Some (cgc_action.ToNext s)"

definition initial where
  "initial \<equiv> cgc_ioa\<lparr>start := {\<lparr>propCmd = {}, learned = \<lambda> p . {}, fromPrev = {\<bottom>}, toNext = {} \<rparr>}\<rparr>"

definition composition where
  "composition \<equiv> hide ((rename initial rn1) \<parallel> (rename cgc_ioa rn2)) {a . \<exists> s . a = Switch s}"

definition spec where
  "spec \<equiv> rename initial rn3"

named_theorems inv_defs

definition inv1 where
  "inv1 r \<equiv> let r1 = fst r; r2 = snd r in
    (\<forall> s \<in> cgc_state.fromPrev r2 . \<forall> l \<in> learners . \<forall> s' \<in> learned r1 l . s' \<preceq> s)"
declare inv1_def[inv_defs]

definition inv2 where
  "inv2 r \<equiv> let r1 = fst r; r2 = snd r in
    cgc_state.fromPrev r2 = cgc_state.toNext r1"
declare inv2_def[inv_defs]

definition inv3 where
  "inv3 r \<equiv> let r1 = fst r; r2 = snd r in
    cgc_state.fromPrev r1 = {\<bottom>}"
declare inv3_def[inv_defs]

definition inv4 where
  "inv4 r \<equiv> let r1 = fst r; r2 = snd r in
    \<forall> l \<in> learners . \<forall> s \<in> learned r2 l .
      \<exists> S cs . S \<noteq> {} \<and> S \<subseteq> cgc_state.fromPrev r2
        \<and> s = \<Sqinter>S \<star> cs \<and> set cs \<subseteq> propCmd r2"
declare inv4_def[inv_defs]

definition inv5 where
  "inv5 r \<equiv> let r1 = fst r; r2 = snd r in
    \<forall> s \<in> cgc_state.toNext r2 .
      \<exists> S cs . S \<noteq> {} \<and> S \<subseteq> cgc_state.fromPrev r2
        \<and> s = \<Sqinter>S \<star> cs \<and> set cs \<subseteq> propCmd r2"
declare inv5_def[inv_defs]

definition inv8 where
  "inv8 r \<equiv> let r1 = fst r; r2 = snd r in
    \<forall> s \<in> cgc_state.toNext r1 .
      \<exists> cs . s = \<bottom> \<star> cs \<and> set cs \<subseteq> propCmd r1"
declare inv8_def[inv_defs]

definition inv9 where
  "inv9 r \<equiv> let r1 = fst r; r2 = snd r in
    \<forall> S . S \<noteq> {} \<and> S \<subseteq> cgc_state.toNext r1 \<longrightarrow>
      (\<exists> cs . \<Sqinter>S = \<bottom> \<star> cs \<and> set cs \<subseteq> propCmd r1)"
declare inv9_def[inv_defs]

definition inv7 where
  "inv7 r \<equiv> let r1 = fst r; r2 = snd r in
    finite (cgc_state.toNext r1) \<and> finite (cgc_state.toNext r2)"
declare inv7_def[inv_defs]

definition inv10 where
  "inv10 r \<equiv> let r1 = fst r; r2 = snd r in
    \<forall> l\<^sub>1 \<in> learners. \<forall> l\<^sub>2 \<in> learners . \<forall> s\<^sub>1 \<in> learned r1 l\<^sub>1 . \<forall> s\<^sub>2 \<in> learned r2 l\<^sub>2 . s\<^sub>1 \<preceq> s\<^sub>2"
declare inv10_def[inv_defs]

definition inv11 where
  "inv11 r \<equiv> let r1 = fst r; r2 = snd r in
    \<forall> l\<^sub>1 \<in> learners. \<forall> s\<^sub>1 \<in> learned r1 l\<^sub>1 . \<forall> s\<^sub>2 \<in> cgc_state.toNext r2 . s\<^sub>1 \<preceq> s\<^sub>2"
declare inv11_def[inv_defs]

definition inv12 where
  "inv12 r \<equiv> let r1 = fst r; r2 = snd r in
    \<forall> l \<in> learners. \<forall> s \<in> learned r2 l . \<exists> cs .  s = \<bottom> \<star> cs \<and> set cs \<subseteq> propCmd r1 \<union> propCmd r2"
declare inv12_def[inv_defs]

definition inv13 where
  "inv13 r \<equiv> let r1 = fst r; r2 = snd r in
    \<forall> s \<in> cgc_state.toNext r2 . \<exists> cs .  s = \<bottom> \<star> cs \<and> set cs \<subseteq> propCmd r1 \<union> propCmd r2"
declare inv13_def[inv_defs]

lemmas cgc_ioa_defs = composition_def par2_def asig_comp2_def cgc_ioa_def rename_def
    rename_set_def cgc_asig_def is_trans_def actions_def cgc_trans_def initial_def hide_def
    propose_def
lemmas actions_defs = learn_def fromPrev_def toNext_def
    hide_asig_def externals_def cgc_start_def spec_def
lemmas ref_defs = refines_def actions_def trace_def schedule_def filter_act_def

named_theorems invs
  -- "named theorem for use by the tactics below"
named_theorems aux_invs
  -- "auxiliary invariants used to prove the invariants needed for the refinement proof"
named_theorems ref_invs
  -- "the invariants needed for the refinement proof"
named_theorems mydefs
  -- "definitions to unfold"
declare cgc_ioa_defs[mydefs]
declare actions_defs[mydefs]

text {* A usefull lemma (l4) *}

lemma l3:
  assumes "\<And> s . s \<in> S \<Longrightarrow> s\<^sub>0 \<preceq> s" and "finite S" and "S \<noteq> {}"
  shows "s\<^sub>0 \<preceq> \<Sqinter>S" using assms
by (metis local.boundedI)

lemma l4:
  assumes "\<exists> S cs . S \<noteq> {} \<and> S \<subseteq> S\<^sub>i \<and> s = \<Sqinter>S \<star> cs" and "finite S\<^sub>i"
  and "\<And> s\<^sub>l s\<^sub>i. s\<^sub>l \<in> S\<^sub>l \<and> s\<^sub>i \<in> S\<^sub>i \<Longrightarrow> s\<^sub>l \<preceq> s\<^sub>i" and "s\<^sub>l \<in> S\<^sub>l"
  shows "s\<^sub>l \<preceq> s" using assms
  proof -
    obtain aa :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a" where
      f1: "\<And>A a. (infinite A \<or> A = {} \<or> aa A a \<in> A \<or> a \<preceq> \<Sqinter> A) \<and> (infinite A \<or> \<not> a \<preceq> aa A a \<or> A = {} \<or> a \<preceq> \<Sqinter> A)"
      using l3 by moura
    obtain AA :: "'a set" and bbs :: "'b list" where
      "AA \<subseteq> S\<^sub>i \<and> {} \<noteq> AA \<and> \<Sqinter> AA \<star> bbs = s"
      using assms(1) by moura
    then show ?thesis
      using f1 by (metis antimono assms(2) assms(3) assms(4) less_eq_def pre_CStruct.trans subset_empty)
  qed

lemma l5[simp]:
  "\<lbrakk>S \<subseteq> {\<bottom>}; S \<noteq> {}\<rbrakk> \<Longrightarrow> \<Sqinter>S = \<bottom>"
by (metis singleton subset_singletonD)

method bring_invs declares invs =
  -- "bring all the invariants in the premises"
  ( (insert invs) -- "insert invariant theorems in the premises;
      this will allow us to use [thin] to get rid of them after use",
    ( (match premises in I[thin]:"invariant composition ?inv"
        and R:"reachable composition ?s" \<Rightarrow>
            \<open>insert I[simplified invariant_def, rule_format, OF R]\<close>)+
        -- "for each invariant theorem, use the reachability assumption to obtain the invariant",
    (match premises in R[thin]:"reachable composition ?s"
      and T:"?s \<midarrow>?a\<midarrow>composition\<longrightarrow> ?t" \<Rightarrow>
        \<open>insert reachable_n[OF R T]\<close>),
    (insert invs),(match premises in I[thin]:"invariant composition ?inv"
        and R:"reachable composition ?s" \<Rightarrow>
            \<open>insert I[simplified invariant_def, rule_format, OF R]\<close>)+,
    (match premises in R[thin]:"reachable composition ?s" \<Rightarrow> succeed)
        -- "finally get rid of the reachability assumption"
        )? -- "don't fail if there are no invariants to bring"
    )

method try_solve_inv declares mydefs invs =
  ( rule invariantI,
    force simp add:mydefs inv_defs -- "solve the base case",
    bring_invs invs:invs,
    match premises in T:"?s \<midarrow>a\<midarrow>composition\<longrightarrow> ?t" for a \<Rightarrow> \<open>case_tac a\<close>
      -- "do case analysis on the action";
    simp add:mydefs inv_defs )

lemma inv2:"invariant composition inv2"
  by try_solve_inv
declare inv2[aux_invs]

lemma inv1:"invariant composition inv1"
  by (try_solve_inv invs:aux_invs)
declare inv1[aux_invs]

lemma inv3:"invariant composition inv3"
  by try_solve_inv
declare inv3[aux_invs]
declare inv3[ref_invs]

lemma inv4:"invariant composition inv4"
  apply (try_solve_inv invs:aux_invs  mydefs:non_trivial_def less_eq_def)
  subgoal by (metis subset_insertI2)
  subgoal by (metis subset_insertI2)
  subgoal by (metis subset_insertI2)
  subgoal by metis
  done
declare inv4[aux_invs]

lemma inv7:"invariant composition inv7"
  by (try_solve_inv invs:aux_invs)
declare inv7[aux_invs]

lemma inv5:"invariant composition inv5"
  apply (try_solve_inv invs:aux_invs mydefs:non_trivial_def less_eq_def)
  subgoal by (metis subset_insertI2)
  subgoal by metis
  subgoal by (metis subset_insertI2)
  subgoal by metis
  done
declare inv5[aux_invs]

lemma inv8:"invariant composition inv8"
  apply (try_solve_inv invs:aux_invs mydefs:non_trivial_def less_eq_def)
  subgoal by (metis subset_insertI2)
  subgoal by metis
  subgoal by (metis singleton subset_singletonD)
  done
declare inv8[aux_invs]

lemma inv9:"invariant composition inv9"
  apply (try_solve_inv invs:aux_invs mydefs:non_trivial_def less_eq_def)
  subgoal by (metis subset_insertI2)
  subgoal by metis
  subgoal premises prems for s t a x5
  proof -
    have 1:"\<And> S s1 . \<lbrakk>S \<subseteq> insert x5 (cgc_state.toNext (fst s)); s1 \<in> S\<rbrakk>
      \<Longrightarrow> \<exists>cs. s1 = \<bottom> \<star> cs \<and> set cs \<subseteq> propCmd (fst s)" using prems(11) by auto
    have 2:"finite (cgc_state.toNext (fst s))" using prems by auto
    show ?thesis
    proof clarify
      fix S x
      assume a1:"S \<noteq> {}" and a2:"S \<subseteq> insert x5 (cgc_state.toNext (fst s))"
      hence 4:"\<And> s1 . s1 \<in> S \<Longrightarrow> \<exists>cs. s1 = \<bottom> \<star> cs \<and> set cs \<subseteq> propCmd (fst s)"
        using 1 by auto
      have 5:"finite S" using 2 a2 by (metis finite_insert infinite_super)
      from 4 5 a1 glb_common_set[of "S" "propCmd (fst s)"]
        show "\<exists>cs. \<Sqinter> S = \<bottom> \<star> cs \<and> set cs \<subseteq> propCmd (fst s)" by fast
    qed
  qed
done
declare inv9[aux_invs]

lemma inv10:"invariant composition inv10"
  apply (try_solve_inv invs: aux_invs)
  subgoal by (smt l4 singletonD singletonI)
  subgoal by (smt insert_iff l4)
  done
declare inv10[ref_invs]

lemma inv11:"invariant composition inv11"
  apply (try_solve_inv invs: aux_invs)
  subgoal by (smt l4 singletonD singletonI)
  subgoal by (smt insert_iff l4)
  done
declare inv11[ref_invs]

lemma inv12:"invariant composition inv12"
  apply (try_solve_inv invs: aux_invs)
  subgoal by (metis subset_insertI2)
  subgoal by (metis subset_insertI2)
  defer
  subgoal by metis
  subgoal by metis
  apply (clarsimp simp add:non_trivial_def)
  subgoal by (metis (full_types) Un_commute pre_CStruct.exec_append set_append sup.mono)
done
declare inv12[ref_invs]

lemma inv13:"invariant composition inv13"
  apply (try_solve_inv invs: aux_invs)
  subgoal by (metis subset_insertI2)
  subgoal by (metis subset_insertI2)
  subgoal by metis
  subgoal by metis
  subgoal by (smt inf_sup_aci(5) pre_CStruct.exec_append set_append sup_mono)
  done
declare inv13[ref_invs]

definition refmap where
  "refmap r \<equiv> let r1 = fst r; r2 = snd r in
    \<lparr>cgc_state.propCmd = propCmd r1 \<union> propCmd r2,
      cgc_state.learned = (\<lambda> l . learned r1 l \<union> learned r2 l) ,
      cgc_state.fromPrev = {\<bottom>},
      toNext = cgc_state.toNext r2\<rparr>"

method split_conjs =
  (rule conjI);split_conjs?

lemma refok:"is_ref_map refmap composition spec"
apply(simp add:is_ref_map_def refmap_def, rule conjI; clarify)
  subgoal by (force simp add:mydefs)

  apply(bring_invs invs:ref_invs)
  apply(case_tac ab, auto)

    apply(rule_tac x="refmap (a,b)" in exI)
    apply(rule_tac x="[(Propose1 x1,refmap (aa,ba))]" in exI)
    subgoal by (force simp add:mydefs ref_defs refmap_def)

    apply(rule_tac x="refmap (a,b)" in exI)
    apply(rule_tac x="[(Propose2 x2,refmap (aa,ba))]" in exI)
    subgoal by (force simp add:mydefs ref_defs refmap_def)

    apply(rule_tac x="refmap (a,b)" in exI)
    apply(rule_tac x="[(Learn1 x31 x32,refmap (aa,ba))]" in exI)
    apply (simp add:ref_defs spec_def actions_defs cgc_ioa_defs actions_defs inv_defs refmap_def non_trivial_def)
    apply (split_conjs?)
    subgoal by (metis Un_upper1 subset_trans)
    subgoal by (metis Un_iff compat2_def insertI1 local.refl)
    subgoal by (metis insert_iff)
    subgoal by (simp add:fun_eq_iff)

    apply(rule_tac x="refmap (a,b)" in exI)
    apply(rule_tac x="[(Learn2 x41 x42,refmap (aa,ba))]" in exI)
    apply (simp add:ref_defs spec_def actions_defs cgc_ioa_defs actions_defs inv_defs refmap_def non_trivial_def)
    apply clarsimp
    apply (split_conjs?)
    subgoal by (metis (mono_tags, lifting) insertI1 insert_absorb2 insert_not_empty singleton singleton_insert_inj_eq)
    subgoal by (metis Un_iff compat2_def insertI1 local.refl)
    subgoal by (simp add:fun_eq_iff)

    apply(rule_tac x="refmap (a,b)" in exI)
    apply(rule_tac x="[]" in exI)
    subgoal by (force simp add:mydefs ref_defs refmap_def)

    apply (rule_tac x="refmap (a,b)" in exI)
    apply (rule_tac x="[(ToNext x6,refmap (aa,ba))]" in exI)
    apply (simp add:ref_defs spec_def actions_defs cgc_ioa_defs actions_defs inv_defs refmap_def non_trivial_def)
    apply clarsimp
    apply (split_conjs?)
    subgoal by (metis insert_absorb2 insert_not_empty singleton singleton_insert_inj_eq)
    subgoal by (metis Un_iff)
done

lemma trace_incl:"traces composition \<subseteq> traces spec"
apply(rule ref_map_soundness[of refmap])
  subgoal by (insert refok, force)
  subgoal by (simp add:mydefs, intro set_eqI; case_tac x; force)
done

theorem composition: "composition =<| spec"
apply(simp add:ioa_implements_def)
apply(intro conjI)
  subgoal by (simp add:mydefs, intro set_eqI; case_tac x; force)
  subgoal by (simp add:mydefs, intro set_eqI; case_tac x; force)
  subgoal by (insert trace_incl, auto)
done

end

end


section \<open>Processes\<close>

theory "Thorn_Calculus-Processes"
imports
  "Equivalence_Reasoner.Equivalence_Reasoner"
  "Transition_Systems.Transition_Systems-Foundations" \<comment> \<open>for the \<^const>\<open>compower\<close> notation\<close>
  "Thorn_Calculus-Foundations"
  "HOL-Library.BNF_Corec"
begin

ML_file \<open>binder_preservation.ML\<close>

codatatype process =
  Stop |
  Send \<open>chan\<close> \<open>val\<close> |
  Receive \<open>chan\<close> \<open>val \<Rightarrow> process\<close> |
  Parallel \<open>process\<close> \<open>process\<close> |
  NewChannel \<open>chan \<Rightarrow> process\<close>

definition
  stop :: "process family" (\<open>\<zero>\<close>)
where
  [simp]: "stop = (\<lambda>_. Stop)"
definition
  send :: "chan family \<Rightarrow> val family \<Rightarrow> process family" (infix \<open>\<triangleleft>\<close> 52)
where
  [simp]: "send A X = (\<lambda>e. Send (A e) (X e))"
definition
  receive :: "chan family \<Rightarrow> (val \<Rightarrow> process family) \<Rightarrow> process family"
where
  [simp]: "receive A \<P> = (\<lambda>e. Receive (A e) (\<lambda>x. \<P> x e))"
definition
  parallel :: "process family \<Rightarrow> process family \<Rightarrow> process family" (infixr \<open>\<parallel>\<close> 51)
where
  [simp]: "parallel P Q = (\<lambda>e. Parallel (P e) (Q e))"
definition
  new_channel :: "(chan \<Rightarrow> process family) \<Rightarrow> process family" (binder \<open>\<nu> \<close> 52)
where
  [simp]: "new_channel \<P> = (\<lambda>e. NewChannel (\<lambda>a. \<P> a e))"

text \<open>
  The notation for \<^const>\<open>receive\<close> cannot be declared with @{theory_text \<open>binder\<close>}, for the
  following reasons:

    \<^item> It does not allow binding multiple variables in one go (like in \<open>\<forall>x\<^sub>1 \<dots> x\<^sub>n. _\<close>).

    \<^item> It has an extra parameter (for the channel family) before the binder.

  Therefore we introduce this notation using the low-level @{theory_text \<open>syntax\<close>},
  @{theory_text \<open>translations\<close>}, and @{theory_text \<open>print_translation\<close>} constructs.
\<close>

syntax
  "_receive" :: "chan family \<Rightarrow> pttrn \<Rightarrow> process family \<Rightarrow> process family"
  (\<open>(3_ \<triangleright> _./ _)\<close> [53, 0, 52] 52)
translations
  "A \<triangleright> x. P" \<rightleftharpoons> "CONST receive A (\<lambda>x. P)"
print_translation \<open>
  [preserve_binder_abs_receive_tr' @{const_syntax receive} @{syntax_const "_receive"}]
\<close>

(* FIXME: Mention that \<open>\<circ>\<close> binds stronger than all the above operators and binders. *)

lemma process_family_distinctnesses [induct_simp]:
  shows
    "\<zero> \<noteq> A \<triangleleft> X"
  and
    "A \<triangleleft> X \<noteq> \<zero>"
  and
    "\<zero> \<noteq> A \<triangleright> x. \<P> x"
  and
    "A \<triangleright> x. \<P> x \<noteq> \<zero>"
  and
    "\<zero> \<noteq> P \<parallel> Q"
  and
    "P \<parallel> Q \<noteq> \<zero>"
  and
    "\<zero> \<noteq> \<nu> a. \<Q> a"
  and
    "\<nu> a. \<Q> a \<noteq> \<zero>"
  and
    "A \<triangleleft> X \<noteq> B \<triangleright> x. \<P> x"
  and
    "A \<triangleright> x. \<P> x \<noteq> B \<triangleleft> X"
  and
    "A \<triangleleft> X \<noteq> P \<parallel> Q"
  and
    "P \<parallel> Q \<noteq> A \<triangleleft> X"
  and
    "A \<triangleleft> X \<noteq> \<nu> a. \<Q> a"
  and
    "\<nu> a. \<Q> a \<noteq> A \<triangleleft> X"
  and
    "A \<triangleright> x. \<P> x \<noteq> P \<parallel> Q"
  and
    "P \<parallel> Q \<noteq> A \<triangleright> x. \<P> x"
  and
    "A \<triangleright> x. \<P> x \<noteq> \<nu> a. \<Q> a"
  and
    "\<nu> a. \<Q> a \<noteq> A \<triangleright> x. \<P> x"
  and
    "P \<parallel> Q \<noteq> \<nu> a. \<Q> a"
  and
    "\<nu> a. \<Q> a \<noteq> P \<parallel> Q"
  by (auto dest: fun_cong)

text \<open>
  Note that the above injectivity statements are not exhaustive, as they do not cover process
  families that are exotic at the top level. Therefore, if such process families occur, these
  injectivity statements are of no help.
\<close>

lemma process_family_injectivities [induct_simp]:
  shows
    "A\<^sub>1 \<triangleleft> X\<^sub>1 = A\<^sub>2 \<triangleleft> X\<^sub>2 \<longleftrightarrow> A\<^sub>1 = A\<^sub>2 \<and> X\<^sub>1 = X\<^sub>2"
  and
    "A\<^sub>1 \<triangleright> x. \<P>\<^sub>1 x = A\<^sub>2 \<triangleright> x. \<P>\<^sub>2 x \<longleftrightarrow> A\<^sub>1 = A\<^sub>2 \<and> \<P>\<^sub>1 = \<P>\<^sub>2"
  and
    "P\<^sub>1 \<parallel> Q\<^sub>1 = P\<^sub>2 \<parallel> Q\<^sub>2 \<longleftrightarrow> P\<^sub>1 = P\<^sub>2 \<and> Q\<^sub>1 = Q\<^sub>2"
  and
    "\<nu> a. \<Q>\<^sub>1 a = \<nu> a. \<Q>\<^sub>2 a \<longleftrightarrow> \<Q>\<^sub>1 = \<Q>\<^sub>2"
  by (auto dest: fun_cong)

definition create_channel :: "process family \<Rightarrow> process family" (\<open>\<star>\<close>) where
  [simp]: "\<star> = new_channel \<circ> \<Delta>"

lemma new_channel_as_create_channel:
  shows "new_channel = \<star> \<circ> \<nabla>"
  by auto

text \<open>
  The following trivially provable lemmas are stated, because they are later used as
  pre-simplification rules.
\<close>

lemma family_uncurry_after_stop:
  shows "\<nabla> (\<lambda>_. \<zero>) = \<zero>"
  by simp

lemma family_uncurry_after_send:
  shows "\<nabla> (\<lambda>b. \<A> b \<triangleleft> \<X> b) = \<nabla> \<A> \<triangleleft> \<nabla> \<X>"
  by simp

lemma family_uncurry_after_receive:
  shows "\<nabla> (\<lambda>b. \<A> b \<triangleright> x. \<P> x b) = \<nabla> \<A> \<triangleright> x. \<nabla> (\<P> x)"
  by simp

lemma family_uncurry_after_parallel:
  shows "\<nabla> (\<lambda>a. \<P> a \<parallel> \<Q> a) = \<nabla> \<P> \<parallel> \<nabla> \<Q>"
  by simp

lemma family_uncurry_after_new_channel:
  shows "\<nabla> (\<lambda>a. \<nu> b. \<P> a b) = \<nu> b. \<nabla> (\<lambda>a. \<P> a b)"
  by simp

text \<open>
  The following trivially provable lemmas are stated, because two of them are used by the
  \<^theory_text>\<open>de_bruijn\<close> method and one of them is used in \<^theory_text>\<open>Thorn_Calculus-Core_Bisimilarities\<close>.
\<close>

lemma deep_uncurry_after_parallel:
  shows "\<nabla>\<^bsub>i\<^esub> (\<lambda>a. \<P> a \<parallel> \<Q> a) = \<nabla>\<^bsub>i\<^esub> \<P> \<parallel> \<nabla>\<^bsub>i\<^esub> \<Q>"
  by simp

lemma deep_uncurry_after_new_channel:
  shows "\<nabla>\<^bsub>i\<^esub> (\<lambda>a. \<nu> b. \<P> a b) = \<nu> b. \<nabla>\<^bsub>i\<^esub> (\<lambda>a. \<P> a b)"
  by simp

lemma deep_uncurry_after_create_channel:
  shows "\<nabla>\<^bsub>i\<^esub> (\<lambda>a. \<star> (\<P> a)) = \<star> (\<nabla>\<^bsub>Suc i\<^esub> \<P>)"
  by simp

lemma adapted_after_stop:
  shows "\<zero> \<guillemotleft> \<E> = \<zero>"
  by transfer (simp add: comp_def)

lemma adapted_after_send:
  shows "(A \<triangleleft> X) \<guillemotleft> \<E> = A \<guillemotleft> \<E> \<triangleleft> X \<guillemotleft> \<E>"
  by transfer (simp add: comp_def)

lemma adapted_after_receive:
  shows "(A \<triangleright> x. \<P> x) \<guillemotleft> \<E> = A \<guillemotleft> \<E> \<triangleright> x. \<P> x \<guillemotleft> \<E>"
  by transfer (simp add: comp_def)

lemma adapted_after_parallel:
  shows "(P \<parallel> Q) \<guillemotleft> \<E> = P \<guillemotleft> \<E> \<parallel> Q \<guillemotleft> \<E>"
  by transfer (simp add: comp_def)

lemma adapted_after_new_channel:
  shows "(\<nu> a. \<Q> a) \<guillemotleft> \<E> = \<nu> a. \<Q> a \<guillemotleft> \<E>"
  by transfer (simp add: comp_def)

lemma adapted_after_create_channel:
  shows "\<star> P \<guillemotleft> \<E> = \<star> (P \<guillemotleft> on_tail \<E>)"
  unfolding on_tail_def
  by transfer (simp add: comp_def)

lemma adapted_after_create_channel_power:
  shows "\<star>\<^bsup>n\<^esup> P \<guillemotleft> \<E> = \<star>\<^bsup>n\<^esup> (P \<guillemotleft> on_suffix n \<E>)"
proof (induction n arbitrary: \<E>)
  case 0
  then show ?case
    by (simp add: identity_as_partial_on_suffix [symmetric])
next
  case (Suc n \<E>)
  show ?case
  proof -
    have "\<star>\<^bsup>Suc n\<^esup> P \<guillemotleft> \<E> = \<star> (\<star>\<^bsup>n\<^esup> P) \<guillemotleft> \<E>"
      by simp
    also have "\<dots> = \<star> (\<star>\<^bsup>n\<^esup> P \<guillemotleft> on_tail \<E>)"
      by (simp only: adapted_after_create_channel)
    also have "\<dots> = \<star> (\<star>\<^bsup>n\<^esup> (P \<guillemotleft> on_suffix n (on_tail \<E>)))"
      by (simp only: Suc.IH)
    also have "\<dots> = \<star> (\<star>\<^bsup>n\<^esup> (P \<guillemotleft> on_suffix (Suc n) \<E>))"
      unfolding on_tail_def
      using composition_as_partial_on_suffix [THEN fun_cong]
      by simp
    also have "\<dots> = \<star>\<^bsup>Suc n\<^esup> (P \<guillemotleft> on_suffix (Suc n) \<E>)"
      by simp
    finally show ?thesis .
  qed
qed

text \<open>
  The next set of lemmas states that a process that can be constructed both via a lifted data
  constructor and via adaptation can be constructed by applying the lifted data constructor to
  adaptations and also by adapting an application of the lifted data constructor.
\<close>
(* FIXME:
  \<^item> Check whether ``lifted data constructor'' is the right term (it sounds bulky).

  \<^item> Phrase this whole text in a more crisp way.

  \<^item> Rename the lemmas below to reflect the pattern described above.
*)

lemma stop_and_adapted:
  assumes "\<zero> = S \<guillemotleft> \<E>"
  shows "S = \<zero>"
  using adapted_undo and assms
  unfolding stop_def
  by (metis comp_def)

lemma send_and_adapted:
  assumes "A' \<triangleleft> X' = S \<guillemotleft> \<E>"
  obtains A and X where "A' = A \<guillemotleft> \<E>" and "X' = X \<guillemotleft> \<E>" and "S = A \<triangleleft> X"
proof -
  from assms have S_definition: "S = A' \<circ> inv \<lfloor>\<E>\<rfloor> \<triangleleft> X' \<circ> inv \<lfloor>\<E>\<rfloor>"
    using adapted_undo
    unfolding send_def
    by (metis comp_def)
  moreover
  from assms [symmetric] and S_definition have "A' = A' \<circ> inv \<lfloor>\<E>\<rfloor> \<guillemotleft> \<E>" and "X' = X' \<circ> inv \<lfloor>\<E>\<rfloor> \<guillemotleft> \<E>"
    by (simp_all only: adapted_after_send process_family_injectivities)
  ultimately show ?thesis
    using that
    by simp
qed

lemma receive_and_adapted:
  assumes "A' \<triangleright> x. \<P>' x = S \<guillemotleft> \<E>"
  obtains A and \<P> where "A' = A \<guillemotleft> \<E>" and "\<P>' = (\<lambda>x. \<P> x \<guillemotleft> \<E>)" and "S = A \<triangleright> x. \<P> x"
proof -
  have "S = S \<guillemotleft> \<E> \<circ> inv \<lfloor>\<E>\<rfloor>"
    by (simp only: adapted_undo)
  also have "\<dots> = A' \<circ> inv \<lfloor>\<E>\<rfloor> \<triangleright> x. \<P>' x \<circ> inv \<lfloor>\<E>\<rfloor>"
    by (simp only: assms [symmetric] receive_def comp_def)
  finally have S_definition: "S = A' \<circ> inv \<lfloor>\<E>\<rfloor> \<triangleright> x. \<P>' x \<circ> inv \<lfloor>\<E>\<rfloor>" .
  moreover
  from assms [symmetric] and S_definition
  have "A' = A' \<circ> inv \<lfloor>\<E>\<rfloor> \<guillemotleft> \<E>" and "\<P>' = (\<lambda>x. \<P>' x \<circ> inv \<lfloor>\<E>\<rfloor> \<guillemotleft> \<E>)"
    by (simp_all only: adapted_after_receive process_family_injectivities)
  ultimately show ?thesis
    using that [where \<P> = "\<lambda>x. \<P>' x \<circ> inv \<lfloor>\<E>\<rfloor>"]
    by blast
qed

lemma parallel_and_adapted:
  assumes "P' \<parallel> Q' = S \<guillemotleft> \<E>"
  obtains P and Q where "P' = P \<guillemotleft> \<E>" and "Q' = Q \<guillemotleft> \<E>" and "S = P \<parallel> Q"
proof -
  from assms have S_definition: "S = P' \<circ> inv \<lfloor>\<E>\<rfloor> \<parallel> Q' \<circ> inv \<lfloor>\<E>\<rfloor>"
    using adapted_undo
    unfolding parallel_def
    by (metis comp_def)
  moreover
  from assms [symmetric] and S_definition have "P' = P' \<circ> inv \<lfloor>\<E>\<rfloor> \<guillemotleft> \<E>" and "Q' = Q' \<circ> inv \<lfloor>\<E>\<rfloor> \<guillemotleft> \<E>"
    by (simp_all only: adapted_after_parallel process_family_injectivities)
  ultimately show ?thesis
    using that
    by simp
qed

lemma new_channel_and_adapted:
  assumes "\<nu> a. \<P>' a = S \<guillemotleft> \<E>"
  obtains \<P> where "\<P>' = (\<lambda>a. \<P> a \<guillemotleft> \<E>)" and "S = \<nu> a. \<P> a"
proof -
  have "S = S \<guillemotleft> \<E> \<circ> inv \<lfloor>\<E>\<rfloor>"
    by (simp only: adapted_undo)
  also have "\<dots> = \<nu> a. \<P>' a \<circ> inv \<lfloor>\<E>\<rfloor>"
    by (simp only: assms [symmetric] new_channel_def comp_def)
  finally have S_definition: "S = \<nu> a. \<P>' a \<circ> inv \<lfloor>\<E>\<rfloor>" .
  moreover
  from assms [symmetric] and S_definition have "\<P>' = (\<lambda>a. \<P>' a \<circ> inv \<lfloor>\<E>\<rfloor> \<guillemotleft> \<E>)"
    by (simp_all only: adapted_after_new_channel process_family_injectivities)
  ultimately show ?thesis
    using that [where \<P> = "\<lambda>a. \<P>' a \<circ> inv \<lfloor>\<E>\<rfloor>"]
    by simp
qed

(*FIXME:
  The following lemmas and all the other \<^theory_text>\<open>environment_dependent\<close> lemmas seem to be used only in the
  manual rewriting under \<open>\<triangleright>\<^sup>\<infinity>\<close> and thus should be removed once the new implementation of
  \<^theory_text>\<open>equivalence\<close> is in place.
*)

(*FIXME:
  If we ever add some sort of wrapping to the statements of the following lemmas in order to make
  tools that try to rewrite repeatedly not hang, we should probably also add
  \<^theory_text>\<open>environment_dependent_stop\<close>.
*)

lemma environment_dependent_send:
  shows "(\<lambda>e. (\<A> e \<triangleleft> \<X> e) e) = (\<lambda>e. \<A> e e) \<triangleleft> (\<lambda>e. \<X> e e)"
  by (simp only: send_def)

lemma environment_dependent_receive:
  shows "(\<lambda>e. (\<A> e \<triangleright> x. \<P> x e) e) = (\<lambda>e. \<A> e e) \<triangleright> x. (\<lambda>e. \<P> x e e)"
  by (simp only: receive_def)

lemma environment_dependent_parallel:
  shows "(\<lambda>e. (\<P> e \<parallel> \<Q> e) e) = (\<lambda>e. \<P> e e) \<parallel> (\<lambda>e. \<Q> e e)"
  by (simp only: parallel_def)

(*FIXME:
  Perhaps we should add \<^theory_text>\<open>environment_dependent_new_channel\<close>, if only for completeness.
*)

(*FIXME:
  Perhaps add \<^theory_text>\<open>environment_dependent\<close> lemmas also for higher-level constructs like the ones from
  \<^theory_text>\<open>Thorn_Calculus-Communication\<close>.
*)

subsection \<open>Repeated Receiving\<close>

corec repeated_receive :: "chan family \<Rightarrow> (val \<Rightarrow> process family) \<Rightarrow> process family" where
  "repeated_receive A \<P> e = Receive (A e) (\<lambda>x. Parallel (\<P> x e) (repeated_receive A \<P> e))"
syntax
  "_repeated_receive" :: "chan family \<Rightarrow> pttrn \<Rightarrow> process family \<Rightarrow> process family"
  (\<open>(3_ \<triangleright>\<^sup>\<infinity> _./ _)\<close> [53, 0, 52] 52)
translations
  "A \<triangleright>\<^sup>\<infinity> x. P" \<rightleftharpoons> "CONST repeated_receive A (\<lambda>x. P)"
print_translation \<open>
  [preserve_binder_abs_receive_tr' @{const_syntax repeated_receive} @{syntax_const "_repeated_receive"}]
\<close>

lemma repeated_receive_proper_def:
  shows "A \<triangleright>\<^sup>\<infinity> x. \<P> x = A \<triangleright> x. (\<P> x \<parallel> A \<triangleright>\<^sup>\<infinity> x. \<P> x)"
  by (rule ext) (subst repeated_receive.code, simp)

lemma adapted_after_repeated_receive:
  shows "(A \<triangleright>\<^sup>\<infinity> x. \<P> x) \<guillemotleft> \<E> = A \<guillemotleft> \<E> \<triangleright>\<^sup>\<infinity> x. \<P> x \<guillemotleft> \<E>"
  by
    (
      standard,
      subst (1 2) repeated_receive_proper_def,
      coinduction rule: repeated_receive.coinduct
    )
    (
      use adapted_after_receive adapted_after_parallel in simp,
      subst (3 4) repeated_receive_proper_def,
      auto intro: repeated_receive.cong_intros
    )

text \<open>
  We define guarding of processes at the host-language level.
\<close>

definition guard :: "bool \<Rightarrow> process family \<Rightarrow> process family" (infixr \<open>?\<close> 52) where
  [simp]: "v ? P = (if v then P else \<zero>)"

(*FIXME: Perhaps add \<^theory_text>\<open>environment_dependent_guard\<close>.*)

lemma adapted_after_guard:
  shows "(v ? P) \<guillemotleft> \<E> = v ? P \<guillemotleft> \<E>"
  by transfer (simp add: comp_def)

(* FIXME: Check if we should also have a \<^theory_text>\<open>guard_and_adapted\<close>. *)

text \<open>
  We define parallel composition over a list of processes families.
\<close>

primrec general_parallel :: "('a \<Rightarrow> process family) \<Rightarrow> 'a list \<Rightarrow> process family" where
  "general_parallel _ [] = \<zero>" |
  "general_parallel \<P> (v # vs) = \<P> v \<parallel> general_parallel \<P> vs"

text \<open>
  We define a notation for repeated parallel composition combined with mapping. Since this notation
  clashes with \<open>HOL.Groups_List._prod_list\<close>, we have to remove the latter.
\<close>

no_syntax
  "_prod_list" :: "pttrn \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" (\<open>(3\<Prod>_\<leftarrow>_. _)\<close> [0, 51, 10] 10)
syntax
  "_general_parallel" :: "pttrn \<Rightarrow> 'a list \<Rightarrow> process \<Rightarrow> process" (\<open>(3\<Prod>_\<leftarrow>_. _)\<close> [0, 0, 52] 52)
translations
  "\<Prod>v\<leftarrow>vs. P" \<rightleftharpoons> "CONST general_parallel (\<lambda>v. P) vs"
print_translation \<open>
  [
    preserve_binder_abs_general_parallel_tr'
      @{const_syntax general_parallel}
      @{syntax_const "_general_parallel"}
  ]
\<close>

lemma adapted_after_general_parallel:
  shows "(\<Prod>v \<leftarrow> vs. \<P> v) \<guillemotleft> \<E> = \<Prod>v \<leftarrow> vs. \<P> v \<guillemotleft> \<E>"
  by
    (induction vs)
    (simp_all only: general_parallel.simps adapted_after_stop adapted_after_parallel)

(* FIXME: Check if we should also have a \<^theory_text>\<open>general_parallel_and_adapted\<close>. *)

lemma environment_dependent_general_parallel:
  shows "(\<lambda>e. (\<Prod>v \<leftarrow> vs. \<P> v e) e) = \<Prod>v \<leftarrow> vs. (\<lambda>e. \<P> v e e)"
proof (induction vs)
  case Nil
  show ?case
    by (simp only: general_parallel.simps(1))
next
  case Cons
  then show ?case
    unfolding general_parallel.simps(2)
    by (subst environment_dependent_parallel, simp only:)
qed

lemma general_parallel_conversion_deferral:
  shows "\<Prod>w \<leftarrow> map f vs. \<P> w = \<Prod>v \<leftarrow> vs. \<P> (f v)"
  by (induction vs) simp_all

(*FIXME: Consider permitting tags of arbitrary types that have a total order. *)

definition tagged_new_channel :: "nat \<Rightarrow> (chan \<Rightarrow> process family) \<Rightarrow> process family" where
  [simp]: "tagged_new_channel _ \<P> = \<nu> a. \<P> a"

syntax
  "_tagged_new_channel" :: "[nat, pttrn, process family] \<Rightarrow> process family"
  (\<open>(3\<langle>_\<rangle> \<nu> _./ _)\<close> [0, 0, 52] 52)
translations
  "\<langle>t\<rangle> \<nu> a. P" \<rightleftharpoons> "CONST tagged_new_channel t (\<lambda>a. P)"
print_translation \<open>
  [
    preserve_binder_abs_receive_tr'
      @{const_syntax tagged_new_channel}
      @{syntax_const "_tagged_new_channel"}
  ]
\<close>

definition tagged_create_channel :: "nat \<Rightarrow> process family \<Rightarrow> process family" (\<open>\<langle>_\<rangle> \<star>\<close>) where
  [simp]: "\<langle>_\<rangle> \<star> = \<star>"

text \<open>
  \<^theory_text>\<open>de_bruijn\<close> expects there to be no chained facts. With chained facts present, there would be two
  issues:

    \<^item> The @{method simp} invocation would insert the chained facts as premises, which would be good.
      However, @{method simp} would not finish successfully when no simplification is possible, and
      thus the insertion of the chained fact would not happen in this case.

    \<^item> The @{method unfold} invocation, when successful, would insert the chained facts a second
      time (which could be prevented with \<^theory_text>\<open>use in\<close>, of course).
\<close>

(*FIXME:
  The implementation of \<^theory_text>\<open>de_bruijn\<close>, in particular the use and handling of \<open>remove\<close> adaptations, is
  very ad-hoc and brittle and thus should be reworked.
*)

method de_bruijn = (
  (
    simp only:
      new_channel_as_create_channel [unfolded comp_def]
      family_uncurry_as_deep_uncurry [where 'a = process]
      deep_uncurry_after_parallel
      deep_uncurry_after_create_channel
      deep_uncurry_reordering [where 'a = process]
  )?,
  (
    unfold
      family_uncurry_as_deep_uncurry [where 'a = process, symmetric]
      constant_function_family_uncurry_as_remove_adapted [where 'a = process]
      remove_adapted_after_family_uncurry [where 'a = process, symmetric]
      adapted_after_stop [where \<E> = "remove _"]
  )?
)

(*FIXME: Come up with an appropriate handling of \<open>\<triangleleft>\<close> and custom processes like bridges. *)

text \<open>
  The @{method de_bruijn} method can solve trivial goals, because it uses @{method simp}. However,
  this should not happen when the goal contains bisimilarities, as no rules for solving these are
  given above.

  Also note that it copies the chained fact into the goal as premises, like @{method simp} does
  (which it internally uses).
\<close>

definition
  process_family_uncurry_relation :: "(chan \<Rightarrow> process family) \<Rightarrow> process family \<Rightarrow> bool"
where
  [simp]: "process_family_uncurry_relation \<P> P = (P = \<nabla> \<P>)"

lemma process_family_uncurry_relation_bi_uniqueness [transfer_rule]:
  shows "bi_unique process_family_uncurry_relation"
  using family_uncurry_is_bijective
  by (auto simp only: bij_def inj_def bi_unique_def process_family_uncurry_relation_def)

lemma process_family_uncurry_relation_bi_totality [transfer_rule]:
  shows "bi_total process_family_uncurry_relation"
  using family_uncurry_is_bijective
  by (auto simp only: bij_def surj_def bi_total_def process_family_uncurry_relation_def)

lemma process_family_uncurry_relation_right_uniqueness [transfer_rule]:
  shows "right_unique process_family_uncurry_relation"
  using process_family_uncurry_relation_bi_uniqueness
  by (simp add: bi_unique_def right_unique_def)

lemma process_family_uncurry_relation_right_totality [transfer_rule]:
  shows "right_total process_family_uncurry_relation"
  using process_family_uncurry_relation_bi_totality
  by (simp add: bi_total_def right_total_def)

lemma process_family_uncurry_transfer [transfer_rule]:
  shows "rel_fun process_family_uncurry_relation (=) \<nabla> (\<lambda>P. P)"
  by (simp add: rel_fun_def)

text \<open>
  \<^theory_text>\<open>process_family_uncurry_elimination\<close> expects there to be no chained facts.
\<close>

method process_family_uncurry_elimination uses in_process_prem processed_prems = (
  match in_process_prem in "V (\<nabla> :: (chan \<Rightarrow> process family) \<Rightarrow> process family)" (cut) for V \<Rightarrow> \<open>
    match (V) in
      "\<lambda>_. ?v" (cut) \<Rightarrow> \<open>
        process_family_uncurry_elimination
          processed_prems: processed_prems in_process_prem
      \<close> \<bar>
      _ (cut) \<Rightarrow> \<open>
        process_family_uncurry_elimination
          in_process_prem: in_process_prem [transferred]
          processed_prems: processed_prems
      \<close>
      \<comment> \<open>
        This technique involving \<^theory_text>\<open>cut\<close> relies on higher-order unification to yield a non-constant
        matching function first if such a function exists.
      \<close>
  \<close> |
  match premises in prem [thin]: _ (cut) \<Rightarrow> \<open>
    (match premises in others [thin]: _ (cut, multi) \<Rightarrow> \<open>insert others\<close>)?,
      \<comment> \<open>
        This is done, because apparently thinning does not work across recursive method calls.
      \<close>
    process_family_uncurry_elimination in_process_prem: prem processed_prems: processed_prems
  \<close> |
  insert processed_prems
)

definition wrapped_remove_adapted :: "process family \<Rightarrow> nat \<Rightarrow> process family" where
  [simp]: "wrapped_remove_adapted P i = P \<guillemotleft> remove i"

text \<open>
  We do not perform rewriting of the facts in @{attribute equivalence}. This is not necessary for
  the approach we are following here, where the only facts in @{attribute equivalence} are
  equivalence inclusions.
\<close>

method process_family_equivalence = (
  -,
  use in \<open>
    de_bruijn;
    process_family_uncurry_elimination,
    (fold wrapped_remove_adapted_def)?,
    equivalence
  \<close>
)

(*FIXME: Currently, \<^theory_text>\<open>process_family_equivalence\<close> does not work with tags. *)

end


(* Author: Andreas Lochbihler, Digital Asset *)

section \<open>The max-flow min-cut theorem in bounded networks\<close>

subsection \<open>Linkages in unhindered bipartite webs\<close>

theory MFMC_Bounded imports
  Matrix_For_Marginals
  MFMC_Reduction
begin

context countable_bipartite_web begin

lemma countable_A [simp]: "countable (A \<Gamma>)"
  using A_vertex countable_V by(blast intro: countable_subset)

lemma unhindered_criterion [rule_format]:
  assumes "\<not> hindered \<Gamma>"
  shows "\<forall>X \<subseteq> A \<Gamma>. finite X \<longrightarrow> (\<Sum>\<^sup>+ x\<in>X. weight \<Gamma> x) \<le> (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. weight \<Gamma> y)"
  using assms
proof(rule contrapos_np)
  assume "\<not> ?thesis"
  then obtain X where "X \<in> {X. X \<subseteq> A \<Gamma> \<and> finite X \<and> (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. weight \<Gamma> y) < (\<Sum>\<^sup>+ x\<in>X. weight \<Gamma> x)}" (is "_ \<in> Collect ?P")
    by(auto simp add: not_le)
  from wf_eq_minimal[THEN iffD1, OF wf_finite_psubset, rule_format, OF this, simplified]
  obtain X where X_A: "X \<subseteq> A \<Gamma>" and fin_X [simp]: "finite X"
    and less: "(\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. weight \<Gamma> y) < (\<Sum>\<^sup>+ x\<in>X. weight \<Gamma> x)"
    and minimal: "\<And>X'. X' \<subset> X \<Longrightarrow> (\<Sum>\<^sup>+ x\<in>X'. weight \<Gamma> x) \<le> (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X'. weight \<Gamma> y)"
    by(clarsimp simp add: not_less)(meson finite_subset order_trans psubset_imp_subset)
  have nonempty: "X \<noteq> {}" using less by auto
  then obtain xx where xx: "xx \<in> X" by auto
  define f where
    "f x = (if x = xx then (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. weight \<Gamma> y) - (\<Sum>\<^sup>+ x\<in>X - {xx}. weight \<Gamma> x) else if x \<in> X then weight \<Gamma> x else 0)" for x
  define g where
    "g y = (if y \<in> \<^bold>E `` X then weight \<Gamma> y else 0)" for y
  define E' where "E' \<equiv> \<^bold>E \<inter> X \<times> UNIV"
  have Xxx: "X - {xx} \<subset> X" using xx by blast
  have E [simp]: "E' `` X' = \<^bold>E `` X'" if "X' \<subseteq> X" for X' using that by(auto simp add: E'_def)
  have in_E': "(x, y) \<in> E' \<longleftrightarrow> x \<in> X \<and> (x, y) \<in> \<^bold>E" for x y by(auto simp add: E'_def)

  have "(\<Sum>\<^sup>+ x\<in>X. f x) = (\<Sum>\<^sup>+ x\<in>X - {xx}. f x) + (\<Sum>\<^sup>+ x\<in>{xx}. f x)" using xx
    by(auto simp add: nn_integral_count_space_indicator nn_integral_add[symmetric] simp del: nn_integral_indicator_singleton intro!: nn_integral_cong split: split_indicator)
  also have "\<dots> = (\<Sum>\<^sup>+ x\<in>X - {xx}. weight \<Gamma> x) + ((\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. weight \<Gamma> y) - (\<Sum>\<^sup>+ x\<in>X - {xx}. weight \<Gamma> x))"
    by(rule arg_cong2[where f="(+)"])(auto simp add: f_def xx nn_integral_count_space_indicator intro!: nn_integral_cong)
  also have "\<dots> = (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. g y)" using minimal[OF Xxx] xx
    by(subst add_diff_eq_iff_ennreal[THEN iffD2])(fastforce simp add: g_def[abs_def] nn_integral_count_space_indicator intro!: nn_integral_cong intro: nn_integral_mono elim: order_trans split: split_indicator)+
  finally have sum_eq: "(\<Sum>\<^sup>+ x\<in>X. f x) = (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. g y)" .

  have "(\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. weight \<Gamma> y) = (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. g y)"
    by(auto simp add: nn_integral_count_space_indicator g_def intro!: nn_integral_cong)
  then have fin: "\<dots> \<noteq> \<top>" using less by auto

  have fin2: "(\<Sum>\<^sup>+ x\<in>X'. weight \<Gamma> x) \<noteq> \<top>" if "X' \<subset> X" for X'
  proof -
    have "(\<Sum>\<^sup>+ x\<in>\<^bold>E `` X'. weight \<Gamma> x) \<le> (\<Sum>\<^sup>+ x\<in>\<^bold>E `` X. weight \<Gamma> x)" using that
      by(auto 4 3 simp add: nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator split_indicator_asm)
    then show ?thesis using minimal[OF that] less by(auto simp add: top_unique)
  qed

  have "f xx = (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. weight \<Gamma> y) - (\<Sum>\<^sup>+ x\<in>X - {xx}. weight \<Gamma> x)" by (simp add: f_def)
  also have "\<dots> < (\<Sum>\<^sup>+ x\<in>X. weight \<Gamma> x) - (\<Sum>\<^sup>+ x\<in>X - {xx}. weight \<Gamma> x)" using less fin2[OF Xxx] minimal[OF Xxx]
    by(subst minus_less_iff_ennreal)(fastforce simp add: less_top[symmetric] nn_integral_count_space_indicator diff_add_self_ennreal intro: nn_integral_mono elim: order_trans split: split_indicator)+
  also have "\<dots> = (\<Sum>\<^sup>+ x\<in>{xx}. weight \<Gamma> x)" using fin2[OF Xxx] xx
    apply(simp add: nn_integral_count_space_indicator del: nn_integral_indicator_singleton)
    apply(subst nn_integral_diff[symmetric])
    apply(auto simp add: AE_count_space split: split_indicator simp del: nn_integral_indicator_singleton intro!: nn_integral_cong)
    done
  also have "\<dots> = weight \<Gamma> xx" by(simp add: nn_integral_count_space_indicator)
  finally have fxx: "f xx < weight \<Gamma> xx" .

  have le: "(\<Sum>\<^sup>+ x\<in>X'. f x) \<le> (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X'. g y)" if "X' \<subseteq> X" for X'
  proof(cases "X' = X")
    case True
    then show ?thesis using sum_eq by simp
  next
    case False
    hence X': "X' \<subset> X" using that by blast
    have "(\<Sum>\<^sup>+ x\<in>X'. f x) = (\<Sum>\<^sup>+ x\<in>X' - {xx}. f x) + (\<Sum>\<^sup>+ x\<in>{xx}. f x * indicator X' xx)"
      by(auto simp add: nn_integral_count_space_indicator nn_integral_add[symmetric] simp del: nn_integral_indicator_singleton intro!: nn_integral_cong split: split_indicator)
    also have "\<dots> \<le> (\<Sum>\<^sup>+ x\<in>X' - {xx}. f x) + (\<Sum>\<^sup>+ x\<in>{xx}. weight \<Gamma> x * indicator X' xx)" using fxx
      by(intro add_mono)(auto split: split_indicator simp add: nn_integral_count_space_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ x\<in>X'. weight \<Gamma> x)" using xx that
      by(auto simp add: nn_integral_count_space_indicator nn_integral_add[symmetric] f_def simp del: nn_integral_indicator_singleton intro!: nn_integral_cong split: split_indicator)
    also have "\<dots> \<le> (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X'. weight \<Gamma> y)" by(rule minimal[OF X'])
    also have "\<dots> = (\<Sum>\<^sup>+ y\<in>\<^bold>E `` X'. g y)" using that
      by(auto 4 3 intro!: nn_integral_cong simp add: g_def Image_iff)
    finally show ?thesis .
  qed

  have "countable X" using X_A A_vertex countable_V by(blast intro: countable_subset)
  moreover have "\<^bold>E `` X \<subseteq> \<^bold>V" by(auto simp add: vertex_def)
  with countable_V have "countable (\<^bold>E `` X)" by(blast intro: countable_subset)
  moreover have "E' \<subseteq> X \<times> \<^bold>E `` X" by(auto simp add: E'_def)
  ultimately obtain h' where h'_dom: "\<And>x y. 0 < h' x y \<Longrightarrow> (x, y) \<in> E'"
    and h'_fin: "\<And>x y. h' x y \<noteq> \<top>"
    and h'_f: "\<And>x. x \<in> X \<Longrightarrow> (\<Sum>\<^sup>+ y\<in>E' `` X. h' x y) = f x"
    and h'_g: "\<And>y. y \<in> E' `` X \<Longrightarrow> (\<Sum>\<^sup>+ x\<in>X. h' x y) = g y"
    using bounded_matrix_for_marginals_ennreal[where f=f and g=g and A=X and B="E' `` X" and R=E' and thesis=thesis] sum_eq fin le
    by(auto)

  have h'_outside: "(x, y) \<notin> E' \<Longrightarrow> h' x y = 0" for x y using h'_dom[of x y] not_gr_zero by(fastforce)

  define h where "h = (\<lambda>(x, y). if x \<in> X \<and> edge \<Gamma> x y then h' x y else 0)"
  have h_OUT: "d_OUT h x = (if x \<in> X then f x else 0)" for x
    by(auto 4 3 simp add: h_def d_OUT_def h'_f[symmetric] E'_def nn_integral_count_space_indicator intro!: nn_integral_cong intro: h'_outside split: split_indicator)
  have h_IN: "d_IN h y = (if y \<in> \<^bold>E `` X then weight \<Gamma> y else 0)" for y using h'_g[of y, symmetric]
    by(auto 4 3 simp add: h_def d_IN_def g_def nn_integral_count_space_indicator nn_integral_0_iff_AE  in_E' intro!: nn_integral_cong intro: h'_outside split: split_indicator split_indicator_asm)

  have h: "current \<Gamma> h"
  proof
    show "d_OUT h x \<le> weight \<Gamma> x" for x using fxx by(auto simp add: h_OUT f_def)
    show "d_IN h y \<le> weight \<Gamma> y" for y by(simp add: h_IN)
    show "h e = 0" if "e \<notin> \<^bold>E" for e using that by(cases e)(auto simp add: h_def)
  qed

  have "separating \<Gamma> (TER h)"
  proof
    fix x y p
    assume x: "x \<in> A \<Gamma>" and y: "y \<in> B \<Gamma>" and p: "path \<Gamma> x p y"
    then obtain [simp]: "p = [y]" and xy: "(x, y) \<in> \<^bold>E" using disjoint
      by -(erule rtrancl_path.cases; auto dest: bipartite_E)+
    show "(\<exists>z\<in>set p. z \<in> TER h) \<or> x \<in> TER h"
    proof(rule disjCI)
      assume "x \<notin> TER h"
      hence "x \<in> X" using x by(auto simp add: SAT.simps SINK.simps h_OUT split: if_split_asm)
      hence "y \<in> TER h" using xy currentD_OUT[OF h y] by(auto simp add: SAT.simps h_IN SINK.simps)
      thus "\<exists>z\<in>set p. z \<in> TER h" by simp
    qed
  qed
  then have w: "wave \<Gamma> h" using h ..

  have "xx \<in> A \<Gamma>" using xx X_A by blast
  moreover have "xx \<notin> \<E> (TER h)"
  proof
    assume "xx \<in> \<E> (TER h)"
    then obtain p y where y: "y \<in> B \<Gamma>" and p: "path \<Gamma> xx p y"
      and bypass: "\<And>z. \<lbrakk> xx \<noteq> y; z \<in> set p \<rbrakk> \<Longrightarrow> z = xx \<or> z \<notin> TER h"
      by(rule \<E>_E) auto
    from p obtain [simp]: "p = [y]" and xy: "edge \<Gamma> xx y" and neq: "xx \<noteq> y" using disjoint X_A xx y
      by -(erule rtrancl_path.cases; auto dest: bipartite_E)+
    from neq bypass[of y] have "y \<notin> TER h" by simp
    moreover from xy xx currentD_OUT[OF h y] have "y \<in> TER h"
      by(auto simp add: SAT.simps h_IN SINK.simps)
    ultimately show False by contradiction
  qed
  moreover have "d_OUT h xx < weight \<Gamma> xx" using fxx xx by(simp add: h_OUT)
  ultimately have "hindrance \<Gamma> h" ..
  then show "hindered \<Gamma>" using h w ..
qed

end

lemma nn_integral_count_space_top_approx:
  fixes f :: "nat => ennreal" and b :: ennreal
  assumes "nn_integral (count_space UNIV) f = top"
  and "b < top"
  obtains n where "b < sum f {..<n}"
  using assms unfolding nn_integral_count_space_nat suminf_eq_SUP SUP_eq_top_iff by(auto)

lemma One_le_of_nat_ennreal: "(1 :: ennreal) \<le> of_nat x \<longleftrightarrow> 1 \<le> x"
  by (metis of_nat_le_iff of_nat_1)

locale bounded_countable_bipartite_web = countable_bipartite_web \<Gamma>
  for \<Gamma> :: "('v, 'more) web_scheme" (structure)
  +
  assumes bounded_B: "x \<in> A \<Gamma> \<Longrightarrow> (\<Sum>\<^sup>+ y \<in> \<^bold>E `` {x}. weight \<Gamma> y) < \<top>"
begin

theorem unhindered_linkable_bounded:
  assumes "\<not> hindered \<Gamma>"
  shows "linkable \<Gamma>"
proof(cases "A \<Gamma> = {}")
  case True
  hence "linkage \<Gamma> (\<lambda>_. 0)" by(auto simp add: linkage.simps)
  moreover have "web_flow \<Gamma> (\<lambda>_. 0)" by(auto simp add: web_flow.simps)
  ultimately show ?thesis by blast
next
  case nonempty: False
  define A_n :: "nat \<Rightarrow> 'v set" where "A_n n = from_nat_into (A \<Gamma>) ` {..n}" for n
  have fin_A_n [simp]: "finite (A_n n)" for n by(simp add: A_n_def)
  have A_n_A: "A_n n \<subseteq> A \<Gamma>" for n by(auto simp add: A_n_def from_nat_into[OF nonempty])

  have countable2: "countable (\<^bold>E `` A_n n)" for n using countable_V
    by(rule countable_subset[rotated])(auto simp add: vertex_def)

  have "\<exists>Y2. \<forall>n. \<forall>X \<subseteq> A_n n. Y2 n X \<subseteq> \<^bold>E `` X \<and> (\<Sum>\<^sup>+ x\<in>X. weight \<Gamma> x) \<le> (\<Sum>\<^sup>+ y\<in>Y2 n X. weight \<Gamma> y) \<and> (\<Sum>\<^sup>+ y\<in>Y2 n X. weight \<Gamma> y) \<noteq> \<top>"
  proof(rule choice strip ex_simps(6)[THEN iffD2])+
    fix n X
    assume X: "X \<subseteq> A_n n"
    then have [simp]: "finite X" by(rule finite_subset) simp
    have X_count: "countable (\<^bold>E `` X)" using countable2
      by(rule countable_subset[rotated])(rule Image_mono[OF order_refl X])

    show "\<exists>Y. Y \<subseteq> \<^bold>E `` X \<and> (\<Sum>\<^sup>+ x\<in>X. weight \<Gamma> x) \<le> (\<Sum>\<^sup>+ y\<in>Y. weight \<Gamma> y) \<and> (\<Sum>\<^sup>+ y\<in>Y. weight \<Gamma> y) \<noteq> \<top>" (is "Ex ?P")
    proof(cases "(\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. weight \<Gamma> y) = \<top>")
      case True
      define Y' where "Y' = to_nat_on (\<^bold>E `` X) ` (\<^bold>E `` X)"
      have inf: "infinite (\<^bold>E `` X)" using True
        by(intro notI)(auto simp add: nn_integral_count_space_finite)
      then have Y': "Y' = UNIV" using X_count by(auto simp add: Y'_def intro!: image_to_nat_on)
      have "(\<Sum>\<^sup>+ y\<in>\<^bold>E `` X. weight \<Gamma> y) = (\<Sum>\<^sup>+ y\<in>from_nat_into (\<^bold>E `` X) ` Y'. weight \<Gamma> y * indicator (\<^bold>E `` X) y)"
        using X_count
        by(auto simp add: nn_integral_count_space_indicator Y'_def image_image intro!: nn_integral_cong from_nat_into_to_nat_on[symmetric] rev_image_eqI split: split_indicator)
      also have "\<dots> = (\<Sum>\<^sup>+ y. weight \<Gamma> (from_nat_into (\<^bold>E `` X) y) * indicator (\<^bold>E `` X) (from_nat_into (\<^bold>E `` X) y))"
        using X_count inf by(subst nn_integral_count_space_reindex)(auto simp add: inj_on_def Y')
      finally have "\<dots> = \<top>" using True by simp
      from nn_integral_count_space_top_approx[OF this, of "sum (weight \<Gamma>) X"]
      obtain yy where yy: "sum (weight \<Gamma>) X < (\<Sum> y<yy. weight \<Gamma> (from_nat_into (\<^bold>E `` X) y) * indicator (\<^bold>E `` X) (from_nat_into (\<^bold>E `` X) y))"
        by(auto simp add: less_top[symmetric])
      define Y where "Y = from_nat_into (\<^bold>E `` X) ` {..<yy} \<inter> \<^bold>E `` X"
      have [simp]: "finite Y" by(simp add: Y_def)
      have "(\<Sum>\<^sup>+ x\<in>X. weight \<Gamma> x) = sum (weight \<Gamma>) X" by(simp add: nn_integral_count_space_finite)
      also have "\<dots> \<le> (\<Sum> y<yy. weight \<Gamma> (from_nat_into (\<^bold>E `` X) y) * indicator (\<^bold>E `` X) (from_nat_into (\<^bold>E `` X) y))"
        using yy by simp
      also have "\<dots> = (\<Sum> y \<in> from_nat_into (\<^bold>E `` X) ` {..<yy}. weight \<Gamma> y * indicator (\<^bold>E `` X) y)"
        using X_count inf by(subst sum.reindex)(auto simp add: inj_on_def)
      also have "\<dots> = (\<Sum> y \<in> Y. weight \<Gamma> y)" by(auto intro!: sum.cong simp add: Y_def)
      also have "\<dots> = (\<Sum>\<^sup>+ y\<in>Y. weight \<Gamma> y)" by(simp add: nn_integral_count_space_finite)
      also have "Y \<subseteq> \<^bold>E `` X" by(simp add: Y_def)
      moreover have "(\<Sum>\<^sup>+ y\<in>Y. weight \<Gamma> y) \<noteq> \<top>" by(simp add: nn_integral_count_space_finite)
      ultimately show ?thesis by blast
    next
      case False
      with unhindered_criterion[OF assms, of X] X A_n_A[of n] have "?P (\<^bold>E `` X)" by auto
      then show ?thesis ..
    qed
  qed
  then obtain Y2
    where Y2_A: "Y2 n X \<subseteq> \<^bold>E `` X"
    and le: "(\<Sum>\<^sup>+ x\<in>X. weight \<Gamma> x) \<le> (\<Sum>\<^sup>+ y\<in>Y2 n X. weight \<Gamma> y)"
    and finY2: "(\<Sum>\<^sup>+ y\<in>Y2 n X. weight \<Gamma> y) \<noteq> \<top>" if "X \<subseteq> A_n n" for n X by iprover
  define Y where "Y n = (\<Union> X \<in> Pow (A_n n). Y2 n X)" for n
  define s where "s n = (\<Sum>\<^sup>+ y\<in>Y n. weight \<Gamma> y)" for n
  have Y_vertex: "Y n \<subseteq> \<^bold>V" for n by(auto 4 3 simp add: Y_def vertex_def dest!: Y2_A[of _ n])
  have Y_B: "Y n \<subseteq> B \<Gamma>" for n unfolding Y_def by(auto dest!: Y2_A[of _ n] dest: bipartite_E)

  have s_top [simp]: "s n \<noteq> \<top>" for n
  proof -
    have "\<lbrakk>x \<in> Y2 n X; X \<subseteq> A_n n\<rbrakk> \<Longrightarrow> Suc 0 \<le> card {X. X \<subseteq> A_n n \<and> x \<in> Y2 n X}" for x X
      by(subst card_le_Suc_iff)(auto intro!: exI[where x=X] exI[where x="{X. X \<subseteq> A_n n \<and> x \<in> Y2 n X} - {X}"])
    then have "(\<Sum>\<^sup>+ y\<in>Y n. weight \<Gamma> y) \<le> (\<Sum>\<^sup>+ y\<in>Y n. \<Sum> X\<in>Pow (A_n n). weight \<Gamma> y * indicator (Y2 n X) y)"
      by(intro nn_integral_mono)(auto simp add: Y_def One_le_of_nat_ennreal intro!: mult_right_mono[of "1 :: ennreal", simplified])
    also have "\<dots> = (\<Sum> X\<in>Pow (A_n n). \<Sum>\<^sup>+ y\<in>Y n. weight \<Gamma> y * indicator (Y2 n X) y)"
      by(subst nn_integral_sum) auto
    also have "\<dots> = (\<Sum> X\<in>Pow (A_n n). \<Sum>\<^sup>+ y\<in>Y2 n X. weight \<Gamma> y)"
      by(auto intro!: sum.cong nn_integral_cong simp add: nn_integral_count_space_indicator Y_def split: split_indicator)
    also have "\<dots> < \<top>" by(simp add: less_top[symmetric] finY2)
    finally show ?thesis by(simp add: less_top s_def)
  qed

  define f :: "nat \<Rightarrow> 'v option \<Rightarrow> real"
    where "f n xo = (case xo of Some x \<Rightarrow> if x \<in> A_n n then enn2real (weight \<Gamma> x) else 0
                    | None \<Rightarrow> enn2real (s n - sum (weight \<Gamma>) (A_n n)))" for n xo
  define g :: "nat \<Rightarrow> 'v \<Rightarrow> real"
    where "g n y = enn2real (weight \<Gamma> y * indicator (Y n) y)" for n y
  define R :: "nat \<Rightarrow> ('v option \<times> 'v) set"
    where "R n = map_prod Some id ` (\<^bold>E \<inter> A_n n \<times> Y n) \<union> {None} \<times> Y n" for n
  define A_n' where "A_n' n = Some ` A_n n \<union> {None}" for n

  have f_simps:
    "f n (Some x) = (if x \<in> A_n n then enn2real (weight \<Gamma> x) else 0)"
    "f n None = enn2real (s n - sum (weight \<Gamma>) (A_n n))"
    for n x by(simp_all add: f_def)

  have g_s: "(\<Sum>\<^sup>+ y\<in>Y n. g n y) = s n" for n
    by(auto simp add: s_def g_def ennreal_enn2real_if intro!: nn_integral_cong)

  have "(\<Sum>\<^sup>+ x\<in>A_n' n. f n x) = (\<Sum>\<^sup>+ x\<in>Some`A_n n. weight \<Gamma> (the x)) + (\<Sum>\<^sup>+ x\<in>{None}. f n x)" for n
    by(auto simp add: nn_integral_count_space_indicator nn_integral_add[symmetric] f_simps A_n'_def ennreal_enn2real_if simp del: nn_integral_indicator_singleton intro!: nn_integral_cong split: split_indicator)
  also have "\<dots> n = sum (weight \<Gamma>) (A_n n) + (s n - sum (weight \<Gamma>) (A_n n))" for n
    by(subst nn_integral_count_space_reindex)(auto simp add: nn_integral_count_space_finite f_simps ennreal_enn2real_if)
  also have "\<dots> n = s n" for n using le[OF order_refl, of n]
    by(simp add: s_def nn_integral_count_space_finite)(auto elim!: order_trans simp add: nn_integral_count_space_indicator Y_def intro!: nn_integral_mono split: split_indicator)
  finally have sum_eq: "(\<Sum>\<^sup>+ x\<in>A_n' n. f n x) = (\<Sum>\<^sup>+ y\<in>Y n. g n y)" for n using g_s by simp

  have "\<exists>h'. \<forall>n. (\<forall>x y. (x, y) \<notin> R n \<longrightarrow> h' n x y = 0) \<and> (\<forall>x y. h' n x y \<noteq> \<top>) \<and> (\<forall>x\<in>A_n' n. (\<Sum>\<^sup>+ y\<in>Y n. h' n x y) = f n x) \<and> (\<forall>y\<in>Y n. (\<Sum>\<^sup>+ x\<in>A_n' n. h' n x y) = g n y)"
    (is "Ex (\<lambda>h'. \<forall>n. ?Q n (h' n))")
  proof(rule choice allI)+
    fix n
    note sum_eq
    moreover have "(\<Sum>\<^sup>+ y\<in>Y n. g n y) \<noteq> \<top>" using g_s by simp
    moreover have le_fg: "(\<Sum>\<^sup>+ x\<in>X. f n x) \<le> (\<Sum>\<^sup>+ y\<in>R n `` X. g n y)" if "X \<subseteq> A_n' n" for X
    proof(cases "None \<in> X")
      case True
      have "(\<Sum>\<^sup>+ x\<in>X. f n x) \<le> (\<Sum>\<^sup>+ x\<in>A_n' n. f n x)" using that
        by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator)
      also have "\<dots> = (\<Sum>\<^sup>+ y\<in>Y n. g n y)" by(simp add: sum_eq)
      also have "R n `` X = Y n" using True by(auto simp add: R_def)
      ultimately show ?thesis by simp
    next
      case False
      then have *: "Some ` (the ` X) = X"
        by(auto simp add: image_image)(metis (no_types, lifting) image_iff notin_range_Some option.sel option.collapse)+
      from False that have X: "the ` X \<subseteq> A_n n" by(auto simp add: A_n'_def)
      from * have "(\<Sum>\<^sup>+ x\<in>X. f n x) = (\<Sum>\<^sup>+ x\<in>Some ` (the ` X). f n x)" by simp
      also have "\<dots> = (\<Sum>\<^sup>+ x\<in>the ` X. f n (Some x))" by(rule nn_integral_count_space_reindex) simp
      also have "\<dots> = (\<Sum>\<^sup>+ x\<in>the ` X. weight \<Gamma> x)" using that False
        by(auto 4  3intro!: nn_integral_cong simp add: f_simps A_n'_def ennreal_enn2real_if)
      also have "\<dots> \<le> (\<Sum>\<^sup>+ y\<in>Y2 n (the ` X). weight \<Gamma> y)" using False that
        by(intro le)(auto simp add: A_n'_def)
      also have "\<dots> \<le> (\<Sum>\<^sup>+ y\<in>R n `` X. weight \<Gamma> y)" using False Y2_A[of "the ` X" n] X
        by(auto simp add: A_n'_def nn_integral_count_space_indicator R_def Image_iff Y_def intro: rev_image_eqI intro!: nn_integral_mono split: split_indicator)
          (drule (1) subsetD; clarify; drule (1) bspec; auto 4 3 intro: rev_image_eqI)
      also have "\<dots> = (\<Sum>\<^sup>+ y\<in>R n `` X. g n y)"
        by(auto intro!: nn_integral_cong simp add: R_def g_def ennreal_enn2real_if)
      finally show ?thesis .
    qed
    moreover have "countable (A_n' n)" by(simp add: A_n'_def countable_finite)
    moreover have "countable (Y2 n X)" if "X \<subseteq> A_n n" for X using Y2_A[OF that]
      by(rule countable_subset)(rule countable_subset[OF _ countable_V]; auto simp add: vertex_def)
    then have "countable (Y n)" unfolding Y_def
      by(intro countable_UN)(simp_all add: countable_finite)
    moreover have "R n \<subseteq> A_n' n \<times> Y n" by(auto simp add: R_def A_n'_def)
    ultimately obtain h' where "\<And>x y. 0 < h' x y \<Longrightarrow> (x, y) \<in> R n" "\<And>x y. h' x y \<noteq> \<top>"
      "\<And>x. x \<in> A_n' n \<Longrightarrow> (\<Sum>\<^sup>+ y\<in>Y n. h' x y) = (f n x)" "\<And>y. y \<in> Y n \<Longrightarrow> (\<Sum>\<^sup>+ x\<in>A_n' n. h' x y) = g n y"
      by(rule bounded_matrix_for_marginals_ennreal) blast+
    hence "?Q n h'" by(auto)(use not_gr_zero in blast)
    thus "Ex (?Q n)" by blast
  qed
  then obtain h' where dom_h': "\<And>x y. (x, y) \<notin> R n \<Longrightarrow> h' n x y = 0"
    and fin_h' [simp]: "\<And>x y. h' n x y \<noteq> \<top>"
    and h'_f: "\<And>x. x \<in> A_n' n \<Longrightarrow> (\<Sum>\<^sup>+ y\<in>Y n. h' n x y) = f n x"
    and h'_g: "\<And>y. y \<in> Y n \<Longrightarrow> (\<Sum>\<^sup>+ x\<in>A_n' n. h' n x y) = g n y"
    for n by blast

  define h :: "nat \<Rightarrow> 'v \<times> 'v \<Rightarrow> real"
    where "h n = (\<lambda>(x, y). if x \<in> A_n n \<and> y \<in> Y n then enn2real (h' n (Some x) y) else 0)" for n
  have h_nonneg: "0 \<le> h n xy" for n xy by(simp add: h_def split_def)
  have h_notB: "h n (x, y) = 0" if "y \<notin> B \<Gamma>" for n x y using Y_B[of n] that by(auto simp add: h_def)
  have h_le_weight2: "h n (x, y) \<le> weight \<Gamma> y" for n x y
  proof(cases "x \<in> A_n n \<and> y \<in> Y n")
    case True
    have "h' n (Some x) y \<le> (\<Sum>\<^sup>+ x\<in>A_n' n. h' n x y)"
      by(rule nn_integral_ge_point)(auto simp add: A_n'_def True)
    also have "\<dots> \<le> weight \<Gamma> y" using h'_g[of y n] True by(simp add: g_def ennreal_enn2real_if)
    finally show ?thesis using True by(simp add: h_def ennreal_enn2real_if)
  qed(auto simp add: h_def)
  have h_OUT: "d_OUT (h n) x = (if x \<in> A_n n then weight \<Gamma> x else 0)" for n x
    using h'_f[of "Some x" n, symmetric]
    by(auto simp add: h_def d_OUT_def A_n'_def f_simps ennreal_enn2real_if nn_integral_count_space_indicator intro!: nn_integral_cong)
  have h_IN: "d_IN (h n) y = (if y \<in> Y n then enn2real (weight \<Gamma> y - h' n None y) else 0)" for n y
  proof(cases "y \<in> Y n")
    case True
    have "d_IN (h n) y = (\<Sum>\<^sup>+ x\<in>Some ` A_n n. h' n x y)"
      by(subst nn_integral_count_space_reindex)
        (auto simp add: d_IN_def h_def nn_integral_count_space_indicator ennreal_enn2real_if R_def intro!: nn_integral_cong dom_h' split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ x\<in>A_n' n. h' n x y) - (\<Sum>\<^sup>+ x\<in>{None}. h' n x y)"
      apply(simp add: nn_integral_count_space_indicator del: nn_integral_indicator_singleton)
      apply(subst nn_integral_diff[symmetric])
      apply(auto simp add: AE_count_space A_n'_def nn_integral_count_space_indicator split: split_indicator intro!: nn_integral_cong)
      done
    also have "\<dots> = g n y - h' n None y" using h'_g[OF True] by(simp add: nn_integral_count_space_indicator)
    finally show ?thesis using True by(simp add: g_def ennreal_enn2real_if)
  qed(auto simp add: d_IN_def ennreal_enn2real_if nn_integral_0_iff_AE AE_count_space h_def g_def)

  let ?Q = "\<^bold>V \<times> \<^bold>V"

  have "bounded (range (\<lambda>n. h n xy))" if "xy \<in> ?Q" for xy unfolding bounded_def dist_real_def
  proof(rule exI strip|erule imageE|hypsubst)+
    fix n
    obtain x y where [simp]: "xy = (x, y)" by(cases xy)
    have "h n (x, y) \<le> d_OUT (h n) x" unfolding d_OUT_def by(rule nn_integral_ge_point) simp
    also have "\<dots> \<le> weight \<Gamma> x" by(simp add: h_OUT)
    finally show "\<bar>0 - h n xy\<bar> \<le> enn2real (weight \<Gamma> (fst xy))"
      by(simp add: h_nonneg)(metis enn2real_ennreal ennreal_cases ennreal_le_iff weight_finite)
  qed
  moreover have "countable ?Q" using countable_V by(simp)
  ultimately obtain k where k: "strict_mono k"
    and conv: "\<And>xy. xy \<in> ?Q \<Longrightarrow> convergent (\<lambda>n. h (k n) xy)"
    by(rule convergent_bounded_family) blast+

  have h_outside: "h n xy = 0" if "xy \<notin> ?Q" for xy n using that A_n_A[of n] A_vertex Y_vertex
    by(auto simp add: h_def split: prod.split)
  have h_outside_AB: "h n (x, y) = 0" if "x \<notin> A \<Gamma> \<or> y \<notin> B \<Gamma>" for n x y
    using that A_n_A[of n] Y_B[of n] by(auto simp add: h_def)
  have h_outside_E: "h n (x, y) = 0" if "(x, y) \<notin> \<^bold>E" for n x y using that unfolding h_def
    by(clarsimp)(subst dom_h', auto simp add: R_def)

  define H where "H xy = lim (\<lambda>n. h (k n) xy)" for xy
  have H: "(\<lambda>n. h (k n) xy) \<longlonglongrightarrow> H xy" for xy
    using conv[of xy] unfolding H_def by(cases "xy \<in> ?Q")(auto simp add: convergent_LIMSEQ_iff h_outside)
  have H_outside: "H (x, y) = 0" if "x \<notin> A \<Gamma> \<or> y \<notin> B \<Gamma>" for x y
    using that by(simp add: H_def convergent_LIMSEQ_iff h_outside_AB)
  have H': "(\<lambda>n. ennreal (h (k n) xy)) \<longlonglongrightarrow> H xy" for xy
    using H by(rule tendsto_ennrealI)
  have H_def': "H xy = lim (\<lambda>n. ennreal (h (k n) xy))" for xy by (metis H' limI)

  have H_OUT: "d_OUT H x = weight \<Gamma> x" if x: "x \<in> A \<Gamma>" for x
  proof -
    let ?w = "\<lambda>y. if (x, y) \<in> \<^bold>E then weight \<Gamma> y else 0"
    have sum_w: "(\<Sum>\<^sup>+ y. if edge \<Gamma> x y then weight \<Gamma> y else 0) = (\<Sum>\<^sup>+ y \<in> \<^bold>E `` {x}. weight \<Gamma> y)"
      by(simp add: nn_integral_count_space_indicator indicator_def of_bool_def if_distrib cong: if_cong)
    have "(\<lambda>n. d_OUT (h (k n)) x) \<longlonglongrightarrow> d_OUT H x" unfolding d_OUT_def
      by(rule nn_integral_dominated_convergence[where w="?w"])(use bounded_B x in \<open>simp_all add: AE_count_space H h_outside_E h_le_weight2 sum_w\<close>)
    moreover define n_x where "n_x = to_nat_on (A \<Gamma>) x"
    have x': "x \<in> A_n (k n)" if "n \<ge> n_x" for n
      using that seq_suble[OF k, of n] x unfolding A_n_def
      by(intro rev_image_eqI[where x=n_x])(simp_all add: A_n_def n_x_def)
    have "(\<lambda>n. d_OUT (h (k n)) x) \<longlonglongrightarrow> weight \<Gamma> x"
      by(intro tendsto_eventually eventually_sequentiallyI[where c="n_x"])(simp add: h_OUT x')
    ultimately show ?thesis by(rule LIMSEQ_unique)
  qed
  then have "linkage \<Gamma> H" ..
  moreover
  have "web_flow \<Gamma> H" unfolding web_flow_iff
  proof
    show "d_OUT H x \<le> weight \<Gamma> x" for x
      by(cases "x \<in> A \<Gamma>")(simp_all add: H_OUT[unfolded d_OUT_def] H_outside d_OUT_def)

    show "d_IN H y \<le> weight \<Gamma> y" for y
    proof -
      have "d_IN H y = (\<Sum>\<^sup>+ x. liminf (\<lambda>n. ennreal (h (k n) (x, y))))" unfolding d_IN_def H_def'
        by(rule nn_integral_cong convergent_liminf_cl[symmetric] convergentI H')+
      also have "\<dots> \<le> liminf (\<lambda>n. d_IN (h (k n)) y)"
        unfolding d_IN_def by(rule nn_integral_liminf) simp
      also have "\<dots> \<le> liminf (\<lambda>n. weight \<Gamma> y)" unfolding h_IN
        by(rule Liminf_mono)(auto simp add: ennreal_enn2real_if)
      also have "\<dots> = weight \<Gamma> y" by(simp add: Liminf_const)
      finally show "?thesis" .
    qed

    show "ennreal (H e) = 0" if "e \<notin> \<^bold>E" for e
    proof(rule LIMSEQ_unique[OF H'])
      obtain x y where [simp]: "e = (x, y)" by(cases e)
      have "ennreal (h (k n) (x, y)) = 0" for n
        using dom_h'[of "Some x" y "k n"] that by(auto simp add: h_def R_def enn2real_eq_0_iff elim: meta_mp)
      then show "(\<lambda>n. ennreal (h (k n) e)) \<longlonglongrightarrow> 0" using that
        by(intro tendsto_eventually eventually_sequentiallyI) simp
    qed
  qed
  ultimately show ?thesis by blast
qed

end

subsection \<open>Glueing the reductions together\<close>

locale bounded_countable_web = countable_web \<Gamma>
  for \<Gamma> :: "('v, 'more) web_scheme" (structure)
  +
  assumes bounded_out: "x \<in> \<^bold>V - B \<Gamma> \<Longrightarrow> (\<Sum>\<^sup>+ y \<in> \<^bold>E `` {x}. weight \<Gamma> y) < \<top>"
begin

lemma bounded_countable_bipartite_web_of: "bounded_countable_bipartite_web (bipartite_web_of \<Gamma>)"
  (is "bounded_countable_bipartite_web ?\<Gamma>")
proof -
  interpret bi: countable_bipartite_web ?\<Gamma> by(rule countable_bipartite_web_of)
  show ?thesis
  proof
    fix x
    assume "x \<in> A ?\<Gamma>"
    then obtain x' where x: "x = Inl x'" and x': "vertex \<Gamma> x'" "x' \<notin> B \<Gamma>" by auto
    have "\<^bold>E\<^bsub>?\<Gamma>\<^esub> `` {x} \<subseteq> Inr ` ({x'} \<union> (\<^bold>E `` {x'}))" using x
      by(auto simp add: bipartite_web_of_def vertex_def split: sum.split_asm)
    hence "(\<Sum>\<^sup>+ y \<in> \<^bold>E\<^bsub>?\<Gamma>\<^esub> `` {x}. weight ?\<Gamma> y) \<le> (\<Sum>\<^sup>+ y \<in> \<dots>. weight ?\<Gamma> y)"
      by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator)
    also have "\<dots> = (\<Sum>\<^sup>+ y\<in>{x'} \<union> (\<^bold>E `` {x'}). weight (bipartite_web_of \<Gamma>) (Inr y))"
      by(rule nn_integral_count_space_reindex)(auto)
    also have "\<dots> \<le> weight \<Gamma> x' + (\<Sum>\<^sup>+ y \<in> \<^bold>E `` {x'}. weight \<Gamma> y)"
      apply(subst (1 2) nn_integral_count_space_indicator, simp, simp)
      apply(cases "\<not> edge \<Gamma> x' x'")
      apply(subst nn_integral_disjoint_pair)
      apply(auto intro!: nn_integral_mono add_increasing split: split_indicator)
      done
    also have "\<dots> < \<top>" using bounded_out[of x'] x' using weight_finite[of x'] by(simp del: weight_finite add: less_top)
    finally show "(\<Sum>\<^sup>+ y \<in> \<^bold>E\<^bsub>?\<Gamma>\<^esub> `` {x}. weight ?\<Gamma> y) < \<top>"  .
  qed
qed

theorem loose_linkable_bounded:
  assumes "loose \<Gamma>"
  shows "linkable \<Gamma>"
proof -
  interpret bi: bounded_countable_bipartite_web "bipartite_web_of \<Gamma>" by(rule bounded_countable_bipartite_web_of)
  have "\<not> hindered (bipartite_web_of \<Gamma>)" using assms by(rule unhindered_bipartite_web_of)
  then have "linkable (bipartite_web_of \<Gamma>)"
    by(rule bi.unhindered_linkable_bounded)
  then show ?thesis by(rule linkable_bipartite_web_ofD) simp
qed

lemma bounded_countable_web_quotient_web: "bounded_countable_web (quotient_web \<Gamma> f)" (is "bounded_countable_web ?\<Gamma>")
proof -
  interpret r: countable_web ?\<Gamma> by(rule countable_web_quotient_web)
  show ?thesis
  proof
    fix x
    assume "x \<in> \<^bold>V\<^bsub>quotient_web \<Gamma> f\<^esub> - B (quotient_web \<Gamma> f)"
    then have x: "x \<in> \<^bold>V - B \<Gamma>" by(auto dest: vertex_quotient_webD)
    have "(\<Sum>\<^sup>+ y \<in> \<^bold>E\<^bsub>?\<Gamma>\<^esub> `` {x}. weight ?\<Gamma> y) \<le> (\<Sum>\<^sup>+ y \<in> \<^bold>E `` {x}. weight \<Gamma> y)"
      by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator)
    also have "\<dots> < \<top>" using x by(rule bounded_out)
    finally show "(\<Sum>\<^sup>+ y \<in> \<^bold>E\<^bsub>?\<Gamma>\<^esub> `` {x}. weight ?\<Gamma> y) < \<top>"  .
  qed
qed

lemma ex_orthogonal_current:
  "\<exists>f S. web_flow \<Gamma> f \<and> separating \<Gamma> S \<and> orthogonal_current \<Gamma> f S"
proof -
  from ex_maximal_wave[OF countable]
  obtain f where f: "current \<Gamma> f"
    and w: "wave \<Gamma> f"
    and maximal: "\<And>w. \<lbrakk> current \<Gamma> w; wave \<Gamma> w; f \<le> w \<rbrakk> \<Longrightarrow> f = w" by blast
  from ex_trimming[OF f w countable weight_finite] obtain h where h: "trimming \<Gamma> f h" ..

  let ?\<Gamma> = "quotient_web \<Gamma> f"
  interpret \<Gamma>: bounded_countable_web "?\<Gamma>" by(rule bounded_countable_web_quotient_web)
  have "loose ?\<Gamma>" using f w maximal by(rule loose_quotient_web[OF  weight_finite])
  then have "linkable ?\<Gamma>" by(rule \<Gamma>.loose_linkable_bounded)
  then obtain g where wg: "web_flow ?\<Gamma> g" and link: "linkage ?\<Gamma> g" by blast

  let ?k = "plus_current h g"
  have "web_flow \<Gamma> ?k" "orthogonal_current \<Gamma> ?k (\<E> (TER f))"
    by(rule linkage_quotient_webD[OF f w wg link h])+
  moreover have "separating \<Gamma> (\<E> (TER f))"
    using waveD_separating[OF w] by(rule separating_essential)
  ultimately show ?thesis by blast
qed

end

locale bounded_countable_network = countable_network \<Delta>
  for \<Delta> :: "('v, 'more) network_scheme" (structure) +
  assumes out: "\<lbrakk> x \<in> \<^bold>V; x \<noteq> source \<Delta>; x \<noteq> sink \<Delta> \<rbrakk> \<Longrightarrow> d_OUT (capacity \<Delta>) x < \<top>"

context antiparallel_edges begin

lemma \<Delta>''_bounded_countable_network: "bounded_countable_network \<Delta>''"
  if "\<And>x. \<lbrakk> x \<in> \<^bold>V; x \<noteq> source \<Delta>; x \<noteq> sink \<Delta> \<rbrakk> \<Longrightarrow> d_OUT (capacity \<Delta>) x < \<top>"
proof -
  interpret ae: countable_network \<Delta>'' by(rule \<Delta>''_countable_network)
  show ?thesis
  proof
    fix x
    assume x: "x \<in> \<^bold>V\<^bsub>\<Delta>''\<^esub>" and not_source: "x \<noteq> source \<Delta>''" and not_sink: "x \<noteq> sink \<Delta>''"
    from x consider (Vertex) x' where "x = Vertex x'" "x' \<in> \<^bold>V" | (Edge) y z where "x = Edge y z" "edge \<Delta> y z"
      unfolding "\<^bold>V_\<Delta>''" by auto
    then show "d_OUT (capacity \<Delta>'') x < \<top>"
    proof cases
      case Vertex
      then show ?thesis using x not_source not_sink that[of x'] by auto
    next
      case Edge
      then show ?thesis using capacity_finite[of "(y, z)"] by(simp del: capacity_finite add: less_top)
    qed
  qed
qed

end

context bounded_countable_network begin

lemma bounded_countable_web_web_of_network:
  assumes source_in: "\<And>x. \<not> edge \<Delta> x (source \<Delta>)"
  and sink_out: "\<And>y. \<not> edge \<Delta> (sink \<Delta>) y"
  and undead: "\<And>x y. edge \<Delta> x y \<Longrightarrow> (\<exists>z. edge \<Delta> y z) \<or> (\<exists>z. edge \<Delta> z x)"
  and source_sink: "\<not> edge \<Delta> (source \<Delta>) (sink \<Delta>)"
  and no_loop: "\<And>x. \<not> edge \<Delta> x x"
  shows "bounded_countable_web (web_of_network \<Delta>)" (is "bounded_countable_web ?\<Gamma>")
proof -
  interpret web: countable_web ?\<Gamma> by(rule countable_web_web_of_network) fact+
  show ?thesis
  proof
    fix e
    assume "e \<in> \<^bold>V\<^bsub>?\<Gamma>\<^esub> - B ?\<Gamma>"
    then obtain x y where e: "e = (x, y)" and xy: "edge \<Delta> x y" by(cases e) simp
    from xy have y: "y \<noteq> source \<Delta>" using source_in[of x] by auto
    have out_sink: "d_OUT (capacity \<Delta>) (sink \<Delta>) = 0" unfolding d_OUT_def
      by(auto simp add: nn_integral_0_iff_AE AE_count_space sink_out intro!: capacity_outside)
    have "\<^bold>E\<^bsub>?\<Gamma>\<^esub> `` {e} \<subseteq> \<^bold>E \<inter> {y} \<times> UNIV" using e by auto
    hence "(\<Sum>\<^sup>+ e' \<in> \<^bold>E\<^bsub>?\<Gamma>\<^esub> `` {e}. weight ?\<Gamma> e') \<le> (\<Sum>\<^sup>+ e \<in> \<^bold>E \<inter> {y} \<times> UNIV. capacity \<Delta> e)" using e
      by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator)
    also have "\<dots> \<le> (\<Sum>\<^sup>+ e \<in> Pair y ` UNIV. capacity \<Delta> e)"
      by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator)
    also have "\<dots> = d_OUT (capacity \<Delta>) y" unfolding d_OUT_def
      by(rule nn_integral_count_space_reindex) simp
    also have "\<dots> < \<top>" using out[of y] xy y out_sink by(cases "y = sink \<Delta>")(auto simp add: vertex_def)
    finally show "(\<Sum>\<^sup>+ e' \<in> \<^bold>E\<^bsub>?\<Gamma>\<^esub> `` {e}. weight ?\<Gamma> e') < \<top>" .
  qed
qed

context begin

qualified lemma max_flow_min_cut'_bounded:
  assumes source_in: "\<And>x. \<not> edge \<Delta> x (source \<Delta>)"
  and sink_out: "\<And>y. \<not> edge \<Delta> (sink \<Delta>) y"
  and undead: "\<And>x y. edge \<Delta> x y \<Longrightarrow> (\<exists>z. edge \<Delta> y z) \<or> (\<exists>z. edge \<Delta> z x)"
  and source_sink: "\<not> edge \<Delta> (source \<Delta>) (sink \<Delta>)"
  and no_loop: "\<And>x. \<not> edge \<Delta> x x"
  and capacity_pos: "\<And>e. e \<in> \<^bold>E \<Longrightarrow> capacity \<Delta> e > 0"
  shows "\<exists>f S. flow \<Delta> f \<and> cut \<Delta> S \<and> orthogonal \<Delta> f S"
  by(rule max_flow_min_cut')(rule bounded_countable_web.ex_orthogonal_current[OF bounded_countable_web_web_of_network], fact+)

qualified lemma max_flow_min_cut''_bounded:
  assumes sink_out: "\<And>y. \<not> edge \<Delta> (sink \<Delta>) y"
  and source_in: "\<And>x. \<not> edge \<Delta> x (source \<Delta>)"
  and no_loop: "\<And>x. \<not> edge \<Delta> x x"
  and capacity_pos: "\<And>e. e \<in> \<^bold>E \<Longrightarrow> capacity \<Delta> e > 0"
  shows "\<exists>f S. flow \<Delta> f \<and> cut \<Delta> S \<and> orthogonal \<Delta> f S"
proof -
  interpret antiparallel_edges \<Delta> ..
  interpret \<Delta>'': bounded_countable_network \<Delta>'' by(rule \<Delta>''_bounded_countable_network)(rule out)
  have "\<exists>f S. flow \<Delta>'' f \<and> cut \<Delta>'' S \<and> orthogonal \<Delta>'' f S"
    by(rule \<Delta>''.max_flow_min_cut'_bounded)(auto simp add: sink_out source_in no_loop capacity_pos elim: edg.cases)
  then obtain f S where f: "flow \<Delta>'' f" and cut: "cut \<Delta>'' S" and ortho: "orthogonal \<Delta>'' f S" by blast
  have "flow \<Delta> (collect f)" using f by(rule flow_collect)
  moreover have "cut \<Delta> (cut' S)" using cut by(rule cut_cut')
  moreover have "orthogonal \<Delta> (collect f) (cut' S)" using ortho f by(rule orthogonal_cut')
  ultimately show ?thesis by blast
qed

qualified lemma max_flow_min_cut'''_bounded:
  assumes sink_out: "\<And>y. \<not> edge \<Delta> (sink \<Delta>) y"
  and source_in: "\<And>x. \<not> edge \<Delta> x (source \<Delta>)"
  and capacity_pos: "\<And>e. e \<in> \<^bold>E \<Longrightarrow> capacity \<Delta> e > 0"
  shows "\<exists>f S. flow \<Delta> f \<and> cut \<Delta> S \<and> orthogonal \<Delta> f S"
proof -
  interpret antiparallel_edges \<Delta> ..
  interpret \<Delta>'': bounded_countable_network \<Delta>'' by(rule \<Delta>''_bounded_countable_network)(rule out)
  have "\<exists>f S. flow \<Delta>'' f \<and> cut \<Delta>'' S \<and> orthogonal \<Delta>'' f S"
    by(rule \<Delta>''.max_flow_min_cut''_bounded)(auto simp add: sink_out source_in capacity_pos elim: edg.cases)
  then obtain f S where f: "flow \<Delta>'' f" and cut: "cut \<Delta>'' S" and ortho: "orthogonal \<Delta>'' f S" by blast
  have "flow \<Delta> (collect f)" using f by(rule flow_collect)
  moreover have "cut \<Delta> (cut' S)" using cut by(rule cut_cut')
  moreover have "orthogonal \<Delta> (collect f) (cut' S)" using ortho f by(rule orthogonal_cut')
  ultimately show ?thesis by blast
qed

lemma \<Delta>'''_bounded_countable_network: "bounded_countable_network \<Delta>'''"
proof -
  interpret \<Delta>''': countable_network \<Delta>''' by(rule \<Delta>'''_countable_network)
  show ?thesis
  proof
    fix x
    assume x: "x \<in> \<^bold>V\<^bsub>\<Delta>'''\<^esub>" and not_source: "x \<noteq> source \<Delta>'''" and not_sink: "x \<noteq> sink \<Delta>'''"
    from x have x': "x \<in> \<^bold>V" by(auto simp add: vertex_def)
    have "d_OUT (capacity \<Delta>''') x \<le> d_OUT (capacity \<Delta>) x" by(rule d_OUT_mono) simp
    also have "\<dots> < \<top>" using x' not_source not_sink by(simp add: out)
    finally show "d_OUT (capacity \<Delta>''') x < \<top>"  .
  qed
qed

theorem max_flow_min_cut_bounded:
  "\<exists>f S. flow \<Delta> f \<and> cut \<Delta> S \<and> orthogonal \<Delta> f S"
proof -
  interpret \<Delta>': bounded_countable_network \<Delta>''' by(rule \<Delta>'''_bounded_countable_network)
  have "\<exists>f S. flow \<Delta>''' f \<and> cut \<Delta>''' S \<and> orthogonal \<Delta>''' f S" by(rule \<Delta>'.max_flow_min_cut'''_bounded) auto
  then obtain f S where f: "flow \<Delta>''' f" and cut: "cut \<Delta>''' S" and ortho: "orthogonal \<Delta>''' f S" by blast
  from flow_\<Delta>'''[OF this] show ?thesis by blast
qed

end

end

end