(* Title:      Nonstrict Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Nonstrict Binary Iterings\<close>

theory Binary_Iterings_Nonstrict

imports Omega_Algebras Binary_Iterings

begin

class nonstrict_itering = bounded_left_zero_omega_algebra + while +
  assumes while_def: "x \<star> y = x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y"
begin

text \<open>Theorem 8.2\<close>

subclass bounded_binary_itering
proof (unfold_locales)
  fix x y z
  show "(x * y) \<star> z = z \<squnion> x * ((y * x) \<star> (y * z))"
    by (metis sup_commute mult_assoc mult_left_dist_sup omega_loop_fixpoint omega_slide star.circ_slide while_def)
next
  fix x y z
  show "(x \<squnion> y) \<star> z = (x \<star> y) \<star> (x \<star> z)"
  proof -
    have 1: "(x \<squnion> y) \<star> z = (x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z)"
      using mult_left_dist_sup omega_decompose star.circ_sup_9 sup_assoc while_def mult_assoc by auto
    hence 2: "(x \<squnion> y) \<star> z \<le> (x \<star> y) \<star> (x \<star> z)"
      by (smt sup_mono sup_ge2 le_iff_sup mult_left_isotone omega_sub_dist star.circ_sub_dist while_def)
    let ?rhs = "x\<^sup>\<star> * y * ((x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z)) \<squnion> (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z)"
    have "x\<^sup>\<omega> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<omega> \<le> x\<^sup>\<omega>"
      by (simp add: omega_sub_vector)
    hence "x\<^sup>\<omega> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<omega> \<le> ?rhs"
      by (smt sup_commute sup_mono sup_ge1 mult_left_dist_sup order_trans)
    hence 3: "(x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<omega> \<le> ?rhs"
      by (metis mult_right_dist_sup omega_unfold)
    have "x\<^sup>\<omega> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z) \<le> x\<^sup>\<omega>"
      by (simp add: omega_mult_star_2 omega_sub_vector)
    hence "x\<^sup>\<omega> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z) \<squnion> x\<^sup>\<star> * y * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z) \<le> ?rhs"
      by (smt sup_commute sup_mono sup_ge2 mult_assoc mult_left_dist_sup order_trans)
    hence "(x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z) \<le> ?rhs"
      by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_right_dist_sup star.circ_loop_fixpoint)
    hence "(x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z) \<le> ?rhs"
      using 3 by simp
    hence "(x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z) \<le> (x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z)"
      by (metis sup_commute omega_induct)
    thus ?thesis
      using 1 2 order.antisym while_def by force
  qed
next
  fix x y z
  show "x \<star> (y \<squnion> z) = (x \<star> y) \<squnion> (x \<star> z)"
    using mult_left_dist_sup sup_assoc sup_commute while_def by auto
next
  fix x y z
  show "(x \<star> y) * z \<le> x \<star> (y * z)"
    using mult_semi_associative omega_sub_vector semiring.add_mono semiring.distrib_right while_def by fastforce
next
  fix v w x y z
  show "x * z \<le> z * (y \<star> 1) \<squnion> w \<longrightarrow> x \<star> (z * v) \<le> z * (y \<star> v) \<squnion> (x \<star> (w * (y \<star> v)))"
  proof
    assume "x * z \<le> z * (y \<star> 1) \<squnion> w"
    hence 1: "x * z \<le> z * y\<^sup>\<omega> \<squnion> z * y\<^sup>\<star> \<squnion> w"
      by (metis mult_left_dist_sup mult_1_right while_def)
    let ?rhs = "z * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v) \<squnion> x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * w * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v)"
    have 2: "z * v \<le> ?rhs"
      by (metis le_supI1 mult_left_sub_dist_sup_right omega_loop_fixpoint)
    have "x * z * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v) \<le> ?rhs"
    proof -
      have "x * z * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v) \<le> (z * y\<^sup>\<omega> \<squnion> z * y\<^sup>\<star> \<squnion> w) * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v)"
        using 1 mult_left_isotone by auto
      also have "... = z * (y\<^sup>\<omega> * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v) \<squnion> y\<^sup>\<star> * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v)) \<squnion> w * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v)"
        by (smt mult_assoc mult_left_dist_sup mult_right_dist_sup)
      also have "... = z * (y\<^sup>\<omega> * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v) \<squnion> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v) \<squnion> w * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v)"
        by (smt sup_assoc mult_assoc mult_left_dist_sup star.circ_transitive_equal star_mult_omega)
      also have "... \<le> z * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v) \<squnion> x\<^sup>\<star> * w * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * v)"
        by (smt sup_commute sup_mono sup_left_top mult_left_dist_sup mult_left_one mult_right_dist_sup mult_right_sub_dist_sup_left omega_vector order_refl star.circ_plus_one)
      finally show ?thesis
        by (smt sup_assoc sup_commute le_iff_sup)
    qed
    hence "x * ?rhs \<le> ?rhs"
      by (smt sup_assoc sup_commute sup_ge1 le_iff_sup mult_assoc mult_left_dist_sup mult_right_dist_sup omega_unfold star.circ_increasing star.circ_transitive_equal)
    hence "z * v \<squnion> x * ?rhs \<le> ?rhs"
      using 2 le_supI by blast
    hence "x\<^sup>\<star> * z * v \<le> ?rhs"
      by (simp add: star_left_induct mult_assoc)
    hence "x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * z * v \<le> ?rhs"
      by (meson order_trans sup_ge1 sup_ge2 sup_least)
    thus "x \<star> (z * v) \<le> z * (y \<star> v) \<squnion> (x \<star> (w * (y \<star> v)))"
      by (simp add: sup_assoc while_def mult_assoc)
  qed
next
  fix v w x y z
  show "z * x \<le> y * (y \<star> z) \<squnion> w \<longrightarrow> z * (x \<star> v) \<le> y \<star> (z * v \<squnion> w * (x \<star> v))"
  proof
    assume "z * x \<le> y * (y \<star> z) \<squnion> w"
    hence "z * x \<le> y * (y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z) \<squnion> w"
      by (simp add: while_def)
    hence 1: "z * x \<le> y\<^sup>\<omega> \<squnion> y * y\<^sup>\<star> * z \<squnion> w"
      using mult_left_dist_sup omega_unfold mult_assoc by auto
    let ?rhs = "y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z * v \<squnion> y\<^sup>\<star> * w * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * v)"
    have 2: "z * x\<^sup>\<omega> \<le> ?rhs"
    proof -
      have "z * x\<^sup>\<omega> \<le> y * y\<^sup>\<star> * z * x\<^sup>\<omega> \<squnion> y\<^sup>\<omega> * x\<^sup>\<omega> \<squnion> w * x\<^sup>\<omega>"
        using 1 by (smt sup_commute le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
      also have "... \<le> y * y\<^sup>\<star> * z * x\<^sup>\<omega> \<squnion> y\<^sup>\<omega> \<squnion> w * x\<^sup>\<omega>"
        using omega_sub_vector semiring.add_mono by blast
      also have "... = y * y\<^sup>\<star> * (z * x\<^sup>\<omega>) \<squnion> (y\<^sup>\<omega> \<squnion> w * x\<^sup>\<omega>)"
        by (simp add: sup_assoc mult_assoc)
      finally have "z * x\<^sup>\<omega> \<le> (y * y\<^sup>\<star>)\<^sup>\<omega> \<squnion> (y * y\<^sup>\<star>)\<^sup>\<star> * (y\<^sup>\<omega> \<squnion> w * x\<^sup>\<omega>)"
        by (simp add: omega_induct sup_commute)
      also have "... = y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega>"
        by (simp add: left_plus_omega semiring.distrib_left star.left_plus_circ star_mult_omega mult_assoc)
      also have "... \<le> ?rhs"
        using mult_left_sub_dist_sup_left sup.mono sup_ge1 by blast
      finally show ?thesis
        .
    qed
    let ?rhs2 = "y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star>)"
    have "?rhs2 * x \<le> ?rhs2"
    proof -
      have 3: "y\<^sup>\<omega> * x \<le> ?rhs2"
        by (simp add: le_supI1 omega_sub_vector)
      have "y\<^sup>\<star> * z * x \<le> y\<^sup>\<star> * (y\<^sup>\<omega> \<squnion> y * y\<^sup>\<star> * z \<squnion> w)"
        using 1 mult_right_isotone mult_assoc by auto
      also have "... = y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * y * y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w"
        by (simp add: semiring.distrib_left star_mult_omega mult_assoc)
      also have "... = y\<^sup>\<omega> \<squnion> y * y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w"
        by (simp add: star.circ_plus_same star.circ_transitive_equal mult_assoc)
      also have "... \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w"
        by (metis sup_left_isotone sup_right_isotone mult_left_isotone star.left_plus_below_circ)
      also have "... \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
        using semiring.add_left_mono star.circ_back_loop_prefixpoint by auto
      finally have 4: "y\<^sup>\<star> * z * x \<le> ?rhs2"
        using mult_left_sub_dist_sup_right order_lesseq_imp semiring.add_left_mono by blast
      have "(x\<^sup>\<omega> \<squnion> x\<^sup>\<star>) * x \<le> x\<^sup>\<omega> \<squnion> x\<^sup>\<star>"
        using omega_sub_vector semiring.distrib_right star.left_plus_below_circ star_plus sup_mono by fastforce
      hence "y\<^sup>\<star> * w * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star>) * x \<le> ?rhs2"
        by (simp add: le_supI2 mult_right_isotone mult_assoc)
      thus ?thesis
        using 3 4 mult_right_dist_sup by force
    qed
    hence "z \<squnion> ?rhs2 * x \<le> ?rhs2"
      by (metis omega_loop_fixpoint sup.boundedE sup_ge1 sup_least)
    hence 5: "z * x\<^sup>\<star> \<le> ?rhs2"
      using star_right_induct by blast
    have "z * x\<^sup>\<star> * v \<le> ?rhs"
    proof -
      have "z * x\<^sup>\<star> * v \<le> ?rhs2 * v"
        using 5 mult_left_isotone by auto
      also have "... = y\<^sup>\<omega> * v \<squnion> y\<^sup>\<star> * z * v \<squnion> y\<^sup>\<star> * w * (x\<^sup>\<omega> * v \<squnion> x\<^sup>\<star> * v)"
        using mult_right_dist_sup mult_assoc by auto
      also have "... \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * z * v \<squnion> y\<^sup>\<star> * w * (x\<^sup>\<omega> * v \<squnion> x\<^sup>\<star> * v)"
        using omega_sub_vector semiring.add_right_mono by blast
      also have "... \<le> ?rhs"
        using mult_right_isotone omega_sub_vector semiring.add_left_mono semiring.add_right_mono by auto
      finally show ?thesis
        .
    qed
    hence "z * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * v) \<le> ?rhs"
      using 2 semiring.distrib_left mult_assoc by force
    thus "z * (x \<star> v) \<le> y \<star> (z * v \<squnion> w * (x \<star> v))"
      by (simp add: semiring.distrib_left sup_assoc while_def mult_assoc)
  qed
qed

text \<open>Theorem 13.8\<close>

lemma while_top:
  "top \<star> x = top"
  by (metis sup_left_top star.circ_top star_omega_top while_def)

text \<open>Theorem 13.7\<close>

lemma while_one_top:
  "1 \<star> x = top"
  by (simp add: omega_one while_def)

lemma while_finite_associative:
  "x\<^sup>\<omega> = bot \<Longrightarrow> (x \<star> y) * z = x \<star> (y * z)"
  by (simp add: while_def mult_assoc)

lemma star_below_while:
  "x\<^sup>\<star> * y \<le> x \<star> y"
  by (simp add: while_def)

text \<open>Theorem 13.9\<close>

lemma while_sub_mult_one:
  "x * (1 \<star> y) \<le> 1 \<star> x"
  by (simp add: omega_one while_def)

lemma while_while_one:
  "y \<star> (x \<star> 1) = y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x\<^sup>\<omega> \<squnion> y\<^sup>\<star> * x\<^sup>\<star>"
  using mult_left_dist_sup sup_assoc while_def by auto

lemma while_simulate_4_plus:
  assumes "y * x \<le> x * (x \<star> (1 \<squnion> y))"
    shows "y * x * x\<^sup>\<star> \<le> x * (x \<star> (1 \<squnion> y))"
proof -
  have 1: "x * (x \<star> (1 \<squnion> y)) = x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y"
    using mult_left_dist_sup omega_unfold sup_assoc while_def mult_assoc by force
  hence "y * x * x\<^sup>\<star> \<le> (x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y) * x\<^sup>\<star>"
    using assms mult_left_isotone by auto
  also have "... = x\<^sup>\<omega> * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y * x\<^sup>\<star>"
    using mult_right_dist_sup by force
  also have "... = x * x\<^sup>\<star> * (y * x * x\<^sup>\<star>) \<squnion> x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y"
    by (smt sup_assoc sup_commute mult_assoc omega_mult_star_2 star.circ_back_loop_fixpoint star.circ_plus_same star.circ_transitive_equal)
  finally have "y * x * x\<^sup>\<star> \<le> x * x\<^sup>\<star> * (y * x * x\<^sup>\<star>) \<squnion> (x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y)"
    using sup_assoc by force
  hence "y * x * x\<^sup>\<star> \<le> (x * x\<^sup>\<star>)\<^sup>\<omega> \<squnion> (x * x\<^sup>\<star>)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y)"
    by (simp add: omega_induct sup_monoid.add_commute)
  also have "... = x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y)"
    by (simp add: left_plus_omega star.left_plus_circ)
  finally show ?thesis
    using 1 by (metis while_def while_mult_star_exchange while_transitive)
qed

lemma while_simulate_4_omega:
  assumes "y * x \<le> x * (x \<star> (1 \<squnion> y))"
    shows "y * x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
proof -
  have "x * (x \<star> (1 \<squnion> y)) = x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y"
    using mult_1_right mult_left_dist_sup omega_unfold sup_assoc while_def mult_assoc by auto
  hence "y * x\<^sup>\<omega> \<le> (x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y) * x\<^sup>\<omega>"
    by (smt assms le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
  also have "... = x\<^sup>\<omega> * x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> * x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> * y * x\<^sup>\<omega>"
    using semiring.distrib_right by auto
  also have "... = x * x\<^sup>\<star> * (y * x\<^sup>\<omega>) \<squnion> x\<^sup>\<omega>"
    by (metis sup_commute le_iff_sup mult_assoc omega_sub_vector omega_unfold star_mult_omega)
  finally have "y * x\<^sup>\<omega> \<le> x * x\<^sup>\<star> * (y * x\<^sup>\<omega>) \<squnion> x\<^sup>\<omega>"
    .
  hence "y * x\<^sup>\<omega> \<le> (x * x\<^sup>\<star>)\<^sup>\<omega> \<squnion> (x * x\<^sup>\<star>)\<^sup>\<star> * x\<^sup>\<omega>"
    by (simp add: omega_induct sup_commute)
  thus ?thesis
    by (metis sup_idem left_plus_omega star_mult_omega)
qed

text \<open>Theorem 13.11\<close>

lemma while_unfold_below:
  "x = z \<squnion> y * x \<Longrightarrow> x \<le> y \<star> z"
  by (simp add: omega_induct while_def)

text \<open>Theorem 13.12\<close>

lemma while_unfold_below_sub:
  "x \<le> z \<squnion> y * x \<Longrightarrow> x \<le> y \<star> z"
  by (simp add: omega_induct while_def)

text \<open>Theorem 13.10\<close>

lemma while_unfold_below_1:
  "x = y * x \<Longrightarrow> x \<le> y \<star> 1"
  by (simp add: while_unfold_below_sub)

lemma while_square_1:
  "x \<star> 1 = (x * x) \<star> (x \<squnion> 1)"
  by (metis mult_1_right omega_square star_square_2 while_def)

lemma while_absorb_below_one:
  "y * x \<le> x \<Longrightarrow> y \<star> x \<le> 1 \<star> x"
  by (simp add: while_unfold_below_sub)

lemma while_loop_is_greatest_postfixpoint:
  "is_greatest_postfixpoint (\<lambda>x . y * x \<squnion> z) (y \<star> z)"
proof -
  have "(y \<star> z) \<le> (\<lambda>x . y * x \<squnion> z) (y \<star> z)"
    using sup_commute while_left_unfold by force
  thus ?thesis
    by (simp add: is_greatest_postfixpoint_def sup_commute while_unfold_below_sub)
qed

lemma while_loop_is_greatest_fixpoint:
  "is_greatest_fixpoint (\<lambda>x . y * x \<squnion> z) (y \<star> z)"
  by (simp add: omega_loop_is_greatest_fixpoint while_def)

proposition while_sumstar_4_below: "(x \<star> y) \<star> ((x \<star> 1) * z) \<le> x \<star> ((y * (x \<star> 1)) \<star> z)" nitpick [expect=genuine,card=6] oops
proposition while_sumstar_2: "(x \<squnion> y) \<star> z = x \<star> ((y * (x \<star> 1)) \<star> z)" nitpick [expect=genuine,card=6] oops
proposition while_sumstar_3: "(x \<squnion> y) \<star> z = ((x \<star> 1) * y) \<star> (x \<star> z)" oops
proposition while_decompose_6: "x \<star> ((y * (x \<star> 1)) \<star> z) = y \<star> ((x * (y \<star> 1)) \<star> z)" nitpick [expect=genuine,card=6] oops
proposition while_finite_associative: "x \<star> bot = bot \<Longrightarrow> (x \<star> y) * z = x \<star> (y * z)" oops
proposition atomicity_refinement: "s = s * q \<Longrightarrow> x = q * x \<Longrightarrow> q * b = bot \<Longrightarrow> r * b \<le> b * r \<Longrightarrow> r * l \<le> l * r \<Longrightarrow> x * l \<le> l * x \<Longrightarrow> b * l \<le> l * b \<Longrightarrow> q * l \<le> l * q \<Longrightarrow> r \<star> q \<le> q * (r \<star> 1) \<Longrightarrow> q \<le> 1 \<Longrightarrow> s * ((x \<squnion> b \<squnion> r \<squnion> l) \<star> (q * z)) \<le> s * ((x * (b \<star> q) \<squnion> r \<squnion> l) \<star> z)" oops

proposition while_separate_right_plus: "y * x \<le> x * (x \<star> (1 \<squnion> y)) \<squnion> 1 \<Longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)" oops
proposition "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1) \<Longrightarrow> (x \<squnion> y) \<star> 1 = x \<star> (y \<star> 1)" oops
proposition "y * x \<le> (1 \<squnion> x) * (y \<star> 1) \<Longrightarrow> (x \<squnion> y) \<star> 1 = x \<star> (y \<star> 1)" oops

proposition while_mult_sub_while_while: "x \<star> (y * z) \<le> (x \<star> y) \<star> z" oops
proposition while_zero_zero: "(x \<star> bot) \<star> bot = x \<star> bot" oops
proposition while_denest_3: "(x \<star> w) \<star> (x \<star> bot) = (x \<star> w) \<star> bot" oops
proposition while_02: "x \<star> ((x \<star> w) \<star> ((x \<star> y) * z)) = (x \<star> w) \<star> ((x \<star> y) * z)" oops
proposition while_sumstar_3_below: "(x \<star> y) \<star> (x \<star> z) \<le> (x \<star> y) \<star> ((x \<star> 1) * z)" oops
proposition while_sumstar_1: "(x \<squnion> y) \<star> z = (x \<star> y) \<star> ((x \<star> 1) * z)" oops
proposition while_denest_4: "(x \<star> w) \<star> (x \<star> (y * z)) = (x \<star> w) \<star> ((x \<star> y) * z)" oops

end

class nonstrict_itering_zero = nonstrict_itering +
  assumes mult_right_zero: "x * bot = bot"
begin

lemma while_finite_associative_2:
  "x \<star> bot = bot \<Longrightarrow> (x \<star> y) * z = x \<star> (y * z)"
  by (metis sup_bot_left sup_bot_right mult_assoc mult_right_zero while_def)

text \<open>Theorem 13 counterexamples\<close>

proposition while_mult_top: "(x * top) \<star> z = z \<squnion> x * top" nitpick [expect=genuine,card=3] oops
proposition tarski_mult_top_idempotent: "x * top = x * top * x * top" nitpick [expect=genuine,card=3] oops

proposition while_denest_0: "w * (x \<star> (y * z)) \<le> (w * (x \<star> y)) \<star> (w * (x \<star> y) * z)" nitpick [expect=genuine,card=3] oops
proposition while_denest_1: "w * (x \<star> (y * z)) \<le> (w * (x \<star> y)) \<star> z" nitpick [expect=genuine,card=3] oops
proposition while_mult_zero_zero: "(x * (y \<star> bot)) \<star> bot = x * (y \<star> bot)" nitpick [expect=genuine,card=3] oops
proposition while_denest_2: "w * ((x \<star> (y * w)) \<star> z) = w * (((x \<star> y) * w) \<star> z)" nitpick [expect=genuine,card=3] oops
proposition while_denest_5: "w * ((x \<star> (y * w)) \<star> (x \<star> (y * z))) = w * (((x \<star> y) * w) \<star> ((x \<star> y) * z))" nitpick [expect=genuine,card=3] oops
proposition while_denest_6: "(w * (x \<star> y)) \<star> z = z \<squnion> w * ((x \<squnion> y * w) \<star> (y * z))" nitpick [expect=genuine,card=3] oops
proposition while_sum_below_one: "y * ((x \<squnion> y) \<star> z) \<le> (y * (x \<star> 1)) \<star> z" nitpick [expect=genuine,card=3] oops
proposition while_separate_unfold: "(y * (x \<star> 1)) \<star> z = (y \<star> z) \<squnion> (y \<star> (y * x * (x \<star> ((y * (x \<star> 1)) \<star> z))))" nitpick [expect=genuine,card=3] oops

proposition while_sub_while_zero: "x \<star> z \<le> (x \<star> y) \<star> z" nitpick [expect=genuine,card=4] oops
proposition while_while_sub_associative: "x \<star> (y \<star> z) \<le> (x \<star> y) \<star> z" nitpick [expect=genuine,card=4] oops
proposition tarski: "x \<le> x * top * x * top" nitpick [expect=genuine,card=3] oops
proposition tarski_top_omega_below: "x * top \<le> (x * top)\<^sup>\<omega>" nitpick [expect=genuine,card=3] oops
proposition tarski_top_omega: "x * top = (x * top)\<^sup>\<omega>" nitpick [expect=genuine,card=3] oops
proposition tarski_below_top_omega: "x \<le> (x * top)\<^sup>\<omega>" nitpick [expect=genuine,card=3] oops
proposition tarski_mult_omega_omega: "(x * y\<^sup>\<omega>)\<^sup>\<omega> = x * y\<^sup>\<omega>" nitpick [expect=genuine,card=3] oops
proposition tarski_mult_omega_omega: "(\<forall>z . z\<^sup>\<omega>\<^sup>\<omega> = z\<^sup>\<omega>) \<Longrightarrow> (x * y\<^sup>\<omega>)\<^sup>\<omega> = x * y\<^sup>\<omega>" nitpick [expect=genuine,card=3] oops
proposition tarski: "x = bot \<or> top * x * top = top" nitpick [expect=genuine,card=3] oops

end

class nonstrict_itering_tarski = nonstrict_itering +
  assumes tarski: "x \<le> x * top * x * top"
begin

text \<open>Theorem 13.14\<close>

lemma tarski_mult_top_idempotent:
  "x * top = x * top * x * top"
  by (metis sup_commute le_iff_sup mult_assoc star.circ_back_loop_fixpoint star.circ_left_top tarski top_mult_top)

lemma tarski_top_omega_below:
  "x * top \<le> (x * top)\<^sup>\<omega>"
  using omega_induct_mult order.refl mult_assoc tarski_mult_top_idempotent by auto

lemma tarski_top_omega:
  "x * top = (x * top)\<^sup>\<omega>"
  by (simp add: order.eq_iff mult_top_omega tarski_top_omega_below)

lemma tarski_below_top_omega:
  "x \<le> (x * top)\<^sup>\<omega>"
  using top_right_mult_increasing tarski_top_omega by auto

lemma tarski_mult_omega_omega:
  "(x * y\<^sup>\<omega>)\<^sup>\<omega> = x * y\<^sup>\<omega>"
  by (metis mult_assoc omega_vector tarski_top_omega)

lemma tarski_omega_idempotent:
  "x\<^sup>\<omega>\<^sup>\<omega> = x\<^sup>\<omega>"
  by (metis omega_vector tarski_top_omega)

lemma while_denest_2a:
  "w * ((x \<star> (y * w)) \<star> z) = w * (((x \<star> y) * w) \<star> z)"
proof -
  have "(x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * w)\<^sup>\<omega> = (x\<^sup>\<star> * y * w)\<^sup>\<star> * x\<^sup>\<omega> * (((x\<^sup>\<star> * y * w)\<^sup>\<star> * x\<^sup>\<omega>)\<^sup>\<omega> \<squnion> ((x\<^sup>\<star> * y * w)\<^sup>\<star> * x\<^sup>\<omega>)\<^sup>\<star> * (x\<^sup>\<star> * y * w)\<^sup>\<omega>) \<squnion> (x\<^sup>\<star> * y * w)\<^sup>\<omega>"
    by (metis sup_commute omega_decompose omega_loop_fixpoint)
  also have "... \<le> (x\<^sup>\<star> * y * w)\<^sup>\<star> * x\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * y * w)\<^sup>\<omega>"
    by (metis sup_left_isotone mult_assoc mult_right_isotone omega_sub_vector)
  finally have 1: "w * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * w)\<^sup>\<omega> \<le> (w * x\<^sup>\<star> * y)\<^sup>\<star> * w * x\<^sup>\<omega> \<squnion> (w * x\<^sup>\<star> * y)\<^sup>\<omega>"
    by (smt sup_commute le_iff_sup mult_assoc mult_left_dist_sup while_def while_slide)
  have "(x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * w)\<^sup>\<star> * z = (x\<^sup>\<star> * y * w)\<^sup>\<star> * x\<^sup>\<omega> * ((x\<^sup>\<star> * y * w)\<^sup>\<star> * x\<^sup>\<omega>)\<^sup>\<star> * (x\<^sup>\<star> * y * w)\<^sup>\<star> * z \<squnion> (x\<^sup>\<star> * y * w)\<^sup>\<star> * z"
    by (smt sup_commute mult_assoc star.circ_sup star.circ_loop_fixpoint)
  also have "... \<le> (x\<^sup>\<star> * y * w)\<^sup>\<star> * x\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * y * w)\<^sup>\<star> * z"
    by (smt sup_commute sup_right_isotone mult_assoc mult_right_isotone omega_sub_vector)
  finally have "w * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * w)\<^sup>\<star> * z \<le> (w * x\<^sup>\<star> * y)\<^sup>\<star> * w * x\<^sup>\<omega> \<squnion> (w * x\<^sup>\<star> * y)\<^sup>\<star> * w * z"
    by (metis mult_assoc mult_left_dist_sup mult_right_isotone star.circ_slide)
  hence "w * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * w)\<^sup>\<omega> \<squnion> w * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * w)\<^sup>\<star> * z \<le> (w * x\<^sup>\<star> * y)\<^sup>\<star> * (w * x\<^sup>\<omega>)\<^sup>\<omega> \<squnion> (w * x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (w * x\<^sup>\<star> * y)\<^sup>\<star> * w * z"
    using 1 by (smt sup_assoc sup_commute le_iff_sup mult_assoc tarski_mult_omega_omega)
  also have "... \<le> (w * x\<^sup>\<omega> \<squnion> w * x\<^sup>\<star> * y)\<^sup>\<star> * (w * x\<^sup>\<omega> \<squnion> w * x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (w * x\<^sup>\<omega> \<squnion> w * x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (w * x\<^sup>\<omega> \<squnion> w * x\<^sup>\<star> * y)\<^sup>\<star> * w * z"
    by (metis sup_mono sup_ge1 sup_ge2 mult_isotone mult_left_isotone omega_isotone star.circ_isotone)
  also have "... = (w * x\<^sup>\<omega> \<squnion> w * x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (w * x\<^sup>\<omega> \<squnion> w * x\<^sup>\<star> * y)\<^sup>\<star> * w * z"
    by (simp add: star_mult_omega)
  finally have "w * ((x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * w)\<^sup>\<omega> \<squnion> (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y * w)\<^sup>\<star> * z) \<le> w * ((x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y) * w)\<^sup>\<omega> \<squnion> w * ((x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * y) * w)\<^sup>\<star> * z"
    by (smt mult_assoc mult_left_dist_sup omega_slide star.circ_slide)
  hence 2: "w * ((x \<star> (y * w)) \<star> z) \<le> w * (((x \<star> y) * w) \<star> z)"
    by (simp add: mult_left_dist_sup while_def mult_assoc)
  have "w * (((x \<star> y) * w) \<star> z) \<le> w * ((x \<star> (y * w)) \<star> z)"
    by (simp add: mult_right_isotone while_left_isotone while_sub_associative)
  thus ?thesis
    using 2 order.antisym by auto
qed

lemma while_denest_3:
  "(x \<star> w) \<star> x\<^sup>\<omega> = (x \<star> w)\<^sup>\<omega>"
proof -
  have 1: "(x \<star> w) \<star> x\<^sup>\<omega> = (x \<star> w)\<^sup>\<omega> \<squnion> (x \<star> w)\<^sup>\<star> * x\<^sup>\<omega>\<^sup>\<omega>"
    by (simp add: while_def tarski_omega_idempotent)
  also have "... \<le> (x \<star> w)\<^sup>\<omega> \<squnion> (x \<star> w)\<^sup>\<star> * (x\<^sup>\<omega> \<squnion> x\<^sup>\<star> * w)\<^sup>\<omega>"
    using mult_right_isotone omega_sub_dist semiring.add_left_mono by blast
  also have "... = (x \<star> w)\<^sup>\<omega>"
    by (simp add: star_mult_omega while_def)
  finally show ?thesis
    using 1 by (simp add: sup.order_iff)
qed

lemma while_denest_4a:
  "(x \<star> w) \<star> (x \<star> (y * z)) = (x \<star> w) \<star> ((x \<star> y) * z)"
proof -
  have "(x \<star> w) \<star> (x \<star> (y * z)) = (x \<star> w)\<^sup>\<omega> \<squnion> ((x \<star> w) \<star> (x\<^sup>\<star> * y * z))"
    using while_def while_denest_3 while_left_dist_sup mult_assoc by auto
  also have "... \<le> (x \<star> w)\<^sup>\<omega> \<squnion> ((x \<star> w) \<star> ((x \<star> y) * z))"
    using mult_right_sub_dist_sup_right order.refl semiring.add_mono while_def while_right_isotone by auto
  finally have 1: "(x \<star> w) \<star> (x \<star> (y * z)) \<le> (x \<star> w) \<star> ((x \<star> y) * z)"
    by (simp add: while_def)
  have "(x \<star> w) \<star> ((x \<star> y) * z) \<le> (x \<star> w) \<star> (x \<star> (y * z))"
    by (simp add: while_right_isotone while_sub_associative)
  thus ?thesis
    using 1 order.antisym by auto
qed

text \<open>Theorem 8.3\<close>

subclass bounded_extended_binary_itering
  apply unfold_locales
  by (smt mult_assoc while_denest_2a while_denest_4a while_increasing while_slide)

text \<open>Theorem 13.13\<close>

lemma while_mult_top:
  "(x * top) \<star> z = z \<squnion> x * top"
proof -
  have 1: "z \<squnion> x * top \<le> (x * top) \<star> z"
    by (metis le_supI sup_ge1 while_def while_increasing tarski_top_omega)
  have "(x * top) \<star> z = z \<squnion> x * top * ((x * top) \<star> z)"
    using while_left_unfold by auto
  also have "... \<le> z \<squnion> x * top"
    using mult_right_isotone sup_right_isotone top_greatest mult_assoc by auto
  finally show ?thesis
    using 1 order.antisym by auto
qed

lemma tarski_top_omega_below_2:
  "x * top \<le> (x * top) \<star> bot"
  by (simp add: while_mult_top)

lemma tarski_top_omega_2:
  "x * top = (x * top) \<star> bot"
  by (simp add: while_mult_top)

lemma tarski_below_top_omega_2:
  "x \<le> (x * top) \<star> bot"
  using top_right_mult_increasing tarski_top_omega_2 by auto

proposition "1 = (x * bot) \<star> 1" nitpick [expect=genuine,card=3] oops

end

class nonstrict_itering_tarski_zero = nonstrict_itering_tarski + nonstrict_itering_zero
begin

lemma while_bot_1:
  "1 = (x * bot) \<star> 1"
  by (simp add: mult_right_zero while_zero)

text \<open>Theorem 13 counterexamples\<close>

proposition while_associative: "(x \<star> y) * z = x \<star> (y * z)" nitpick [expect=genuine,card=2] oops
proposition "(x \<star> 1) * y = x \<star> y" nitpick [expect=genuine,card=2] oops
proposition while_one_mult: "(x \<star> 1) * x = x \<star> x" nitpick [expect=genuine,card=4] oops
proposition "(x \<squnion> y) \<star> z = ((x \<star> 1) * y) \<star> ((x \<star> 1) * z)" nitpick [expect=genuine,card=2] oops
proposition while_mult_top_2: "(x * top) \<star> z = z \<squnion> x * top * z" nitpick [expect=genuine,card=2] oops
proposition while_top_2: "top \<star> z = top * z" nitpick [expect=genuine,card=2] oops

proposition tarski: "x = bot \<or> top * x * top = top" nitpick [expect=genuine,card=3] oops
proposition while_back_loop_is_fixpoint: "is_fixpoint (\<lambda>x . x * y \<squnion> z) (z * (y \<star> 1))" nitpick [expect=genuine,card=4] oops
proposition "1 \<squnion> x * bot = x \<star> 1" nitpick [expect=genuine,card=3] oops
proposition "x = x * (x \<star> 1)" nitpick [expect=genuine,card=3] oops
proposition "x * (x \<star> 1) = x \<star> 1" nitpick [expect=genuine,card=2] oops
proposition "x \<star> 1 = x \<star> (1 \<star> 1)" nitpick [expect=genuine,card=3] oops
proposition "(x \<squnion> y) \<star> 1 = (x \<star> (y \<star> 1)) \<star> 1" nitpick [expect=genuine,card=3] oops
proposition "z \<squnion> y * x = x \<Longrightarrow> y \<star> z \<le> x" nitpick [expect=genuine,card=2] oops
proposition "y * x = x ==> y \<star> x \<le> x" nitpick [expect=genuine,card=2] oops
proposition "z \<squnion> x * y = x \<Longrightarrow> z * (y \<star> 1) \<le> x" nitpick [expect=genuine,card=3] oops
proposition "x * y = x \<Longrightarrow> x * (y \<star> 1) \<le> x" nitpick [expect=genuine,card=3] oops
proposition "x * z = z * y \<Longrightarrow> x \<star> z \<le> z * (y \<star> 1)" nitpick [expect=genuine,card=2] oops

proposition tarski: "x = bot \<or> top * x * top = top" nitpick [expect=genuine,card=3] oops
proposition tarski_case: assumes t1: "x = bot \<longrightarrow> P x" and t2: "top * x * top = top \<longrightarrow> P x" shows "P x" nitpick [expect=genuine,card=3] oops

end

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_31
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun qrev :: "'a list => 'a list => 'a list" where
  "qrev (nil2) y = y"
| "qrev (cons2 z xs) y = qrev xs (cons2 z y)"

theorem property0 :
  "((qrev (qrev x (nil2)) (nil2)) = x)"
  oops

end


(*  Title:       variants/e_all_abcd/Loop_Freedom.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "Routing graphs and loop freedom"

theory E_Loop_Freedom
imports E_Aodv_Predicates E_Fresher
begin

text \<open>Define the central theorem that relates an invariant over network states to the absence
      of loops in the associate routing graph.\<close>

definition
  rt_graph :: "(ip \<Rightarrow> state) \<Rightarrow> ip \<Rightarrow> ip rel"
where
  "rt_graph \<sigma> = (\<lambda>dip.
     {(ip, ip') | ip ip' dsn dsk hops.
        ip \<noteq> dip \<and> rt (\<sigma> ip) dip = Some (dsn, dsk, val, hops, ip')})"

text \<open>Given the state of a network @{term \<sigma>}, a routing graph for a given destination
      ip address @{term dip} abstracts the details of routing tables into nodes
      (ip addresses) and vertices (valid routes between ip addresses).\<close>

lemma rt_graphE [elim]:
    fixes n dip ip ip'
  assumes "(ip, ip') \<in> rt_graph \<sigma> dip"
    shows "ip \<noteq> dip \<and> (\<exists>r. rt (\<sigma> ip) = r
                            \<and> (\<exists>dsn dsk hops. r dip = Some (dsn, dsk, val, hops, ip')))"
  using assms unfolding rt_graph_def by auto

lemma rt_graph_vD [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> rt_graph \<sigma> dip \<Longrightarrow> dip \<in> vD(rt (\<sigma> ip))"
  unfolding rt_graph_def vD_def by auto

lemma rt_graph_vD_trans [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> (rt_graph \<sigma> dip)\<^sup>+ \<Longrightarrow> dip \<in> vD(rt (\<sigma> ip))"
  by (erule converse_tranclE) auto

lemma rt_graph_not_dip [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> rt_graph \<sigma> dip \<Longrightarrow> ip \<noteq> dip"
  unfolding rt_graph_def by auto

lemma rt_graph_not_dip_trans [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> (rt_graph \<sigma> dip)\<^sup>+ \<Longrightarrow> ip \<noteq> dip"
  by (erule converse_tranclE) auto

text "NB: the property below cannot be lifted to the transitive closure"

lemma rt_graph_nhip_is_nhop [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> rt_graph \<sigma> dip \<Longrightarrow> ip' = the (nhop (rt (\<sigma> ip)) dip)"
  unfolding rt_graph_def by auto

theorem inv_to_loop_freedom:
  assumes "\<forall>i dip. let nhip = the (nhop (rt (\<sigma> i)) dip)
                   in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                      \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip))"
    shows "\<forall>dip. irrefl ((rt_graph \<sigma> dip)\<^sup>+)"
  using assms proof (intro allI)
    fix \<sigma> :: "ip \<Rightarrow> state" and dip
    assume inv: "\<forall>ip dip.
                  let nhip = the (nhop (rt (\<sigma> ip)) dip)
                  in dip \<in> vD(rt (\<sigma> ip)) \<inter> vD(rt (\<sigma> nhip)) \<and>
                     nhip \<noteq> dip \<longrightarrow> rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
    { fix ip ip'
      assume "(ip, ip') \<in> (rt_graph \<sigma> dip)\<^sup>+"
         and "dip \<in> vD(rt (\<sigma> ip'))"
         and "ip' \<noteq> dip"
       hence "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> ip')"
         proof induction
           fix nhip
           assume "(ip, nhip) \<in> rt_graph \<sigma> dip"
              and "dip \<in> vD(rt (\<sigma> nhip))"
              and "nhip \<noteq> dip"
           from \<open>(ip, nhip) \<in> rt_graph \<sigma> dip\<close> have "dip \<in> vD(rt (\<sigma> ip))"
                                               and "nhip = the (nhop (rt (\<sigma> ip)) dip)"
             by auto
           from \<open>dip \<in> vD(rt (\<sigma> ip))\<close> and \<open>dip \<in> vD(rt (\<sigma> nhip))\<close>
             have "dip \<in> vD(rt (\<sigma> ip)) \<inter> vD(rt (\<sigma> nhip))" ..
           with \<open>nhip = the (nhop (rt (\<sigma> ip)) dip)\<close>
                and \<open>nhip \<noteq> dip\<close>
                and inv
             show "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
             by (clarsimp simp: Let_def)
         next
           fix nhip nhip'
           assume "(ip, nhip) \<in> (rt_graph \<sigma> dip)\<^sup>+"
              and "(nhip, nhip') \<in> rt_graph \<sigma> dip"
              and IH: "\<lbrakk> dip \<in> vD(rt (\<sigma> nhip)); nhip \<noteq> dip \<rbrakk> \<Longrightarrow> rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
              and "dip \<in> vD(rt (\<sigma> nhip'))"
              and "nhip' \<noteq> dip"
           from \<open>(nhip, nhip') \<in> rt_graph \<sigma> dip\<close> have 1: "dip \<in> vD(rt (\<sigma> nhip))"
                                                  and 2: "nhip \<noteq> dip"
                                                  and "nhip' = the (nhop (rt (\<sigma> nhip)) dip)"
             by auto
           from 1 2 have "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)" by (rule IH)
           also have "rt (\<sigma> nhip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip')"
             proof -
               from \<open>dip \<in> vD(rt (\<sigma> nhip))\<close> and \<open>dip \<in> vD(rt (\<sigma> nhip'))\<close>
                 have "dip \<in> vD(rt (\<sigma> nhip)) \<inter> vD(rt (\<sigma> nhip'))" ..
               with \<open>nhip' \<noteq> dip\<close>
                    and \<open>nhip' = the (nhop (rt (\<sigma> nhip)) dip)\<close>
                    and inv
                 show "rt (\<sigma> nhip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip')"
                   by (clarsimp simp: Let_def)
             qed
           finally show "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip')" .
         qed } note fresher = this

    show "irrefl ((rt_graph \<sigma> dip)\<^sup>+)"
    unfolding irrefl_def proof (intro allI notI)
      fix ip
      assume "(ip, ip) \<in> (rt_graph \<sigma> dip)\<^sup>+"
      moreover then have "dip \<in> vD(rt (\<sigma> ip))"
                     and "ip \<noteq> dip"
        by auto
      ultimately have "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> ip)" by (rule fresher)
      thus False by simp
    qed
  qed

end


(*:maxLineLen=78:*)

chapter \<open>Dutch Book Theorem \label{chap:dutch-book-theorem}\<close>

text \<open> The first completeness theorem for inequalities for probability logic
       to be investigated is due to Patrick Suppes.\<close>

theory Dutch_Book
  imports
    "../../Logic/Classical/Classical_Connectives"
    "Probability_Logic_Inequality_Completeness"
    "HOL.Real"
begin

section \<open> Fixed Odds Markets \label{sec:fixed-odds-markets} \<close>

record 'p bet_offer =
  bet :: 'p
  amount :: real

record 'p book =
  buys :: "('p bet_offer) list"
  sells ::  "('p bet_offer) list"

definition payoff :: "('p \<Rightarrow> bool) \<Rightarrow> 'p book \<Rightarrow> real" ("\<pi>") where
  [simp]: "\<pi> s b \<equiv>  (\<Sum> i \<leftarrow> sells b. (if s (bet i) then 1 else 0) - amount i)
                   + (\<Sum> i \<leftarrow> buys b. amount i - (if s (bet i) then 1 else 0))"

definition settle_bet :: "('p \<Rightarrow> bool) \<Rightarrow> 'p \<Rightarrow> real" where
  "settle_bet s \<phi> \<equiv> if (s \<phi>) then 1 else 0"

lemma payoff_alt_def1:
  "\<pi> s book =   (\<Sum> i \<leftarrow> sells book. settle_bet s (bet i) - amount i)
              + (\<Sum> i \<leftarrow> buys book. amount i - settle_bet s (bet i))"
  unfolding settle_bet_def
  by simp

definition settle :: "('p \<Rightarrow> bool) \<Rightarrow> 'p bet_offer list \<Rightarrow> real" where
  "settle s bets \<equiv> \<Sum> b \<leftarrow> bets. settle_bet s (bet b)"

definition total_amount :: "('p bet_offer) list \<Rightarrow> real" where
  "total_amount offers \<equiv> \<Sum> i \<leftarrow> offers. amount i"

lemma payoff_alt_def2:
  "\<pi> s book =   settle s (sells book)
              - settle s (buys book)
              + total_amount (buys book)
              - total_amount (sells book)"
  unfolding payoff_alt_def1 total_amount_def settle_def
  by (simp add: sum_list_subtractf)

(* TODO: Cite Lehman *)

definition (in classical_logic) possibility :: "('a \<Rightarrow> bool) \<Rightarrow> bool" where
  [simp]: "possibility p \<equiv>
                \<not> (p \<bottom>)
              \<and> (\<forall> \<phi>. \<turnstile> \<phi> \<longrightarrow> p \<phi>)
              \<and> (\<forall> \<phi> \<psi> . p (\<phi> \<rightarrow> \<psi>) \<longrightarrow> p \<phi> \<longrightarrow> p \<psi>)
              \<and> (\<forall> \<phi> . p \<phi> \<or> p (\<phi> \<rightarrow> \<bottom>))"

definition (in classical_logic) possibilities :: "('a \<Rightarrow> bool) set" where
  [simp]: "possibilities = {p. possibility p}"

lemma (in classical_logic) possibility_negation:
  assumes "possibility p"
  shows "p (\<phi> \<rightarrow> \<bottom>) = (\<not> p \<phi>)"
proof
  assume "p (\<phi> \<rightarrow> \<bottom>)"
  show "\<not> p \<phi>"
  proof
    assume "p \<phi>"
    have "\<turnstile> \<phi> \<rightarrow> (\<phi> \<rightarrow> \<bottom>) \<rightarrow> \<bottom>"
      by (simp add: double_negation_converse)
    hence "p ((\<phi> \<rightarrow> \<bottom>) \<rightarrow> \<bottom>)"
      using \<open>p \<phi>\<close> \<open>possibility p\<close> by auto
    thus "False" using \<open>p (\<phi> \<rightarrow> \<bottom>)\<close> \<open>possibility p\<close> by auto
  qed
next
  show "\<not> p \<phi> \<Longrightarrow> p (\<phi> \<rightarrow> \<bottom>)" using \<open>possibility p\<close> by fastforce
qed

lemma (in classical_logic) possibilities_logical_closure:
  assumes "possibility p"
      and "{x. p x} \<tturnstile> \<phi>"
    shows "p \<phi>"
proof -
  {
    fix \<Gamma>
    assume "set \<Gamma> \<subseteq> Collect p"
    hence "\<forall> \<phi>. \<Gamma> :\<turnstile> \<phi> \<longrightarrow> p \<phi>"
    proof (induct \<Gamma>)
      case Nil
      have "\<forall>\<phi>. \<turnstile> \<phi> \<longrightarrow> p \<phi>"
        using \<open>possibility p\<close> by auto
      then show ?case
        using list_deduction_base_theory by blast
    next
      case (Cons \<gamma> \<Gamma>)
      hence "p \<gamma>"
        by simp
      have "\<forall> \<phi>. \<Gamma> :\<turnstile> \<gamma> \<rightarrow> \<phi> \<longrightarrow> p (\<gamma> \<rightarrow> \<phi>)"
        using Cons.hyps Cons.prems by auto
      then show ?case
        by (meson \<open>p \<gamma>\<close> \<open>possibility p\<close> list_deduction_theorem possibility_def)
    qed
  }
  thus ?thesis
    using \<open>Collect p \<tturnstile> \<phi>\<close> set_deduction_def by auto
qed

lemma (in classical_logic) possibilities_are_MCS:
  assumes "possibility p"
  shows "MCS {x. p x}"
  using assms
  by (metis
        (mono_tags, lifting)
        formula_consistent_def
        formula_maximally_consistent_set_def_def
        maximally_consistent_set_def
        possibilities_logical_closure
        possibility_def
        mem_Collect_eq)

lemma (in classical_logic) MCSs_are_possibilities:
  assumes "MCS s"
  shows "possibility (\<lambda> x. x \<in> s)"
proof -
  have "\<bottom> \<notin> s"
    using \<open>MCS s\<close>
          formula_consistent_def
          formula_maximally_consistent_set_def_def
          maximally_consistent_set_def
          set_deduction_reflection
    by blast
  moreover have "\<forall> \<phi>. \<turnstile> \<phi> \<longrightarrow> \<phi> \<in> s"
    using \<open>MCS s\<close>
          formula_maximally_consistent_set_def_reflection
          maximally_consistent_set_def
          set_deduction_weaken
    by blast
  moreover have "\<forall> \<phi> \<psi>. (\<phi> \<rightarrow> \<psi>) \<in> s \<longrightarrow> \<phi> \<in> s \<longrightarrow> \<psi> \<in> s"
    using \<open>MCS s\<close>
          formula_maximal_consistency
          formula_maximally_consistent_set_def_implication
    by blast
  moreover have "\<forall> \<phi>. \<phi> \<in> s \<or> (\<phi> \<rightarrow> \<bottom>) \<in> s"
    using assms
          formula_maximally_consistent_set_def_implication
          maximally_consistent_set_def
    by blast
  ultimately show ?thesis by simp
qed

definition (in classical_logic) negate_bets ("_\<^sup>\<sim>") where
  "bets\<^sup>\<sim> = [b \<lparr> bet := \<sim> (bet b) \<rparr>. b \<leftarrow> bets]"

lemma (in classical_logic) possibility_payoff:
  assumes "possibility p"
  shows   "  \<pi> p \<lparr> buys = buys', sells = sells' \<rparr>
           = settle p (buys'\<^sup>\<sim> @ sells') + total_amount buys' - total_amount sells' - length buys'"
proof (induct buys')
  case Nil
  then show ?case
    unfolding payoff_alt_def2
              negate_bets_def
              total_amount_def
              settle_def
              settle_bet_def
    by simp
next
  case (Cons b buys')
  have "p (\<sim> (bet b)) = (\<not> (p (bet b)))" using assms negation_def by auto
  moreover have "  total_amount ((b # buys') @ sells')
                 = amount b + total_amount buys' + total_amount sells'"
    unfolding total_amount_def
    by (induct buys', induct sells', auto)
  ultimately show ?case
    using Cons
    unfolding payoff_alt_def2 negate_bets_def settle_def settle_bet_def
    by simp
qed

lemma (in consistent_classical_logic) minimum_payoff_existence:
  "\<exists>! x. (\<exists> p \<in> possibilities. \<pi> p bets = x) \<and> (\<forall> q \<in> possibilities. x \<le> \<pi> q bets)"
proof (rule ex_ex1I)
  show "\<exists>x. (\<exists>p\<in>possibilities. \<pi> p bets = x) \<and> (\<forall>q\<in>possibilities. x \<le> \<pi> q bets)"
  proof (rule ccontr)
    obtain buys' sells' where "bets = \<lparr> buys = buys', sells = sells' \<rparr>"
      by (metis book.cases)
    assume "\<nexists>x. (\<exists> p \<in> possibilities. \<pi> p bets = x) \<and> (\<forall> q \<in> possibilities. x \<le> \<pi> q bets)"
    hence "\<forall>x. (\<exists> p \<in> possibilities. \<pi> p bets = x) \<longrightarrow> (\<exists> q \<in> possibilities. \<pi> q bets < x)"
      by (meson le_less_linear)
    hence \<star>: "\<forall>p \<in> possibilities. \<exists> q \<in> possibilities. \<pi> q bets < \<pi> p bets"
      by blast
    have \<lozenge>: "\<forall> p \<in> possibilities. \<exists> q \<in> possibilities.
                    settle q (buys'\<^sup>\<sim> @ sells') < settle p (buys'\<^sup>\<sim> @ sells')"
    proof
      fix p
      assume "p \<in> possibilities"
      from this obtain q where "q \<in> possibilities" and "\<pi> q bets < \<pi> p bets"
        using \<star> by blast
      hence
        "  settle q (buys'\<^sup>\<sim> @ sells') + total_amount buys' - total_amount sells' - length buys'
         < settle p (buys'\<^sup>\<sim> @ sells') + total_amount buys' - total_amount sells' - length buys'"
        by (metis \<open>\<pi> q bets < \<pi> p bets\<close>
                  \<open>bets = \<lparr>buys = buys', sells = sells'\<rparr>\<close>
                  \<open>p \<in> possibilities\<close>
                  possibilities_def
                  possibility_payoff
                  mem_Collect_eq)
      hence "settle q (buys'\<^sup>\<sim> @ sells') < settle p (buys'\<^sup>\<sim> @ sells')"
        by simp
      thus "\<exists>q\<in>possibilities. settle q (buys'\<^sup>\<sim> @ sells') < settle p (buys'\<^sup>\<sim> @ sells')"
        using \<open>q \<in> possibilities\<close> by blast
    qed
    {
      fix bets :: "('a bet_offer) list"
      fix s :: "'a \<Rightarrow> bool"
      have "\<exists> n \<in> \<nat>. settle s bets = real n"
        unfolding settle_def settle_bet_def
        by (induct bets, auto, metis Nats_1 Nats_add Suc_eq_plus1_left of_nat_Suc)
    } note \<dagger> = this
    {
      fix n :: "nat"
      have "    (\<exists> p \<in> possibilities. settle p (buys'\<^sup>\<sim> @ sells') \<le> n)
            \<longrightarrow> (\<exists> q \<in> possibilities. settle q (buys'\<^sup>\<sim> @ sells') < 0)" (is "_ \<longrightarrow> ?consequent")
      proof (induct n)
        case 0
        {
          fix p :: "'a \<Rightarrow> bool"
          assume"p \<in> possibilities" and "settle p (buys'\<^sup>\<sim> @ sells') \<le> 0"
          from this obtain q where
            "q \<in> possibilities"
            "settle q (buys'\<^sup>\<sim> @ sells') < settle p (buys'\<^sup>\<sim> @ sells')"
            using \<lozenge> by blast
          hence ?consequent
            by (metis "\<dagger>" \<open>settle p (buys'\<^sup>\<sim> @ sells') \<le> 0\<close> of_nat_0_eq_iff of_nat_le_0_iff)
        }
        then show ?case by auto
      next
        case (Suc n)
        {
          fix p :: "'a \<Rightarrow> bool"
          assume"p \<in> possibilities" and "settle p (buys'\<^sup>\<sim> @ sells') \<le> Suc n"
          from this obtain q\<^sub>1 where
            "q\<^sub>1 \<in> possibilities"
            "settle q\<^sub>1 (buys'\<^sup>\<sim> @ sells') < Suc n"
            by (metis \<lozenge> antisym_conv not_less)
          from this obtain q\<^sub>2 where
            "q\<^sub>2 \<in> possibilities"
            "settle q\<^sub>2 (buys'\<^sup>\<sim> @ sells') < n"
            using \<lozenge>
            by (metis \<dagger> add.commute nat_le_real_less nat_less_le of_nat_Suc of_nat_less_iff)
          hence ?consequent
            by (metis \<dagger> Suc.hyps nat_less_le of_nat_le_iff of_nat_less_iff)
        }
        then show ?case by auto
      qed
    }
    hence "\<nexists> p. p \<in> possibilities"
      by (metis \<dagger> not_less0 of_nat_0 of_nat_less_iff order_refl)
    moreover
    have "\<not> {} \<tturnstile> \<bottom>"
      using consistency set_deduction_base_theory by auto
    from this obtain \<Gamma> where "MCS \<Gamma>"
      by (meson formula_consistent_def
                formula_maximal_consistency
                formula_maximally_consistent_extension)
    hence "(\<lambda> \<gamma>. \<gamma> \<in> \<Gamma>) \<in> possibilities"
      using MCSs_are_possibilities possibilities_def by blast
    ultimately show False
      by blast
  qed
next
  fix x y
  assume A: "(\<exists>p \<in> possibilities. \<pi> p bets = x) \<and> (\<forall>q \<in> possibilities. x \<le> \<pi> q bets)"
  and B: "(\<exists>p \<in> possibilities. \<pi> p bets = y) \<and> (\<forall>q \<in> possibilities. y \<le> \<pi> q bets)"
  from this obtain p\<^sub>x p\<^sub>y where
    "p\<^sub>x \<in> possibilities"
    "p\<^sub>y \<in> possibilities"
    "\<pi> p\<^sub>x bets = x"
    "\<pi> p\<^sub>y bets = y"
    by blast
  with A B have "x \<le> y" "y \<le> x"
    by blast+
  thus "x = y" by linarith
qed

definition (in consistent_classical_logic)
  minimum_payoff :: "'a book \<Rightarrow> real" ("\<pi>\<^sub>m\<^sub>i\<^sub>n") where
  "\<pi>\<^sub>m\<^sub>i\<^sub>n b \<equiv> THE x. (\<exists> p \<in> possibilities. \<pi> p b = x)
                   \<and> (\<forall> q \<in> possibilities. x \<le> \<pi> q b)"

lemma (in classical_logic) possibility_payoff_dual:
  assumes "possibility p"
  shows   "  \<pi> p \<lparr> buys = buys', sells = sells' \<rparr>
           = - settle p (sells'\<^sup>\<sim> @ buys')
             + total_amount buys' + length sells' - total_amount sells'"
proof (induct sells')
  case Nil
  then show ?case
    unfolding payoff_alt_def2
              negate_bets_def
              total_amount_def
              settle_def
    by simp
next
  case (Cons sell' sells')
  have "p (\<sim> (bet sell')) = (\<not> (p (bet sell')))"
    using assms negation_def by auto
  moreover have
    "total_amount ((sell' # sells') @ buys')
       = amount sell' + total_amount sells' + total_amount buys'"
    unfolding total_amount_def
    by (induct buys', induct sells', auto)
  ultimately show ?case
    using Cons
    unfolding payoff_alt_def2 negate_bets_def settle_def settle_bet_def
    by simp
qed

lemma settle_alt_def:
  "settle q bets = length [\<phi> \<leftarrow> [ bet b . b \<leftarrow> bets ] . q \<phi>]"
  unfolding settle_def settle_bet_def
  by (induct bets, simp+)

section \<open> Dutch Book Theorems \label{sec:dutch-book-theorem} \<close>

subsection \<open> MaxSAT Dutch Book \label{subsec:dutch-book-maxsat-reduction} \<close>

theorem (in consistent_classical_logic) dutch_book_maxsat:
  "  (k \<le> \<pi>\<^sub>m\<^sub>i\<^sub>n \<lparr> buys = buys', sells = sells' \<rparr>)
   = (  MaxSAT [bet b . b \<leftarrow> sells'\<^sup>\<sim> @ buys'] + (k :: real)
      \<le> total_amount buys' + length sells' - total_amount sells')"
  (is "(k \<le> \<pi>\<^sub>m\<^sub>i\<^sub>n ?bets) = (MaxSAT ?props + k \<le> total_amount _ + _ - _)")
proof
  assume "k \<le> \<pi>\<^sub>m\<^sub>i\<^sub>n ?bets"
  let ?P = "\<lambda> x . (\<exists> p \<in> possibilities. \<pi> p ?bets = x)
                       \<and> (\<forall> q \<in> possibilities. x \<le> \<pi> q ?bets)"
  obtain p where
      "possibility p" and
      "\<forall> q \<in> possibilities. \<pi> p ?bets \<le> \<pi> q ?bets"
    using \<open>k \<le> \<pi>\<^sub>m\<^sub>i\<^sub>n ?bets\<close>
          minimum_payoff_existence [of ?bets]
    by (metis possibilities_def mem_Collect_eq)
  hence "?P (\<pi> p ?bets)"
    using possibilities_def by blast
  hence "\<pi>\<^sub>m\<^sub>i\<^sub>n ?bets = \<pi> p ?bets"
    unfolding minimum_payoff_def
    using minimum_payoff_existence [of ?bets]
          the1_equality [where P = ?P and a = "\<pi> p ?bets"]
    by blast

  let ?\<Phi> = "[\<phi> \<leftarrow> ?props. p \<phi>]"

  have "mset ?\<Phi> \<subseteq># mset ?props"
    by(induct ?props,
       auto,
       simp add: subset_mset.add_mono)
  moreover
  have "\<not> (?\<Phi> :\<turnstile> \<bottom>)"
  proof -
    have "set ?\<Phi> \<subseteq> {x. p x}"
      by auto
    hence "\<not> (set ?\<Phi> \<tturnstile> \<bottom>)"
      by (meson \<open>possibility p\<close>
                possibilities_are_MCS [of p]
                formula_consistent_def
                formula_maximally_consistent_set_def_def
                maximally_consistent_set_def
                list_deduction_monotonic
                set_deduction_def)
    thus ?thesis
      using set_deduction_def by blast
  qed
  moreover
  {
    fix \<Psi>
    assume "mset \<Psi> \<subseteq># mset ?props" and "\<not> \<Psi> :\<turnstile> \<bottom>"
    from this obtain \<Omega>\<^sub>\<Psi> where "MCS \<Omega>\<^sub>\<Psi>" and "set \<Psi> \<subseteq> \<Omega>\<^sub>\<Psi>"
      by (meson formula_consistent_def
                formula_maximal_consistency
                formula_maximally_consistent_extension
                list_deduction_monotonic
                set_deduction_def)
    let ?q = "\<lambda>\<phi> . \<phi> \<in> \<Omega>\<^sub>\<Psi>"
    have "possibility ?q"
      using \<open>MCS \<Omega>\<^sub>\<Psi>\<close> MCSs_are_possibilities by blast
    hence "\<pi> p ?bets \<le> \<pi> ?q ?bets"
      using \<open>\<forall>q\<in>possibilities. \<pi> p ?bets \<le> \<pi> q ?bets\<close>
            possibilities_def
      by blast
    let ?c = "total_amount buys' + length sells' - total_amount sells'"
    have "- settle p (sells'\<^sup>\<sim> @ buys') + ?c \<le> - settle ?q (sells'\<^sup>\<sim> @ buys') + ?c"
      using \<open>\<pi> p ?bets \<le> \<pi> ?q ?bets\<close>
            \<open>possibility p\<close>
            possibility_payoff_dual [of p buys' sells']
            \<open>possibility ?q\<close>
            possibility_payoff_dual [of ?q buys' sells']
      by linarith
    hence "settle ?q (sells'\<^sup>\<sim> @ buys') \<le> settle p (sells'\<^sup>\<sim> @ buys')"
      by linarith
    let ?\<Psi>' = "[\<phi> \<leftarrow> ?props. ?q \<phi>]"
    have "length ?\<Psi>' \<le> length ?\<Phi>"
      using \<open>settle ?q (sells'\<^sup>\<sim> @ buys') \<le> settle p (sells'\<^sup>\<sim> @ buys')\<close>
      unfolding settle_alt_def
      by simp
    moreover
    have "length \<Psi> \<le> length ?\<Psi>'"
    proof -
      have "mset [\<psi> \<leftarrow> \<Psi>. ?q \<psi>] \<subseteq># mset ?\<Psi>'"
      proof -
        {
          fix props :: "'a list"
          have "\<forall> \<Psi>. \<forall> \<Omega>. mset \<Psi> \<subseteq># mset props \<longrightarrow>
                            mset [\<psi> \<leftarrow> \<Psi>. \<psi> \<in> \<Omega>] \<subseteq># mset [\<phi> \<leftarrow> props. \<phi> \<in> \<Omega>]"
            by (simp add: multiset_filter_mono)
        }
        thus ?thesis
          using \<open>mset \<Psi> \<subseteq># mset ?props\<close> by blast
      qed
      hence "length [\<psi> \<leftarrow> \<Psi>. ?q \<psi>] \<le> length ?\<Psi>'"
        by (metis (no_types, lifting) length_sub_mset mset_eq_length nat_less_le not_le)
      moreover have "length \<Psi> = length [\<psi> \<leftarrow> \<Psi>. ?q \<psi>]"
        using \<open>set \<Psi> \<subseteq> \<Omega>\<^sub>\<Psi>\<close>
        by (induct \<Psi>, simp+)
      ultimately show ?thesis by linarith
    qed
    ultimately have "length \<Psi> \<le> length ?\<Phi>" by linarith
  }
  ultimately have "?\<Phi> \<in> \<C> ?props \<bottom>"
    unfolding unproving_core_def
    by blast
  hence "MaxSAT ?props = length ?\<Phi>"
    using core_size_intro by presburger
  hence "MaxSAT ?props = settle p (sells'\<^sup>\<sim> @ buys')"
    unfolding settle_alt_def
    by simp
  thus "MaxSAT ?props + k \<le> total_amount buys' + length sells' - total_amount sells'"
    using possibility_payoff_dual [of p buys' sells']
          \<open>k \<le> \<pi>\<^sub>m\<^sub>i\<^sub>n ?bets\<close>
          \<open>\<pi>\<^sub>m\<^sub>i\<^sub>n ?bets = \<pi> p ?bets\<close>
          \<open>possibility p\<close>
    by linarith
next
  let ?c = "total_amount buys' + length sells' - total_amount sells'"
  assume "MaxSAT ?props + k \<le> ?c"
  from this obtain \<Phi> where "\<Phi> \<in> \<C> ?props \<bottom>" and "length \<Phi> + k \<le> ?c"
    using consistency core_size_intro unproving_core_existence by fastforce
  hence "\<not> \<Phi> :\<turnstile> \<bottom>"
    using unproving_core_def by blast
  from this obtain \<Omega>\<^sub>\<Phi> where "MCS \<Omega>\<^sub>\<Phi>" and "set \<Phi> \<subseteq> \<Omega>\<^sub>\<Phi>"
    by (meson formula_consistent_def
              formula_maximal_consistency
              formula_maximally_consistent_extension
              list_deduction_monotonic
              set_deduction_def)
  let ?p = "\<lambda>\<phi> . \<phi> \<in> \<Omega>\<^sub>\<Phi>"
  have "possibility ?p"
    using \<open>MCS \<Omega>\<^sub>\<Phi>\<close> MCSs_are_possibilities by blast
  have "mset \<Phi> \<subseteq># mset ?props"
    using \<open>\<Phi> \<in> \<C> ?props \<bottom>\<close> unproving_core_def by blast
  have "mset \<Phi> \<subseteq># mset [ b \<leftarrow> ?props. ?p b]"
    by (metis \<open>mset \<Phi> \<subseteq># mset ?props\<close>
              \<open>set \<Phi> \<subseteq> \<Omega>\<^sub>\<Phi>\<close>
              filter_True
              mset_filter
              multiset_filter_mono
              subset_code(1))
  have "mset \<Phi> = mset [ b \<leftarrow> ?props. ?p b]"
  proof (rule ccontr)
    assume "mset \<Phi> \<noteq> mset [ b \<leftarrow> ?props. ?p b]"
    hence "length \<Phi> < length [ b \<leftarrow> ?props. ?p b]"
      using \<open>mset \<Phi> \<subseteq># mset [ b \<leftarrow> ?props. ?p b]\<close> length_sub_mset not_less by blast
    moreover
    have "\<not> [ b \<leftarrow> ?props. ?p b] :\<turnstile> \<bottom>"
      by (metis IntE
                \<open>MCS \<Omega>\<^sub>\<Phi>\<close>
                inter_set_filter
                formula_consistent_def
                formula_maximally_consistent_set_def_def
                maximally_consistent_set_def
                set_deduction_def
                subsetI)
    hence "length [ b \<leftarrow> ?props. ?p b] \<le> length \<Phi>"
      by (metis (mono_tags, lifting)
                \<open>\<Phi> \<in> \<C> ?props \<bottom>\<close>
                unproving_core_def [of ?props \<bottom>]
                mem_Collect_eq
                mset_filter
                multiset_filter_subset)
    ultimately show "False"
      using not_le by blast
  qed
  hence "length \<Phi> = settle ?p (sells'\<^sup>\<sim> @ buys')"
    unfolding settle_alt_def
    using mset_eq_length by fastforce
  hence "k \<le> settle ?p (sells'\<^sup>\<sim> @ buys')
             + total_amount buys' + length sells' - total_amount sells'"
    using \<open>length \<Phi> + k \<le> ?c\<close> by linarith
  hence "k \<le> \<pi> ?p ?bets"
    using \<open>possibility ?p\<close>
          possibility_payoff_dual [of ?p buys' sells']
          \<open>length \<Phi> + k \<le> ?c\<close>
          \<open>length \<Phi> = settle ?p (sells'\<^sup>\<sim> @ buys')\<close>
    by linarith
  have "\<forall> q \<in> possibilities. \<pi> ?p ?bets \<le> \<pi> q ?bets"
  proof
    fix q
    assume "q \<in> possibilities"
    hence "\<not> [ b \<leftarrow> ?props. q b] :\<turnstile> \<bottom>"
      unfolding possibilities_def
      by (metis filter_set
                possibilities_logical_closure
                possibility_def
                set_deduction_def
                mem_Collect_eq
                member_filter
                subsetI)
    hence "length [ b \<leftarrow> ?props. q b] \<le> length \<Phi>"
      by (metis (mono_tags, lifting)
                \<open>\<Phi> \<in> \<C> ?props \<bottom>\<close>
                unproving_core_def
                mem_Collect_eq
                mset_filter
                multiset_filter_subset)
    hence
      "  - settle ?p (sells'\<^sup>\<sim> @ buys') + total_amount buys' + length sells' - total_amount sells'
       \<le> - settle q (sells'\<^sup>\<sim> @ buys') + total_amount buys' + length sells' - total_amount sells'"
      using \<open>length \<Phi> = settle ?p (sells'\<^sup>\<sim> @ buys')\<close>
            settle_alt_def [of q "sells'\<^sup>\<sim> @ buys'"]
      by linarith
    thus "\<pi> ?p ?bets \<le> \<pi> q ?bets"
      using possibility_payoff_dual [of ?p buys' sells']
            possibility_payoff_dual [of q buys' sells']
            \<open>possibility ?p\<close>
            \<open>q \<in> possibilities\<close>
      unfolding possibilities_def
      by (metis mem_Collect_eq)
  qed
  have "\<pi>\<^sub>m\<^sub>i\<^sub>n ?bets = \<pi> ?p ?bets"
    unfolding minimum_payoff_def
  proof
    show "(\<exists>p\<in>possibilities. \<pi> p ?bets = \<pi> ?p ?bets) \<and> (\<forall>q\<in>possibilities. \<pi> ?p ?bets \<le> \<pi> q ?bets)"
      using \<open>\<forall> q \<in> possibilities. \<pi> ?p ?bets \<le> \<pi> q ?bets\<close>
            \<open>possibility ?p\<close>
      unfolding possibilities_def
      by blast
  next
    fix n
    assume \<star>: "(\<exists>p\<in>possibilities. \<pi> p ?bets = n) \<and> (\<forall>q\<in>possibilities. n \<le> \<pi> q ?bets)"
    from this obtain p where "\<pi> p ?bets = n" and "possibility p"
      using possibilities_def by blast
    hence "\<pi> p ?bets \<le> \<pi> ?p ?bets"
      using \<star> \<open>possibility ?p\<close>
      unfolding possibilities_def
      by blast
    moreover have "\<pi> ?p ?bets \<le> \<pi> p ?bets"
      using \<open>\<forall> q \<in> possibilities. \<pi> ?p ?bets \<le> \<pi> q ?bets\<close>
            \<open>possibility p\<close>
      unfolding possibilities_def
      by blast
    ultimately show "n = \<pi> ?p ?bets" using \<open>\<pi> p ?bets = n\<close> by linarith
  qed
  thus "k \<le> \<pi>\<^sub>m\<^sub>i\<^sub>n ?bets"
    using \<open>k \<le> \<pi> ?p ?bets\<close>
    by auto
qed

subsection \<open> Probability Dutch Book \label{subsec:probability-dutch-book} \<close>

lemma (in consistent_classical_logic) nonstrict_dutch_book:
  "  (k \<le> \<pi>\<^sub>m\<^sub>i\<^sub>n \<lparr> buys = buys', sells = sells' \<rparr>)
   = (\<forall> Pr \<in> probabilities.
         (\<Sum>b\<leftarrow>buys'. Pr (bet b)) + total_amount sells' + k
       \<le> (\<Sum>s\<leftarrow>sells'. Pr (bet s)) + total_amount buys')"
  (is "?lhs = _")
proof -
  let ?tot_ss = "total_amount sells'" and ?tot_bs = "total_amount buys'"
  have "[bet b . b \<leftarrow> sells'\<^sup>\<sim> @ buys'] = \<^bold>\<sim> [bet s. s \<leftarrow> sells'] @ [bet b. b \<leftarrow> buys']"
    (is "_ = \<^bold>\<sim> ?sell_\<phi>s @ ?buy_\<phi>s")
    unfolding negate_bets_def
    by (induct sells', simp+)
  hence "?lhs = (MaxSAT (\<^bold>\<sim> ?sell_\<phi>s @ ?buy_\<phi>s) + k \<le> ?tot_bs + length sells' - ?tot_ss)"
    using dutch_book_maxsat [of k buys' sells'] by auto
  also have "\<dots> = (MaxSAT (\<^bold>\<sim> ?sell_\<phi>s @ ?buy_\<phi>s) + (?tot_ss - ?tot_bs + k) \<le> length sells')"
    by linarith
  also have "\<dots> = (MaxSAT (\<^bold>\<sim> ?sell_\<phi>s @ ?buy_\<phi>s) + (?tot_ss - ?tot_bs + k) \<le> length ?sell_\<phi>s)"
    by simp
  finally have I: "?lhs = (\<forall> Pr \<in> dirac_measures.
    (\<Sum>\<phi>\<leftarrow>?buy_\<phi>s. Pr \<phi>) + (?tot_ss - ?tot_bs + k) \<le> (\<Sum>\<gamma>\<leftarrow>?sell_\<phi>s. Pr \<gamma>))"
    using binary_inequality_equiv [of ?buy_\<phi>s "?tot_ss - ?tot_bs + k" ?sell_\<phi>s]
    by blast
  moreover
  {
    fix Pr :: "'a \<Rightarrow> real"
    have "(\<Sum>\<phi>\<leftarrow>?buy_\<phi>s. Pr \<phi>) = (\<Sum>b\<leftarrow>buys'. Pr (bet b))"
         "(\<Sum>\<gamma>\<leftarrow>?sell_\<phi>s. Pr \<gamma>) = (\<Sum>s\<leftarrow>sells'. Pr (bet s))"
      by (simp add: comp_def)+
    hence "  ((\<Sum>\<phi>\<leftarrow>?buy_\<phi>s. Pr \<phi>) + (?tot_ss - ?tot_bs + k) \<le> (\<Sum>\<gamma>\<leftarrow>?sell_\<phi>s. Pr \<gamma>))
           = ((\<Sum>b\<leftarrow>buys'. Pr (bet b)) + ?tot_ss + k \<le> (\<Sum>s\<leftarrow>sells'. Pr (bet s)) + ?tot_bs)"
      by linarith
  }
  ultimately show ?thesis
    by (meson dirac_measures_subset dirac_ceiling dirac_collapse subset_eq)
qed

lemma (in consistent_classical_logic) strict_dutch_book:
  "  (k < \<pi>\<^sub>m\<^sub>i\<^sub>n \<lparr> buys = buys', sells = sells' \<rparr>)
   = (\<forall> Pr \<in> probabilities.
         (\<Sum>b\<leftarrow>buys'. Pr (bet b)) + total_amount sells' + k
       < (\<Sum>s\<leftarrow>sells'. Pr (bet s)) + total_amount buys')"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  from this obtain \<epsilon> where "0 < \<epsilon>" "k + \<epsilon> \<le> \<pi>\<^sub>m\<^sub>i\<^sub>n \<lparr>buys = buys', sells = sells'\<rparr>"
    using less_diff_eq by fastforce
  hence "\<forall>Pr \<in> probabilities.
            (\<Sum>b\<leftarrow>buys'. Pr (bet b)) + total_amount sells' + (k + \<epsilon>)
          \<le> (\<Sum>s\<leftarrow>sells'. Pr (bet s)) + total_amount buys'"
    using nonstrict_dutch_book [of "k + \<epsilon>" buys' sells'] by auto
  thus ?rhs
    using \<open>0 < \<epsilon>\<close> by auto
next
  have "[bet b . b \<leftarrow> sells'\<^sup>\<sim> @ buys'] = \<^bold>\<sim> [bet s. s \<leftarrow> sells'] @ [bet b. b \<leftarrow> buys']"
    (is "_ = \<^bold>\<sim> ?sell_\<phi>s @ ?buy_\<phi>s")
    unfolding negate_bets_def
    by (induct sells', simp+)
  {
    fix Pr :: "'a \<Rightarrow> real"
    have "(\<Sum>b\<leftarrow>buys'. Pr (bet b)) = (\<Sum>\<phi>\<leftarrow>?buy_\<phi>s. Pr \<phi>)"
         "(\<Sum>b\<leftarrow>sells'. Pr (bet b)) = (\<Sum>\<phi>\<leftarrow>?sell_\<phi>s. Pr \<phi>)"
      by (induct buys', auto, induct sells', auto)
  }
  note \<star> =  this
  let ?tot_ss = "total_amount sells'" and ?tot_bs = "total_amount buys'"
  let ?c = "?tot_ss + k - ?tot_bs"
  assume ?rhs
  have "\<forall> Pr \<in> probabilities. (\<Sum>b\<leftarrow>buys'. Pr (bet b)) + ?c < (\<Sum>s\<leftarrow>sells'. Pr (bet s))"
    using \<open>?rhs\<close> by fastforce
  hence "\<forall> Pr \<in> probabilities. (\<Sum>\<phi>\<leftarrow>?buy_\<phi>s. Pr \<phi>) + ?c < (\<Sum>\<phi>\<leftarrow>?sell_\<phi>s. Pr \<phi>)"
    using \<star> by auto
  hence "\<forall> Pr \<in> dirac_measures. (\<Sum>\<phi>\<leftarrow>?buy_\<phi>s. Pr \<phi>) + (\<lfloor>?c\<rfloor> + 1) \<le> (\<Sum>\<phi>\<leftarrow>?sell_\<phi>s. Pr \<phi>)"
    using strict_dirac_collapse [of ?buy_\<phi>s ?c ?sell_\<phi>s]
    by auto
  hence "MaxSAT (\<^bold>\<sim> ?sell_\<phi>s @ ?buy_\<phi>s) + (\<lfloor>?c\<rfloor> + 1) \<le> length ?sell_\<phi>s"
    by (metis floor_add_int floor_mono floor_of_nat binary_inequality_equiv)
  hence "MaxSAT (\<^bold>\<sim> ?sell_\<phi>s @ ?buy_\<phi>s) + ?c < length ?sell_\<phi>s"
    by linarith
  from this obtain \<epsilon> :: real where
    "0 < \<epsilon>"
    "MaxSAT (\<^bold>\<sim> ?sell_\<phi>s @ ?buy_\<phi>s) + (k + \<epsilon>) \<le> ?tot_bs + length sells' - ?tot_ss"
    using less_diff_eq by fastforce
  hence "k + \<epsilon> \<le> \<pi>\<^sub>m\<^sub>i\<^sub>n \<lparr>buys = buys', sells = sells'\<rparr>"
    using \<open>[bet b . b \<leftarrow> sells'\<^sup>\<sim> @ buys'] = \<^bold>\<sim> ?sell_\<phi>s @ ?buy_\<phi>s\<close>
          dutch_book_maxsat [of "k + \<epsilon>" buys' sells']
    by simp
  thus ?lhs
    using \<open>0 < \<epsilon>\<close> by linarith
qed

theorem (in consistent_classical_logic) dutch_book:
  "  (0 < \<pi>\<^sub>m\<^sub>i\<^sub>n \<lparr> buys = buys', sells = sells' \<rparr>)
   = (\<forall> Pr \<in> probabilities.
         (\<Sum>b\<leftarrow>buys'. Pr (bet b)) + total_amount sells'
       < (\<Sum>s\<leftarrow>sells'. Pr (bet s)) + total_amount buys')"
  by (simp add: strict_dutch_book)

end


(* Title:      Containers/Extend_Partial_Order.thy
   Author:     Andreas Lochbihler, KIT *)

theory Extend_Partial_Order
imports Main
begin

section \<open>Every partial order can be extended to a total order\<close>

lemma ChainsD: "\<lbrakk> x \<in> C; C \<in> Chains r; y \<in> C \<rbrakk> \<Longrightarrow> (x, y) \<in> r \<or> (y, x) \<in> r"
by(simp add: Chains_def)

lemma Chains_Field: "\<lbrakk> C \<in> Chains r; x \<in> C \<rbrakk> \<Longrightarrow> x \<in> Field r"
by(auto simp add: Chains_def Field_def)

lemma total_onD:
  "\<lbrakk> total_on A r; x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> (x, y) \<in> r \<or> x = y \<or> (y, x) \<in> r"
unfolding total_on_def by blast

lemma linear_order_imp_linorder: "linear_order {(A, B). leq A B} \<Longrightarrow> class.linorder leq (\<lambda>x y. leq x y \<and> \<not> leq y x)"
by(unfold_locales)(auto 4 4 simp add: linear_order_on_def partial_order_on_def preorder_on_def dest: refl_onD antisymD transD total_onD)

lemma (in linorder) linear_order: "linear_order {(A, B). A \<le> B}"
by(auto simp add: linear_order_on_def partial_order_on_def preorder_on_def total_on_def intro: refl_onI antisymI transI)

definition order_consistent :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
where "order_consistent r s \<longleftrightarrow> (\<forall>a a'. (a, a') \<in> r \<longrightarrow> (a', a) \<in> s \<longrightarrow> a = a')"

lemma order_consistent_sym:
  "order_consistent r s \<Longrightarrow> order_consistent s r"
by(auto simp add: order_consistent_def)

lemma refl_on_trancl:
  assumes "refl_on A r"
  shows "refl_on A (r^+)"
proof(rule refl_onI, safe del: conjI)
  fix a b
  assume "(a, b) \<in> r^+"
  thus "a \<in> A \<and> b \<in> A"
    by induct(blast intro: refl_onD1[OF assms] refl_onD2[OF assms])+
qed(blast dest: refl_onD[OF assms])

lemma total_on_refl_on_consistent_into:
  assumes r: "total_on A r" "refl_on A r"
  and consist: "order_consistent r s"
  and x: "x \<in> A" and y: "y \<in> A" and s: "(x, y) \<in> s"
  shows "(x, y) \<in> r"
proof(cases "x = y")
  case False
  with r x y have "(x, y) \<in> r \<or> (y, x) \<in> r" unfolding total_on_def by blast
  thus ?thesis
  proof
    assume "(y, x) \<in> r"
    with s consist have "x = y" unfolding order_consistent_def by blast
    with False show ?thesis by contradiction
  qed
qed(blast intro: refl_onD r x y)

lemma porder_linorder_tranclpE [consumes 5, case_names base step]:
  assumes r: "partial_order_on A r"
  and s: "linear_order_on B s"
  and consist: "order_consistent r s"
  and B_subset_A: "B \<subseteq> A"
  and trancl: "(x, y) \<in> (r \<union> s)^+"
  obtains "(x, y) \<in> r"
        | u v where "(x, u) \<in> r" "(u, v) \<in> s" "(v, y) \<in> r"
proof(atomize_elim)
  from r have "refl_on A r" "trans r" by(simp_all add: partial_order_on_def preorder_on_def)
  from s have "refl_on B s" "total_on B s" "trans s"
    by(simp_all add: partial_order_on_def preorder_on_def linear_order_on_def)

  from trancl show "(x, y) \<in> r \<or> (\<exists>u v. (x, u) \<in> r \<and> (u, v) \<in> s \<and> (v, y) \<in> r)"
  proof(induction)
    case (base y)
    thus ?case
    proof
      assume "(x, y) \<in> s"
      with \<open>refl_on B s\<close> have "x \<in> B" "y \<in> B"
        by(blast dest: refl_onD1 refl_onD2)+
      with B_subset_A have "x \<in> A" "y \<in> A" by blast+
      hence "(x, x) \<in> r" "(y, y) \<in> r"
        using \<open>refl_on A r\<close> by(blast intro: refl_onD)+
      with \<open>(x, y) \<in> s\<close> show ?thesis by blast
    qed(simp)
  next
    case (step y z)
    from \<open>(y, z) \<in> r \<union> s\<close> show ?case
    proof
      assume "(y, z) \<in> s"
      with \<open>refl_on B s\<close> have "y \<in> B" "z \<in> B"
        by(blast dest: refl_onD2 refl_onD1)+
      from step.IH show ?thesis
      proof
        assume "(x, y) \<in> r"
        moreover from \<open>z \<in> B\<close> B_subset_A \<open>refl_on A r\<close>
        have "(z, z) \<in> r" by(blast dest: refl_onD)
        ultimately show ?thesis using \<open>(y, z) \<in> s\<close> by blast
      next
        assume "\<exists>u v. (x, u) \<in> r \<and> (u, v) \<in> s \<and> (v, y) \<in> r"
        then obtain u v where "(x, u) \<in> r" "(u, v) \<in> s" "(v, y) \<in> r" by blast
        from \<open>refl_on B s\<close> \<open>(u, v) \<in> s\<close> have "v \<in> B" by(rule refl_onD2)
        with \<open>total_on B s\<close> \<open>refl_on B s\<close> order_consistent_sym[OF consist]
        have "(v, y) \<in> s" using \<open>y \<in> B\<close> \<open>(v, y) \<in> r\<close>
          by(rule total_on_refl_on_consistent_into)
        with \<open>trans s\<close> have "(v, z) \<in> s" using \<open>(y, z) \<in> s\<close> by(rule transD)
        with \<open>trans s\<close> \<open>(u, v) \<in> s\<close> have "(u, z) \<in> s" by(rule transD)
        moreover from \<open>z \<in> B\<close> B_subset_A have "z \<in> A" ..
        with \<open>refl_on A r\<close> have "(z, z) \<in> r" by(rule refl_onD)
        ultimately show ?thesis using \<open>(x, u) \<in> r\<close> by blast
      qed
    next
      assume "(y, z) \<in> r"
      with step.IH show ?thesis
        by(blast intro: transD[OF \<open>trans r\<close>])
    qed
  qed
qed

lemma porder_on_consistent_linorder_on_trancl_antisym:
  assumes r: "partial_order_on A r"
  and s: "linear_order_on B s"
  and consist: "order_consistent r s"
  and B_subset_A: "B \<subseteq> A"
  shows "antisym ((r \<union> s)^+)"
proof(rule antisymI)
  fix x y
  let ?rs = "(r \<union> s)^+"
  assume "(x, y) \<in> ?rs" "(y, x) \<in> ?rs"
  from r have "antisym r" "trans r" by(simp_all add: partial_order_on_def preorder_on_def)
  from s have "total_on B s" "refl_on B s" "trans s" "antisym s"
    by(simp_all add: partial_order_on_def preorder_on_def linear_order_on_def)

  from r s consist B_subset_A \<open>(x, y) \<in> ?rs\<close>
  show "x = y"
  proof(cases rule: porder_linorder_tranclpE)
    case base
    from r s consist B_subset_A \<open>(y, x) \<in> ?rs\<close>
    show ?thesis
    proof(cases rule: porder_linorder_tranclpE)
      case base
      with \<open>antisym r\<close> \<open>(x, y) \<in> r\<close> show ?thesis by(rule antisymD)
    next
      case (step u v)
      from \<open>(v, x) \<in> r\<close> \<open>(x, y) \<in> r\<close> \<open>(y, u) \<in> r\<close> have "(v, u) \<in> r"
        by(blast intro: transD[OF \<open>trans r\<close>])
      with consist have "v = u" using \<open>(u, v) \<in> s\<close>
        by(simp add: order_consistent_def)
      with \<open>(y, u) \<in> r\<close> \<open>(v, x) \<in> r\<close> have "(y, x) \<in> r"
        by(blast intro: transD[OF \<open>trans r\<close>])
      with \<open>antisym r\<close> \<open>(x, y) \<in> r\<close> show ?thesis by(rule antisymD)
    qed
  next
    case (step u v)
    from r s consist B_subset_A \<open>(y, x) \<in> ?rs\<close>
    show ?thesis
    proof(cases rule: porder_linorder_tranclpE)
      case base
      from \<open>(v, y) \<in> r\<close> \<open>(y, x) \<in> r\<close> \<open>(x, u) \<in> r\<close> have "(v, u) \<in> r"
        by(blast intro: transD[OF \<open>trans r\<close>])
      with consist \<open>(u, v) \<in> s\<close>
      have "u = v" by(auto simp add: order_consistent_def)
      with \<open>(v, y) \<in> r\<close> \<open>(x, u) \<in> r\<close> have "(x, y) \<in> r"
        by(blast intro: transD[OF \<open>trans r\<close>])
      with \<open>antisym r\<close> show ?thesis using \<open>(y, x) \<in> r\<close> by(rule antisymD)
    next
      case (step u' v')
      note r_into_s = total_on_refl_on_consistent_into[OF \<open>total_on B s\<close> \<open>refl_on B s\<close> order_consistent_sym[OF consist]]
      from \<open>refl_on B s\<close> \<open>(u, v) \<in> s\<close> \<open>(u', v') \<in> s\<close>
      have "u \<in> B" "v \<in> B" "u' \<in> B" "v' \<in> B" by(blast dest: refl_onD1 refl_onD2)+
      from \<open>trans r\<close> \<open>(v', x) \<in> r\<close> \<open>(x, u) \<in> r\<close> have "(v', u) \<in> r" by(rule transD)
      with \<open>v' \<in> B\<close> \<open>u \<in> B\<close> have "(v', u) \<in> s" by(rule r_into_s)
      also note \<open>(u, v) \<in> s\<close> also (transD[OF \<open>trans s\<close>])
      from \<open>trans r\<close> \<open>(v, y) \<in> r\<close> \<open>(y, u') \<in> r\<close> have "(v, u') \<in> r" by(rule transD)
      with \<open>v \<in> B\<close> \<open>u' \<in> B\<close> have "(v, u') \<in> s" by(rule r_into_s)
      finally (transD[OF \<open>trans s\<close>])
      have "v' = u'" using \<open>(u', v') \<in> s\<close> by(rule antisymD[OF \<open>antisym s\<close>])
      moreover with \<open>(v, u') \<in> s\<close> \<open>(v', u) \<in> s\<close> have "(v, u) \<in> s"
        by(blast intro: transD[OF \<open>trans s\<close>])
      with \<open>antisym s\<close> \<open>(u, v) \<in> s\<close> have "u = v" by(rule antisymD)
      ultimately have "(x, y) \<in> r" "(y, x) \<in> r"
        using \<open>(x, u) \<in> r\<close> \<open>(v, y) \<in> r\<close> \<open>(y, u') \<in> r\<close> \<open>(v', x) \<in> r\<close>
        by(blast intro: transD[OF \<open>trans r\<close>])+
      with \<open>antisym r\<close> show ?thesis by(rule antisymD)
    qed
  qed
qed

lemma porder_on_linorder_on_tranclp_porder_onI:
  assumes r: "partial_order_on A r"
  and s: "linear_order_on B s"
  and consist: "order_consistent r s"
  and subset: "B \<subseteq> A"
  shows "partial_order_on A ((r \<union> s)^+)"
  unfolding partial_order_on_def preorder_on_def
proof(intro conjI)
  let ?rs = "r \<union> s"
  from r have "refl_on A r" by(simp add: partial_order_on_def preorder_on_def)
  moreover from s have "refl_on B s"
    by(simp add: linear_order_on_def partial_order_on_def preorder_on_def)
  ultimately have "refl_on (A \<union> B) ?rs" by(rule refl_on_Un)
  also from subset have "A \<union> B = A" by blast
  finally show "refl_on A (?rs^+)" by(rule refl_on_trancl)

  show "trans (?rs^+)" by(rule trans_trancl)

  from r s consist subset show "antisym (?rs^+)"
    by(rule porder_on_consistent_linorder_on_trancl_antisym)
qed

lemma porder_extend_to_linorder:
  assumes r: "partial_order_on A r"
  obtains s where "linear_order_on A s" "order_consistent r s"
proof(atomize_elim)
  define S where "S = {s. partial_order_on A s \<and> r \<subseteq> s}"
  from r have r_in_S: "r \<in> S" unfolding S_def by auto

  have "\<exists>y\<in>S. \<forall>x\<in>S. y \<subseteq> x \<longrightarrow> x = y"
  proof(rule Zorn_Lemma2[rule_format])
    fix c
    assume "c \<in> chains S"
    hence "c \<subseteq> S" by(rule chainsD2)

    show "\<exists>y\<in>S. \<forall>x\<in>c. x \<subseteq> y"
    proof(cases "c = {}")
      case True
      with r_in_S show ?thesis by blast
    next
      case False
      then obtain s where "s \<in> c" by blast
      hence s: "partial_order_on A s"
        and r_in_s: "r \<subseteq> s"
        using \<open>c \<subseteq> S\<close> unfolding S_def by blast+

      have "partial_order_on A (\<Union>c)"
        unfolding partial_order_on_def preorder_on_def
      proof(intro conjI)
        show "refl_on A (\<Union>c)"
        proof(rule refl_onI[OF subsetI])
          fix x
          assume "x \<in> \<Union>c"
          then obtain X where "X \<in> c" and "x \<in> X" by blast
          from \<open>X \<in> c\<close> \<open>c \<subseteq> S\<close> have "X \<in> S" ..
          hence "partial_order_on A X" unfolding S_def by simp
          with \<open>x \<in> X\<close> show "x \<in> A \<times> A"
            by(cases x)(auto simp add: partial_order_on_def preorder_on_def dest: refl_onD1 refl_onD2)
        next
          fix x
          assume "x \<in> A"
          with s have "(x, x) \<in> s" unfolding partial_order_on_def preorder_on_def
            by(blast dest: refl_onD)
          with \<open>s \<in> c\<close> show "(x, x) \<in> \<Union>c" by(rule UnionI)
        qed

        show "antisym (\<Union>c)"
        proof(rule antisymI)
          fix x y
          assume "(x, y) \<in> \<Union>c" "(y, x) \<in> \<Union>c"
          then obtain X Y where "X \<in> c" "Y \<in> c" "(x, y) \<in> X" "(y, x) \<in> Y" by blast
          from \<open>X \<in> c\<close> \<open>Y \<in> c\<close> \<open>c \<subseteq> S\<close> have "antisym X" "antisym Y"
            unfolding S_def by(auto simp add: partial_order_on_def)
          moreover from \<open>c \<in> chains S\<close> \<open>X \<in> c\<close> \<open>Y \<in> c\<close>
          have "X \<subseteq> Y \<or> Y \<subseteq> X" by(rule chainsD)
          ultimately show "x = y" using \<open>(x, y) \<in> X\<close> \<open>(y, x) \<in> Y\<close>
            by(auto dest: antisymD)
        qed

        show "trans (\<Union>c)"
        proof(rule transI)
          fix x y z
          assume "(x, y) \<in> \<Union>c" "(y, z) \<in> \<Union>c"
          then obtain X Y where "X \<in> c" "Y \<in> c" "(x, y) \<in> X" "(y, z) \<in> Y" by blast
          from \<open>X \<in> c\<close> \<open>Y \<in> c\<close> \<open>c \<subseteq> S\<close> have "trans X" "trans Y"
            unfolding S_def by(auto simp add: partial_order_on_def preorder_on_def)
          from \<open>c \<in> chains S\<close> \<open>X \<in> c\<close> \<open>Y \<in> c\<close>
          have "X \<subseteq> Y \<or> Y \<subseteq> X" by(rule chainsD)
          thus "(x, z) \<in> \<Union>c"
          proof
            assume "X \<subseteq> Y"
            with \<open>trans Y\<close> \<open>(x, y) \<in> X\<close> \<open>(y, z) \<in> Y\<close>
            have "(x, z) \<in> Y" by(blast dest: transD)
            with \<open>Y \<in> c\<close> show ?thesis by(rule UnionI)
          next
            assume "Y \<subseteq> X"
            with \<open>trans X\<close> \<open>(x, y) \<in> X\<close> \<open>(y, z) \<in> Y\<close>
            have "(x, z) \<in> X" by(blast dest: transD)
            with \<open>X \<in> c\<close> show ?thesis by(rule UnionI)
          qed
        qed
      qed
      moreover
      have "r \<subseteq> \<Union>c" using r_in_s \<open>s \<in> c\<close> by blast
      ultimately have "\<Union>c \<in> S" unfolding S_def by simp
      thus ?thesis by blast
    qed
  qed
  then obtain s where "s \<in> S" and y_max: "\<And>t. \<lbrakk> t \<in> S; s \<subseteq> t \<rbrakk> \<Longrightarrow> s = t" by blast

  have "partial_order_on A s" using \<open>s \<in> S\<close>
    unfolding S_def by simp
  moreover
  have r_in_s: "r \<subseteq> s" using \<open>s \<in> S\<close> unfolding S_def by blast

  have "total_on A s"
    unfolding total_on_def
  proof(intro strip)
    fix x y
    assume "x \<in> A" "y \<in> A" "x \<noteq> y"
    show "(x, y) \<in> s \<or> (y, x) \<in> s"
    proof(rule ccontr)
      assume "\<not> ?thesis"
      hence xy: "(x, y) \<notin> s" "(y, x) \<notin> s" by simp_all

      define s' where "s' = {(a, b). a = x \<and> (b = y \<or> b = x) \<or> a = y \<and> b = y}"
      let ?s' = "(s \<union> s')^+"
      note \<open>partial_order_on A s\<close>
      moreover have "linear_order_on {x, y} s'" unfolding s'_def
        by(auto simp add: linear_order_on_def partial_order_on_def preorder_on_def total_on_def intro: refl_onI transI antisymI)
      moreover have "order_consistent s s'"
        unfolding s'_def using xy unfolding order_consistent_def by blast
      moreover have "{x, y} \<subseteq> A" using \<open>x \<in> A\<close> \<open>y \<in> A\<close> by blast
      ultimately have "partial_order_on A ?s'"
        by(rule porder_on_linorder_on_tranclp_porder_onI)
      moreover have "r \<subseteq> ?s'" using r_in_s by auto
      ultimately have "?s' \<in> S" unfolding S_def by simp
      moreover have "s \<subseteq> ?s'" by auto
      ultimately have "s = ?s'" by(rule y_max)
      moreover have "(x, y) \<in> ?s'" by(auto simp add: s'_def)
      ultimately show False using \<open>(x, y) \<notin> s\<close> by simp
    qed
  qed
  ultimately have "linear_order_on A s" by(simp add: linear_order_on_def)
  moreover have "order_consistent r s" unfolding order_consistent_def
  proof(intro strip)
    fix a a'
    assume "(a, a') \<in> r" "(a', a) \<in> s"
    from \<open>(a, a') \<in> r\<close> have "(a, a') \<in> s" using r_in_s by blast
    with \<open>partial_order_on A s\<close> \<open>(a', a) \<in> s\<close>
    show "a = a'" unfolding partial_order_on_def by(blast dest: antisymD)
  qed
  ultimately show "\<exists>s. linear_order_on A s \<and> order_consistent r s" by blast
qed

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Prefix
imports Trace
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite (noTick | t = <>)                  *)
(*                                                                     *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*********************************************************)

definition
  prefix         :: "'a trace => 'a trace => bool"
  where
  prefix_def        : "prefix s t == (EX u. t = s ^^^ u & (noTick s | u = <>))"

definition
  prefix_closed  :: "('a trace set) => bool"
  where
  prefix_closed_def :
    "prefix_closed T == ALL s t. ((t : T & prefix s t) --> s : T)"

(***********************************************************
                       lemmas (prefix)
 ***********************************************************)

lemma prefix_closed_iff:
  "[| t : T ; prefix s t ; prefix_closed T |] ==> s : T"
apply (unfold prefix_closed_def[of T])
apply (drule_tac x="s" in spec)
apply (drule_tac x="t" in spec)
by (simp)

(*** Prefix itself ***)

lemma prefix_itself[simp]: "prefix s s"
apply (simp add: prefix_def)
apply (rule_tac x="<>" in exI)
by (simp)

(*** Prefix appt ***)

lemma prefix_appt_simp[simp]: "(noTick s | t = <>) ==> prefix s (s ^^^ t)"
apply (simp add: prefix_def)
apply (rule_tac x="t" in exI)
by (simp)

lemma prefix_appt:
  "[| (noTick t | u = <>) ; prefix s t |] ==> prefix s (t ^^^ u)"
apply (simp add: prefix_def)
apply (erule exE)
apply (simp)
apply (rule_tac x="ua ^^^ u" in exI)
apply (elim conjE disjE)
apply (simp_all)
by (simp add: appt_assoc)

(*** <> is a prefix of any trace ***)

lemma nil_is_prefix[simp]: "prefix <> s"
by (simp add: prefix_def)

(*** the prefix of <> is <> ***)

lemma prefix_of_nil[simp]: "prefix s <> = (s = <>)"
by (auto simp add: prefix_def)

(*** prefix of [a]t ***)

lemma prefix_of_one[simp]: "prefix s <a> = (s = <> | s = <a>)"
apply (simp add: prefix_def)
apply (auto)
apply (rule_tac x="<>" in exI)
by (simp)

(*** length of prefix ***)

lemma length_of_prefix:
  "prefix s t ==> lengtht s <= lengtht t"
apply (simp add: prefix_def)
apply (erule exE)
by (simp)

(*** prefix closed & prefix ***)

lemma prefix_closed_prop:
  "[| prefix_closed T ; t : T ; prefix s t |] ==> s : T"
apply (unfold prefix_closed_def)
by (blast)

(***********************************************************
                   convenient lemmas
 ***********************************************************)

(*** prefix a#v u ***)

lemma prefix_same_head_only_if:
  "prefix (<Ev a> ^^^ v) u
    ==> (EX u'. u = <Ev a> ^^^ u' & prefix v u')"
apply (simp add: prefix_def)
apply (erule exE)
apply (rule_tac x="v ^^^ ua" in exI)
apply (simp add: appt_assoc)
by (rule_tac x="ua" in exI, simp)

lemma prefix_same_head_if:
  "(EX u'. u = <Ev a> ^^^ u' & prefix v u')
   ==> prefix (<Ev a> ^^^ v) u"
apply (simp add: prefix_def)
apply (elim conjE exE)
apply (rule_tac x="ua" in exI)
by (simp add: appt_assoc)

lemma prefix_same_head[simp]:
  "prefix (<Ev a> ^^^ v) u
    = (EX u'. u = <Ev a> ^^^ u' & prefix v u')"
apply (rule iffI)
apply (simp add: prefix_same_head_only_if)
apply (simp add: prefix_same_head_if)
done

(*** prefix v a#u ***)

lemma prefix_same_head_inv_only_if:
  "prefix v (<Ev a> ^^^ u)
      ==> v = <> | (EX v'. v = <Ev a> ^^^ v' & prefix v' u)"
apply (simp add: prefix_def)
apply (erule exE)

apply (insert trace_nil_or_Tick_or_Ev)
apply (drule_tac x="v" in spec)
apply (erule disjE, simp)
apply (erule disjE, erule conjE, simp)

apply (elim exE conjE)
apply (simp add: appt_assoc)
apply (rule_tac x="ua" in exI)
by (simp)

lemma prefix_same_head_inv_if:
  "[| v = <> | (EX v'. v = <Ev a> ^^^ v' & prefix v' u) |]
      ==> prefix v (<Ev a> ^^^ u)"
by (auto)

lemma prefix_same_head_inv[simp]:
  "prefix v (<Ev a> ^^^ u) =
   (v = <> | (EX v'. v = <Ev a> ^^^ v' & prefix v' u))"
apply (rule iffI)
apply (simp add: prefix_same_head_inv_only_if)
apply (simp add: prefix_same_head_inv_if)
done

(*** prefix v u#a ***)

(* only if *)

lemma prefix_last_inv_only_if:
  "[| noTick u ; prefix v (u ^^^ <e>) |]
   ==> (v = u ^^^ <e> | prefix v u)"
apply (simp add: prefix_def)
apply (elim exE conjE)
apply (simp)
apply (insert trace_last_nil_or_unnil)
apply (drule_tac x="ua" in spec)
apply (elim disjE conjE exE)
apply (simp_all)
apply (simp add: appt_assoc_sym)
by (fast)

(* if *)

lemma prefix_last_inv_if:
  "[| noTick u ; v = u ^^^ <e> | prefix v u |] ==> prefix v (u ^^^ <e>)"
apply (erule disjE)
apply (simp)
apply (simp add: prefix_appt)
done

lemma prefix_last_inv[simp]:
  "noTick u ==> prefix v (u ^^^ <e>) = (v = u ^^^ <e> | prefix v u)"
apply (rule iffI)
apply (simp add: prefix_last_inv_only_if)
apply (simp add: prefix_last_inv_if)
done

(*-------------------------*
 |          sett           |
 *-------------------------*)

lemma prefix_subsett: "prefix s t ==> sett s <= sett t"
apply (simp add: prefix_def)
apply (erule exE)
by (auto)

lemma prefix_noTick: "[| prefix s t ; noTick t |] ==> noTick s"
apply (simp add: noTick_def)
apply (simp add: prefix_def)
apply (erule exE)
by (simp)

(*-------------------------*
 |         Tick            |
 *-------------------------*)

lemma prefix_Tick: "(prefix (<Tick>) t) = (t = <Tick>)"
by (simp add: prefix_def)

(****************** to add it again ******************)

declare disj_not1   [simp]

end


theory CaesarTheories
imports Main
begin

subsection{*Misc*}

lemma ex_helper: "cond something = (\<exists>x. (x = something \<and> (cond x)))" by simp

lemma hrule: "(S = UNIV) = (\<forall>x. x \<in> S)"
  by blast

lemma Union_intersection_helper: "\<Union>x = UNIV \<Longrightarrow> \<Union>y = UNIV \<Longrightarrow> \<Union>{a \<inter> b|a b. a \<in> x \<and> b \<in> y \<and> a \<inter> b \<noteq> {}} = UNIV"
  apply(subgoal_tac "\<Union>{a \<inter> b|a b. a \<in> x \<and> b \<in> y} = UNIV")
   apply(thin_tac "\<Union>x = UNIV")
   apply(thin_tac "\<Union>y = UNIV")
   apply(unfold hrule)[1]
   apply clarify
   apply(rename_tac xx)
   apply(subgoal_tac "\<exists>a b. (xx \<in> a \<inter> b \<and> a \<in> x \<and> b \<in> y \<and> a \<inter> b \<noteq> {})")
    apply blast
   apply fast
  apply auto
  apply(metis IntI UNIV_I UnionE)
done

lemma fst_pairset: "fst ` {(f1 b, f2 b) |b. b \<in> R} = {f1 b|b. b \<in> R}"
  by force

lemma image_pair_image: "(\<lambda>(x, y). (f1 x, f2 y)) ` (\<lambda>x. (g1 x, g2 x)) ` A = (\<lambda>x. (f1 (g1 x), f2 (g2 x))) ` A"
  unfolding image_image
  by simp

lemma snd_image_pair: "snd ` (\<lambda>(x, y). (f1 x, f2 y)) ` r = (f2 \<circ> snd) ` r"
  unfolding comp_def image_image by force

lemma image_set_comprehension: "f ` set S = {f x|x. x \<in> set S}"
   by blast

subsection{*single valued on lists*}

lemma foldr_True_set: "foldr (\<lambda>x. op \<and> (f x)) l True = (\<forall>x \<in> set l. f x)"
  by (induction l) simp_all

fun single_valued_code where
"single_valued_code [] = True" |
"single_valued_code (e#es) = (foldr (\<lambda>x. op \<and> (fst x \<noteq> fst e \<or> snd x = snd e)) es True \<and> single_valued_code es)"
lemma single_valued_code_lam[code_unfold]:
  "single_valued (set r) = single_valued_code r"
proof(induction r)
  case Nil show ?case by simp
next
  case (Cons e es)
  show ?case
  proof
    case goal2
    have "single_valued (set es)" using Cons.IH conjunct2[OF goal2[unfolded single_valued_code.simps]] ..
    moreover
    have "\<forall>x\<in>set es. fst x \<noteq> fst e \<or> snd x = snd e"
      using conjunct1[OF goal2[unfolded single_valued_code.simps(2)], unfolded foldr_True_set] .
    ultimately
    show ?case unfolding single_valued_def by auto
  next
    case goal1
    have "single_valued (set es)" using goal1 unfolding single_valued_def by simp
    with Cons.IH[symmetric] have "single_valued_code es" ..
    moreover
    have "\<forall>x\<in>set es. fst x \<noteq> fst e \<or> snd x = snd e" using goal1 unfolding single_valued_def by clarsimp
    from conjI[OF this calculation, unfolded foldr_True_set[symmetric]]
    show ?case unfolding single_valued_code.simps .
  qed
qed

subsection{*Reduction*}

definition "domain_for R y \<equiv> {x. (x, y) \<in> R}"
lemma "domain_for {(1::nat, ''x''), (2, ''y''), (3, ''x'')} ''x'' = {1,3}" by(auto simp add: domain_for_def)
definition "left_reduce R \<equiv> {z|b z. z = (\<Union>domain_for R b,b) \<and> b \<in> Range R}"

lemma domain_for_image: "domain_for ((\<lambda>(x, y). (f1 x, y)) ` r) a = f1 ` domain_for r a"
  unfolding domain_for_def by fast

lemma left_reduce_preimage_stable: "\<Union>(fst`(left_reduce R)) = \<Union>(fst ` R)"
  unfolding left_reduce_def domain_for_def
  by force

lemma left_reduce_alt_def: "left_reduce R = {(\<Union>{a|a. (a,b) \<in> R}, b)|b. b : Range R}"
  unfolding left_reduce_def domain_for_def by simp

lemma left_reduce_image_stable: "snd`(left_reduce R) = (snd ` R)"
  unfolding left_reduce_alt_def
  by force

definition "list_domain_for r y = (foldr (\<lambda>x f. if snd x = y then fst x # f else f) r [])"
lemma list_domain_for_eq: "set (list_domain_for r y) = domain_for (set r) y"
  unfolding list_domain_for_def domain_for_def
  by(induction r) (simp, force)

definition list_left_reduce :: "('a list \<Rightarrow> 'a) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'b) list" where
  "list_left_reduce ff R \<equiv> map (\<lambda>rs. (ff (list_domain_for R rs), rs)) (remdups (map snd R))"

lemma list_left_reduce_set_eq:
  assumes ltr: "\<And>rs. rts (ltr rs) = \<Union>set (map rts rs)"
  assumes rrtsr: "\<And>r. rrtsr r \<equiv> set (map (\<lambda>(x, y). (rts x, y)) r)"
  shows "rrtsr (list_left_reduce ltr r) = left_reduce (rrtsr r)"
  unfolding list_left_reduce_def left_reduce_def
  unfolding rrtsr
  unfolding set_map set_remdups
  unfolding image_pair_image
  unfolding ltr
  unfolding set_map
  unfolding list_domain_for_eq
  unfolding domain_for_image
  unfolding image_image
  unfolding Range_snd
  unfolding snd_image_pair[of _ id, unfolded id_o id_def]
  by force

end