section \<open>Nondeterministic Automata\<close>

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

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

    sublocale transition_system_initial
      "\<lambda> a p. snd a" "\<lambda> a p. fst a \<in> alphabet A \<and> snd a \<in> transition A (fst a) p" "\<lambda> p. p \<in> initial A"
      for A
      defines path' = path and run' = run and reachable' = reachable and nodes' = nodes
      by this

    lemma states_alt_def: "states r p = map snd r" by (induct r arbitrary: p) (auto)
    lemma trace_alt_def: "trace r p = smap snd r" by (coinduction arbitrary: r p) (auto)

    lemma successors_alt_def: "successors A p = (\<Union> a \<in> alphabet A. transition A a p)" by auto

    lemma path_alphabet:
      assumes "length r = length w" "path A (w || r) p"
      shows "w \<in> lists (alphabet A)"
      using assms by (induct arbitrary: p rule: list_induct2) (auto)
    lemma run_alphabet:
      assumes "run A (w ||| r) p"
      shows "w \<in> streams (alphabet A)"
      using assms by (coinduction arbitrary: w r p) (metis run.cases stream.map szip_smap szip_smap_fst)

    definition restrict :: "'automaton \<Rightarrow> 'automaton" where
      "restrict A \<equiv> automaton
        (alphabet A)
        (initial A)
        (\<lambda> a p. if a \<in> alphabet A then transition A a p else {})
        (condition A)"

    lemma restrict_simps[simp]:
      "alphabet (restrict A) = alphabet A"
      "initial (restrict A) = initial A"
      "transition (restrict A) a p = (if a \<in> alphabet A then transition A a p else {})"
      "condition (restrict A) = condition A"
      unfolding restrict_def by auto

    lemma restrict_path[simp]: "path (restrict A) = path A"
    proof (intro ext iffI)
      show "path A wr p" if "path (restrict A) wr p" for wr p using that by induct auto
      show "path (restrict A) wr p" if "path A wr p" for wr p using that by induct auto
    qed
    lemma restrict_run[simp]: "run (restrict A) = run A"
    proof (intro ext iffI)
      show "run A wr p" if "run (restrict A) wr p" for wr p using that by coinduct auto
      show "run (restrict A) wr p" if "run A wr p" for wr p using that by coinduct auto
    qed

  end

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

    definition language :: "'automaton \<Rightarrow> 'label list set" where
      "language A \<equiv> {w |w r p. length r = length w \<and> p \<in> initial A \<and> path A (w || r) p \<and> test (condition A) w r p}"

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

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

    lemma restrict_language[simp]: "language (restrict A) = language A" by force

  end

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

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

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

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

    lemma restrict_language[simp]: "language (restrict A) = language A" by force

  end

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

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

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

    lemma run_degeneralize:
      assumes "a.run A (w ||| r) p"
      shows "b.run (degeneralize A) (w ||| r ||| sscan (count (condition\<^sub>1 A) \<circ> item) (p ## r ||| w ||| r) k) (p, k)"
      using assms by (coinduction arbitrary: w r p k) (force elim: a.run.cases)
    lemma degeneralize_run:
      assumes "b.run (degeneralize A) (w ||| rs) pk"
      obtains r s p k
      where "rs = r ||| s" "pk = (p, k)" "a.run A (w ||| r) p" "s = sscan (count (condition\<^sub>1 A) \<circ> item) (p ## r ||| w ||| r) k"
    proof -
      obtain r s p k where 1: "rs = r ||| s" "pk = (p, k)" using szip_smap surjective_pairing by metis
      show ?thesis
      proof
        show "rs = r ||| s" "pk = (p, k)" using 1 by this
        show "a.run A (w ||| r) p"
          using assms unfolding 1 by (coinduction arbitrary: w r s p k) (force elim: b.run.cases)
        show "s = sscan (count (condition\<^sub>1 A) \<circ> item) (p ## r ||| w ||| r) k"
          using assms unfolding 1 by (coinduction arbitrary: w r s p k) (erule b.run.cases, force)
      qed
    qed

    lemma degeneralize_nodes:
      "b.nodes (degeneralize A) \<subseteq> a.nodes A \<times> insert 0 {0 ..< length (condition\<^sub>1 A)}"
    proof
      fix pk
      assume "pk \<in> b.nodes (degeneralize A)"
      then show "pk \<in> a.nodes A \<times> insert 0 {0 ..< length (condition\<^sub>1 A)}"
        by (induct) (force, cases "condition\<^sub>1 A = []", auto)
    qed
    lemma nodes_degeneralize: "a.nodes A \<subseteq> fst ` b.nodes (degeneralize A)"
    proof
      fix p
      assume "p \<in> a.nodes A"
      then show "p \<in> fst ` b.nodes (degeneralize A)"
      proof induct
        case (initial p)
        have "(p, 0) \<in> b.nodes (degeneralize A)" using initial by auto
        then show ?case using image_iff fst_conv by force
      next
        case (execute p aq)
        obtain k where "(p, k) \<in> b.nodes (degeneralize A)" using execute(2) by auto
        then have "(snd aq, count (condition\<^sub>1 A) (item (p, aq)) k) \<in> b.nodes (degeneralize A)"
          using execute(3) by auto
        then show ?case using image_iff snd_conv by force
      qed
    qed

    lemma degeneralize_nodes_finite[iff]: "finite (b.nodes (degeneralize A)) \<longleftrightarrow> finite (a.nodes A)"
    proof
      show "finite (a.nodes A)" if "finite (b.nodes (degeneralize A))"
        using finite_subset nodes_degeneralize that by blast
      show "finite (b.nodes (degeneralize A))" if "finite (a.nodes A)"
        using finite_subset degeneralize_nodes that by blast
    qed

  end

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

    lemma degeneralize_language[simp]: "b.language (degeneralize A) = a.language A"
      unfolding a.language_def b.language_def by (auto dest: run_degeneralize elim!: degeneralize_run)

  end

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

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

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

    lemma product_target[simp]:
      assumes "length w = length r" "length r = length s"
      shows "c.target (w || r || s) (p, q) = (a.target (w || r) p, b.target (w || s) q)"
      using assms by (induct arbitrary: p q rule: list_induct3) (auto)

    lemma product_path[iff]:
      assumes "length w = length r" "length r = length s"
      shows "c.path (product A B) (w || r || s) (p, q) \<longleftrightarrow>
        a.path A (w || r) p \<and> b.path B (w || s) q"
      using assms by (induct arbitrary: p q rule: list_induct3) (auto)
    lemma product_run[iff]: "c.run (product A B) (w ||| r ||| s) (p, q) \<longleftrightarrow>
      a.run A (w ||| r) p \<and> b.run B (w ||| s) q"
    proof safe
      show "a.run A (w ||| r) p" if "c.run (product A B) (w ||| r ||| s) (p, q)"
        using that by (coinduction arbitrary: w r s p q) (force elim: c.run.cases)
      show "b.run B (w ||| s) q" if "c.run (product A B) (w ||| r ||| s) (p, q)"
        using that by (coinduction arbitrary: w r s p q) (force elim: c.run.cases)
      show "c.run (product A B) (w ||| r ||| s) (p, q)" if "a.run A (w ||| r) p" "b.run B (w ||| s) q"
        using that by (coinduction arbitrary: w r s p q) (auto elim: a.run.cases b.run.cases)
    qed

    lemma product_nodes: "c.nodes (product A B) \<subseteq> a.nodes A \<times> b.nodes B"
    proof
      fix pq
      assume "pq \<in> c.nodes (product A B)"
      then show "pq \<in> a.nodes A \<times> b.nodes B" by induct auto
    qed

    lemma product_nodes_finite[intro]:
      assumes "finite (a.nodes A)" "finite (b.nodes B)"
      shows "finite (c.nodes (product A B))"
      using finite_subset product_nodes assms by blast

  end

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

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

  end

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

    lemma product_language[simp]: "c.language (product A B) = a.language A \<inter> b.language B"
      unfolding a.language_def b.language_def c.language_def by (fastforce iff: split_szip)

  end

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

    definition sum :: "'automaton\<^sub>1 \<Rightarrow> 'automaton\<^sub>2 \<Rightarrow> 'automaton\<^sub>3" where
      "sum A B \<equiv> automaton\<^sub>3
        (alphabet\<^sub>1 A \<union> alphabet\<^sub>2 B)
        (initial\<^sub>1 A <+> initial\<^sub>2 B)
        (\<lambda> a. \<lambda> Inl p \<Rightarrow> Inl ` transition\<^sub>1 A a p | Inr q \<Rightarrow> Inr ` transition\<^sub>2 B a q)
        (condition (condition\<^sub>1 A) (condition\<^sub>2 B))"

    lemma sum_simps[simp]:
      "alphabet\<^sub>3 (sum A B) = alphabet\<^sub>1 A \<union> alphabet\<^sub>2 B"
      "initial\<^sub>3 (sum A B) = initial\<^sub>1 A <+> initial\<^sub>2 B"
      "transition\<^sub>3 (sum A B) a (Inl p) = Inl ` transition\<^sub>1 A a p"
      "transition\<^sub>3 (sum A B) a (Inr q) = Inr ` transition\<^sub>2 B a q"
      "condition\<^sub>3 (sum A B) = condition (condition\<^sub>1 A) (condition\<^sub>2 B)"
      unfolding sum_def by auto

    lemma path_sum_a:
      assumes "length r = length w" "a.path A (w || r) p"
      shows "c.path (sum A B) (w || map Inl r) (Inl p)"
      using assms by (induct arbitrary: p rule: list_induct2) (auto)
    lemma path_sum_b:
      assumes "length s = length w" "b.path B (w || s) q"
      shows "c.path (sum A B) (w || map Inr s) (Inr q)"
      using assms by (induct arbitrary: q rule: list_induct2) (auto)
    lemma sum_path:
      assumes "alphabet\<^sub>1 A = alphabet\<^sub>2 B"
      assumes "length rs = length w" "c.path (sum A B) (w || rs) pq"
      obtains
        (a) r p where "rs = map Inl r" "pq = Inl p" "a.path A (w || r) p" |
        (b) s q where "rs = map Inr s" "pq = Inr q" "b.path B (w || s) q"
    proof (cases pq)
      case (Inl p)
      have 1: "rs = map Inl (map projl rs)"
        using assms(2, 3) unfolding Inl by (induct arbitrary: p rule: list_induct2) (auto)
      have 2: "a.path A (w || map projl rs) p"
        using assms(2, 1, 3) unfolding Inl by (induct arbitrary: p rule: list_induct2) (auto)
      show ?thesis using a 1 Inl 2 by this
    next
      case (Inr q)
      have 1: "rs = map Inr (map projr rs)"
        using assms(2, 3) unfolding Inr by (induct arbitrary: q rule: list_induct2) (auto)
      have 2: "b.path B (w || map projr rs) q"
        using assms(2, 1, 3) unfolding Inr by (induct arbitrary: q rule: list_induct2) (auto)
      show ?thesis using b 1 Inr 2 by this
    qed

    lemma run_sum_a:
      assumes "a.run A (w ||| r) p"
      shows "c.run (sum A B) (w ||| smap Inl r) (Inl p)"
      using assms by (coinduction arbitrary: w r p) (force elim: a.run.cases)
    lemma run_sum_b:
      assumes "b.run B (w ||| s) q"
      shows "c.run (sum A B) (w ||| smap Inr s) (Inr q)"
      using assms by (coinduction arbitrary: w s q) (force elim: b.run.cases)
    lemma sum_run:
      assumes "alphabet\<^sub>1 A = alphabet\<^sub>2 B"
      assumes "c.run (sum A B) (w ||| rs) pq"
      obtains
        (a) r p where "rs = smap Inl r" "pq = Inl p" "a.run A (w ||| r) p" |
        (b) s q where "rs = smap Inr s" "pq = Inr q" "b.run B (w ||| s) q"
    proof (cases pq)
      case (Inl p)
      have 1: "rs = smap Inl (smap projl rs)"
        using assms(2) unfolding Inl by (coinduction arbitrary: w rs p) (force elim: c.run.cases)
      have 2: "a.run A (w ||| smap projl rs) p"
        using assms unfolding Inl by (coinduction arbitrary: w rs p) (force elim: c.run.cases)
      show ?thesis using a 1 Inl 2 by this
    next
      case (Inr q)
      have 1: "rs = smap Inr (smap projr rs)"
        using assms(2) unfolding Inr by (coinduction arbitrary: w rs q) (force elim: c.run.cases)
      have 2: "b.run B (w ||| smap projr rs) q"
        using assms unfolding Inr by (coinduction arbitrary: w rs q) (force elim: c.run.cases)
      show ?thesis using b 1 Inr 2 by this
    qed

    lemma sum_nodes_finite[intro]:
      assumes "alphabet\<^sub>1 A = alphabet\<^sub>2 B"
      assumes "finite (a.nodes A)" "finite (b.nodes B)"
      shows "finite (c.nodes (sum A B))"
      using finite_subset sum_nodes assms by (auto intro: finite_Plus)

  end

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

    lemma sum_language[simp]:
      assumes "alphabet\<^sub>1 A = alphabet\<^sub>2 B"
      shows "c.language (sum A B) = a.language A \<union> b.language B"
      using assms unfolding a.language_def b.language_def c.language_def
      by (force intro: path_sum_a path_sum_b elim!: sum_path)

  end

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

    lemma sum_language[simp]:
      assumes "alphabet\<^sub>1 A = alphabet\<^sub>2 B"
      shows "c.language (sum A B) = a.language A \<union> b.language B"
      using assms unfolding a.language_def b.language_def c.language_def
      by (auto intro: run_sum_a run_sum_b elim!: sum_run)

  end

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

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

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

    lemma product_run_length:
      assumes "length ps = length AA"
      assumes "b.run (product AA) (w ||| r) ps"
      assumes "qs \<in> sset r"
      shows "length qs = length AA"
    proof -
      have "pred_stream (\<lambda> qs. length qs = length AA) r"
        using assms(1, 2) by (coinduction arbitrary: w r ps)
          (force elim: b.run.cases simp: listset_member list_all2_conv_all_nth)
      then show ?thesis using assms(3) unfolding stream.pred_set by auto
    qed
    lemma product_run_stranspose:
      assumes "length ps = length AA"
      assumes "b.run (product AA) (w ||| r) ps"
      obtains rs where "r = stranspose rs" "length rs = length AA"
    proof
      define rs where "rs \<equiv> map (\<lambda> k. smap (\<lambda> ps. ps ! k) r) [0 ..< length AA]"
      have "length qs = length AA" if "qs \<in> sset r" for qs using product_run_length assms that by this
      then show "r = stranspose rs"
        unfolding rs_def by (coinduction arbitrary: r) (auto intro: nth_equalityI simp: comp_def)
      show "length rs = length AA" unfolding rs_def by auto
    qed

    lemma run_product:
      assumes "length rs = length AA" "length ps = length AA"
      assumes "\<And> k. k < length AA \<Longrightarrow> a.run (AA ! k) (w ||| rs ! k) (ps ! k)"
      shows "b.run (product AA) (w ||| stranspose rs) ps"
    using assms
    proof (coinduction arbitrary: w rs ps)
      case (run ap r)
      then show ?case
      proof (intro conjI exI)
        show "fst ap \<in> alphabet\<^sub>2 (product AA)"
          using run by (force elim: a.run.cases simp: set_conv_nth)
        show "snd ap \<in> transition\<^sub>2 (product AA) (fst ap) ps"
          using run by (force elim: a.run.cases simp: listset_member list_all2_conv_all_nth)
        show "\<forall> k < length AA. a.run' (AA ! k) (stl w ||| map stl rs ! k) (map shd rs ! k)"
          using run by (force elim: a.run.cases)
      qed auto
    qed

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

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

  end

  locale automaton_intersection_list_run =
    automaton_product_list
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      condition +
    a: automaton_run automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_run automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and condition
    +
    assumes test[iff]: "length rs = length cs \<Longrightarrow> length ps = length cs \<Longrightarrow>
      test\<^sub>2 (condition cs) w (stranspose rs) ps \<longleftrightarrow> list_all (\<lambda> (c, r, p). test\<^sub>1 c w r p) (cs || rs || ps)"
  begin

    lemma product_language[simp]: "b.language (product AA) = \<Inter> (a.language ` set AA)"
    proof safe
      fix A w
      assume 1: "w \<in> b.language (product AA)" "A \<in> set AA"
      obtain r ps where 2:
        "ps \<in> initial\<^sub>2 (product AA)"
        "b.run (product AA) (w ||| r) ps"
        "test\<^sub>2 (condition\<^sub>2 (product AA)) w r ps"
        using 1(1) by auto
      have 3: "length ps = length AA" using 2(1) by (simp add: listset_member list_all2_conv_all_nth)
      obtain rs where 4: "r = stranspose rs" "length rs = length AA"
        using product_run_stranspose 3 2(2) by this
      obtain k where 5: "k < length AA" "A = AA ! k" using 1(2) unfolding set_conv_nth by auto
      show "w \<in> a.language A"
      proof
        show "ps ! k \<in> initial\<^sub>1 A" using 2(1) 5 by (auto simp: listset_member list_all2_conv_all_nth)
        show "a.run A (w ||| rs ! k) (ps ! k)" using 2(2) 3 4 5 by (auto intro: product_run)
        show "test\<^sub>1 (condition\<^sub>1 A) w (rs ! k) (ps ! k)" using 2(3) 3 4 5 by (simp add: list_all_length)
      qed
    next
      fix w
      assume 1: "w \<in> \<Inter> (a.language ` set AA)"
      have 2: "\<forall> A \<in> set AA. \<exists> r p. p \<in> initial\<^sub>1 A \<and> a.run A (w ||| r) p \<and> test\<^sub>1 (condition\<^sub>1 A) w r p"
        using 1 by blast
      obtain rs ps where 3:
        "length rs = length AA" "length ps = length AA"
        "\<And> k. k < length AA \<Longrightarrow> ps ! k \<in> initial\<^sub>1 (AA ! k)"
        "\<And> k. k < length AA \<Longrightarrow> a.run (AA ! k) (w ||| rs ! k) (ps ! k)"
        "\<And> k. k < length AA \<Longrightarrow> test\<^sub>1 (condition\<^sub>1 (AA ! k)) w (rs ! k) (ps ! k)"
        using 2
        unfolding Ball_set list_choice_zip list_choice_pair
        unfolding list.pred_set set_conv_nth
        by force
      show "w \<in> b.language (product AA)"
      proof
        show "ps \<in> initial\<^sub>2 (product AA)" using 3 by (auto simp: listset_member list_all2_conv_all_nth)
        show "b.run (product AA) (w ||| stranspose rs) ps" using 3 by (auto intro: run_product)
        show "test\<^sub>2 (condition\<^sub>2 (product AA)) w (stranspose rs) ps" using 3 by (auto simp: list_all_length)
      qed
    qed

  end

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

    definition sum :: "'automaton\<^sub>1 list \<Rightarrow> 'automaton\<^sub>2" where
      "sum AA \<equiv> automaton\<^sub>2
        (\<Union> (alphabet\<^sub>1 ` set AA))
        (\<Union> k < length AA. {k} \<times> initial\<^sub>1 (AA ! k))
        (\<lambda> a (k, p). {k} \<times> transition\<^sub>1 (AA ! k) a p)
        (condition (map condition\<^sub>1 AA))"

    lemma sum_simps[simp]:
      "alphabet\<^sub>2 (sum AA) = \<Union> (alphabet\<^sub>1 ` set AA)"
      "initial\<^sub>2 (sum AA) = (\<Union> k < length AA. {k} \<times> initial\<^sub>1 (AA ! k))"
      "transition\<^sub>2 (sum AA) a (k, p) = {k} \<times> transition\<^sub>1 (AA ! k) a p"
      "condition\<^sub>2 (sum AA) = condition (map condition\<^sub>1 AA)"
      unfolding sum_def by auto

    lemma run_sum:
      assumes "\<Inter> (alphabet\<^sub>1 ` set AA) = \<Union> (alphabet\<^sub>1 ` set AA)"
      assumes "A \<in> set AA"
      assumes "a.run A (w ||| s) p"
      obtains k where "k < length AA" "A = AA ! k" "b.run (sum AA) (w ||| sconst k ||| s) (k, p)"
    proof -
      obtain k where 1: "k < length AA" "A = AA ! k" using assms(2) unfolding set_conv_nth by auto
      show ?thesis
      proof
        show "k < length AA" "A = AA ! k" using 1 by this
        show "b.run (sum AA) (w ||| sconst k ||| s) (k, p)"
          using assms 1(2) by (coinduction arbitrary: w s p) (force elim: a.run.cases)
      qed
    qed
    lemma sum_run:
      assumes "\<Inter> (alphabet\<^sub>1 ` set AA) = \<Union> (alphabet\<^sub>1 ` set AA)"
      assumes "k < length AA"
      assumes "b.run (sum AA) (w ||| r) (k, p)"
      obtains s where "r = sconst k ||| s" "a.run (AA ! k) (w ||| s) p"
    proof
      show "r = sconst k ||| smap snd r"
        using assms by (coinduction arbitrary: w r p) (force elim: b.run.cases)
      show "a.run (AA ! k) (w ||| smap snd r) p"
        using assms by (coinduction arbitrary: w r p) (force elim: b.run.cases)
    qed

    lemma sum_nodes:
      assumes "\<Inter> (alphabet\<^sub>1 ` set AA) = \<Union> (alphabet\<^sub>1 ` set AA)"
      shows "b.nodes (sum AA) \<subseteq> (\<Union> k < length AA. {k} \<times> a.nodes (AA ! k))"
    proof
      show "kp \<in> (\<Union> k < length AA. {k} \<times> a.nodes (AA ! k))" if "kp \<in> b.nodes (sum AA)" for kp
        using that assms by (induct) (auto 0 4)
    qed

    lemma sum_nodes_finite[intro]:
      assumes "\<Inter> (alphabet\<^sub>1 ` set AA) = \<Union> (alphabet\<^sub>1 ` set AA)"
      assumes "list_all (finite \<circ> a.nodes) AA"
      shows "finite (b.nodes (sum AA))"
    proof (rule finite_subset)
      show "b.nodes (sum AA) \<subseteq> (\<Union> k < length AA. {k} \<times> a.nodes (AA ! k))"
        using sum_nodes assms(1) by this
      show "finite (\<Union> k < length AA. {k} \<times> a.nodes' (AA ! k))"
        using assms(2) unfolding list_all_length by auto
    qed

  end

  locale automaton_union_list_run =
    automaton_sum_list
      automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1
      automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2
      condition +
    a: automaton_run automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1 +
    b: automaton_run automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    for automaton\<^sub>1 alphabet\<^sub>1 initial\<^sub>1 transition\<^sub>1 condition\<^sub>1 test\<^sub>1
    and automaton\<^sub>2 alphabet\<^sub>2 initial\<^sub>2 transition\<^sub>2 condition\<^sub>2 test\<^sub>2
    and condition
    +
    assumes test[iff]: "k < length cs \<Longrightarrow> test\<^sub>2 (condition cs) w (sconst k ||| r) (k, p) \<longleftrightarrow> test\<^sub>1 (cs ! k) w r p"
  begin

    lemma sum_language[simp]:
      assumes "\<Inter> (alphabet\<^sub>1 ` set AA) = \<Union> (alphabet\<^sub>1 ` set AA)"
      shows "b.language (sum AA) = \<Union> (a.language ` set AA)"
    proof
      show "b.language (sum AA) \<subseteq> \<Union> (a.language ` set AA)"
        using assms unfolding a.language_def b.language_def by (force elim: sum_run)
      show "\<Union> (a.language ` set AA) \<subseteq> b.language (sum AA)"
        using assms unfolding a.language_def b.language_def by (force elim!: run_sum)
    qed

  end

end


(*  Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      HeapList.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2004-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

header {* Paths and Lists in the Heap *}
theory HeapList
imports Simpl_Heap
begin

text {* Adapted from 'HOL/Hoare/Heap.thy'. *}

subsection "Paths in The Heap"

primrec
 Path :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref \<Rightarrow>  ref list  \<Rightarrow> bool"
where
"Path x h y [] = (x = y)" |
"Path x h y (p#ps) = (x = p \<and> x \<noteq> Null \<and> Path (h x) h y ps)"

lemma Path_Null_iff [iff]: "Path Null h y xs  = (xs = [] \<and> y = Null)"
apply(case_tac xs)
apply fastforce
apply fastforce
done

lemma Path_not_Null_iff [simp]: "p\<noteq>Null \<Longrightarrow>
  Path p h q as = (as = [] \<and> q = p  \<or>  (\<exists>ps. as = p#ps \<and> Path (h p) h q ps ))"
apply(case_tac as)
apply fastforce
apply fastforce
done

lemma Path_append [simp]:
  "\<And>p. Path p f q (as@bs)  = (\<exists>y. Path p f y as \<and> Path y f q bs)"
by(induct as, simp+)

lemma notin_Path_update[simp]:
 "\<And>p. u \<notin> set ps \<Longrightarrow> Path p (f(u := v)) q ps  = Path p f q ps "
by(induct ps, simp, simp add:eq_sym_conv)

lemma Path_upd_same [simp]:
  "Path p (f(p:=p)) q qs =
      ((p=Null \<and> q=Null \<and> qs = []) \<or> (p\<noteq>Null \<and> q=p \<and> (\<forall>x\<in>set qs. x=p)))"
by (induct qs) auto

text {* @{thm[source] Path_upd_same} prevents
@{term "p\<noteq>Null \<Longrightarrow> Path p (f(p:=p)) q qs = X"} from looping, because of
@{thm[source] Path_not_Null_iff} and @{thm[source]fun_upd_apply}.
 *}

lemma notin_Path_updateI [intro]:
 "\<lbrakk>Path p h q ps ; r \<notin> set ps\<rbrakk> \<Longrightarrow> Path p (h(r := y)) q ps "
by simp

lemma Path_update_new [simp]: "\<lbrakk>set ps \<subseteq> set alloc\<rbrakk>
     \<Longrightarrow> Path p (f(new (set alloc) := x)) q ps  = Path p f q ps "
  by (rule notin_Path_update) fastforce

lemma Null_notin_Path [simp,intro]:
"\<And>p. Path p f q ps \<Longrightarrow> Null \<notin> set ps"
by(induct ps) auto

lemma Path_snoc:
 "\<lbrakk>Path p (f(a := q)) a as ; a\<noteq>Null\<rbrakk> \<Longrightarrow> Path p (f(a := q)) q (as @ [a])"
by simp

subsection "Lists on The Heap"

subsubsection "Relational Abstraction"

definition
 List :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref list \<Rightarrow> bool" where
"List p h ps = Path p h Null ps "

lemma List_empty [simp]: "List p h [] = (p = Null)"
by(simp add:List_def)

lemma List_cons [simp]: "List p h (a#ps) = (p = a \<and> p\<noteq>Null \<and> List (h p) h ps)"
by(simp add:List_def)

lemma List_Null [simp]: "List Null h ps = (ps = [])"
by(case_tac ps, simp_all)

lemma List_not_Null [simp]: "p\<noteq>Null \<Longrightarrow>
  List p h as = (\<exists>ps. as = p#ps \<and> List (h p) h ps)"
by(case_tac as, simp_all, fast)

lemma Null_notin_List [simp,intro]: "\<And>p. List p h ps \<Longrightarrow> Null \<notin> set ps"
by (simp add : List_def)

lemma List_upd_same_lemma: "\<And>p.  p \<noteq> Null \<Longrightarrow> \<not> List p (h(p := p)) ps"
apply (induct ps)
apply  simp
apply (simp (no_asm_simp) del: fun_upd_apply)
apply (simp (no_asm_simp) only: fun_upd_apply refl if_True)
apply blast
done

lemma List_upd_same [simp]: "List p (h(p:=p)) ps = (p = Null \<and> ps = [])"
apply (cases "p=Null")
apply  simp
apply (fast dest: List_upd_same_lemma)
done

text {* @{thm[source] List_upd_same} prevents
@{term "p\<noteq>Null \<Longrightarrow> List p (h(p:=p)) as = X"} from looping, because of
@{thm[source] List_not_Null} and @{thm[source] fun_upd_apply}.
 *}

lemma  List_update_new [simp]: "\<lbrakk>set ps \<subseteq> set alloc\<rbrakk>
     \<Longrightarrow> List p (h(new (set alloc) := x)) ps = List p h ps"
by (rule notin_List_update) fastforce

lemma List_updateI [intro]:
 "\<lbrakk>List p h ps; q \<notin> set ps\<rbrakk> \<Longrightarrow> List p (h(q := y)) ps"
by simp

lemma List_unique: "\<And>p bs. List p h as \<Longrightarrow> List p h bs \<Longrightarrow> as = bs"
by(induct as, simp, clarsimp)

lemma List_unique1: "List p h as \<Longrightarrow> \<exists>!as. List p h as"
by(blast intro:List_unique)

lemma List_app: "\<And>p. List p h (as@bs) = (\<exists>y. Path p h y as \<and> List y h bs)"
by(induct as, simp, clarsimp)

lemma List_hd_not_in_tl[simp]: "List (h p) h ps \<Longrightarrow> p \<notin> set ps"
apply (clarsimp simp add:in_set_conv_decomp)
apply(frule List_app[THEN iffD1])
apply(fastforce dest: List_unique)
done

lemma List_distinct[simp]: "\<And>p. List p h ps \<Longrightarrow> distinct ps"
apply(induct ps, simp)
apply(fastforce dest:List_hd_not_in_tl)
done

lemma heap_eq_List_eq:
  "\<And>p. \<forall>x \<in> set ps. h x = g x \<Longrightarrow> List p h ps = List p g ps"
  by (induct ps) auto

lemma heap_eq_ListI:
  assumes list: "List p h ps"
  assumes hp_eq: "\<forall>x \<in> set ps. h x = g x"
  shows "List p g ps"
  using list
  by (simp add: heap_eq_List_eq [OF hp_eq])

lemma heap_eq_ListI1:
  assumes list: "List p h ps"
  assumes hp_eq: "\<forall>x \<in> set ps. g x = h x"
  shows "List p g ps"
  using list
  by (simp add: heap_eq_List_eq [OF hp_eq])

text {* The following lemmata are usefull for the simplifier to instantiate
bound variables in the assumptions resp. conclusion, using the uniqueness
of the List predicate *}

lemma conj_impl_simp: "(P \<and> Q \<longrightarrow> K) = (P \<longrightarrow> Q \<longrightarrow> K)"
by auto

lemma  List_unique_all_impl_simp [simp]:
 "List p h ps \<Longrightarrow> (\<forall>ps. List p h ps \<longrightarrow> P ps) = P ps"
by (auto dest: List_unique)

(*
lemma  List_unique_all_impl_simp1 [simp]:
 "List p h ps \<Longrightarrow> (\<forall>ps. Q ps \<longrightarrow> List p h ps \<longrightarrow> P ps) = Q ps \<longrightarrow> P ps"
by (auto dest: List_unique)
*)
lemma List_unique_ex_conj_simp [simp]:
"List p h ps \<Longrightarrow> (\<exists>ps. List p h ps \<and> P ps) = P ps"
by (auto dest: List_unique)

subsection "Functional abstraction"

definition
 islist :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> bool" where
"islist p h = (\<exists>ps. List p h ps)"

definition
 list :: "ref \<Rightarrow> (ref \<Rightarrow> ref) \<Rightarrow> ref list" where
"list p h = (THE ps. List p h ps)"

lemma List_conv_islist_list: "List p h ps = (islist p h \<and> ps = list p h)"
apply(simp add:islist_def list_def)
apply(rule iffI)
apply(rule conjI)
apply blast
apply(subst the1_equality)
  apply(erule List_unique1)
 apply assumption
apply(rule refl)
apply simp
apply (clarify)
apply (rule theI)
apply  assumption
by (rule List_unique)

lemma List_islist [intro]:
  "List p h ps \<Longrightarrow> islist p h"
  apply (simp add: List_conv_islist_list)
  done

lemma List_list:
  "List p h ps \<Longrightarrow> list p h = ps"
  apply (simp only: List_conv_islist_list)
  done

lemma [simp]: "p\<noteq>Null \<Longrightarrow> islist (h p) h = islist p h"
by(simp add:islist_def)

lemma [simp]: "list Null h = []"
by(simp add:list_def)

lemma list_Ref_conv[simp]:
 "\<lbrakk>islist (h p) h; p\<noteq>Null \<rbrakk> \<Longrightarrow> list p h = p # list (h p) h"
apply(insert List_not_Null[of _ h])
apply(fastforce simp:List_conv_islist_list)
done

lemma [simp]: "islist (h p) h \<Longrightarrow> p \<notin> set(list (h p) h)"
apply(insert List_hd_not_in_tl[of h])
apply(simp add:List_conv_islist_list)
done

lemma list_upd_conv[simp]:
 "islist p h \<Longrightarrow> y \<notin> set(list p h) \<Longrightarrow> list p (h(y := q)) = list p h"
apply(drule notin_List_update[of _ _ p h q])
apply(simp add:List_conv_islist_list)
done

lemma islist_upd[simp]:
 "islist p h \<Longrightarrow> y \<notin> set(list p h) \<Longrightarrow> islist p (h(y := q))"
apply(frule notin_List_update[of _ _ p h q])
apply(simp add:List_conv_islist_list)
done

lemma list_distinct[simp]: "islist p h \<Longrightarrow> distinct (list p h)"
apply (clarsimp simp add: list_def islist_def)
apply (frule List_unique1)
apply (drule (1) the1_equality)
apply simp
done

lemma Null_notin_list [simp,intro]: "islist p h \<Longrightarrow> Null \<notin> set (list p h)"
apply (clarsimp simp add: list_def islist_def)
apply (frule List_unique1)
apply (drule (1) the1_equality)
apply simp
done

end


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

section{*Infinite-Branching Datatype Definitions*}

theory InfDatatype imports Datatype_ZF Univ Finite Cardinal_AC begin

lemmas fun_Limit_VfromE =
    Limit_VfromE [OF apply_funtype InfCard_csucc [THEN InfCard_is_Limit]]

lemma fun_Vcsucc_lemma:
  assumes f: "f \<in> D -> Vfrom(A,csucc(K))" and DK: "|D| \<le> K" and ICK: "InfCard(K)"
  shows "\<exists>j. f \<in> D -> Vfrom(A,j) & j < csucc(K)"
proof (rule exI, rule conjI)
  show "f \<in> D \<rightarrow> Vfrom(A, \<Union>z\<in>D. \<mu> i. f`z \<in> Vfrom (A,i))"
    proof (rule Pi_type [OF f])
      fix d
      assume d: "d \<in> D"
      show "f ` d \<in> Vfrom(A, \<Union>z\<in>D. \<mu> i. f ` z \<in> Vfrom(A, i))"
        proof (rule fun_Limit_VfromE [OF f d ICK])
          fix x
          assume "x < csucc(K)"  "f ` d \<in> Vfrom(A, x)"
          hence "f`d \<in> Vfrom(A, \<mu> i. f`d \<in> Vfrom (A,i))" using d
            by (fast elim: LeastI ltE)
          also have "... \<subseteq> Vfrom(A, \<Union>z\<in>D. \<mu> i. f ` z \<in> Vfrom(A, i))"
            by (rule Vfrom_mono) (auto intro: d)
          finally show "f`d \<in> Vfrom(A, \<Union>z\<in>D. \<mu> i. f ` z \<in> Vfrom(A, i))" .
        qed
    qed
next
  show "(\<Union>d\<in>D. \<mu> i. f ` d \<in> Vfrom(A, i)) < csucc(K)"
    proof (rule le_UN_Ord_lt_csucc [OF ICK DK])
      fix d
      assume d: "d \<in> D"
      show "(\<mu> i. f ` d \<in> Vfrom(A, i)) < csucc(K)"
        proof (rule fun_Limit_VfromE [OF f d ICK])
          fix x
          assume "x < csucc(K)"  "f ` d \<in> Vfrom(A, x)"
          thus "(\<mu> i. f ` d \<in> Vfrom(A, i)) < csucc(K)"
            by (blast intro: Least_le lt_trans1 lt_Ord)
        qed
    qed
qed

lemma subset_Vcsucc:
     "[| D \<subseteq> Vfrom(A,csucc(K));  |D| \<le> K;  InfCard(K) |]
      ==> \<exists>j. D \<subseteq> Vfrom(A,j) & j < csucc(K)"
by (simp add: subset_iff_id fun_Vcsucc_lemma)

(*Version for arbitrary index sets*)
lemma fun_Vcsucc:
     "[| |D| \<le> K;  InfCard(K);  D \<subseteq> Vfrom(A,csucc(K)) |] ==>
          D -> Vfrom(A,csucc(K)) \<subseteq> Vfrom(A,csucc(K))"
apply (safe dest!: fun_Vcsucc_lemma subset_Vcsucc)
apply (rule Vfrom [THEN ssubst])
apply (drule fun_is_rel)
(*This level includes the function, and is below csucc(K)*)
apply (rule_tac a1 = "succ (succ (j \<union> ja))" in UN_I [THEN UnI2])
apply (blast intro: ltD InfCard_csucc InfCard_is_Limit Limit_has_succ
                    Un_least_lt)
apply (erule subset_trans [THEN PowI])
apply (fast intro: Pair_in_Vfrom Vfrom_UnI1 Vfrom_UnI2)
done

lemma fun_in_Vcsucc:
     "[| f: D -> Vfrom(A, csucc(K));  |D| \<le> K;  InfCard(K);
         D \<subseteq> Vfrom(A,csucc(K)) |]
       ==> f: Vfrom(A,csucc(K))"
by (blast intro: fun_Vcsucc [THEN subsetD])

text{*Remove @{text "\<subseteq>"} from the rule above*}
lemmas fun_in_Vcsucc' = fun_in_Vcsucc [OF _ _ _ subsetI]

(** Version where K itself is the index set **)

lemma Card_fun_Vcsucc:
     "InfCard(K) ==> K -> Vfrom(A,csucc(K)) \<subseteq> Vfrom(A,csucc(K))"
apply (frule InfCard_is_Card [THEN Card_is_Ord])
apply (blast del: subsetI
             intro: fun_Vcsucc Ord_cardinal_le i_subset_Vfrom
                   lt_csucc [THEN leI, THEN le_imp_subset, THEN subset_trans])
done

lemma Card_fun_in_Vcsucc:
     "[| f: K -> Vfrom(A, csucc(K));  InfCard(K) |] ==> f: Vfrom(A,csucc(K))"
by (blast intro: Card_fun_Vcsucc [THEN subsetD])

lemma Limit_csucc: "InfCard(K) ==> Limit(csucc(K))"
by (erule InfCard_csucc [THEN InfCard_is_Limit])

lemmas Pair_in_Vcsucc = Pair_in_VLimit [OF _ _ Limit_csucc]
lemmas Inl_in_Vcsucc = Inl_in_VLimit [OF _ Limit_csucc]
lemmas Inr_in_Vcsucc = Inr_in_VLimit [OF _ Limit_csucc]
lemmas zero_in_Vcsucc = Limit_csucc [THEN zero_in_VLimit]
lemmas nat_into_Vcsucc = nat_into_VLimit [OF _ Limit_csucc]

(*For handling Cardinals of the form  @{term"nat \<union> |X|"} *)

lemmas InfCard_nat_Un_cardinal = InfCard_Un [OF InfCard_nat Card_cardinal]

lemmas le_nat_Un_cardinal =
     Un_upper2_le [OF Ord_nat Card_cardinal [THEN Card_is_Ord]]

lemmas UN_upper_cardinal = UN_upper [THEN subset_imp_lepoll, THEN lepoll_imp_Card_le]

(*The new version of Data_Arg.intrs, declared in Datatype.ML*)
lemmas Data_Arg_intros =
       SigmaI InlI InrI
       Pair_in_univ Inl_in_univ Inr_in_univ
       zero_in_univ A_into_univ nat_into_univ UnCI

(*For most K-branching datatypes with domain Vfrom(A, csucc(K)) *)
lemmas inf_datatype_intros =
     InfCard_nat InfCard_nat_Un_cardinal
     Pair_in_Vcsucc Inl_in_Vcsucc Inr_in_Vcsucc
     zero_in_Vcsucc A_into_Vfrom nat_into_Vcsucc
     Card_fun_in_Vcsucc fun_in_Vcsucc' UN_I

end


(*  Title:      HOL/Probability/Complete_Measure.thy
    Author:     Robert Himmelmann, Johannes Hoelzl, TU Muenchen
*)

theory Complete_Measure
  imports Bochner_Integration Probability_Measure
begin

definition
  "split_completion M A p = (if A \<in> sets M then p = (A, {}) else
   \<exists>N'. A = fst p \<union> snd p \<and> fst p \<inter> snd p = {} \<and> fst p \<in> sets M \<and> snd p \<subseteq> N' \<and> N' \<in> null_sets M)"

definition
  "main_part M A = fst (Eps (split_completion M A))"

definition
  "null_part M A = snd (Eps (split_completion M A))"

definition completion :: "'a measure \<Rightarrow> 'a measure" where
  "completion M = measure_of (space M) { S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' }
    (emeasure M \<circ> main_part M)"

lemma completion_into_space:
  "{ S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' } \<subseteq> Pow (space M)"
  using sets.sets_into_space by auto

lemma space_completion[simp]: "space (completion M) = space M"
  unfolding completion_def using space_measure_of[OF completion_into_space] by simp

lemma completionI:
  assumes "A = S \<union> N" "N \<subseteq> N'" "N' \<in> null_sets M" "S \<in> sets M"
  shows "A \<in> { S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' }"
  using assms by auto

lemma completionE:
  assumes "A \<in> { S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' }"
  obtains S N N' where "A = S \<union> N" "N \<subseteq> N'" "N' \<in> null_sets M" "S \<in> sets M"
  using assms by auto

lemma sigma_algebra_completion:
  "sigma_algebra (space M) { S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' }"
    (is "sigma_algebra _ ?A")
  unfolding sigma_algebra_iff2
proof (intro conjI ballI allI impI)
  show "?A \<subseteq> Pow (space M)"
    using sets.sets_into_space by auto
next
  show "{} \<in> ?A" by auto
next
  let ?C = "space M"
  fix A assume "A \<in> ?A" from completionE[OF this] guess S N N' .
  then show "space M - A \<in> ?A"
    by (intro completionI[of _ "(?C - S) \<inter> (?C - N')" "(?C - S) \<inter> N' \<inter> (?C - N)"]) auto
next
  fix A :: "nat \<Rightarrow> 'a set" assume A: "range A \<subseteq> ?A"
  then have "\<forall>n. \<exists>S N N'. A n = S \<union> N \<and> S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N'"
    by (auto simp: image_subset_iff)
  from choice[OF this] guess S ..
  from choice[OF this] guess N ..
  from choice[OF this] guess N' ..
  then show "UNION UNIV A \<in> ?A"
    using null_sets_UN[of N']
    by (intro completionI[of _ "UNION UNIV S" "UNION UNIV N" "UNION UNIV N'"]) auto
qed

lemma sets_completion:
  "sets (completion M) = { S \<union> N |S N N'. S \<in> sets M \<and> N' \<in> null_sets M \<and> N \<subseteq> N' }"
  using sigma_algebra.sets_measure_of_eq[OF sigma_algebra_completion] by (simp add: completion_def)

lemma sets_completionE:
  assumes "A \<in> sets (completion M)"
  obtains S N N' where "A = S \<union> N" "N \<subseteq> N'" "N' \<in> null_sets M" "S \<in> sets M"
  using assms unfolding sets_completion by auto

lemma sets_completionI:
  assumes "A = S \<union> N" "N \<subseteq> N'" "N' \<in> null_sets M" "S \<in> sets M"
  shows "A \<in> sets (completion M)"
  using assms unfolding sets_completion by auto

lemma sets_completionI_sets[intro, simp]:
  "A \<in> sets M \<Longrightarrow> A \<in> sets (completion M)"
  unfolding sets_completion by force

lemma null_sets_completion:
  assumes "N' \<in> null_sets M" "N \<subseteq> N'" shows "N \<in> sets (completion M)"
  using assms by (intro sets_completionI[of N "{}" N N']) auto

lemma split_completion:
  assumes "A \<in> sets (completion M)"
  shows "split_completion M A (main_part M A, null_part M A)"
proof cases
  assume "A \<in> sets M" then show ?thesis
    by (simp add: split_completion_def[abs_def] main_part_def null_part_def)
next
  assume nA: "A \<notin> sets M"
  show ?thesis
    unfolding main_part_def null_part_def if_not_P[OF nA]
  proof (rule someI2_ex)
    from assms[THEN sets_completionE] guess S N N' . note A = this
    let ?P = "(S, N - S)"
    show "\<exists>p. split_completion M A p"
      unfolding split_completion_def if_not_P[OF nA] using A
    proof (intro exI conjI)
      show "A = fst ?P \<union> snd ?P" using A by auto
      show "snd ?P \<subseteq> N'" using A by auto
   qed auto
  qed auto
qed

lemma
  assumes "S \<in> sets (completion M)"
  shows main_part_sets[intro, simp]: "main_part M S \<in> sets M"
    and main_part_null_part_Un[simp]: "main_part M S \<union> null_part M S = S"
    and main_part_null_part_Int[simp]: "main_part M S \<inter> null_part M S = {}"
  using split_completion[OF assms]
  by (auto simp: split_completion_def split: split_if_asm)

lemma main_part[simp]: "S \<in> sets M \<Longrightarrow> main_part M S = S"
  using split_completion[of S M]
  by (auto simp: split_completion_def split: split_if_asm)

lemma null_part:
  assumes "S \<in> sets (completion M)" shows "\<exists>N. N\<in>null_sets M \<and> null_part M S \<subseteq> N"
  using split_completion[OF assms] by (auto simp: split_completion_def split: split_if_asm)

lemma null_part_sets[intro, simp]:
  assumes "S \<in> sets M" shows "null_part M S \<in> sets M" "emeasure M (null_part M S) = 0"
proof -
  have S: "S \<in> sets (completion M)" using assms by auto
  have "S - main_part M S \<in> sets M" using assms by auto
  moreover
  from main_part_null_part_Un[OF S] main_part_null_part_Int[OF S]
  have "S - main_part M S = null_part M S" by auto
  ultimately show sets: "null_part M S \<in> sets M" by auto
  from null_part[OF S] guess N ..
  with emeasure_eq_0[of N _ "null_part M S"] sets
  show "emeasure M (null_part M S) = 0" by auto
qed

lemma emeasure_main_part_UN:
  fixes S :: "nat \<Rightarrow> 'a set"
  assumes "range S \<subseteq> sets (completion M)"
  shows "emeasure M (main_part M (\<Union>i. (S i))) = emeasure M (\<Union>i. main_part M (S i))"
proof -
  have S: "\<And>i. S i \<in> sets (completion M)" using assms by auto
  then have UN: "(\<Union>i. S i) \<in> sets (completion M)" by auto
  have "\<forall>i. \<exists>N. N \<in> null_sets M \<and> null_part M (S i) \<subseteq> N"
    using null_part[OF S] by auto
  from choice[OF this] guess N .. note N = this
  then have UN_N: "(\<Union>i. N i) \<in> null_sets M" by (intro null_sets_UN) auto
  have "(\<Union>i. S i) \<in> sets (completion M)" using S by auto
  from null_part[OF this] guess N' .. note N' = this
  let ?N = "(\<Union>i. N i) \<union> N'"
  have null_set: "?N \<in> null_sets M" using N' UN_N by (intro null_sets.Un) auto
  have "main_part M (\<Union>i. S i) \<union> ?N = (main_part M (\<Union>i. S i) \<union> null_part M (\<Union>i. S i)) \<union> ?N"
    using N' by auto
  also have "\<dots> = (\<Union>i. main_part M (S i) \<union> null_part M (S i)) \<union> ?N"
    unfolding main_part_null_part_Un[OF S] main_part_null_part_Un[OF UN] by auto
  also have "\<dots> = (\<Union>i. main_part M (S i)) \<union> ?N"
    using N by auto
  finally have *: "main_part M (\<Union>i. S i) \<union> ?N = (\<Union>i. main_part M (S i)) \<union> ?N" .
  have "emeasure M (main_part M (\<Union>i. S i)) = emeasure M (main_part M (\<Union>i. S i) \<union> ?N)"
    using null_set UN by (intro emeasure_Un_null_set[symmetric]) auto
  also have "\<dots> = emeasure M ((\<Union>i. main_part M (S i)) \<union> ?N)"
    unfolding * ..
  also have "\<dots> = emeasure M (\<Union>i. main_part M (S i))"
    using null_set S by (intro emeasure_Un_null_set) auto
  finally show ?thesis .
qed

lemma emeasure_completion[simp]:
  assumes S: "S \<in> sets (completion M)" shows "emeasure (completion M) S = emeasure M (main_part M S)"
proof (subst emeasure_measure_of[OF completion_def completion_into_space])
  let ?\<mu> = "emeasure M \<circ> main_part M"
  show "S \<in> sets (completion M)" "?\<mu> S = emeasure M (main_part M S) " using S by simp_all
  show "positive (sets (completion M)) ?\<mu>"
    by (simp add: positive_def emeasure_nonneg)
  show "countably_additive (sets (completion M)) ?\<mu>"
  proof (intro countably_additiveI)
    fix A :: "nat \<Rightarrow> 'a set" assume A: "range A \<subseteq> sets (completion M)" "disjoint_family A"
    have "disjoint_family (\<lambda>i. main_part M (A i))"
    proof (intro disjoint_family_on_bisimulation[OF A(2)])
      fix n m assume "A n \<inter> A m = {}"
      then have "(main_part M (A n) \<union> null_part M (A n)) \<inter> (main_part M (A m) \<union> null_part M (A m)) = {}"
        using A by (subst (1 2) main_part_null_part_Un) auto
      then show "main_part M (A n) \<inter> main_part M (A m) = {}" by auto
    qed
    then have "(\<Sum>n. emeasure M (main_part M (A n))) = emeasure M (\<Union>i. main_part M (A i))"
      using A by (auto intro!: suminf_emeasure)
    then show "(\<Sum>n. ?\<mu> (A n)) = ?\<mu> (UNION UNIV A)"
      by (simp add: completion_def emeasure_main_part_UN[OF A(1)])
  qed
qed

lemma emeasure_completion_UN:
  "range S \<subseteq> sets (completion M) \<Longrightarrow>
    emeasure (completion M) (\<Union>i::nat. (S i)) = emeasure M (\<Union>i. main_part M (S i))"
  by (subst emeasure_completion) (auto simp add: emeasure_main_part_UN)

lemma emeasure_completion_Un:
  assumes S: "S \<in> sets (completion M)" and T: "T \<in> sets (completion M)"
  shows "emeasure (completion M) (S \<union> T) = emeasure M (main_part M S \<union> main_part M T)"
proof (subst emeasure_completion)
  have UN: "(\<Union>i. binary (main_part M S) (main_part M T) i) = (\<Union>i. main_part M (binary S T i))"
    unfolding binary_def by (auto split: split_if_asm)
  show "emeasure M (main_part M (S \<union> T)) = emeasure M (main_part M S \<union> main_part M T)"
    using emeasure_main_part_UN[of "binary S T" M] assms
    unfolding range_binary_eq Un_range_binary UN by auto
qed (auto intro: S T)

lemma sets_completionI_sub:
  assumes N: "N' \<in> null_sets M" "N \<subseteq> N'"
  shows "N \<in> sets (completion M)"
  using assms by (intro sets_completionI[of _ "{}" N N']) auto

lemma completion_ex_simple_function:
  assumes f: "simple_function (completion M) f"
  shows "\<exists>f'. simple_function M f' \<and> (AE x in M. f x = f' x)"
proof -
  let ?F = "\<lambda>x. f -` {x} \<inter> space M"
  have F: "\<And>x. ?F x \<in> sets (completion M)" and fin: "finite (f`space M)"
    using simple_functionD[OF f] simple_functionD[OF f] by simp_all
  have "\<forall>x. \<exists>N. N \<in> null_sets M \<and> null_part M (?F x) \<subseteq> N"
    using F null_part by auto
  from choice[OF this] obtain N where
    N: "\<And>x. null_part M (?F x) \<subseteq> N x" "\<And>x. N x \<in> null_sets M" by auto
  let ?N = "\<Union>x\<in>f`space M. N x"
  let ?f' = "\<lambda>x. if x \<in> ?N then undefined else f x"
  have sets: "?N \<in> null_sets M" using N fin by (intro null_sets.finite_UN) auto
  show ?thesis unfolding simple_function_def
  proof (safe intro!: exI[of _ ?f'])
    have "?f' ` space M \<subseteq> f`space M \<union> {undefined}" by auto
    from finite_subset[OF this] simple_functionD(1)[OF f]
    show "finite (?f' ` space M)" by auto
  next
    fix x assume "x \<in> space M"
    have "?f' -` {?f' x} \<inter> space M =
      (if x \<in> ?N then ?F undefined \<union> ?N
       else if f x = undefined then ?F (f x) \<union> ?N
       else ?F (f x) - ?N)"
      using N(2) sets.sets_into_space by (auto split: split_if_asm simp: null_sets_def)
    moreover { fix y have "?F y \<union> ?N \<in> sets M"
      proof cases
        assume y: "y \<in> f`space M"
        have "?F y \<union> ?N = (main_part M (?F y) \<union> null_part M (?F y)) \<union> ?N"
          using main_part_null_part_Un[OF F] by auto
        also have "\<dots> = main_part M (?F y) \<union> ?N"
          using y N by auto
        finally show ?thesis
          using F sets by auto
      next
        assume "y \<notin> f`space M" then have "?F y = {}" by auto
        then show ?thesis using sets by auto
      qed }
    moreover {
      have "?F (f x) - ?N = main_part M (?F (f x)) \<union> null_part M (?F (f x)) - ?N"
        using main_part_null_part_Un[OF F] by auto
      also have "\<dots> = main_part M (?F (f x)) - ?N"
        using N `x \<in> space M` by auto
      finally have "?F (f x) - ?N \<in> sets M"
        using F sets by auto }
    ultimately show "?f' -` {?f' x} \<inter> space M \<in> sets M" by auto
  next
    show "AE x in M. f x = ?f' x"
      by (rule AE_I', rule sets) auto
  qed
qed

lemma completion_ex_borel_measurable_pos:
  fixes g :: "'a \<Rightarrow> ereal"
  assumes g: "g \<in> borel_measurable (completion M)" and "\<And>x. 0 \<le> g x"
  shows "\<exists>g'\<in>borel_measurable M. (AE x in M. g x = g' x)"
proof -
  from g[THEN borel_measurable_implies_simple_function_sequence'] guess f . note f = this
  from this(1)[THEN completion_ex_simple_function]
  have "\<forall>i. \<exists>f'. simple_function M f' \<and> (AE x in M. f i x = f' x)" ..
  from this[THEN choice] obtain f' where
    sf: "\<And>i. simple_function M (f' i)" and
    AE: "\<forall>i. AE x in M. f i x = f' i x" by auto
  show ?thesis
  proof (intro bexI)
    from AE[unfolded AE_all_countable[symmetric]]
    show "AE x in M. g x = (SUP i. f' i x)" (is "AE x in M. g x = ?f x")
    proof (elim AE_mp, safe intro!: AE_I2)
      fix x assume eq: "\<forall>i. f i x = f' i x"
      moreover have "g x = (SUP i. f i x)"
        unfolding f using `0 \<le> g x` by (auto split: split_max)
      ultimately show "g x = ?f x" by auto
    qed
    show "?f \<in> borel_measurable M"
      using sf[THEN borel_measurable_simple_function] by auto
  qed
qed

lemma completion_ex_borel_measurable:
  fixes g :: "'a \<Rightarrow> ereal"
  assumes g: "g \<in> borel_measurable (completion M)"
  shows "\<exists>g'\<in>borel_measurable M. (AE x in M. g x = g' x)"
proof -
  have "(\<lambda>x. max 0 (g x)) \<in> borel_measurable (completion M)" "\<And>x. 0 \<le> max 0 (g x)" using g by auto
  from completion_ex_borel_measurable_pos[OF this] guess g_pos ..
  moreover
  have "(\<lambda>x. max 0 (- g x)) \<in> borel_measurable (completion M)" "\<And>x. 0 \<le> max 0 (- g x)" using g by auto
  from completion_ex_borel_measurable_pos[OF this] guess g_neg ..
  ultimately
  show ?thesis
  proof (safe intro!: bexI[of _ "\<lambda>x. g_pos x - g_neg x"])
    show "AE x in M. max 0 (- g x) = g_neg x \<longrightarrow> max 0 (g x) = g_pos x \<longrightarrow> g x = g_pos x - g_neg x"
    proof (intro AE_I2 impI)
      fix x assume g: "max 0 (- g x) = g_neg x" "max 0 (g x) = g_pos x"
      show "g x = g_pos x - g_neg x" unfolding g[symmetric]
        by (cases "g x") (auto split: split_max)
    qed
  qed auto
qed

lemma (in prob_space) prob_space_completion: "prob_space (completion M)"
  by (rule prob_spaceI) (simp add: emeasure_space_1)

lemma null_sets_completionI: "N \<in> null_sets M \<Longrightarrow> N \<in> null_sets (completion M)"
  by (auto simp: null_sets_def)

lemma AE_completion: "(AE x in M. P x) \<Longrightarrow> (AE x in completion M. P x)"
  unfolding eventually_ae_filter by (auto intro: null_sets_completionI)

lemma null_sets_completion_iff: "N \<in> sets M \<Longrightarrow> N \<in> null_sets (completion M) \<longleftrightarrow> N \<in> null_sets M"
  by (auto simp: null_sets_def)

lemma AE_completion_iff: "{x\<in>space M. P x} \<in> sets M \<Longrightarrow> (AE x in M. P x) \<longleftrightarrow> (AE x in completion M. P x)"
  by (simp add: AE_iff_null null_sets_completion_iff)

end


section \<open> CVA.thy \<close>

theory CVA
  imports Main OVA
begin

(* CVA type (concurrent valuation algebra) *)
record ('A, 'a) CVA =
  par_algebra :: "('A, 'a) OVA"
  seq_algebra :: "('A, 'a) OVA"

abbreviation prealgebra :: "('A,'a) CVA \<Rightarrow> ('A, 'a) Prealgebra" where
"prealgebra V \<equiv> OVA.prealgebra (par_algebra V)"

abbreviation elems :: "('A,'a) CVA \<Rightarrow> ('A, 'a) Valuation set" where
"elems V \<equiv> OVA.elems (par_algebra V)"

abbreviation (input) space :: "('A,'a) CVA \<Rightarrow> 'A Space" where
"space V \<equiv> OVA.space (par_algebra V)"

abbreviation par :: "('A,'a) CVA \<Rightarrow>  ('A, 'a) Valuation \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> ('A, 'a) Valuation" where
"par V \<equiv> OVA.comb (par_algebra V)"

abbreviation seq :: "('A,'a) CVA \<Rightarrow>  ('A, 'a) Valuation \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> ('A, 'a) Valuation" where
"seq V \<equiv> OVA.comb (seq_algebra V)"

abbreviation le :: "('A,'a) CVA \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> bool" where
"le V \<equiv> OVA.le (par_algebra V)"

abbreviation local_le :: "('A,'a) CVA \<Rightarrow> 'A Open \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> bool" where
"local_le V \<equiv> OVA.local_le (par_algebra V)"

abbreviation neut_par :: "('A, 'a) CVA \<Rightarrow> ('A Open \<Rightarrow> ('A, 'a) Valuation)" where
"neut_par V \<equiv> OVA.neut (par_algebra V)"

abbreviation neut_seq :: "('A, 'a) CVA \<Rightarrow> ('A Open \<Rightarrow> ('A, 'a) Valuation)" where
"neut_seq V \<equiv> OVA.neut (seq_algebra V)"

abbreviation res :: "('A,'a) CVA \<Rightarrow> 'A Open \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> ('A, 'a) Valuation" where
"res V \<equiv> OVA.res (par_algebra V)"

abbreviation ext :: "('A,'a) CVA \<Rightarrow> 'A Open \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> ('A, 'a) Valuation" where
"ext V \<equiv>  OVA.ext (par_algebra V)"

definition valid :: "('A, 'a) CVA \<Rightarrow> bool" where
  "valid V \<equiv>
    let
        par = OVA.comb (par_algebra V);
        seq = OVA.comb (seq_algebra V);
        le = OVA.le (par_algebra V);

        \<delta> = OVA.neut (par_algebra V);
        \<epsilon> = OVA.neut (seq_algebra V);

        welldefined = OVA.valid (par_algebra V)
                      \<and> OVA.valid (seq_algebra V)
                      \<and> (OVA.prealgebra (par_algebra V) = OVA.prealgebra (seq_algebra V));

        commutativity = is_commutative (par_algebra V);

        weak_exchange = \<forall> a b c d. a \<in> elems V \<longrightarrow> b \<in> elems V \<longrightarrow> c \<in> elems V \<longrightarrow> d \<in> elems V \<longrightarrow>
                         le (seq (par a b) (par c d)) (par (seq a c) (seq b d)) ;

        neutral_law_par = (\<forall>A . A \<in> opens (space V) \<longrightarrow> le (seq (\<delta> A) (\<delta> A)) (\<delta> A));

        neutral_law_seq = (\<forall>A . A \<in> opens (space V) \<longrightarrow> le (\<epsilon> A) (par (\<epsilon> A) (\<epsilon> A)))
    in
      welldefined \<and> commutativity \<and> weak_exchange \<and> neutral_law_par \<and> neutral_law_seq"

abbreviation hoare :: "('A,'a) CVA \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> ('A, 'a) Valuation \<Rightarrow> bool" where
"hoare V p a q \<equiv> le V (seq V p a) q"

(* Validity *)

lemma valid_welldefined: "valid V \<Longrightarrow> OVA.valid (par_algebra V) \<and> OVA.valid (seq_algebra V) \<and> (OVA.prealgebra (par_algebra V) = OVA.prealgebra (seq_algebra V))"
  unfolding valid_def
  by metis

lemma valid_commutativity: "valid V \<Longrightarrow> is_commutative (par_algebra V)"
  unfolding valid_def
  by metis

lemma valid_elems :
  fixes V :: "('A, 'a) CVA"
  assumes "valid V"
  shows "elems V = OVA.elems (seq_algebra V)"
  by (metis CVA.valid_welldefined assms valid_gc_poset)

lemma valid_le :
  fixes V :: "('A, 'a) CVA"
  assumes "valid V"
  shows "le V = OVA.le (seq_algebra V)"
  by (metis (mono_tags, opaque_lifting) CVA.valid_welldefined assms valid_gc_poset)

lemma local_le :
  fixes V :: "('A, 'a) CVA"
  assumes "valid V"
  shows "local_le V = OVA.local_le (seq_algebra V)"
  by (simp add: CVA.valid_welldefined assms valid_gc_poset)

lemma valid_weak_exchange: "valid V \<Longrightarrow> a1 \<in> elems V \<Longrightarrow> a2 \<in> elems V \<Longrightarrow> a3 \<in> elems V \<Longrightarrow> a4 \<in> elems V \<Longrightarrow>
                        le V (seq V (par V a1 a2) (par V a3 a4)) (par V (seq V a1 a3) (seq V a2 a4))"
  unfolding valid_def
  by presburger

lemma valid_neutral_law_par: "valid V \<Longrightarrow> A \<in> opens (space V) \<Longrightarrow>  \<delta>A = (neut_par V A)
  \<Longrightarrow> le V (seq V \<delta>A \<delta>A) \<delta>A"
  unfolding valid_def
  by meson

lemma valid_neutral_law_seq: "valid V \<Longrightarrow>  A \<in> opens (space V) \<Longrightarrow> \<epsilon>A = (neut_seq V A)
  \<Longrightarrow> le V \<epsilon>A (par V \<epsilon>A \<epsilon>A)"
  unfolding valid_def
  by meson

lemma valid_res: "valid V \<Longrightarrow> A \<in> opens (space V) \<Longrightarrow> a \<in> elems V \<Longrightarrow> res V A a = OVA.res (seq_algebra V) A a"
  unfolding valid_def
  by (metis res_def valid_gc_poset)

lemma valid_ext:
  fixes V :: "('A, 'a) CVA" and A :: "'A Open" and b :: "('A, 'a) Valuation"
  assumes V_valid : "valid V"
  and A_open : "A \<in> opens (space V)"
  and b_elem : "b \<in> elems V"
  and B_leq_A : "d b \<subseteq> A"
  defines "ex \<equiv> ext V" and "ex' \<equiv> OVA.ext (seq_algebra V)"
  shows "ex A b = ex' A b"
  unfolding valid_def
proof -
(*
    fix b
    assume "b \<in> elems V"
    fix A
    assume "A \<in> opens (space V)"
    assume "B \<subseteq> A"
*)
    define "B" where "B = d b"
    define "pr" where "pr = res V"
    have "local_le V B (pr B (ex A b)) b"
      by (metis A_open B_def B_leq_A CVA.valid_welldefined Grothendieck.local_le OVA.valid_welldefined V_valid b_elem ex_def galois_insertion pr_def valid_poset valid_reflexivity)
     moreover have "A \<in> opens (space V) \<and> B \<in> opens (space V)"
       using A_open B_def CVA.valid_welldefined V_valid b_elem d_elem_is_open by blast
    moreover have lhs:"local_le V A (ex A b) (ex' A b)" using valid_res [where ?V=V] OVA.res_ext_adjunction [where
   ?V="seq_algebra V" and ?a="ex A b" and ?b=b]
      by (metis (no_types, lifting) B_def B_leq_A CVA.valid_welldefined V_valid b_elem calculation(1) calculation(2) d_ext ex'_def ex_def ext_elem pr_def valid_elems)
    moreover have "local_le V B (pr B (ex' A b)) b"
      by (metis B_def B_leq_A CVA.valid_welldefined V_valid b_elem calculation(1) calculation(2) ex'_def ex_def galois_insertion ext_elem pr_def valid_elems valid_res)
    moreover have rhs:"local_le V A (ex' A b) (ex A b)" using valid_res [where ?V=V] OVA.res_ext_adjunction [where
   ?V="par_algebra V" and ?a="(ex' A b)" and ?b=b]
      by (metis (full_types) B_def B_leq_A CVA.valid_welldefined V_valid b_elem calculation(2) calculation(4) d_ext ex'_def ex_def ext_elem pr_def valid_elems)
    moreover have "ex' A b = ex A b" using calculation
      by (metis B_def B_leq_A CVA.valid_welldefined V_valid b_elem d_ext e_ext ex'_def ex_def prod.collapse valid_antisymmetry valid_elems valid_ob valid_prealgebra)
    ultimately show "ex A b = ex' A b"
      by presburger
  qed

(* To-do: can we actually prove ex = ex' with fun ext? *)
lemma valid_ext_funext:
  fixes V :: "('A, 'a) CVA"
  defines "ex \<equiv> ext V" and "ex' \<equiv> OVA.ext (seq_algebra V)"
  shows "ex = ex'"
  oops

(* Paper results *)

(* [Proposition 1 (1/3), CVA] *)
proposition epsilon_le_delta [simp] :
  fixes V :: "('A, 'a) CVA" and A :: "'A Open"
  assumes V_valid : "valid V" and A_open : "A \<in> opens (space V)"
  defines "\<delta>A \<equiv> neut_par V A" and "\<epsilon>A \<equiv> neut_seq V A"
  shows "le V \<epsilon>A \<delta>A"
proof -
  have "\<epsilon>A = seq V \<epsilon>A \<epsilon>A" using assms valid_welldefined [where ?V=V] valid_neutral_law_left
    by (metis fst_conv neutral_is_element)
  moreover have "\<epsilon>A = par V \<delta>A \<epsilon>A " using assms valid_welldefined [where ?V=V]
      valid_neutral_law_left
    by (metis fst_conv neutral_is_element valid_elems)
  moreover have "\<epsilon>A = par V \<epsilon>A \<delta>A " using assms valid_welldefined [where ?V=V]  valid_commutativity
    by (metis calculation(2) neutral_is_element valid_elems)
  moreover have "seq V \<epsilon>A \<epsilon>A = seq V (par V \<delta>A \<epsilon>A) (par V \<epsilon>A \<delta>A)" using calculation assms
    by auto
  moreover have "le V (seq V (par V \<delta>A \<epsilon>A) (par V \<epsilon>A \<delta>A)) (par V (seq V \<delta>A \<epsilon>A) (seq V \<epsilon>A \<delta>A))"
    using calculation assms valid_weak_exchange
    by (metis CVA.valid_welldefined \<delta>A_def \<epsilon>A_def neutral_is_element valid_elems)
  moreover have "(seq V \<delta>A \<epsilon>A) = \<delta>A" using calculation assms
    by (metis CVA.valid_welldefined fst_eqD neutral_is_element valid_elems valid_neutral_law_right)
 moreover have "(seq V \<epsilon>A \<delta>A ) = \<delta>A" using calculation assms valid_neutral_law_left
   by (metis CVA.valid_welldefined fst_conv neutral_is_element valid_elems)
  moreover have "(par V (seq V \<delta>A \<epsilon>A) (seq V \<epsilon>A \<delta>A)) = par V \<delta>A \<delta>A" using calculation assms
    by auto
  moreover have "par V \<delta>A \<delta>A = \<delta>A" using assms valid_neutral_law_right
    by (metis CVA.valid_welldefined fst_conv neutral_is_element)
  ultimately show ?thesis
    by metis
qed

lemma epsilon_par_epsilon_le_epsilon :
  fixes V :: "('A, 'a) CVA" and A :: "'A Open"
  assumes V_valid : "valid V" and A_open : "A \<in> opens (space V)"
  defines "\<delta>A \<equiv> neut_par V A" and "\<epsilon>A \<equiv> neut_seq V A"
  shows "le V (par V \<epsilon>A \<epsilon>A) \<epsilon>A"
proof -
  have "le V (par V \<epsilon>A \<epsilon>A) (par V \<epsilon>A \<delta>A)" using assms valid_comb_monotone
    by (smt (z3) CVA.valid_welldefined comb_is_element fst_conv neutral_is_element valid_domain_law valid_elems valid_neutral_law_left valid_neutral_law_right valid_weak_exchange)
  moreover have "par V \<epsilon>A \<delta>A = \<epsilon>A"
    by (smt (verit) A_open CVA.valid_welldefined V_valid \<delta>A_def \<epsilon>A_def fst_conv neutral_is_element valid_elems valid_neutral_law_right)
  ultimately show ?thesis
    by metis
qed

lemma delta_le_delta_seq_delta :
  fixes V :: "('A, 'a) CVA" and A :: "'A Open"
  assumes V_valid : "valid V" and A_open : "A \<in> opens (space V)"
  defines "\<delta>A \<equiv> neut_par V A" and "\<epsilon>A \<equiv> neut_seq V A"
  shows "le V \<delta>A (seq V \<delta>A \<delta>A)"
proof -
  have "le V (seq V \<epsilon>A \<delta>A) (seq V \<delta>A \<delta>A)" using assms OVA.valid_comb_monotone
 [where ?V="seq_algebra V" and ?a1.0=\<epsilon>A and ?a2.0=\<delta>A and ?b1.0=\<delta>A and ?b2.0=\<delta>A]
    by (smt (verit) CVA.valid_welldefined epsilon_le_delta neutral_is_element valid_gc_poset valid_poset valid_reflexivity valid_semigroup)
  moreover have "seq V \<epsilon>A \<delta>A = \<delta>A"
    by (smt (verit) A_open CVA.valid_welldefined V_valid \<delta>A_def \<epsilon>A_def fst_conv neutral_is_element surj_pair valid_elems valid_neutral_law_left)
  ultimately show ?thesis
    by metis
qed

(* [Proposition 1 (2/3), CVA] *)
proposition delta_seq_delta_eq_delta [simp] :
  fixes V :: "('A, 'a) CVA" and A :: "'A Open"
  assumes V_valid : "valid V" and A_open : "A \<in> opens (space V)"
  defines "\<delta>A \<equiv> neut_par V A"
  shows "(seq V \<delta>A \<delta>A) = \<delta>A"
proof -
  have "le V \<delta>A (seq V \<delta>A \<delta>A)" using assms delta_le_delta_seq_delta
    by blast
  moreover have "le V (seq V \<delta>A \<delta>A) \<delta>A" using assms valid_neutral_law_par [where ?V=V and ?A=A]
    by blast
  ultimately show ?thesis
    by (metis A_open CVA.valid_welldefined V_valid \<delta>A_def comb_is_element neutral_is_element valid_antisymmetry valid_elems valid_poset valid_semigroup)
qed

(* [Proposition 1 (3/3), CVA] *)
proposition epsilon_par_epsilon_eq_epsilon [simp] :
  fixes V :: "('A, 'a) CVA" and A :: "'A Open"
  assumes V_valid : "valid V" and A_open : "A \<in> opens (space V)"
  defines "\<epsilon>A \<equiv> neut_seq V A"
  shows "(par V \<epsilon>A \<epsilon>A) = \<epsilon>A"
proof -
  have "le V (par V \<epsilon>A \<epsilon>A) \<epsilon>A" using assms epsilon_par_epsilon_le_epsilon
    by blast
  moreover have "le V \<epsilon>A (par V \<epsilon>A \<epsilon>A)" using assms valid_neutral_law_seq [where ?V=V and ?A=A]
    by blast
  ultimately show ?thesis
    by (metis A_open CVA.valid_welldefined V_valid \<epsilon>A_def comb_is_element neutral_is_element valid_antisymmetry valid_elems valid_poset valid_semigroup)
qed

(* [Proposition 2, CVA] *)
proposition comparitor :
  fixes V :: "('A, 'a) CVA" and a b :: "('A,'a) Valuation"
  assumes V_valid : "valid V"
  and a_elem : "a \<in> elems V" and b_elem : "b \<in> elems V"
  and neutral_collapse : "neut_par V = neut_seq V"
  and strongly_neutral_seq: "is_strongly_neutral (seq_algebra V)"
  shows "le V (seq V a b) (par V a b)"
proof -
  define "A" where "A = d a"
  define "B" where "B = d b"
  define "pc" where "pc = par V"
  define "sc" where "sc = seq V"
  define "\<gamma>" where "\<gamma> = neut_par V"
  have "A \<union> B \<in> opens (space V)"
    by (metis A_def B_def CVA.valid_welldefined V_valid a_elem b_elem comb_is_element d_elem_is_open fst_conv neutral_is_element strongly_neutral_seq)
  moreover have "a = pc a (\<gamma> A)"
    by (metis pc_def A_def CVA.valid_welldefined V_valid \<gamma>_def a_elem valid_neutral_law_right)
  moreover have "b = pc (\<gamma> B) b" using pc_def B_def CVA.valid_welldefined V_valid \<gamma>_def b_elem
    by (metis (no_types, lifting) valid_neutral_law_left)
  moreover have "sc a b = sc (pc a (\<gamma> A)) (pc (\<gamma> B) b)"
    using \<open>b = pc (\<gamma> B) b\<close> calculation by presburger
  moreover have "le V (sc (pc a (\<gamma> A)) (pc (\<gamma> B) b)) (pc (sc a (\<gamma> B)) (sc (\<gamma> A) b))"
    by (metis (no_types, lifting) A_def B_def CVA.valid_welldefined V_valid \<gamma>_def a_elem b_elem d_elem_is_open neutral_is_element pc_def sc_def valid_weak_exchange)
  moreover have "d (sc a (\<gamma> B)) = A \<union> B"
    by (metis (no_types, lifting) A_def B_def CVA.valid_welldefined V_valid \<gamma>_def a_elem b_elem d_elem_is_open fst_conv neutral_is_element sc_def valid_domain_law valid_elems)
  moreover have "sc a (\<gamma> B) = sc (sc a (\<gamma> B)) (\<gamma> (A \<union> B))"using assms valid_neutral_law_right
    by (metis (no_types, lifting) B_def CVA.valid_welldefined \<gamma>_def calculation(6) comb_is_element d_elem_is_open neutral_is_element sc_def valid_elems)
  moreover have "... = sc a (sc (\<gamma> B) (\<gamma> (A \<union> B)))"
    by (metis (no_types, lifting) B_def CVA.valid_welldefined V_valid \<gamma>_def a_elem b_elem calculation(1) d_elem_is_open neutral_is_element sc_def valid_comb_associative valid_elems)
  moreover have "... = sc a (\<gamma> (A \<union> B))"
    by (metis B_def CVA.valid_welldefined Int_Un_eq(2) Un_Int_eq(4) V_valid \<gamma>_def assms(5) b_elem calculation(1) d_elem_is_open neutral_collapse sc_def)
  moreover have "... = OVA.ext (seq_algebra V) (A \<union> B) a"  using assms calculation OVA.symmetric_ext [where ?V="seq_algebra V"]
    by (metis (mono_tags, lifting) A_def CVA.valid_welldefined \<gamma>_def sc_def sup_ge1 valid_elems)
  moreover have "... = pc a (\<gamma> (A \<union> B))"
    by (metis A_def CVA.valid_welldefined \<gamma>_def assms(1) assms(2) calculation(1) pc_def sup_ge1 symmetric_ext valid_ext)
  moreover have "sc (\<gamma> A) b = sc (\<gamma> (A \<union> B)) (sc (\<gamma> A) b)"  using assms valid_neutral_law_left
      [where ?V="seq_algebra V"]
    by (smt (verit) A_def B_def CVA.valid_welldefined \<gamma>_def comb_is_element d_elem_is_open d_neut neutral_is_element sc_def valid_domain_law valid_elems)
  moreover have "... = sc (sc (\<gamma> (A \<union> B)) (\<gamma> A)) b"
    by (metis (no_types, lifting) A_def CVA.valid_welldefined V_valid \<gamma>_def a_elem b_elem calculation(1) d_elem_is_open neutral_is_element sc_def valid_comb_associative valid_elems)
  moreover have "... = sc (\<gamma> (A \<union> B)) b" using \<gamma>_def neutral_collapse sc_def strongly_neutral_seq sup_commute
    by (metis (no_types, lifting) A_def CVA.valid_welldefined Int_Un_eq(4) V_valid a_elem calculation(1) d_elem_is_open inf_sup_absorb)
  moreover have "... =   OVA.ext (seq_algebra V) (A \<union> B) b"
    by (metis B_def CVA.valid_welldefined V_valid \<gamma>_def b_elem calculation(1) ext_def neutral_collapse sc_def sup_ge2 valid_elems)
  moreover have "... = ext V (A \<union> B) b"
    by (metis B_def V_valid b_elem calculation(1) sup_ge2 valid_ext)
  moreover have "... = pc (\<gamma> (A \<union> B)) b" using pc_def \<gamma>_def A_def B_def b_elem OVA.ext_def [where
        ?V="par_algebra V" and ?A="A \<union> B" and ?b=b]
    using calculation(1) by force
  moreover have "pc (sc a (\<gamma> B)) (sc (\<gamma> A) b) = pc (pc a (\<gamma> (A \<union> B))) ( pc (\<gamma> (A \<union> B)) b)"
    using calculation(10) calculation(11) calculation(12) calculation(13) calculation(14) calculation(15) calculation(16) calculation(17) calculation(7) calculation(8) calculation(9) by presburger
  moreover have "... =   pc a (pc (\<gamma> (A \<union> B)) ( pc (\<gamma> (A \<union> B)) b))" using valid_comb_associative
    by (metis (no_types, lifting) CVA.valid_welldefined V_valid \<gamma>_def a_elem b_elem calculation(1) comb_is_element neutral_is_element pc_def)
  moreover have "... =   pc a (pc (\<gamma> (A \<union> B)) b)"
    by (metis B_def CVA.valid_welldefined V_valid \<gamma>_def b_elem calculation(1) calculation(17) d_ext ext_elem inf_sup_ord(4) pc_def valid_neutral_law_left)
  moreover have "... =   pc a (pc b (\<gamma> (A \<union> B)))"
    by (metis CVA.valid_welldefined V_valid \<gamma>_def b_elem calculation(1) neutral_is_element pc_def valid_commutativity)
moreover have "... =   pc a b"
  by (metis (no_types, lifting) A_def B_def CVA.valid_welldefined V_valid \<gamma>_def assms(2) b_elem calculation(1) comb_is_element neutral_is_element pc_def valid_comb_associative valid_domain_law valid_neutral_law_right)
  ultimately show ?thesis
    by (metis pc_def sc_def)
qed

lemma neutral_collapse_strongly_neutral :
  fixes V :: "('A, 'a) CVA"
  assumes V_valid : "valid V"
  and neutral_collapse : "neut_par V = neut_seq V"
shows "is_strongly_neutral (par_algebra V) \<longleftrightarrow> is_strongly_neutral (seq_algebra V)"
proof (standard)
  define "pc" where "pc = par V"
  define "sc" where "sc = seq V"
  define "\<gamma>" where "\<gamma> = neut_par V"

  assume "is_strongly_neutral (par_algebra V)"
  show "is_strongly_neutral (seq_algebra V)"
  proof (safe)
    fix A B
    assume A_open: "A \<in> opens (OVA.space (seq_algebra V))"
    assume B_open: "B \<in> opens (OVA.space (seq_algebra V))"
    have "A \<union> B \<in> opens (space V)"
        by (metis A_open B_open CVA.valid_welldefined V_valid comb_is_element d_elem_is_open d_neut neutral_is_element valid_domain_law)
    moreover have "d (sc (\<gamma> A) (\<gamma> B)) = A \<union> B"
      using A_open B_open CVA.valid_welldefined V_valid \<gamma>_def neutral_is_element sc_def valid_elems by fastforce
    moreover have "sc (\<gamma> A) (\<gamma> B) = sc  (\<gamma> (A \<union> B)) (sc (\<gamma> A) (\<gamma> B))"
      by (metis A_open B_open CVA.valid_welldefined V_valid \<gamma>_def calculation(2) comb_is_element neutral_collapse neutral_is_element sc_def valid_neutral_law_left)
    moreover have "... = sc (sc  (\<gamma> (A \<union> B)) (\<gamma> A)) (\<gamma> B)"
      by (metis (no_types, lifting) A_open B_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) neutral_is_element sc_def valid_comb_associative valid_elems)
    moreover have "... = sc (ext V (A \<union> B) (\<gamma> A)) (\<gamma> B)"
      by (metis (no_types, lifting) A_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) d_neut ext_def local.neutral_collapse neutral_is_element sc_def sup_ge1 valid_ext)
    moreover have "... = sc (pc (\<gamma> (A \<union> B)) (\<gamma> A)) (\<gamma> B)"
        by (metis (no_types, lifting) A_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) d_neut ext_def neutral_is_element pc_def sup_ge1)
    moreover have "... = sc (\<gamma> (A \<union> B)) (\<gamma> B)"
      by (metis A_open CVA.valid_welldefined Int_Un_eq(4) Un_Int_eq(3) V_valid \<gamma>_def \<open>\<forall>A B. A \<in> opens (OVA.space (par_algebra V)) \<longrightarrow> B \<in> opens (OVA.space (par_algebra V)) \<longrightarrow> par V (neut_par V A) (neut_par V B) = neut_par V (A \<union> B)\<close> calculation(1) pc_def)
    moreover have "... = ext V (A \<union> B) (\<gamma> B)"
      by (metis (no_types, lifting) B_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) d_neut ext_def local.neutral_collapse neutral_is_element sc_def sup_ge2 valid_ext)
    moreover have "... = \<gamma> (A \<union> B)"
      using B_open CVA.valid_welldefined V_valid \<gamma>_def strongly_neutral_covariance sup_ge2
      using \<open>\<forall>A B. A \<in> opens (OVA.space (par_algebra V)) \<longrightarrow> B \<in> opens (OVA.space (par_algebra V)) \<longrightarrow> par V (neut_par V A) (neut_par V B) = neut_par V (A \<union> B)\<close> calculation(1) by fastforce
    ultimately have "sc (\<gamma> A) (\<gamma> B) = \<gamma> (A \<union> B)"
      by presburger
    thus "seq V (neut_seq V A) (neut_seq V B) = neut_seq V (A \<union> B)"  unfolding sc_def
        \<gamma>_def neutral_collapse .
  qed
next
  define "pc" where "pc = par V"
  define "sc" where "sc = seq V"
  define "\<gamma>" where "\<gamma> = neut_par V"

  assume "is_strongly_neutral (seq_algebra V)"
  show "is_strongly_neutral (par_algebra V)"
  proof (safe)
    fix A B
    assume A_open: "A \<in> opens (OVA.space (par_algebra V))"
    assume B_open: "B \<in> opens (OVA.space (par_algebra V))"

    have "A \<union> B \<in> opens (space V)"
      by (metis A_open B_open CVA.valid_welldefined V_valid comb_is_element d_elem_is_open d_neut neutral_is_element valid_domain_law)
    moreover have "d (pc (\<gamma> A) (\<gamma> B)) = A \<union> B"
      by (metis A_open B_open CVA.valid_welldefined V_valid \<gamma>_def d_neut neutral_is_element pc_def valid_domain_law)
    moreover have "pc (\<gamma> A) (\<gamma> B) = pc  (\<gamma> (A \<union> B)) (pc (\<gamma> A) (\<gamma> B))"
      by (metis A_open B_open CVA.valid_welldefined V_valid \<gamma>_def calculation(2) comb_is_element neutral_is_element pc_def valid_neutral_law_left)
    moreover have "... = pc (pc  (\<gamma> (A \<union> B)) (\<gamma> A)) (\<gamma> B)"
      using A_open B_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) neutral_is_element pc_def valid_comb_associative by fastforce
    moreover have "... = pc (ext V (A \<union> B) (\<gamma> A)) (\<gamma> B)"
      by (metis (no_types, lifting) A_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) d_neut ext_def neutral_is_element pc_def sup_ge1)
    moreover have "... = pc (OVA.ext (seq_algebra V) (A \<union> B) (\<gamma> A)) (\<gamma> B)"
      by (metis A_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) d_neut neutral_is_element sup_ge1 valid_ext)
    moreover have "... = pc (sc (\<gamma> (A \<union> B)) (\<gamma> A)) (\<gamma> B)"
      by (metis (no_types, lifting) A_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) d_neut ext_def local.neutral_collapse neutral_is_element sc_def sup_ge1)
    moreover have "... = pc (\<gamma> (A \<union> B)) (\<gamma> B)"
      by (metis A_open CVA.valid_welldefined Int_Un_eq(4) Un_Int_eq(3) V_valid \<gamma>_def \<open>\<forall>A B. A \<in> opens (OVA.space (seq_algebra V)) \<longrightarrow> B \<in> opens (OVA.space (seq_algebra V)) \<longrightarrow> seq V (neut_seq V A) (neut_seq V B) = neut_seq V (A \<union> B)\<close> calculation(1) neutral_collapse sc_def)
    moreover have "... = ext V (A \<union> B) (\<gamma> B)" using A_open B_open CVA.valid_welldefined V_valid d_neut neutral_is_element  ext_def [where
          ?V="par_algebra V"]
      by (metis \<gamma>_def calculation(1) pc_def sup_ge2)
    moreover have "d (pc (\<gamma> A) (\<gamma> B)) = A \<union> B"
      by (metis A_open B_open CVA.valid_welldefined V_valid \<gamma>_def d_neut neutral_is_element pc_def valid_domain_law)
    moreover have "pc (\<gamma> A) (\<gamma> B) = pc  (\<gamma> (A \<union> B)) (pc (\<gamma> A) (\<gamma> B))"
      by (metis A_open B_open CVA.valid_welldefined V_valid \<gamma>_def calculation(2) comb_is_element neutral_is_element pc_def valid_neutral_law_left)
    moreover have "... = pc (pc  (\<gamma> (A \<union> B)) (\<gamma> A)) (\<gamma> B)"
      using A_open B_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) neutral_is_element pc_def valid_comb_associative by fastforce
    moreover have "... = pc (ext V (A \<union> B) (\<gamma> A)) (\<gamma> B)"
      by (metis (no_types, lifting) A_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) d_neut ext_def neutral_is_element pc_def sup_ge1)
    moreover have "... = pc (OVA.ext (seq_algebra V) (A \<union> B) (\<gamma> A)) (\<gamma> B)"
      by (metis A_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) d_neut neutral_is_element sup_ge1 valid_ext)
      moreover have "... = pc (sc (\<gamma> (A \<union> B)) (\<gamma> A)) (\<gamma> B)"
        by (metis (no_types, lifting) A_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) d_neut ext_def local.neutral_collapse neutral_is_element sc_def sup_ge1)
      moreover have "... = pc (\<gamma> (A \<union> B)) (\<gamma> B)"
        using calculation(8) by blast
    moreover have "... = ext V (A \<union> B) (\<gamma> B)"
      by (metis (no_types, lifting) B_open CVA.valid_welldefined V_valid \<gamma>_def calculation(1) d_neut ext_def neutral_is_element pc_def sup_commute sup_ge1)
    moreover have "... = \<gamma> (A \<union> B)"
      by (smt (verit, ccfv_threshold) B_open CVA.valid_welldefined V_valid \<gamma>_def \<open>\<forall>A B. A \<in> opens (OVA.space (seq_algebra V)) \<longrightarrow> B \<in> opens (OVA.space (seq_algebra V)) \<longrightarrow> seq V (neut_seq V A) (neut_seq V B) = neut_seq V (A \<union> B)\<close> calculation(1) d_neut neutral_collapse neutral_is_element strongly_neutral_covariance sup_ge2 valid_ext)
    ultimately have "pc (\<gamma> A) (\<gamma> B) = \<gamma> (A \<union> B)"
      by presburger
    thus "par V (neut_par V A) (neut_par V B) = neut_par V (A \<union> B)"  unfolding pc_def
        \<gamma>_def .
  qed
qed

(* [Proposition 3, CVA] *)
proposition hoare_concurrency_rule  :
  fixes V :: "('A, 'a) CVA" and p p' a a' q q' :: "('A,'a) Valuation"
  assumes V_valid : "valid V"
  and "p \<in> elems V" and "p' \<in> elems V" and "a \<in> elems V" and "a' \<in> elems V" and "q \<in> elems V" and "q' \<in> elems V"
  and "hoare V p a q" and "hoare V p' a' q'"
  shows "hoare V (par V p p') (par V a a') (par V q q')"
proof -
  define "sc" where "sc = seq V"
  define "pc" where "pc = par V"
  define "gl" where "gl = le V"
  have "gl (sc p a) q"
    using assms(8) gl_def sc_def by blast
  moreover have "gl (sc p' a') q'"
    using assms(9) gl_def sc_def by blast
  moreover have "gl  (sc (pc p p') (pc a a')) (pc (sc p a) (sc p' a'))"
    using V_valid assms(2) assms(3) assms(4) assms(5) gl_def pc_def sc_def valid_weak_exchange by blast
moreover have "gl (pc (sc p a) (sc p' a')) (pc q q')"
  by (smt (verit, ccfv_threshold) CVA.valid_welldefined V_valid assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) assms(8) assms(9) comb_is_element gl_def pc_def sc_def valid_elems valid_monotone valid_semigroup)
  ultimately show ?thesis
    by (smt (verit, ccfv_threshold) CVA.valid_welldefined V_valid assms(2) assms(3) assms(4) assms(5) assms(6) assms(7) comb_is_element gl_def pc_def sc_def valid_elems valid_poset valid_semigroup valid_transitivity)
qed

end