section \<open>Finite Fields\<close>

theory Finite_Field
  imports "HOL-Computational_Algebra.Euclidean_Algorithm" Int31
begin

(* Int31 could be replaced by "Native_Word.Word32". *)

text \<open>We introduce types for finite fields of prime order, i.\,e. fields isomorphic to $\mathbb{Z}_p$
  for some prime number $p$.\<close>

subsection \<open>Conversions between @{typ int} and @{typ integer}\<close>

lemma is_unit_int_of_integer: "is_unit (int_of_integer a) \<longleftrightarrow> is_unit a"
  by (metis divide_integer.rep_eq dvd_def dvd_mult_div_cancel integer_eqI one_integer.rep_eq times_integer.rep_eq)

corollary is_unit_integer_of_int: "is_unit (integer_of_int a) \<longleftrightarrow> is_unit a"
proof -
  have "is_unit (integer_of_int a) \<longleftrightarrow> is_unit (int_of_integer (integer_of_int a))"
    by (simp only: is_unit_int_of_integer)
  also have "... \<longleftrightarrow> is_unit a" by simp
  finally show ?thesis .
qed

lemma irreducible_int_of_integerI:
  assumes "irreducible (a::integer)"
  shows "irreducible (int_of_integer a)"
proof (rule irreducibleI)
  from assms(1) have "a \<noteq> 0" by (simp add: irreducible_def)
  thus "int_of_integer a \<noteq> 0" by (simp add: integer_eq_iff)
next
  from assms(1) have "\<not> is_unit a" by (simp add: irreducible_def)
  thus "\<not> is_unit (int_of_integer a)" by (simp only: is_unit_int_of_integer not_False_eq_True)
next
  fix x y :: int
  assume "int_of_integer a = x * y"
  hence "integer_of_int (int_of_integer a) = integer_of_int (x * y)" by (rule arg_cong)
  hence "a = integer_of_int x * integer_of_int y" by simp
  with assms have "is_unit (integer_of_int x) \<or> is_unit (integer_of_int y)" by (rule irreducibleD)
  thus "is_unit x \<or> is_unit y" by (simp only: is_unit_integer_of_int)
qed

lemma irreducible_int_of_integerD:
  assumes "irreducible (int_of_integer a)"
  shows "irreducible (a::integer)"
proof (rule irreducibleI)
  from assms(1) have "int_of_integer a \<noteq> 0" by (simp add: irreducible_def)
  thus "a \<noteq> 0" by (simp add: integer_eq_iff)
next
  from assms(1) have "\<not> is_unit (int_of_integer a)" by (simp add: irreducible_def)
  thus "\<not> is_unit a" by (simp only: is_unit_int_of_integer not_False_eq_True)
next
  fix x y :: integer
  assume "a = x * y"
  hence "int_of_integer a = int_of_integer (x * y)" by (rule arg_cong)
  hence "int_of_integer a = int_of_integer x * int_of_integer y" by simp
  with assms have "is_unit (int_of_integer x) \<or> is_unit (int_of_integer y)" by (rule irreducibleD)
  thus "is_unit x \<or> is_unit y" by (simp only: is_unit_int_of_integer)
qed

corollary irreducible_int_of_integer: "irreducible (int_of_integer a) \<longleftrightarrow> irreducible a"
  by (auto dest: irreducible_int_of_integerI irreducible_int_of_integerD)

corollary irreducible_integer_of_int: "irreducible (integer_of_int a) \<longleftrightarrow> irreducible a"
proof -
  have "irreducible (integer_of_int a) \<longleftrightarrow> irreducible (int_of_integer (integer_of_int a))"
    by (simp only: irreducible_int_of_integer)
  also have "... \<longleftrightarrow> irreducible a" by simp
  finally show ?thesis .
qed

lemma irreducible_intI:
  assumes "2 \<le> a" and "list_all (\<lambda>m. \<not> (int m) dvd a) [2..<nat a]"
  shows "irreducible (a::int)"
proof (rule irreducibleI)
  from assms(1) show "a \<noteq> 0" by simp
  from assms(1) have abs_a: "abs a = a" by simp

  show "\<not> is_unit a"
  proof
    have "1 \<noteq> (0::int)" by simp
    moreover assume "is_unit a"
    ultimately have "abs a \<le> abs 1" by (rule dvd_imp_le_int)
    hence "a \<le> 1" by (simp add: abs_a)
    with assms(1) show False by simp
  qed

  fix x y :: int
  define m where "m = nat (abs x)"
  have int_m: "int m = abs x" by (simp add: m_def)
  assume "a = x * y"
  from this[symmetric] have "a = abs x * abs y" by (simp add: abs_a flip: abs_mult)
  hence *: "int m dvd a" by (simp add: int_m)
  with assms(2) have "m < 2 \<or> nat a \<le> m" by (auto simp: list_all_def)
  thus "is_unit x \<or> is_unit y"
  proof
    assume "m < 2"
    hence "m = 0 \<or> m = 1" by auto
    hence "is_unit x"
    proof
      assume "m = 0"
      hence "x = 0" by (simp add: m_def)
      with assms(1) show ?thesis by (simp add: \<open>a = x * y\<close>)
    next
      assume "m = 1"
      hence "abs x = 1" by (auto simp add: m_def)
      thus ?thesis by (simp add: dvd_if_abs_eq)
    qed
    thus ?thesis ..
  next
    assume "nat a \<le> m"
    hence **: "a \<le> int m" by simp
    from \<open>a \<noteq> 0\<close> have "abs (int m) \<le> abs a" using * by (rule dvd_imp_le_int)
    hence "int m \<le> a" by (simp add: abs_a)
    hence "int m = a" using ** by (rule antisym)
    hence "abs x = a" by (simp add: int_m)
    with \<open>a = abs x * abs y\<close> \<open>a \<noteq> 0\<close> have "abs y = 1" by fastforce
    hence "is_unit y" by (simp add: dvd_if_abs_eq)
    thus ?thesis ..
  qed
qed

corollary irreducible_integerI:
  assumes "2 \<le> p" and "list_all (\<lambda>m. \<not> (int m) dvd (int_of_integer p)) [2..<nat (int_of_integer p)]"
  shows "irreducible (p::integer)"
proof -
  from assms(1) have "2 \<le> int_of_integer p" by (simp add: less_eq_integer.rep_eq)
  hence "irreducible (int_of_integer p)" using assms(2) by (rule irreducible_intI)
  thus ?thesis by (simp only: irreducible_int_of_integer)
qed

lemma gcd_is_unitI_irreducible:
  assumes "irreducible a" and "\<not> a dvd (b::'a::semiring_gcd)"
  shows "is_unit (gcd a b)"
proof -
  from gcd_dvd1 obtain k where a: "a = gcd a b * k" by (rule dvdE)
  with assms(1) have "is_unit (gcd a b) \<or> is_unit k" by (rule irreducibleD)
  thus ?thesis
  proof
    assume "is_unit k"
    then obtain m where "1 = k * m" by (rule dvdE)
    from a have "a * m = gcd a b * k * m" by (rule arg_cong)
    also have "... = gcd a b * (k * m)" by (simp add: ac_simps)
    also have "... = gcd a b" by (simp add: \<open>1 = k * m\<close>[symmetric])
    finally have "gcd a b = a * m" by (rule sym)
    hence "a dvd gcd a b" by (rule dvdI)
    also have "... dvd b" by (fact gcd_dvd2)
    finally have "a dvd b" .
    with assms(2) show ?thesis ..
  qed
qed

subsection \<open>Inverse Modulo $p$\<close>

instantiation integer :: semidom_divide_unit_factor
begin

definition unit_factor_integer :: "integer \<Rightarrow> integer" where "unit_factor_integer = sgn"

context includes integer.lifting
begin

instance proof
  show "unit_factor 0 = (0::integer)" by (simp add: unit_factor_integer_def)
next
  fix a :: integer
  show "is_unit a \<Longrightarrow> unit_factor a = a" unfolding unit_factor_integer_def
    by transfer (auto simp add: abs_eq_iff')
next
  fix a :: integer
  show "a \<noteq> 0 \<Longrightarrow> is_unit (unit_factor a)" unfolding unit_factor_integer_def
    by (metis abs_sgn_eq_1 dvd_abs_iff dvd_refl)
next
  fix a b :: integer
  show "unit_factor (a * b) = unit_factor a * unit_factor b"
    by (simp add: unit_factor_integer_def sgn_mult)
qed

end

end

instantiation integer :: normalization_semidom
begin

definition normalize_integer :: "integer \<Rightarrow> integer" where "normalize_integer = abs"

instance proof
  fix a :: integer
  show "unit_factor a * normalize a = a"
    by (simp add: unit_factor_integer_def normalize_integer_def sgn_mult_abs)
next
  show "normalize 0 = (0::integer)" by (simp add: normalize_integer_def)
qed

end

instance integer :: normalization_euclidean_semiring ..

instantiation integer :: Gcd
begin

definition Gcd_integer :: "integer set \<Rightarrow> integer"
  where "Gcd_integer A = integer_of_int (Gcd (int_of_integer ` A))"

definition Lcm_integer :: "integer set \<Rightarrow> integer"
  where "Lcm_integer A = integer_of_int (Lcm (int_of_integer ` A))"

lemma int_of_Gcd: "int_of_integer (Gcd A) = Gcd (int_of_integer ` A)"
  by (simp add: Gcd_integer_def)

lemma int_of_Lcm: "int_of_integer (Lcm A) = Lcm (int_of_integer ` A)"
  by (simp add: Lcm_integer_def)

instance ..

end

instantiation integer :: semiring_gcd
begin

context includes integer.lifting
begin

instance proof
  fix a b :: integer
  show "gcd a b dvd a" by transfer simp
  show "gcd a b dvd b" by transfer simp
  show "normalize (gcd a b) = gcd a b" unfolding normalize_integer_def by transfer simp
  show "lcm a b = normalize (a * b) div gcd a b" unfolding normalize_integer_def
    by transfer (simp add: lcm_gcd)
next
  fix c a b :: integer
  show "c dvd a \<Longrightarrow> c dvd b \<Longrightarrow> c dvd gcd a b" by transfer simp
qed

end

end

instantiation integer :: semiring_Gcd
begin

context includes integer.lifting
begin

instance proof
  fix a::integer and A::"integer set"
  show "a \<in> A \<Longrightarrow> Gcd A dvd a" unfolding Gcd_integer_def by transfer simp
  show "(\<And>b. b \<in> A \<Longrightarrow> a dvd b) \<Longrightarrow> a dvd Gcd A" unfolding Gcd_integer_def by transfer simp
  show "a \<in> A \<Longrightarrow> a dvd Lcm A" unfolding Lcm_integer_def by transfer simp
  show "(\<And>b. b \<in> A \<Longrightarrow> b dvd a) \<Longrightarrow> Lcm A dvd a" unfolding Lcm_integer_def by transfer simp
next
  fix A :: "integer set"
  show "normalize (Gcd A) = Gcd A" unfolding normalize_integer_def Gcd_integer_def by transfer simp
  show "normalize (Lcm A) = Lcm A" unfolding normalize_integer_def Lcm_integer_def by transfer simp
qed

end

end

instantiation integer :: euclidean_ring_gcd
begin

context includes integer.lifting
begin

instance proof
  interpret semiring_Gcd 1 0 times
    "Euclidean_Algorithm.gcd" "Euclidean_Algorithm.lcm"
    "Euclidean_Algorithm.Gcd" "Euclidean_Algorithm.Lcm"
    divide plus minus unit_factor normalize
    rewrites "dvd.dvd (*) = Rings.dvd"
    by (fact semiring_Gcd) (simp add: dvd.dvd_def dvd_def fun_eq_iff)
  show [simp]: "(Euclidean_Algorithm.gcd::integer \<Rightarrow> _) = gcd"
  proof (rule ext)+
    fix k l :: integer
    show "Euclidean_Algorithm.gcd k l = gcd k l"
    proof (induct k l rule: eucl_induct)
      case (zero b)
      show ?case by (simp add: normalize_integer_def)
    next
      case (mod k l)
      have "gcd l (k mod l) = gcd l k"
      proof transfer
        fix l k :: int
        show "gcd l (k mod l) = gcd l k"
        proof (cases l "0::int" rule: linorder_cases)
          case less
          then show ?thesis
            using gcd_non_0_int [of "- l" "- k"] by (simp add: ac_simps)
        next
          case equal
          with mod show ?thesis
            by simp
        next
          case greater
          then show ?thesis
            using gcd_non_0_int [of l k] by (simp add: ac_simps)
        qed
      qed
      with mod show ?case by (simp add: Euclidean_Algorithm.gcd_mod ac_simps)
    qed
  qed
  show [simp]: "(Euclidean_Algorithm.Lcm :: integer set \<Rightarrow> _) = Lcm"
    by (auto simp: intro!: ext Lcm_eqI semiring_Gcd_class.dvd_Lcm semiring_Gcd_class.Lcm_least)
  show "(Euclidean_Algorithm.lcm :: integer \<Rightarrow> _) = lcm"
    by (simp add: fun_eq_iff Euclidean_Algorithm.lcm_def semiring_gcd_class.lcm_gcd)
  show "(Euclidean_Algorithm.Gcd :: integer set \<Rightarrow> _) = Gcd"
    by (simp add: fun_eq_iff Euclidean_Algorithm.Gcd_def semiring_Gcd_class.Gcd_Lcm)
qed

end

end

definition inverse_int :: "'a \<Rightarrow> 'a \<Rightarrow> 'a::euclidean_ring_gcd"
  where "inverse_int p a = fst (bezout_coefficients a p) mod p"

lemma inverse_int_gcd:
  assumes "0 \<le> a" and "a < (p::integer)"
  shows "(inverse_int p a * a) mod p = (gcd a p) mod p"
proof -
  from assms have a: "a mod p = a"
    by (rule unique_euclidean_semiring_numeral_class.mod_less)
  have "(gcd a p) mod p = (fst (bezout_coefficients a p) * a + snd (bezout_coefficients a p) * p) mod p"
    by (simp only: bezout_coefficients_fst_snd)
  also have "... = (inverse_int p a * (a mod p)) mod p"
    by (simp add: inverse_int_def mod_mult_eq)
  also have "... = (inverse_int p a * a) mod p" by (simp only: a)
  finally show ?thesis by (simp only:)
qed

corollary inverse_int_irreducible:
  assumes "irreducible p" and "0 < a" and "a < (p::integer)"
  shows "(inverse_int p a * a) mod p = 1"
proof -
  have "\<not> p dvd a"
  proof
    from assms(2) have "int_of_integer a \<noteq> 0"
      by (metis less_numeral_extra(3) of_int_0 of_int_integer_of)
    assume "p dvd a"
    hence "int_of_integer p dvd int_of_integer a" by auto
    with \<open>int_of_integer a \<noteq> 0\<close> have "abs (int_of_integer p) \<le> abs (int_of_integer a)"
      by (rule dvd_imp_le_int)
    hence "abs p \<le> abs a" by (simp flip: abs_integer.rep_eq less_eq_integer.rep_eq)
    also from assms(2) have "... = a" by simp
    finally have "p \<le> a" by simp
    with assms(3) show False by simp
  qed
  with assms(1) have "is_unit (gcd p a)" by (rule gcd_is_unitI_irreducible)
  hence eq: "gcd a p = 1" by (simp only: is_unit_gcd_iff ac_simps)
  from assms(2) have "0 \<le> a" by simp
  hence "(inverse_int p a * a) mod p = (gcd a p) mod p" using assms(3)
    by (rule inverse_int_gcd)
  also have "... = 1 mod p" by (simp only: eq)
  also have "... = 1"
    by (metis assms(2, 3) le_less_trans less_imp_le mod_by_1 not_less_iff_gr_or_eq
              unique_euclidean_semiring_numeral_class.mod_less zero_le_one)
  finally show ?thesis .
qed

subsection \<open>The Finite Field of Order $32003$\<close>

definition "o32003 = (Int31 32003)"

lemma pos_o32003: "0 < o32003"
  by (simp add: o32003_def)

lemma irreducible_o32003: "irreducible o32003"
proof (rule irreducible_integerI)
  show "2 \<le> o32003" by (simp add: o32003_def)
next
  show "list_all (\<lambda>m. \<not> int m dvd int_of_integer o32003) [2..<nat (int_of_integer o32003)]"
    by eval
qed

typedef gf32003 = "{n::int31. 0 \<le> n \<and> n < o32003}"
proof
  from pos_o32003 show "0 \<in> {n. 0 \<le> n \<and> n < o32003}" by simp
qed

setup_lifting type_definition_gf32003

definition GF32003 :: "int31 \<Rightarrow> gf32003" where
  "GF32003 n = Abs_gf32003 (n mod o32003)"

definition "gf32003_of_int = GF32003"

lemma GF32003_Rep [code abstype]: "GF32003 (Rep_gf32003 n) = n"
proof -
  from Rep_gf32003[of n] have "0 \<le> Rep_gf32003 n" and "Rep_gf32003 n < o32003" by simp_all
  hence "Rep_gf32003 n mod o32003 = Rep_gf32003 n"
    by (rule unique_euclidean_semiring_numeral_class.mod_less)
  thus ?thesis by (simp add: GF32003_def Rep_gf32003_inverse)
qed

lemma [code abstract]: "Rep_gf32003 (gf32003_of_int n) = n mod o32003"
  unfolding gf32003_of_int_def GF32003_def
  by (rule Abs_gf32003_inverse, simp add: pos_o32003 pos_mod_sign pos_mod_bound)

instantiation gf32003 :: equal
begin

definition equal_gf32003 :: "gf32003 \<Rightarrow> gf32003 \<Rightarrow> bool" where "equal_gf32003 = (=)"

instance by standard (simp add: equal_gf32003_def)

end

subsubsection \<open>Additive Structure\<close>

instantiation gf32003 :: zero
begin

lift_definition zero_gf32003 :: gf32003 is 0 by (simp add: o32003_def)

instance ..

end

instantiation gf32003 :: plus
begin

lift_definition plus_gf32003 :: "gf32003 \<Rightarrow> gf32003 \<Rightarrow> gf32003" is "\<lambda>x y. (x + y) mod o32003"
  by (simp add: pos_o32003 pos_mod_sign pos_mod_bound)

instance ..

end

instantiation gf32003 :: uminus
begin

lift_definition uminus_gf32003 :: "gf32003 \<Rightarrow> gf32003" is "\<lambda>x. if x = 0 then 0 else o32003 - x"
  by (simp add: pos_o32003 pos_mod_sign pos_mod_bound)

instance ..

end

instantiation gf32003 :: minus
begin

lift_definition minus_gf32003 :: "gf32003 \<Rightarrow> gf32003 \<Rightarrow> gf32003" is "\<lambda>x y. if x < y then (o32003 + x) - y else x - y"
  by (simp add: pos_o32003 pos_mod_sign pos_mod_bound)

instance ..

end

instance gf32003 :: ab_group_add
proof
  fix a b c :: gf32003
  show "a + b + c = a + (b + c)"
    by transfer (simp add: add.commute add.left_commute mod_add_right_eq)
next
  fix a b :: gf32003
  have "a + b = b + a \<and> a - b = a + (- b)" by transfer (simp add: add.commute mod_add_right_eq)
  thus "a + b = b + a" and "a - b = a + (- b)" by blast+
next
  fix a :: gf32003
  have "0 + a = a \<and> - a + a = 0"
    by transfer (simp add: mod_add_left_eq unique_euclidean_semiring_numeral_class.mod_less)
  thus "0 + a = a" and "- a + a = 0" by blast+
qed

subsubsection \<open>Multiplicative Structure\<close>

instantiation gf32003 :: one
begin

lift_definition one_gf32003 :: gf32003 is 1 by (simp add: o32003_def)

instance ..

end

instantiation gf32003 :: times
begin

lift_definition times_gf32003 :: "gf32003 \<Rightarrow> gf32003 \<Rightarrow> gf32003" is "\<lambda>x y. (x * y) mod o32003"
  by (simp add: pos_o32003 pos_mod_sign pos_mod_bound)

instance ..

end

instance gf32003 :: comm_ring_1
proof
  fix a b c :: gf32003
  have "a * b * c = a * (b * c) \<and> (a + b) * c = a * c + b * c"
    sorry (*by transfer (simp add: distrib_left mod_add_left_eq mod_add_right_eq mod_mult_right_eq mult.commute mult.left_commute)*)
  thus "a * b * c = a * (b * c)" and "(a + b) * c = a * c + b * c" by blast+
next
  fix a b :: gf32003
  show "a * b = b * a" by transfer (simp add: mult.commute)
next
  fix a :: gf32003
  show "1 * a = a" by transfer (simp add: unique_euclidean_semiring_numeral_class.mod_less)
next
  show "0 \<noteq> (1::gf32003)" by transfer simp
qed

subsubsection \<open>Field Structure\<close>

instantiation gf32003 :: inverse
begin

lift_definition inverse_gf32003 :: "gf32003 \<Rightarrow> gf32003" is "inverse_int31 o32003"
  by (simp add: inverse_int_def pos_o32003 pos_mod_sign pos_mod_bound)

definition divide_gf32003 :: "gf32003 \<Rightarrow> gf32003 \<Rightarrow> gf32003"
  where "divide_gf32003 x y = x * inverse y"

instance ..

end

instance gf32003 :: field
proof
  fix a :: gf32003
  show "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1" sorry
(*
  proof transfer
    fix a :: integer
    assume "0 \<le> a \<and> a < o32003" and "a \<noteq> 0"
    hence "0 < a" and "a < o32003" by simp_all
    with irreducible_o32003 show "inverse_int o32003 a * a mod o32003 = 1"
      by (rule inverse_int_irreducible)
  qed
*)
next
  fix a b :: gf32003
  show "a / b = a * inverse b" by (fact divide_gf32003_def)
next
  show "inverse 0 = (0::gf32003)" by transfer (simp add: inverse_int_def bezout_coefficients_left_0)
qed

subsubsection \<open>Code Generation\<close>

code_printing
  constant "o32003" \<rightharpoonup>
    (SML) "!(32003 : Int31.int)"

lemmas [code abstract] = zero_gf32003.rep_eq one_gf32003.rep_eq

value [code] "0::gf32003"

value [code] "gf32003_of_int 25687 + gf32003_of_int 456"

value [code] "- gf32003_of_int 25687"

value [code] "gf32003_of_int 3185 - gf32003_of_int 25687"

value [code] "1::gf32003"

value [code] "(1::gf32003) = (gf32003_of_int 32004)"

value [code] "inverse (32002 / 5637::gf32003)"

export_code "inverse::gf32003 \<Rightarrow> _" in SML module_name Example

end (* theory *)


(* License: LGPL *)
(* Author: Julian Parsert *)

theory Lotteries
  imports
    PMF_Composition
    "HOL-Probability.Probability"
begin

section \<open> Lotteries \<close>

definition lotteries_on
  where
    "lotteries_on Oc = {p . (set_pmf p) \<subseteq> Oc}"

lemma lotteries_on_subset:
  assumes "A \<subseteq> B"
  shows "lotteries_on A \<subseteq> lotteries_on B"
  by (metis (no_types, lifting) Collect_mono assms gfp.leq_trans lotteries_on_def)

lemma support_in_outcomes:
  "\<forall>oc. \<forall>p \<in> lotteries_on oc. \<forall>a \<in> set_pmf p. a \<in> oc"
  by (simp add: lotteries_on_def subsetD)

lemma lotteries_on_nonempty:
  assumes "outcomes \<noteq> {}"
  shows "lotteries_on outcomes \<noteq> {}"
  by (auto simp: lotteries_on_def) (metis (full_types) assms
      empty_subsetI ex_in_conv insert_subset set_return_pmf)

lemma finite_support_one_oc:
  assumes "card outcomes = 1"
  shows "\<forall>l \<in> lotteries_on outcomes. finite (set_pmf l)"
  by (metis assms card_infinite finite_subset lotteries_on_def mem_Collect_eq zero_neq_one)

lemma one_outcome_card_support_1:
  assumes "card outcomes = 1"
  shows "\<forall>l \<in> lotteries_on outcomes. card (set_pmf l) = 1"
proof
  fix l
  assume "l \<in> lotteries_on outcomes"
  have "finite outcomes"
    using assms card_infinite by force
  then have "l \<in> lotteries_on outcomes \<longrightarrow> 1 = card (set_pmf l)"
    by (metis assms card_eq_0_iff card_mono finite_support_one_oc le_neq_implies_less
        less_one lotteries_on_def mem_Collect_eq set_pmf_not_empty)
  then show "card (set_pmf l) = 1"
    by (simp add: \<open>l \<in> lotteries_on outcomes\<close>)
qed

lemma finite_nempty_ex_degernate_in_lotteries:
  assumes "out \<noteq> {}"
  assumes "finite out"
  shows "\<exists>e \<in> lotteries_on out. \<exists>x \<in> out. pmf e x = 1"
proof (rule ccontr)
  assume a: "\<not> (\<exists>e\<in>lotteries_on out. \<exists>x\<in>out. pmf e x = 1)"
  then have subset: "\<forall>e \<in> lotteries_on out. set_pmf e \<subseteq> out"
    using lotteries_on_def by (simp add: lotteries_on_def)
  then have "\<forall>e. e \<in> lotteries_on out \<longrightarrow> ((\<Sum>i\<in>set_pmf e. pmf e i) = 1)"
    using sum_pmf_eq_1 by (metis subset  assms(2) finite_subset order_refl)
  then show False
    by (metis (no_types, lifting) a assms(1) assms(2) card_empty card_gt_0_iff card_seteq
        empty_subsetI finite.emptyI finite_insert insert_subset lotteries_on_def subsetI
        measure_measure_pmf_finite mem_Collect_eq nat_less_le pmf.rep_eq set_pmf_of_set )
qed

lemma card_support_1_probability_1:
  assumes "card (set_pmf p) = 1"
  shows "\<forall>e \<in> set_pmf p. pmf p e = 1"
  by(auto) (metis assms card_1_singletonE card_ge_0_finite
      card_subset_eq ex_card le_numeral_extra(4) measure_measure_pmf_finite
      pmf.rep_eq singletonD sum_pmf_eq_1 zero_less_one)

lemma one_outcome_card_lotteries_1:
  assumes "card outcomes = 1"
  shows "card (lotteries_on outcomes) = 1"
proof -
  obtain x :: 'a where
    x: "outcomes = {x}"
    using assms card_1_singletonE by blast
  have exl: "\<exists>l \<in> lotteries_on outcomes. pmf l x = 1"
    by (metis x assms card_infinite empty_iff
        finite_nempty_ex_degernate_in_lotteries insert_iff zero_neq_one)
  have pmfs: "\<forall>l \<in> lotteries_on outcomes. set_pmf l = {x}"
    by (simp add: lotteries_on_def set_pmf_subset_singleton x)
  have "\<forall>l \<in> lotteries_on outcomes. pmf l x = 1"
    by (simp add: lotteries_on_def set_pmf_subset_singleton x)
  then show ?thesis
    by (metis exl empty_iff is_singletonI' is_singleton_altdef
        order_refl pmfs set_pmf_subset_singleton)
qed

lemma return_pmf_card_equals_set:
  shows "card {return_pmf x |x. x \<in> S} = card S"
proof-
  have "{return_pmf x |x. x \<in> S} = return_pmf ` S"
    by blast
  also have "card \<dots> = card S"
    by (intro card_image) (auto simp: inj_on_def)
  finally show "card {return_pmf x |x. x \<in> S} = card S" .
qed

lemma card_degen_lotteries_equals_outcomes:
  shows "card {x \<in> lotteries_on out. card (set_pmf x) = 1} = card out"
proof -
  consider (empty) "out = {}" | (not_empty) "out \<noteq> {}"
    by blast
  then show ?thesis
  proof (cases)
    case not_empty
    define DG where
      DG: "DG = {x \<in> lotteries_on out. card (set_pmf x) = 1}"
    define AP where
      AP: "AP = {return_pmf x |x. x \<in> out}"
    have **: "card AP = card out"
      using AP return_pmf_card_equals_set by blast
    have *: "\<forall>d \<in> DG. d \<in> AP"
    proof
      fix l
      assume "l \<in> DG"
      then have "l \<in> lotteries_on out \<and> 1 = card (set_pmf l)"
        using DG by force
      then obtain x where
        x: "x \<in> out" "set_pmf l = {x}"
        by (metis (no_types) card_1_singletonE singletonI support_in_outcomes)
      have "return_pmf x = l"
        using set_pmf_subset_singleton x(2) by fastforce
      then show "l \<in> AP"
        using AP x(1) by blast
    qed
    moreover have "AP = DG"
    proof
      have "\<forall>e \<in> AP. e \<in> lotteries_on out"
        by(auto simp: lotteries_on_def AP)
      then show "AP \<subseteq> DG" using DG AP by force
    qed (auto simp: *)
    ultimately show ?thesis
      using DG ** by blast
  qed (simp add: lotteries_on_def set_pmf_not_empty)
qed

end


(*  Title:      HOL/UNITY/Simple/Reachability.thy
    Author:     Tanja Vos, Cambridge University Computer Laboratory
    Copyright   2000  University of Cambridge

Reachability in Graphs.

From Chandy and Misra, "Parallel Program Design" (1989), sections 6.2
and 11.3.
*)

theory Reachability imports "../Detects" Reach begin

type_synonym edge = "vertex * vertex"

record state =
  reach :: "vertex => bool"
  nmsg  :: "edge => nat"

consts root :: "vertex"
       E :: "edge set"
       V :: "vertex set"

inductive_set REACHABLE :: "edge set"
  where
    base: "v \<in> V ==> ((v,v) \<in> REACHABLE)"
  | step: "((u,v) \<in> REACHABLE) & (v,w) \<in> E ==> ((u,w) \<in> REACHABLE)"

definition reachable :: "vertex => state set" where
  "reachable p == {s. reach s p}"

definition nmsg_eq :: "nat => edge  => state set" where
  "nmsg_eq k == %e. {s. nmsg s e = k}"

definition nmsg_gt :: "nat => edge  => state set" where
  "nmsg_gt k  == %e. {s. k < nmsg s e}"

definition nmsg_gte :: "nat => edge => state set" where
  "nmsg_gte k == %e. {s. k \<le> nmsg s e}"

definition nmsg_lte  :: "nat => edge => state set" where
  "nmsg_lte k  == %e. {s. nmsg s e \<le> k}"

definition final :: "state set" where
  "final == (\<Inter>v\<in>V. reachable v <==> {s. (root, v) \<in> REACHABLE}) \<inter>
            (\<Inter>((nmsg_eq 0) ` E))"

axiomatization
where
    Graph1: "root \<in> V" and

    Graph2: "(v,w) \<in> E ==> (v \<in> V) & (w \<in> V)" and

    MA1:  "F \<in> Always (reachable root)" and

    MA2:  "v \<in> V ==> F \<in> Always (- reachable v \<union> {s. ((root,v) \<in> REACHABLE)})" and

    MA3:  "[|v \<in> V;w \<in> V|] ==> F \<in> Always (-(nmsg_gt 0 (v,w)) \<union> (reachable v))" and

    MA4:  "(v,w) \<in> E ==>
           F \<in> Always (-(reachable v) \<union> (nmsg_gt 0 (v,w)) \<union> (reachable w))" and

    MA5:  "[|v \<in> V; w \<in> V|]
           ==> F \<in> Always (nmsg_gte 0 (v,w) \<inter> nmsg_lte (Suc 0) (v,w))" and

    MA6:  "[|v \<in> V|] ==> F \<in> Stable (reachable v)" and

    MA6b: "[|v \<in> V;w \<in> W|] ==> F \<in> Stable (reachable v \<inter> nmsg_lte k (v,w))" and

    MA7:  "[|v \<in> V;w \<in> V|] ==> F \<in> UNIV LeadsTo nmsg_eq 0 (v,w)"

lemmas E_imp_in_V_L = Graph2 [THEN conjunct1]
lemmas E_imp_in_V_R = Graph2 [THEN conjunct2]

lemma lemma2:
     "(v,w) \<in> E ==> F \<in> reachable v LeadsTo nmsg_eq 0 (v,w) \<inter> reachable v"
apply (rule MA7 [THEN PSP_Stable, THEN LeadsTo_weaken_L])
apply (rule_tac [3] MA6)
apply (auto simp add: E_imp_in_V_L E_imp_in_V_R)
done

lemma Induction_base: "(v,w) \<in> E ==> F \<in> reachable v LeadsTo reachable w"
apply (rule MA4 [THEN Always_LeadsTo_weaken])
apply (rule_tac [2] lemma2)
apply (auto simp add: nmsg_eq_def nmsg_gt_def)
done

lemma REACHABLE_LeadsTo_reachable:
     "(v,w) \<in> REACHABLE ==> F \<in> reachable v LeadsTo reachable w"
apply (erule REACHABLE.induct)
apply (rule subset_imp_LeadsTo, blast)
apply (blast intro: LeadsTo_Trans Induction_base)
done

lemma Detects_part1: "F \<in> {s. (root,v) \<in> REACHABLE} LeadsTo reachable v"
apply (rule single_LeadsTo_I)
apply (simp split: if_split_asm)
apply (rule MA1 [THEN Always_LeadsToI])
apply (erule REACHABLE_LeadsTo_reachable [THEN LeadsTo_weaken_L], auto)
done

lemma Reachability_Detected:
     "v \<in> V ==> F \<in> (reachable v) Detects {s. (root,v) \<in> REACHABLE}"
apply (unfold Detects_def, auto)
 prefer 2 apply (blast intro: MA2 [THEN Always_weaken])
apply (rule Detects_part1 [THEN LeadsTo_weaken_L], blast)
done

lemma LeadsTo_Reachability:
     "v \<in> V ==> F \<in> UNIV LeadsTo (reachable v <==> {s. (root,v) \<in> REACHABLE})"
by (erule Reachability_Detected [THEN Detects_Imp_LeadstoEQ])

(* ------------------------------------ *)

(* Some lemmas about <==> *)

lemma Eq_lemma1:
     "(reachable v <==> {s. (root,v) \<in> REACHABLE}) =
      {s. ((s \<in> reachable v) = ((root,v) \<in> REACHABLE))}"
by (unfold Equality_def, blast)

lemma Eq_lemma2:
     "(reachable v <==> (if (root,v) \<in> REACHABLE then UNIV else {})) =
      {s. ((s \<in> reachable v) = ((root,v) \<in> REACHABLE))}"
by (unfold Equality_def, auto)

(* ------------------------------------ *)

(* Some lemmas about final (I don't need all of them!)  *)

lemma final_lemma1:
     "(\<Inter>v \<in> V. \<Inter>w \<in> V. {s. ((s \<in> reachable v) = ((root,v) \<in> REACHABLE)) &
                              s \<in> nmsg_eq 0 (v,w)})
      \<subseteq> final"
apply (unfold final_def Equality_def, auto)
apply (frule E_imp_in_V_R)
apply (frule E_imp_in_V_L, blast)
done

lemma final_lemma2:
 "E\<noteq>{}
  ==> (\<Inter>v \<in> V. \<Inter>e \<in> E. {s. ((s \<in> reachable v) = ((root,v) \<in> REACHABLE))}
                           \<inter> nmsg_eq 0 e)    \<subseteq>  final"
apply (unfold final_def Equality_def)
apply (auto split!: if_split)
apply (frule E_imp_in_V_L, blast)
done

lemma final_lemma3:
     "E\<noteq>{}
      ==> (\<Inter>v \<in> V. \<Inter>e \<in> E.
           (reachable v <==> {s. (root,v) \<in> REACHABLE}) \<inter> nmsg_eq 0 e)
          \<subseteq> final"
apply (frule final_lemma2)
apply (simp (no_asm_use) add: Eq_lemma2)
done

lemma final_lemma4:
     "E\<noteq>{}
      ==> (\<Inter>v \<in> V. \<Inter>e \<in> E.
           {s. ((s \<in> reachable v) = ((root,v) \<in> REACHABLE))} \<inter> nmsg_eq 0 e)
          = final"
apply (rule subset_antisym)
apply (erule final_lemma2)
apply (unfold final_def Equality_def, blast)
done

lemma final_lemma5:
     "E\<noteq>{}
      ==> (\<Inter>v \<in> V. \<Inter>e \<in> E.
           ((reachable v) <==> {s. (root,v) \<in> REACHABLE}) \<inter> nmsg_eq 0 e)
          = final"
apply (frule final_lemma4)
apply (simp (no_asm_use) add: Eq_lemma2)
done

lemma final_lemma6:
     "(\<Inter>v \<in> V. \<Inter>w \<in> V.
       (reachable v <==> {s. (root,v) \<in> REACHABLE}) \<inter> nmsg_eq 0 (v,w))
      \<subseteq> final"
apply (simp (no_asm) add: Eq_lemma2 Int_def)
apply (rule final_lemma1)
done

lemma final_lemma7:
     "final =
      (\<Inter>v \<in> V. \<Inter>w \<in> V.
       ((reachable v) <==> {s. (root,v) \<in> REACHABLE}) \<inter>
       (-{s. (v,w) \<in> E} \<union> (nmsg_eq 0 (v,w))))"
apply (unfold final_def)
apply (rule subset_antisym, blast)
apply (auto split: if_split_asm)
apply (blast dest: E_imp_in_V_L E_imp_in_V_R)+
done

(* ------------------------------------ *)

(* ------------------------------------ *)

(* Stability theorems *)
lemma not_REACHABLE_imp_Stable_not_reachable:
     "[| v \<in> V; (root,v) \<notin> REACHABLE |] ==> F \<in> Stable (- reachable v)"
apply (drule MA2 [THEN AlwaysD], auto)
done

lemma Stable_reachable_EQ_R:
     "v \<in> V ==> F \<in> Stable (reachable v <==> {s. (root,v) \<in> REACHABLE})"
apply (simp (no_asm) add: Equality_def Eq_lemma2)
apply (blast intro: MA6 not_REACHABLE_imp_Stable_not_reachable)
done

lemma lemma4:
     "((nmsg_gte 0 (v,w) \<inter> nmsg_lte (Suc 0) (v,w)) \<inter>
       (- nmsg_gt 0 (v,w) \<union> A))
      \<subseteq> A \<union> nmsg_eq 0 (v,w)"
apply (unfold nmsg_gte_def nmsg_lte_def nmsg_gt_def nmsg_eq_def, auto)
done

lemma lemma5:
     "reachable v \<inter> nmsg_eq 0 (v,w) =
      ((nmsg_gte 0 (v,w) \<inter> nmsg_lte (Suc 0) (v,w)) \<inter>
       (reachable v \<inter> nmsg_lte 0 (v,w)))"
by (unfold nmsg_gte_def nmsg_lte_def nmsg_gt_def nmsg_eq_def, auto)

lemma lemma6:
     "- nmsg_gt 0 (v,w) \<union> reachable v \<subseteq> nmsg_eq 0 (v,w) \<union> reachable v"
apply (unfold nmsg_gte_def nmsg_lte_def nmsg_gt_def nmsg_eq_def, auto)
done

lemma Always_reachable_OR_nmsg_0:
     "[|v \<in> V; w \<in> V|] ==> F \<in> Always (reachable v \<union> nmsg_eq 0 (v,w))"
apply (rule Always_Int_I [OF MA5 MA3, THEN Always_weaken])
apply (rule_tac [5] lemma4, auto)
done

lemma Stable_reachable_AND_nmsg_0:
     "[|v \<in> V; w \<in> V|] ==> F \<in> Stable (reachable v \<inter> nmsg_eq 0 (v,w))"
apply (subst lemma5)
apply (blast intro: MA5 Always_imp_Stable [THEN Stable_Int] MA6b)
done

lemma Stable_nmsg_0_OR_reachable:
     "[|v \<in> V; w \<in> V|] ==> F \<in> Stable (nmsg_eq 0 (v,w) \<union> reachable v)"
by (blast intro!: Always_weaken [THEN Always_imp_Stable] lemma6 MA3)

lemma not_REACHABLE_imp_Stable_not_reachable_AND_nmsg_0:
     "[| v \<in> V; w \<in> V; (root,v) \<notin> REACHABLE |]
      ==> F \<in> Stable (- reachable v \<inter> nmsg_eq 0 (v,w))"
apply (rule Stable_Int [OF MA2 [THEN Always_imp_Stable]
                           Stable_nmsg_0_OR_reachable,
            THEN Stable_eq])
   prefer 4 apply blast
apply auto
done

lemma Stable_reachable_EQ_R_AND_nmsg_0:
     "[| v \<in> V; w \<in> V |]
      ==> F \<in> Stable ((reachable v <==> {s. (root,v) \<in> REACHABLE}) \<inter>
                      nmsg_eq 0 (v,w))"
by (simp add: Equality_def Eq_lemma2  Stable_reachable_AND_nmsg_0
              not_REACHABLE_imp_Stable_not_reachable_AND_nmsg_0)

(* ------------------------------------ *)

(* LeadsTo final predicate (Exercise 11.2 page 274) *)

lemma UNIV_lemma: "UNIV \<subseteq> (\<Inter>v \<in> V. UNIV)"
by blast

lemmas UNIV_LeadsTo_completion =
    LeadsTo_weaken_L [OF Finite_stable_completion UNIV_lemma]

lemma LeadsTo_final_E_empty: "E={} ==> F \<in> UNIV LeadsTo final"
apply (unfold final_def, simp)
apply (rule UNIV_LeadsTo_completion)
  apply safe
 apply (erule LeadsTo_Reachability [simplified])
apply (drule Stable_reachable_EQ_R, simp)
done

lemma Leadsto_reachability_AND_nmsg_0:
     "[| v \<in> V; w \<in> V |]
      ==> F \<in> UNIV LeadsTo
             ((reachable v <==> {s. (root,v) \<in> REACHABLE}) \<inter> nmsg_eq 0 (v,w))"
apply (rule LeadsTo_Reachability [THEN LeadsTo_Trans], blast)
apply (subgoal_tac
         "F \<in> (reachable v <==> {s. (root,v) \<in> REACHABLE}) \<inter>
              UNIV LeadsTo (reachable v <==> {s. (root,v) \<in> REACHABLE}) \<inter>
              nmsg_eq 0 (v,w) ")
apply simp
apply (rule PSP_Stable2)
apply (rule MA7)
apply (rule_tac [3] Stable_reachable_EQ_R, auto)
done

lemma LeadsTo_final_E_NOT_empty: "E\<noteq>{} ==> F \<in> UNIV LeadsTo final"
apply (rule LeadsTo_weaken_L [OF LeadsTo_weaken_R UNIV_lemma])
apply (rule_tac [2] final_lemma6)
apply (rule Finite_stable_completion)
  apply blast
 apply (rule UNIV_LeadsTo_completion)
   apply (blast intro: Stable_INT Stable_reachable_EQ_R_AND_nmsg_0
                    Leadsto_reachability_AND_nmsg_0)+
done

lemma LeadsTo_final: "F \<in> UNIV LeadsTo final"
apply (cases "E={}")
 apply (rule_tac [2] LeadsTo_final_E_NOT_empty)
apply (rule LeadsTo_final_E_empty, auto)
done

(* ------------------------------------ *)

(* Stability of final (Exercise 11.2 page 274) *)

lemma Stable_final_E_empty: "E={} ==> F \<in> Stable final"
apply (unfold final_def, simp)
apply (rule Stable_INT)
apply (drule Stable_reachable_EQ_R, simp)
done

lemma Stable_final_E_NOT_empty: "E\<noteq>{} ==> F \<in> Stable final"
apply (subst final_lemma7)
apply (rule Stable_INT)
apply (rule Stable_INT)
apply (simp (no_asm) add: Eq_lemma2)
apply safe
apply (rule Stable_eq)
apply (subgoal_tac [2]
     "({s. (s \<in> reachable v) = ((root,v) \<in> REACHABLE) } \<inter> nmsg_eq 0 (v,w)) =
      ({s. (s \<in> reachable v) = ( (root,v) \<in> REACHABLE) } \<inter> (- UNIV \<union> nmsg_eq 0 (v,w)))")
prefer 2 apply blast
prefer 2 apply blast
apply (rule Stable_reachable_EQ_R_AND_nmsg_0
            [simplified Eq_lemma2 Collect_const])
apply (blast, blast)
apply (rule Stable_eq)
 apply (rule Stable_reachable_EQ_R [simplified Eq_lemma2 Collect_const])
 apply simp
apply (subgoal_tac
        "({s. (s \<in> reachable v) = ((root,v) \<in> REACHABLE) }) =
         ({s. (s \<in> reachable v) = ( (root,v) \<in> REACHABLE) } \<inter>
              (- {} \<union> nmsg_eq 0 (v,w)))")
apply blast+
done

lemma Stable_final: "F \<in> Stable final"
apply (cases "E={}")
 prefer 2 apply (blast intro: Stable_final_E_NOT_empty)
apply (blast intro: Stable_final_E_empty)
done

end


chapter \<open>Terms with explicit bound variable names\<close>

theory Nterm
imports Term_Class
begin

text \<open>
  The \<open>nterm\<close> type is similar to @{typ term}, but removes the distinction between bound and free
  variables. Instead, there are only named variables.
\<close>

datatype nterm =
  Nconst name |
  Nvar name |
  Nabs name nterm ("\<Lambda>\<^sub>n _. _" [0, 50] 50) |
  Napp nterm nterm (infixl "$\<^sub>n" 70)

derive linorder nterm

instantiation nterm :: pre_term begin

definition app_nterm where
"app_nterm t u = t $\<^sub>n u"

fun unapp_nterm where
"unapp_nterm (t $\<^sub>n u) = Some (t, u)" |
"unapp_nterm _ = None"

definition const_nterm where
"const_nterm = Nconst"

fun unconst_nterm where
"unconst_nterm (Nconst name) = Some name" |
"unconst_nterm _ = None"

definition free_nterm where
"free_nterm = Nvar"

fun unfree_nterm where
"unfree_nterm (Nvar name) = Some name" |
"unfree_nterm _ = None"

fun frees_nterm :: "nterm \<Rightarrow> name fset" where
"frees_nterm (Nvar x) = {| x |}" |
"frees_nterm (t\<^sub>1 $\<^sub>n t\<^sub>2) = frees_nterm t\<^sub>1 |\<union>| frees_nterm t\<^sub>2" |
"frees_nterm (\<Lambda>\<^sub>n x. t) = frees_nterm t - {| x |}" |
"frees_nterm (Nconst _) = {||}"

fun subst_nterm :: "nterm \<Rightarrow> (name, nterm) fmap \<Rightarrow> nterm" where
"subst_nterm (Nvar s) env = (case fmlookup env s of Some t \<Rightarrow> t | None \<Rightarrow> Nvar s)" |
"subst_nterm (t\<^sub>1 $\<^sub>n t\<^sub>2) env = subst_nterm t\<^sub>1 env $\<^sub>n subst_nterm t\<^sub>2 env" |
"subst_nterm (\<Lambda>\<^sub>n x. t) env = (\<Lambda>\<^sub>n x. subst_nterm t (fmdrop x env))" |
"subst_nterm t env = t"

fun consts_nterm :: "nterm \<Rightarrow> name fset" where
"consts_nterm (Nconst x) = {| x |}" |
"consts_nterm (t\<^sub>1 $\<^sub>n t\<^sub>2) = consts_nterm t\<^sub>1 |\<union>| consts_nterm t\<^sub>2" |
"consts_nterm (Nabs _ t) = consts_nterm t" |
"consts_nterm (Nvar _) = {||}"

instance
by standard
   (auto
      simp: app_nterm_def const_nterm_def free_nterm_def
      elim: unapp_nterm.elims unconst_nterm.elims unfree_nterm.elims
      split: option.splits)

end

instantiation nterm :: "term" begin

definition abs_pred_nterm :: "(nterm \<Rightarrow> bool) \<Rightarrow> nterm \<Rightarrow> bool" where
[code del]: "abs_pred P t \<longleftrightarrow> (\<forall>t' x. t = (\<Lambda>\<^sub>n x. t') \<longrightarrow> P t' \<longrightarrow> P t)"

instance proof (standard, goal_cases)
  case (1 P t)
  then show ?case
    by (induction t) (auto simp: abs_pred_nterm_def const_nterm_def free_nterm_def app_nterm_def)
next
  case 3
  show ?case
    unfolding abs_pred_nterm_def
    apply auto
    apply (subst fmdrop_comm)
    by auto
next
  case 4
  show ?case
    unfolding abs_pred_nterm_def
    apply auto
    apply (erule_tac x = "fmdrop x env\<^sub>1" in allE)
    apply (erule_tac x = "fmdrop x env\<^sub>2" in allE)
    by (auto simp: fdisjnt_alt_def)
next
  case 5
  show ?case
    unfolding abs_pred_nterm_def
    apply clarify
    subgoal for t' x env
      apply (erule allE[where x = "fmdrop x env"])
      by auto
    done
next
  case 6
  show ?case
    unfolding abs_pred_nterm_def
    apply clarify
    subgoal premises prems[rule_format] for t x env
      unfolding consts_nterm.simps subst_nterm.simps frees_nterm.simps
      apply (subst prems)
      unfolding fmimage_drop fmdom_drop
      apply (rule arg_cong[where f = "(|\<union>|) (consts t)"])
      apply (rule arg_cong[where f = ffUnion])
      apply (rule arg_cong[where f = "\<lambda>x. consts |`| fmimage env x"])
      by auto
    done
qed (auto simp: abs_pred_nterm_def)

end

lemma no_abs_abs[simp]: "\<not> no_abs (\<Lambda>\<^sub>n x. t)"
by (subst no_abs.simps) (auto simp: term_cases_def)

end


theory Boat
  imports "Hybrid-Verification.Hybrid_Verification"
begin

subsection \<open> Preliminaries \<close>

lit_vars

no_notation (ASCII)
  comp  (infixl "o" 55)

lemma self_dot [simp]: "\<parallel>v\<parallel> * \<parallel>v\<parallel> = v \<bullet> v"
  by (metis norm_cauchy_schwarz_eq)

lemma orth_mag [simp]: "a \<bullet> b = \<parallel>a\<parallel> * \<parallel>b\<parallel> \<Longrightarrow> \<parallel>a + b\<parallel> = \<parallel>a\<parallel> + \<parallel>b\<parallel>"
  by (simp add: norm_cauchy_schwarz_eq norm_triangle_eq)

lemma orth_mag' [simp]: "b \<bullet> a = \<parallel>b\<parallel> * \<parallel>a\<parallel> \<Longrightarrow> \<parallel>a + b\<parallel> = \<parallel>a\<parallel> + \<parallel>b\<parallel>"
  by (simp add: norm_cauchy_schwarz_eq norm_triangle_eq)

lemma "a \<noteq> 0 \<Longrightarrow> \<parallel>sgn a\<parallel> = 1"
  by (simp add: norm_sgn)

lemma "a \<noteq> 0 \<Longrightarrow> sgn a \<bullet> sgn a = 1"
  by (meson norm_eq_1 norm_sgn)

lemma sgn_self_dot:
  assumes "a \<noteq> 0"
  shows "(sgn a) \<bullet> (sgn a) = 1"
  by (meson assms norm_eq_1 norm_sgn)

lemma "a \<noteq> 0 \<Longrightarrow> (a / \<parallel>a\<parallel>) \<bullet> (a / \<parallel>a\<parallel>) = 1"
  by simp

lemma "\<lbrakk> a \<ge> 0; a\<^sup>2 = b \<rbrakk> \<Longrightarrow> a = sqrt(b)"
  by (simp add: real_sqrt_unique)

lemma
  assumes "(a::'a::ordered_euclidean_space) \<noteq> 0"
  shows "a \<bullet> b / \<parallel>a\<parallel> = sgn a \<bullet> b"
  by (simp add: divide_inverse_commute sgn_div_norm)

lemma "v \<noteq> 0 \<Longrightarrow> arccos(v \<bullet> v / (\<parallel>v\<parallel> * \<parallel>v\<parallel>)) = 0"
  by (simp)

declare num1_eq1 [simp del]

lemma exhaust_2':
  fixes x :: 2
  shows "x = 0 \<or> x = 1"
  using exhaust_2 by fastforce

lemma forall_2': "(\<forall>i::2. P i) \<longleftrightarrow> P 0 \<and> P 1"
  by (metis exhaust_2')

declare UNIV_1 [simp del]
declare UNIV_2 [simp del]

lemma UNIV_1 [simp]: "(UNIV :: 1 set) = {0}"
  by (metis UNIV_1 num1_eq1)

lemma UNIV_2 [simp]: "(UNIV :: 2 set) = {0,1}"
  by (simp add: UNIV_eq_I exhaust_2')

subsection \<open> Vector Theorems and Simplifications \<close>

lemma vec_norm: "\<parallel>\<^bold>[[x, y]\<^bold>]\<parallel> = sqrt(x\<^sup>2 + y\<^sup>2)"
  by (simp add: norm_vec_def)

lemma vec_simps [simp]:
  "k *\<^sub>R \<^bold>[[x, y]\<^bold>] = \<^bold>[[k *\<^sub>R x, k *\<^sub>R y]\<^bold>]"
  "\<^bold>[[x\<^sub>1::real, y\<^sub>1]\<^bold>] \<bullet> \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] = x\<^sub>1 * x\<^sub>2 + y\<^sub>1 * y\<^sub>2"
  "\<^bold>[[x\<^sub>1, y\<^sub>1]\<^bold>] + \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] = \<^bold>[[x\<^sub>1 + x\<^sub>2, y\<^sub>1 + y\<^sub>2]\<^bold>]"
  "\<^bold>[[x\<^sub>1, y\<^sub>1]\<^bold>] - \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] = \<^bold>[[x\<^sub>1 - x\<^sub>2, y\<^sub>1 - y\<^sub>2]\<^bold>]"
  "\<^bold>[[0, 0]\<^bold>] = 0"
     apply (subst scaleR_Mat, simp_all)
  apply (simp add: inner_vec_def)
    apply (subst plus_Mat, simp_all)
   apply (subst minus_Mat, simp_all)
   apply (simp add: matrix_eq_iff nat_of_num1_def forall_2')
  done

lemma orient_vec_mag_1 [simp]: "\<parallel>\<^bold>[[sin \<theta> :: real, cos \<theta>]\<^bold>]\<parallel> = 1"
  by (simp add: vec_norm)

lemma orient_vec_mag_n [simp]:
  assumes "n \<ge> 0"
  shows "\<parallel>\<^bold>[[n * sin \<theta> :: real, n * cos \<theta>]\<^bold>]\<parallel> = n" (is "?P = ?Q")
proof -
  have "?P = \<parallel>\<^bold>[[n *\<^sub>R sin \<theta> :: real, n *\<^sub>R cos \<theta>]\<^bold>]\<parallel>"
    by (metis real_scaleR_def)
  also have "... = \<parallel>n *\<^sub>R \<^bold>[[sin \<theta> :: real, cos \<theta>]\<^bold>]\<parallel>"
    by simp
  also have "... = \<parallel>n\<parallel> * \<parallel>\<^bold>[[sin \<theta> :: real, cos \<theta>]\<^bold>]\<parallel>"
    by (metis norm_scaleR real_norm_def)
  also from assms have "... = n"
    by simp
  finally show ?thesis .
qed

lemma sin_cos_self_dot [simp]: "\<^bold>[[sin(\<theta>::real), cos(\<theta>)]\<^bold>] \<bullet> \<^bold>[[sin(\<theta>), cos(\<theta>)]\<^bold>] = 1"
  by (simp, metis power2_eq_square sin_cos_squared_add)

lemma vector_2_cases [cases type]:
  fixes x
  assumes "\<And> x\<^sub>1 x\<^sub>2. x = \<^bold>[[x\<^sub>1, x\<^sub>2]\<^bold>] \<Longrightarrow> P"
  shows "P"
proof -
  have "x = \<^bold>[[x$1$0, x$1$1]\<^bold>]"
    by (simp add: matrix_eq_iff nat_of_num1_def forall_2')
  thus ?thesis
    using assms by metis
qed

lemma cos_r1:
  assumes "- 1 \<le> y" "y < 1"
  shows "0 < arccos y"
proof -
  have "arccos 1 < arccos y"
    by (rule arccos_less_arccos, simp_all add: assms)
  thus ?thesis
    by simp
qed

lemma cos_r2:
  assumes "0 < x" "x \<le> 1"
  shows "arccos x * 2 < pi"
proof -
  have "arccos x < arccos 0"
    by (rule arccos_less_arccos, simp_all add: assms)
  thus ?thesis
    by simp
qed

lemma vec_2_eq_iff [simp]: "\<^bold>[[x\<^sub>1, y\<^sub>1]\<^bold>] = \<^bold>[[x\<^sub>2, y\<^sub>2]\<^bold>] \<longleftrightarrow> (x\<^sub>1 = x\<^sub>2 \<and> y\<^sub>1 = y\<^sub>2)"
  by (auto simp add: Mat_eq_iff')

lemma vec_2_eq_zero_off [simp]: "\<^bold>[[x, y]\<^bold>] = 0 \<longleftrightarrow> (x = 0 \<and> y = 0)"
  by (subst vec_simps(5) [THEN sym], simp only: vec_2_eq_iff)

subsection \<open> Angle Calculations \<close>

find_theorems vangle

abbreviation "angOfVec \<equiv> vangle \<^bold>[[0::real,100]\<^bold>]"

abbreviation "\<phi>\<^sub>m\<^sub>a\<^sub>x \<equiv> pi / 3"

definition angDiff :: "real \<Rightarrow> real \<Rightarrow> bool \<Rightarrow> real" where
"angDiff \<phi>\<^sub>A \<phi>\<^sub>B rotRestr \<equiv>
  let dphi =
  (if (abs(\<phi>\<^sub>A - \<phi>\<^sub>B) <= pi) then
    \<phi>\<^sub>A - \<phi>\<^sub>B
  else
    -sgn(\<phi>\<^sub>A - \<phi>\<^sub>B) * (2 * pi - abs(\<phi>\<^sub>A - \<phi>\<^sub>B)))
  in
  if (rotRestr) then
    -sgn(dphi) * min(abs(dphi)) \<phi>\<^sub>m\<^sub>a\<^sub>x
  else dphi"

lemma "angOfVec (Matrix[[0,1]]) = 0" \<comment> \<open> 0 degree angOfVector \<close>
  by (simp add: vangle_def vec_norm)

lemma "angOfVec (Matrix[[1,0]]) = pi / 2" \<comment> \<open> 90 degree angOfVector \<close>
  by (simp add: vangle_def)

lemma arccos_inv_sqrt2: "arccos (1 / sqrt 2) = pi / 4"
  by (smt arccos_cos arccos_minus_1 arcsin_minus_1 arcsin_plus_arccos arctan arctan_less_pi4_pos arctan_one arctan_zero_zero cos_45 eq_divide_eq mult_cancel_left1 real_div_sqrt real_divide_square_eq)

lemma "angOfVec (Matrix[[1,1]]) = pi / 4" \<comment> \<open> 45 degree angOfVector \<close>
  by (simp add: vangle_def arccos_inv_sqrt2 vec_norm)

lemma "angDiff (pi/2) (pi/4) False = pi/4"
  by (simp add: angDiff_def)

lemma "angDiff (pi) (pi/4) False = 3 / 4 * pi"
  by (simp add: angDiff_def)

datatype OPMode = OCM | HCM | MOM | CAM

dataspace AMV =
  constants
    S    :: real
    f\<^sub>m\<^sub>a\<^sub>x  :: real
  assumes
    f\<^sub>m\<^sub>a\<^sub>x: "f\<^sub>m\<^sub>a\<^sub>x \<ge> 0"
  variables
    \<comment> \<open> Continuous Variables \<close>
    p :: "real vec[2]" \<comment> \<open> Position \<close>
    v :: "real vec[2]" \<comment> \<open> Velocity \<close>
    a :: "real vec[2]" \<comment> \<open> Acceleration \<close>
    \<phi> :: "real" \<comment> \<open> Heading \<close>
    s :: "real" \<comment> \<open> Linear Speed \<close>
    \<comment> \<open> Discrete Variables\<close>
    wps :: "(real vec[2]) list" \<comment> \<open> Path of way points \<close>
    org :: "(real vec[2]) set" \<comment> \<open> Obstacle register \<close>
    rs      :: "real" \<comment> \<open> Requested speed \<close>
    rh      :: "real" \<comment> \<open> Requested heading \<close>

context AMV
begin

abbreviation "ax \<equiv> (s *\<^sub>R \<^bold>[[sin(\<phi>), cos(\<phi>)]\<^bold>] = v \<and> 0 \<le> s \<and> s \<le> S)\<^sup>e"

abbreviation "\<omega> \<equiv> (if (\<parallel>v\<parallel> = 0) then 0 else arccos((v + a) \<bullet> v / (\<parallel>v + a\<parallel> * \<parallel>v\<parallel>)))\<^sub>e"

abbreviation "ODE \<equiv>
   { p` = v
   , v` = a
   , a` = 0
   , \<phi>` = @\<omega>
   , s` = if s \<noteq> 0 then (v \<bullet> a) / s else \<parallel>a\<parallel>
   | @ax }"

text \<open> Heavily simplified for the purpose of example \<close>

abbreviation "Autopilot \<equiv> rs ::= 1; rs ::= 0"

lemma "ODE nmods (rs, rh, wps, org)"
  by (auto intro!: closure; subst_eval)

lemma "Autopilot nmods (p, a, v, s)"
  by (auto intro!: closure; subst_eval)

lemma "\<^bold>{s\<^sup>2 = v \<bullet> v\<^bold>} ODE \<^bold>{s\<^sup>2 = v \<bullet> v\<^bold>}"
  by (dWeaken, metis orient_vec_mag_n self_dot)

lemma "\<^bold>{a = 0 \<and> v = V\<^bold>} ODE \<^bold>{a = 0 \<and> v = V\<^bold>}" by dInduct_mega

lemma "\<^bold>{(a = 0 \<and> s > 0) \<and> \<phi> = X\<^bold>} ODE \<^bold>{\<phi> = X\<^bold>}" by dInduct_mega

lemma "\<^bold>{a \<bullet> v \<ge> 0 \<and> (a \<bullet> v)\<^sup>2 = (a \<bullet> a) * (v \<bullet> v)\<^bold>}
        ODE
       \<^bold>{a \<bullet> v \<ge> 0 \<and> (a \<bullet> v)\<^sup>2 = (a \<bullet> a) * (v \<bullet> v)\<^bold>}"
  by (dInduct_mega, metis inner_commute)

end

end


header {* Word Problem for Context-Free Grammars  *}
(*<*)
theory CFG_Examples
imports Coinductive_Language
begin
(*>*)

text {*
The function @{term in_language} decides the word problem for a given language.
Since we can construct the language of a CFG using @{const cfg.lang} we obtain an
executable (but not very efficient) decision procedure for CFGs for free.
*}

abbreviation "\<aa> \<equiv> Inl True"
abbreviation "\<bb> \<equiv> Inl False"
abbreviation "S \<equiv> Inr ()"

interpretation palindromes!: cfg "()" "\<lambda>_. [[], [\<aa>], [\<bb>], [\<aa>, S, \<aa>], [\<bb>, S, \<bb>]]"
  by unfold_locales auto
lemma "in_language palindromes.lang []" by normalization
lemma "in_language palindromes.lang [True]" by normalization
lemma "in_language palindromes.lang [False]" by normalization
lemma "in_language palindromes.lang [True, True]" by normalization
lemma "in_language palindromes.lang [True, False, True]" by normalization
lemma "\<not> in_language palindromes.lang [True, False]" by normalization
lemma "\<not> in_language palindromes.lang [True, False, True, False]" by normalization
(* slow
lemma "in_language palindromes.lang [True, False, True, True, False, True]" by normalization
lemma "\<not> in_language palindromes.lang [True, False, True, False, False, True]" by normalization
*)

interpretation Dyck!: cfg "()" "\<lambda>_. [[], [\<aa>, S, \<bb>, S]]"
  by unfold_locales auto
lemma "in_language Dyck.lang []" by normalization
lemma "\<not> in_language Dyck.lang [True]" by normalization
lemma "\<not> in_language Dyck.lang [False]" by normalization
lemma "in_language Dyck.lang [True, False, True, False]" by normalization
lemma "in_language Dyck.lang [True, True, False, False]" by normalization
lemma "in_language Dyck.lang [True, False, True, False]" by normalization
(* slow
lemma "in_language Dyck.lang [True, False, True, False, True, True, False, False]" by normalization
*)
lemma "\<not> in_language Dyck.lang [True, False, True, True, False]" by normalization
lemma "\<not> in_language Dyck.lang [True, True, False, False, False, True]" by normalization

end


(*  Title:       Conflict analysis/List Interleaving Operator
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
section "List Interleaving Operator"
theory Interleave
imports Main Misc
begin
text_raw \<open>\label{thy:Interleave}\<close>

text \<open>
  This theory defines an operator to return the set of all possible interleavings of two lists.
\<close>

(*
  Is \<Otimes>-operator needed ?
    Should we better do a reformulation of \<otimes> on sets of lists, to get an associative, commutative operator with identity (ACI ?) ?
*)

subsection "Definitions"

subsubsection "Prepend and concatenate lifted to sets"

definition list_set_cons :: "'a \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<cdot>" 65)
  where [simp]: "a\<cdot>S = (#) a ` S"

definition list_set_append :: "'a list \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<odot>" 65)
  where [simp]: "a\<odot>S = (@) a ` S"

subsubsection "The interleaving operator"

function
  interleave :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list set" (infixr "\<otimes>" 64)
where
  "[]\<otimes>b = {b}"
  | "a\<otimes>[] = {a}"
  | "a#l \<otimes> b#r = ((a\<cdot>(l \<otimes> b#r)) \<union> (b\<cdot>(a#l \<otimes> r)))"
by pat_completeness auto
termination by lexicographic_order

subsection "Properties"

subsubsection "Lifted prepend and concatenate operators"
lemma cons_set_cons_eq: "a#l \<in> b\<cdot>S = (a=b & l\<in>S)"
  by auto
lemma append_set_append_eq: "\<lbrakk>length a = length b\<rbrakk> \<Longrightarrow> a@l \<in> b\<odot>S = (a=b & l\<in>S)"
  by auto

lemma list_set_cons_cases[cases set]: "\<lbrakk>w\<in>a\<cdot>S; !!w'. \<lbrakk> w=a#w'; w'\<in>S \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by auto
lemma list_set_append_cases[cases set]: "\<lbrakk>w\<in>a\<odot>S; !!w'. \<lbrakk> w=a@w'; w'\<in>S \<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by auto

subsubsection "Standard simplification-, introduction-, elimination-, and induction rules"
lemma interleave_cons1: "l \<in> a\<otimes>b \<Longrightarrow> x#l \<in> x#a \<otimes> b"
  apply(case_tac b)
  apply(auto)
done

lemma interleave_cons2: "l \<in> a\<otimes>b \<Longrightarrow> x#l \<in> a \<otimes> x#b"
  apply(case_tac a)
  apply(auto)
done

lemmas interleave_cons = interleave_cons1 interleave_cons2

lemma interleave_empty[simp]: "[]\<in>a\<otimes>b = (a=[] & b=[])"
  apply(case_tac a)
  apply(case_tac b)
  apply(simp)
  apply(simp)
  apply(case_tac b)
  apply(auto)
done

(* TODO: Is this wise as default simp ?*)
lemma interleave_length[rule_format, simp]: "ALL x : a\<otimes>b . length x = length a + length b"
  apply(induct rule: interleave.induct)
  apply(auto)
done

lemma interleave_same[simp]: "y\<in>l\<otimes>y = (l=[])"
  apply (rule iffI)
  apply (subgoal_tac "length y = length l + length y")
  apply (simp del: interleave_length)
  apply (erule interleave_length)
  apply simp
done

lemma interleave_comm[simp]: "a\<otimes>b = b\<otimes>a" (is "?P f a b")
  apply(induct rule: interleave.induct)
  apply(auto)
done

lemma interleave_cont_conc[rule_format, simp]: "ALL b . a@b \<in> a\<otimes>b"
  apply(induct_tac a)
  apply(auto simp add: interleave_cons)
done

lemma interleave_cont_rev_conc[simp]: "b@a \<in> a\<otimes>b"
  apply (subgoal_tac "b@a \<in> b\<otimes>a")
  apply(simp)
  apply(simp only: interleave_cont_conc)
done

lemma interleave_not_empty: "a\<otimes>b ~= {}"
  apply(induct rule: interleave.induct)
  apply(auto)
done

lemma cons_interleave_split: "\<lbrakk>a#l \<in> l1\<otimes>l2\<rbrakk> \<Longrightarrow> (EX lh . l1=a#lh & l \<in> lh\<otimes>l2 | l2=a#lh & l \<in> l1\<otimes>lh )"
  apply(case_tac l1)
  apply(auto)
  apply(case_tac l2)
  apply(auto)
done

lemma cons_interleave_cases[cases set, case_names left right]: "\<lbrakk>a#l \<in> l1\<otimes>l2; !!lh . \<lbrakk>l1=a#lh; l \<in> lh\<otimes>l2\<rbrakk> \<Longrightarrow> P; !!lh. \<lbrakk>l2=a#lh; l \<in> l1\<otimes>lh\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (blast dest: cons_interleave_split)

lemma interleave_cases[cases set, case_names empty left right]: "\<lbrakk>l\<in>l1\<otimes>l2; \<lbrakk> l=[]; l1=[]; l2=[] \<rbrakk> \<Longrightarrow> P; !!a l' l1'. \<lbrakk>l=a#l'; l1=a#l1'; l'\<in>l1'\<otimes>l2\<rbrakk> \<Longrightarrow> P; !!a l' l2'. \<lbrakk>l=a#l'; l2=a#l2'; l'\<in>l1\<otimes>l2'\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply (cases l)
  apply (simp)
  apply simp
  apply (erule cons_interleave_cases)
  apply simp_all
  done

lemma interleave_elem_induct[induct set, case_names empty left right]:
  "!!w1 w2. \<lbrakk> w\<in>w1\<otimes>w2; P [] [] []; !!e w w1 w2. \<lbrakk> P w w1 w2; w\<in>w1\<otimes>w2 \<rbrakk> \<Longrightarrow> P (e#w) (e#w1) w2; !!e w w1 w2. \<lbrakk> P w w1 w2; w\<in>w1\<otimes>w2 \<rbrakk> \<Longrightarrow> P (e#w) w1 (e#w2) \<rbrakk> \<Longrightarrow> P w w1 w2"
  by (induct w) (auto elim!: cons_interleave_cases intro!: interleave_cons)

lemma interleave_rev_cons1[rule_format]: "ALL a b . l \<in> a\<otimes>b \<longrightarrow> l@[x] \<in> a@[x] \<otimes> b" (is "?P l")
proof (induct l)
  case Nil show ?case by (simp)
  case (Cons e l)
    assume IH[rule_format]: "?P l"
    show "?P (e#l)" proof (intro allI impI)
      fix a b
      assume "e#l \<in> a\<otimes>b"
      then obtain c where SPLIT: "a=e#c & l\<in>c\<otimes>b | b=e#c & l\<in>a\<otimes>c" by (blast dest: cons_interleave_split)
      with IH have "a=e#c & l@[x]\<in>c@[x]\<otimes>b | b=e#c & l@[x]\<in>a@[x]\<otimes>c" by auto
      hence "a=e#c & e#l@[x]\<in>e#c@[x]\<otimes>b | b=e#c & e#l@[x]\<in>a@[x]\<otimes>e#c" by (auto simp add: interleave_cons)
      thus "(e#l)@[x]\<in>a@[x]\<otimes>b" by auto
    qed
qed

corollary interleave_rev_cons2: "l \<in> a\<otimes>b \<Longrightarrow> l@[x] \<in> a \<otimes> b@[x]"
proof -
  assume "l \<in> a\<otimes>b"
  hence "l\<in>b\<otimes>a" by auto
  hence "l@[x] \<in> b@[x] \<otimes> a" by (blast dest: interleave_rev_cons1)
  thus ?thesis by auto
qed

lemmas interleave_rev_cons = interleave_rev_cons1 interleave_rev_cons2

subsubsection "Interleaving and list concatenation"

lemma interleave_append1: "\<lbrakk>l \<in> a\<otimes>b\<rbrakk> \<Longrightarrow> x@l \<in> x@a \<otimes> b" proof -
  have "ALL l a b . l \<in> a\<otimes>b \<longrightarrow> x@l \<in> x@a \<otimes> b" (is "?P x") proof (induct x)
    show "?P []" by simp
  next
    fix e
    fix x::"'a list"
    assume IH: "?P x"
    show "?P (e#x)" proof (intro impI allI)
      fix l::"'a list"
      fix a b
      assume "l \<in> a \<otimes> b"
      with IH have "x@l \<in> x@a \<otimes> b" by auto
      with interleave_cons1 show "(e # x) @ l \<in> (e # x) @ a \<otimes> b" by force
    qed
  qed
  moreover assume "l \<in> a \<otimes> b"
  ultimately show ?thesis by blast
qed

lemma interleave_append2: "\<lbrakk>l \<in> a\<otimes>b\<rbrakk> \<Longrightarrow> x@l \<in> a \<otimes> x@b" proof -
  have "ALL l a b . l \<in> a\<otimes>b \<longrightarrow> x@l \<in> a \<otimes> x@b" (is "?P x") proof (induct x)
    show "?P []" by simp
  next
    fix a
    fix x::"'a list"
    assume IH: "\<forall>l a b. l \<in> a \<otimes> b \<longrightarrow> x @ l \<in> a \<otimes> x @ b"
    show "\<forall>l aa b. l \<in> aa \<otimes> b \<longrightarrow> (a # x) @ l \<in> aa \<otimes> (a # x) @ b" proof (intro impI allI)
      fix l::"'a list"
      fix aa b
      assume "l \<in> aa \<otimes> b"

      with IH have "x@l \<in> aa \<otimes> x@b" by auto
      with interleave_cons2 show "(a # x) @ l \<in> aa \<otimes> (a # x) @ b" by force
    qed
  qed
  moreover assume "l \<in> a \<otimes> b"
  ultimately show ?thesis by blast
qed

lemmas interleave_append = interleave_append1 interleave_append2

lemma interleave_rev_append1: "!!a b w. w\<in>a\<otimes>b \<Longrightarrow> w@w' \<in> a@w' \<otimes> b"
proof (induct w' rule: rev_induct)
  case Nil thus ?case by simp
next
  case (snoc e w') note IHP=this
  hence "w@w'\<in>a@w'\<otimes>b" by auto
  thus ?case using interleave_rev_cons1[of "w@w'" "a@w'" "b"] by (simp)
qed

lemma interleave_rev1[rule_format]: "ALL w1 w2 . (w\<in>w1\<otimes>w2) \<longrightarrow> (rev w \<in> rev w1 \<otimes> rev w2)" (is "?P w")
proof (induct w)
  case Nil show ?case by (simp)
  case (Cons e w)
    assume IH[rule_format]: "?P w"
    show ?case proof (clarsimp)
      fix w1 w2
      assume "e # w \<in> w1 \<otimes> w2"
      then obtain w' where "w1=e#w' & w\<in>w'\<otimes>w2 | w2=e#w' & w\<in>w1\<otimes>w'" by (blast dest: cons_interleave_split)
      with IH have "w1=e#w' & rev w\<in>rev w' \<otimes> rev w2 | w2=e#w' & rev w \<in> rev w1 \<otimes> rev w'" by auto
      thus "rev w @ [e]\<in>rev w1 \<otimes> rev w2" by (auto simp add: interleave_rev_cons)
    qed
qed

corollary interleave_rev2: "(rev w \<in> rev w1 \<otimes> rev w2) \<Longrightarrow> (w\<in>w1\<otimes>w2)"
  apply (subgoal_tac "(rev w\<in>rev w1\<otimes>rev w2) = (rev (rev w) \<in> rev (rev w1) \<otimes> rev (rev w2))")
  apply(simp)
  apply (blast dest: interleave_rev1)
done

lemmas interleave_rev = interleave_rev1 interleave_rev2

lemma rev_cons_interleave_split: "\<lbrakk>l@[a] \<in> l1\<otimes>l2\<rbrakk> \<Longrightarrow> (EX lh . l1=lh@[a] & l \<in> lh\<otimes>l2 | l2=lh@[a] & l \<in> l1\<otimes>lh )"
proof -
  assume "l@[a] \<in> l1\<otimes>l2"
  hence "a#rev l \<in> rev l1 \<otimes> rev l2" by (auto dest: interleave_rev)
  then obtain lh where "rev l1 = a#lh & rev l \<in> lh\<otimes>rev l2 | rev l2 = a#lh & rev l \<in> rev l1 \<otimes> lh" by (blast dest: cons_interleave_split)
  hence "rev l1 = a#lh & l \<in> rev lh \<otimes> l2 | rev l2 = a#lh & l \<in> l1 \<otimes> rev lh" by (auto dest: interleave_rev)
  hence "l1 = rev lh @ [a] & l \<in> rev lh \<otimes> l2 | l2 = rev lh @ [a] & l \<in> l1 \<otimes> rev lh" by (simp add: rev_swap)
  thus ?thesis by blast
qed

subsubsection "Associativity"

lemma interleave_s_assoc1[rule_format]: "ALL w1 ws w2 w3 . (w\<in>w1\<otimes>ws & ws\<in>w2\<otimes>w3 \<longrightarrow> (EX ws' : w1\<otimes>w2 . w \<in> ws'\<otimes>w3))" proof (induct w)
  case Nil show ?case by (auto)
  case (Cons e w)
    assume IH: "ALL w1 ws w2 w3 . w\<in>w1\<otimes>ws & ws\<in>w2\<otimes>w3 \<longrightarrow> (EX ws' : w1\<otimes>w2 . w \<in> ws'\<otimes>w3)"
    show ?case proof (intro impI allI)
      fix w1 ws w2 w3
      assume A: "e#w \<in> w1 \<otimes> ws \<and> ws \<in> w2 \<otimes> w3"
      then obtain wh where CASES: "w1=e#wh & w\<in>wh\<otimes>ws | ws=e#wh & w\<in>w1\<otimes>wh" by (blast dest!: cons_interleave_split)
      moreover {
        assume CASE: "w1=e#wh & w\<in>wh\<otimes>ws"
        with A IH obtain ws' where "ws'\<in>wh\<otimes>w2 & w\<in>ws'\<otimes>w3" by (blast)
        hence "e#ws'\<in> (e#wh)\<otimes>w2 & e#w \<in> (e#ws')\<otimes>w3" by (auto simp add: interleave_cons)
        with CASE have "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
      } moreover {
        assume CASE: "ws=e#wh & w\<in>w1\<otimes>wh"
        with A obtain whh where "w2=e#whh & wh\<in>whh\<otimes>w3 | w3=e#whh & wh\<in>w2\<otimes>whh" by (blast dest!: cons_interleave_split)
        moreover {
          assume SCASE: "w2=e#whh & wh\<in>whh\<otimes>w3"
          with CASE IH obtain ws' where "ws'\<in>w1\<otimes>whh & w\<in>ws'\<otimes>w3" by blast
          with SCASE have "e#ws'\<in>w1\<otimes>w2 & e#w \<in> (e#ws')\<otimes>w3" by (auto simp add: interleave_cons)
          hence "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
        } moreover {
          assume SCASE: "w3=e#whh & wh\<in>w2\<otimes>whh"
          with CASE IH obtain ws' where "ws'\<in>w1\<otimes>w2 & w\<in>ws'\<otimes>whh" by blast
          with SCASE have "ws'\<in>w1\<otimes>w2 & e#w \<in> ws'\<otimes>w3" by (auto simp add: interleave_cons)
          hence "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
        } ultimately have "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
      } ultimately show "\<exists>ws'\<in>w1 \<otimes> w2. e # w \<in> ws' \<otimes> w3" by blast
    qed
qed

lemma interleave_s_assoc2: "\<lbrakk>w\<in>ws\<otimes>w3; ws\<in>w1\<otimes>w2\<rbrakk> \<Longrightarrow> EX ws' : w2\<otimes>w3 . w \<in> w1\<otimes>ws'" proof -
  assume "w \<in> ws \<otimes> w3" "ws \<in> w1 \<otimes> w2"
  hence "w \<in> w3 \<otimes> ws & ws \<in> w2 \<otimes> w1" by simp
  hence "EX ws':w3\<otimes>w2 . w\<in>ws'\<otimes>w1" by (simp only: interleave_s_assoc1)
  thus ?thesis by simp
qed

lemmas interleave_s_assoc = interleave_s_assoc1 interleave_s_assoc2

subsubsection "Relation to other standard list operations"

lemma interleave_set: "w\<in>w1\<otimes>w2 \<Longrightarrow> set w = set w1 \<union> set w2"
  by (induct rule: interleave_elem_induct) auto
lemma interleave_map: "w\<in>w1\<otimes>w2 \<Longrightarrow> map f w \<in> map f w1 \<otimes> map f w2"
  by (induct rule: interleave_elem_induct) (auto intro!: interleave_cons)
lemma interleave_filter: "w\<in>w1\<otimes>w2 \<Longrightarrow> filter f w \<in> filter f w1 \<otimes> filter f w2"
  by (induct rule: interleave_elem_induct) (auto intro!: interleave_cons)

subsubsection "Relation to sublist order"

lemma ileq_interleave_alt: "l'\<preceq>l == \<exists>lb. l\<in>lb \<otimes> l'" proof (rule eq_reflection)
  {fix l' l have "l'\<preceq>l \<Longrightarrow> \<exists>lb. l\<in>lb \<otimes> l'" by (induct rule: less_eq_list_induct) (simp, (blast intro: interleave_cons)+)}
  moreover {fix l have "!!lb l'. l\<in>lb\<otimes>l' \<Longrightarrow> l'\<preceq>l" by (induct l) (auto intro: less_eq_list_drop elim!: cons_interleave_cases)}
  ultimately show "(l'\<preceq>l) = (\<exists>lb. l\<in>lb \<otimes> l')" by blast
qed

lemma ileq_interleave: "w\<in>w1\<otimes>w2 \<Longrightarrow> w1\<preceq>w & w2\<preceq>w"
  by (unfold ileq_interleave_alt, auto)

lemma ilt_ex_notempty: "x < y \<longleftrightarrow> (\<exists>xs. xs \<noteq> [] \<and> y \<in> xs \<otimes> x)"
  apply (auto simp add: order_less_le ileq_interleave_alt)
  apply (case_tac lb)
  apply auto
done

lemma ilt_interleave1: "\<lbrakk>w\<in>w1\<otimes>w2; w1~=[]\<rbrakk> \<Longrightarrow> w2<w"
  by (simp only: ilt_ex_notempty, blast)
lemma ilt_interleave2: "\<lbrakk>w\<in>w1\<otimes>w2; w2~=[]\<rbrakk> \<Longrightarrow> w1<w"
  by (simp only: ilt_ex_notempty interleave_comm[of w1 w2], blast)
lemmas ilt_interleave = ilt_interleave1 ilt_interleave2

subsubsection "Exotic/specialized lemmas"
\<comment> \<open>Recover structure of @{text w} wrt. to structure of @{text "w1"}\<close>
lemma interleave_recover1[rule_format]: "ALL w1a w1b w2 . w\<in>(w1a@w1b)\<otimes>w2 \<longrightarrow> (EX wa wb w2a w2b . w=wa@wb & w2=w2a@w2b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b)"
  (is "?P w" is "ALL w1a w1b w2 . ?PRE w w1a w1b w2 \<longrightarrow> ?CONS w w1a w1b w2")
proof (induct w)
  case Nil show ?case by (auto)
  case (Cons e w)
    assume IH[rule_format]: "?P w"
    show "?P (e#w)" proof (intro allI impI)
      fix w1a w1b w2
      assume PRE: "e # w \<in> w1a @ w1b \<otimes> w2"
      {
        assume CASE: "w1a=[]"
        with PRE have "e#w=[]@(e#w) & w2=[]@w2 & []\<in>w1a\<otimes>[] & e#w\<in>w1b\<otimes>w2" by (auto)
        hence "?CONS (e#w) w1a w1b w2" by blast
      } moreover {
        assume CASE: "w1a~=[]"
        with PRE obtain wh where SCASES: "w1a@w1b=e#wh & w\<in>wh\<otimes>w2 | w2=e#wh & w\<in>w1a@w1b\<otimes>wh" by (blast dest: cons_interleave_split)
        moreover {
          assume SCASE: "w1a@w1b=e#wh & w\<in>wh\<otimes>w2"
          with CASE obtain w1ah where W1AFMT: "w1a=e#w1ah & w1ah@w1b=wh" by (cases w1a, auto)
          with SCASE have "w\<in>w1ah@w1b\<otimes>w2" by auto
          with IH[of w1ah w1b w2] obtain wa wb w2a w2b where "w=wa@wb & w2=w2a@w2b & wa\<in>w1ah\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by (blast)
          with W1AFMT have "e#w=(e#wa)@wb & e#w\<in>e#wa\<otimes>wb & w2=w2a@w2b & e#wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by (auto simp add: interleave_cons)
          hence "?CONS (e#w) w1a w1b w2" by blast
        } moreover {
          assume SCASE: "w2=e#wh & w\<in>w1a@w1b\<otimes>wh"
          with IH[of w1a w1b wh] obtain wa wb w2a w2b where "w=wa@wb & wh=w2a@w2b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b" by blast
          with SCASE have "e#w=(e#wa)@wb & w2=(e#w2a)@w2b & e#wa\<in>w1a\<otimes>e#w2a & wb\<in>w1b\<otimes>w2b" by (auto simp add: interleave_cons)
          hence "?CONS (e#w) w1a w1b w2" by blast
        }
        ultimately have "?CONS (e#w) w1a w1b w2" by blast
      }
      ultimately show "?CONS (e#w) w1a w1b w2" by blast
    qed
qed

lemma interleave_recover2: "w\<in>w1\<otimes>(w2a@w2b) \<Longrightarrow> EX wa wb w1a w1b . w=wa@wb & w1=w1a@w1b & wa\<in>w1a\<otimes>w2a & wb\<in>w1b\<otimes>w2b"
proof -
  assume "w\<in>w1\<otimes>(w2a@w2b)"
  hence "w\<in>(w2a@w2b)\<otimes>w1" by auto
  hence "EX wa wb w1a w1b . w=wa@wb & w1=w1a@w1b & wa\<in>w2a\<otimes>w1a & wb\<in>w2b\<otimes>w1b" by (blast dest: interleave_recover1)
  thus ?thesis by auto
qed

lemmas interleave_recover = interleave_recover1 interleave_recover2

\<comment> \<open>Split operands according to element of result\<close>
lemma interleave_unconc: "!! l2 w1 w2 . l1@l2 \<in> w1\<otimes>w2 \<Longrightarrow> \<exists> w11 w12 w21 w22 . w1=w11@w12 \<and> w2=w21@w22 \<and> l1\<in>w11\<otimes>w21 \<and> l2\<in>w12\<otimes>w22"
proof (induct l1)
  case Nil hence "w1=[]@w1 & w2=[]@w2 & []\<in>[]\<otimes>[] & l2\<in>w1\<otimes>w2" by auto
  thus ?case by fast
next
  case (Cons e l1') note IHP=this
  hence "e#(l1'@l2)\<in>w1\<otimes>w2" by auto
  with cons_interleave_split obtain w' where "(w1=e#w' & l1'@l2\<in>w'\<otimes>w2) | (w2=e#w' & l1'@l2\<in>w1\<otimes>w')" (is "?C1 | ?C2") by (fast)
  moreover {
    assume CASE: ?C1
    moreover then obtain w11' w12' w21 w22 where "w'=w11'@w12' \<and> w2=w21@w22 \<and> l1'\<in>w11'\<otimes>w21 \<and> l2\<in>w12'\<otimes>w22" by (fast dest: IHP(1))
    moreover hence "e#w'=(e#w11')@w12' & e#l1'\<in>(e#w11')\<otimes>w21" by (auto dest: interleave_cons)
    ultimately have ?case by fast
  } moreover {
    assume CASE: ?C2
    moreover then obtain w11 w12 w21' w22' where "w1=w11@w12 \<and> w'=w21'@w22' \<and> l1'\<in>w11\<otimes>w21' \<and> l2\<in>w12\<otimes>w22'" by (fast dest: IHP(1))
    moreover hence "e#w'=(e#w21')@w22' & e#l1'\<in>w11\<otimes>(e#w21')" by (auto dest: interleave_cons)
    ultimately have ?case by fast
  } ultimately show ?case by fast
qed

\<comment> \<open>Reverse direction of @{thm [source] "interleave_unconc"}\<close>
lemma interleave_reconc: "!!w11 w21 l2 w12 w22 . \<lbrakk>l1\<in>w11\<otimes>w21;l2\<in>w12\<otimes>w22\<rbrakk> \<Longrightarrow> l1@l2\<in>(w11@w12)\<otimes>(w21@w22)"
proof (induct l1)
  case Nil thus ?case by (auto)
next
  case (Cons e l1') note IHP=this
  then obtain w' where "(w11=e#w' & l1'\<in>w'\<otimes>w21) | (w21=e#w' & l1'\<in>w11\<otimes>w')" (is "?C1 | ?C2") by (fast dest: cons_interleave_split)
  moreover {
    assume CASE: ?C1
    moreover with IHP have "l1'@l2\<in>(w'@w12)\<otimes>(w21@w22)" by auto
    ultimately have ?case by (auto dest: interleave_cons)
  } moreover {
    assume CASE: ?C2
    moreover with IHP have "l1'@l2\<in>(w11@w12)\<otimes>(w'@w22)" by auto
    ultimately have ?case by (auto dest: interleave_cons)
  } ultimately show ?case by fast
qed

(* interleave_unconc and interleave_reconc as equivalence *)
lemma interleave_unconc_eq: "!! l2 w1 w2 . l1@l2 \<in> w1\<otimes>w2 = (\<exists> w11 w12 w21 w22 . w1=w11@w12 \<and> w2=w21@w22 \<and> l1\<in>w11\<otimes>w21 \<and> l2\<in>w12\<otimes>w22)"
  by (fast dest: interleave_reconc interleave_unconc)

end


theory Prefix_Language
  imports Language
begin

datatype 'a plist = Trace "'a llist" | Pre "'a llist"

fun pappend :: "'a plist \<Rightarrow> 'a plist \<Rightarrow> 'a plist" where
  "pappend (Pre xs) ys = Pre xs"
| "pappend (Trace xs) (Pre ys) = Pre (xs \<frown> ys)"
| "pappend (Trace xs) (Trace ys) = Trace (xs \<frown> ys)"

lemma pappend_assoc: "pappend (pappend xs ys) zs = pappend xs (pappend ys zs)"
  apply (cases xs)
  apply simp_all
  apply (cases ys)
  apply simp_all
  apply (cases zs)
  apply simp_all
  by (metis lappend_assoc)+

type_synonym 'a plan = "'a plist set"

lemma lprefixD: "lprefix xs' xs \<Longrightarrow> (\<exists>xs''. xs = xs' \<frown> xs'')"
  by (metis lprefix_def)

lemma set_bex_iso: "B \<subseteq> A \<Longrightarrow> \<exists>xs\<in>B. P xs \<Longrightarrow> \<exists>xs\<in>A. P xs"
  by (metis set_rev_mp)

lemma tshuffle_exchange: "lfinite xs \<Longrightarrow> lfinite ys \<Longrightarrow> (xs \<sha> ys) \<cdot> (xs' \<sha> ys') \<subseteq> (xs \<frown> xs') \<sha> (ys \<frown> ys')"
  apply (auto simp add: tshuffle_words_def l_prod_def)
  apply (metis lfinite_lr)
  apply (metis lfinite_lr)
  apply (metis lefts_append)
  by (metis rights_append)

definition strict_lprefix :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> bool" (infixl "\<prec>" 57) where
  "xs \<prec> ys \<equiv> lprefix xs ys \<and> xs \<noteq> ys"

lemma "xs \<prec> ys \<Longrightarrow> lfinite xs"
  by (metis not_lfinite_lprefix_conv_eq strict_lprefix_def)

lemma strict_lprefix: "xs \<prec> ys \<longleftrightarrow> (\<exists>xs'. ys = xs \<frown> xs' \<and> xs' \<noteq> LNil \<and> lfinite xs)"
  by (metis lprefixD lstrict_prefix_def lstrict_prefix_lappend_conv strict_lprefix_def)

axiomatization
  alternates :: "'a llist \<Rightarrow> 'b llist \<Rightarrow> ('a + 'b) llist"
where
  alternate: "alternates xs ys \<in> xs \<sha> ys"

lemma shuffle_never_empty: "xs \<sha> ys \<noteq> {}"
  apply (auto simp add: tshuffle_words_def)
  apply (rule_tac x = "alternates xs ys" in exI)
  using alternate by (auto simp add: tshuffle_words_def)

lemma
  assumes "zs' \<in> xs' \<sha> ys'"
  and "xs' \<prec> xs" and "ys' \<prec> ys"
  shows "\<exists>zs\<in>xs \<sha> ys. zs' \<prec> zs"
proof -
  obtain xs'' and ys''
  where "xs = xs' \<frown> xs''" and "xs'' \<noteq> LNil" and "lfinite xs'"
  and "ys = ys' \<frown> ys''" and "ys'' \<noteq> LNil" and "lfinite ys'"
    by (metis assms(2) assms(3) lappend_LNil2 lprefixD not_lfinite_lprefix_conv_eq strict_lprefix_def)

  have "xs'' \<sha> ys'' \<noteq> {}"
    by (metis shuffle_never_empty)
  then obtain zs'' where "zs'' \<in> xs'' \<sha> ys''"
    by (metis alternate)

  have "\<exists>zs\<in>(xs' \<sha> ys') \<cdot> (xs'' \<sha> ys''). zs' \<prec> zs"
    apply (subst fin_l_prod)
    apply (metis FIN_def `lfinite xs'` `lfinite ys'` lfinite_shuffle mem_Collect_eq subsetI)
    apply (simp add: strict_lprefix)
    apply (rule_tac x = "zs' \<frown> zs''" in exI)
    apply (intro conjI)
    apply (rule_tac x = "zs'" in exI)
    apply (rule_tac x = "zs''" in exI)
    apply simp_all
    apply (metis `zs'' \<in> xs'' \<sha> ys''` assms(1))
    apply (rule_tac x = "zs''" in exI)
    apply simp
    by (metis (lifting, full_types) `xs'' \<noteq> LNil` `zs'' \<in> xs'' \<sha> ys''` `lfinite xs'` `lfinite ys'` assms(1) lefts_LNil lfinite_shuffle mem_Collect_eq tshuffle_words_def)
  hence "\<exists>zs\<in>(xs' \<frown> xs'') \<sha> (ys' \<frown> ys''). zs' \<prec> zs"
    by (metis `lfinite xs'` `lfinite ys'` in_mono tshuffle_exchange)
  thus "\<exists>zs\<in>xs \<sha> ys. zs' \<prec> zs"
    by (metis `xs = xs' \<frown> xs''` `ys = ys' \<frown> ys''`)
qed

lemma strict_lprefix_irrefl: "\<not> (xs \<prec> xs)"
  by (auto simp add: strict_lprefix) (metis lappend_LNil2 llist.distinct(1) lstrict_prefix_lappend_conv)

lemma strict_lprefix_trans: "xs \<prec> ys \<Longrightarrow> ys \<prec> zs \<Longrightarrow> xs \<prec> zs"
  apply (auto simp add: strict_lprefix_def)
  apply (metis lprefix_trans)
  by (metis lprefix_antisym)

lemma strict_lprefix_antisym: "xs \<prec> ys \<Longrightarrow> ys \<prec> xs \<Longrightarrow> False"
  by (metis lprefix_antisym strict_lprefix_def)

primrec pclose :: "'a plist \<Rightarrow> 'a plan" where
  "pclose (Trace xs') = insert (Trace xs') {Pre xs |xs. xs \<prec> xs'}"
| "pclose (Pre xs') = insert (Pre xs') {Pre xs |xs. xs \<prec> xs'}"

definition pclosure :: "'a plan \<Rightarrow> 'a plan" ("_\<^sup>\<dagger>" [1000] 1000) where
  "pclosure X = \<Union>(pclose ` X)"

lemma "Pre xs \<in> (Trace ` X)\<^sup>\<dagger> \<Longrightarrow> lfinite xs"
  by (auto simp add: pclosure_def) (metis strict_lprefix)

lemma pclose_trans: "xs \<in> pclose ys \<Longrightarrow> ys \<in> pclose zs \<Longrightarrow> xs \<in> pclose zs"
  apply (cases ys)
  apply simp_all
  apply (cases zs)
  apply simp_all
  apply (cases zs)
  apply (simp_all)
  by (metis strict_lprefix_trans)+

lemma pclose_refl: "xs \<in> pclose xs"
  by (cases xs) simp_all

lemma pc_idem: "X\<^sup>\<dagger>\<^sup>\<dagger> = X\<^sup>\<dagger>"
  apply (auto simp add: pclosure_def)
  apply (rename_tac xs zs ys)
  apply (rule_tac x = zs in bexI)
  apply (metis pclose_trans)
  apply simp
  apply (rename_tac xs ys)
  apply (rule_tac x = ys in bexI)
  apply simp_all
  apply (rule_tac x = xs in bexI)
  apply simp_all
  by (rule pclose_refl)

lemma "X \<le> X\<^sup>\<dagger>"
  by (auto simp add: pclosure_def) (metis pclose_refl)

lemma "X \<le> Y \<Longrightarrow> X\<^sup>\<dagger> \<le> Y\<^sup>\<dagger>"
  by (auto simp add: pclosure_def)

primrec pterm :: "'a plist \<Rightarrow> bool" where
  "pterm (Pre xs) = False"
| "pterm (Trace xs) = lfinite xs"

definition pprod :: "'a plan \<Rightarrow> 'a plan \<Rightarrow> 'a plan" (infixl "\<bowtie>" 80) where
  "pprod X Y = {pappend xs ys |xs ys. xs \<in> X \<and> pterm xs \<and> ys \<in> Y} \<union> {xs. xs \<in> X \<and> \<not> pterm xs}"

lemma pterm_pappend: "pterm (pappend xs ys) \<longleftrightarrow> (pterm xs \<and> pterm ys)"
  apply (cases xs)
  apply simp_all
  apply (cases ys)
  by simp_all

lemma pprod_assoc: "(X \<bowtie> Y) \<bowtie> Z = X \<bowtie> (Y \<bowtie> Z)"
  apply (simp add: pprod_def)
  apply safe
  by (metis pappend_assoc pterm_pappend)+

lemma pprod_inf_dist: "(\<Union> \<XX>) \<bowtie> Y = \<Union>{X \<bowtie> Y |X. X \<in> \<XX>}"
  by (auto simp add: pprod_def)

(*
lemma "(Trace ` X)\<^sup>\<dagger> \<bowtie> (Trace ` Y)\<^sup>\<dagger> = (Trace ` (X \<cdot> Y))\<^sup>\<dagger>"
proof -
  have "(Trace ` X)\<^sup>\<dagger> \<bowtie> (Trace ` Y)\<^sup>\<dagger> = \<Union>(pclose ` Trace ` X) \<bowtie> \<Union>(pclose ` Trace ` Y)"
    by (simp add: pclosure_def)
  also have "... = \<Union>{X' \<bowtie> \<Union>(pclose ` Trace ` Y) |X'. X' \<in> pclose ` Trace ` X}"
    by (subst pprod_inf_dist) simp
  also have "... = \<Union>(pclose ` Trace ` (X \<cdot> Y))"
    apply (rule arg_cong) back
    apply (simp add: l_prod_def pprod_def image_def)
    apply safe
    sledgehammer
    apply (rule_tac x
*)

fun pshuffle_words :: "'a plist \<Rightarrow> 'b plist \<Rightarrow> ('a + 'b) plan" where
  "pshuffle_words (Pre xs) (Pre ys) = Pre ` (xs \<sha> ys)"
| "pshuffle_words (Pre xs) (Trace ys) = (if lfinite ys then Pre ` (xs \<sha> ys) else {})"
| "pshuffle_words (Trace xs) (Pre ys) = (if lfinite xs then Pre ` (xs \<sha> ys) else {})"
| "pshuffle_words (Trace xs) (Trace ys) = Trace ` (xs \<sha> ys)"

lemma lprefixD: "lprefix xs' xs \<Longrightarrow> (\<exists>xs''. xs = xs' \<frown> xs'')"
  by (metis lprefix_def)

lemma set_bex_iso: "B \<subseteq> A \<Longrightarrow> \<exists>xs\<in>B. P xs \<Longrightarrow> \<exists>xs\<in>A. P xs"
  by (metis set_rev_mp)

lemma tshuffle_exchange: "lfinite xs \<Longrightarrow> lfinite ys \<Longrightarrow> (xs \<sha> ys) \<cdot> (xs' \<sha> ys') \<subseteq> (xs \<frown> xs') \<sha> (ys \<frown> ys')"
  apply (auto simp add: tshuffle_words_def l_prod_def)
  apply (metis lfinite_lr)
  apply (metis lfinite_lr)
  apply (metis lefts_append)
  by (metis rights_append)

definition strict_lprefix :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> bool" (infixl "\<prec>" 57) where
  "xs \<prec> ys \<equiv> lprefix xs ys \<and> xs \<noteq> ys"

lemma "xs \<prec> ys \<Longrightarrow> lfinite xs"
  by (metis not_lfinite_lprefix_conv_eq strict_lprefix_def)

lemma strict_lprefix: "xs \<prec> ys \<longleftrightarrow> (\<exists>xs'. ys = xs \<frown> xs' \<and> xs' \<noteq> LNil \<and> lfinite xs)"
  by (metis lprefixD lstrict_prefix_def lstrict_prefix_lappend_conv strict_lprefix_def)

axiomatization
  alternates :: "'a llist \<Rightarrow> 'b llist \<Rightarrow> ('a + 'b) llist"
where
  alternate: "alternates xs ys \<in> xs \<sha> ys"

lemma shuffle_never_empty: "xs \<sha> ys \<noteq> {}"
  apply (auto simp add: tshuffle_words_def)
  apply (rule_tac x = "alternates xs ys" in exI)
  using alternate by (auto simp add: tshuffle_words_def)

lemma
  assumes "zs' \<in> xs' \<sha> ys'"
  and "xs' \<prec> xs" and "ys' \<prec> ys"
  shows "\<exists>zs\<in>xs \<sha> ys. zs' \<prec> zs"
proof -
  obtain xs'' and ys''
  where "xs = xs' \<frown> xs''" and "xs'' \<noteq> LNil" and "lfinite xs'"
  and "ys = ys' \<frown> ys''" and "ys'' \<noteq> LNil" and "lfinite ys'"
    by (metis assms(2) assms(3) lappend_LNil2 lprefixD not_lfinite_lprefix_conv_eq strict_lprefix_def)

  have "xs'' \<sha> ys'' \<noteq> {}"
    by (metis shuffle_never_empty)
  then obtain zs'' where "zs'' \<in> xs'' \<sha> ys''"
    by (metis alternate)

  have "\<exists>zs\<in>(xs' \<sha> ys') \<cdot> (xs'' \<sha> ys''). zs' \<prec> zs"
    apply (subst fin_l_prod)
    apply (metis FIN_def `lfinite xs'` `lfinite ys'` lfinite_shuffle mem_Collect_eq subsetI)
    apply (simp add: strict_lprefix)
    apply (rule_tac x = "zs' \<frown> zs''" in exI)
    apply (intro conjI)
    apply (rule_tac x = "zs'" in exI)
    apply (rule_tac x = "zs''" in exI)
    apply simp_all
    apply (metis `zs'' \<in> xs'' \<sha> ys''` assms(1))
    apply (rule_tac x = "zs''" in exI)
    apply simp
    by (metis (lifting, full_types) `xs'' \<noteq> LNil` `zs'' \<in> xs'' \<sha> ys''` `lfinite xs'` `lfinite ys'` assms(1) lefts_LNil lfinite_shuffle mem_Collect_eq tshuffle_words_def)
  hence "\<exists>zs\<in>(xs' \<frown> xs'') \<sha> (ys' \<frown> ys''). zs' \<prec> zs"
    by (metis `lfinite xs'` `lfinite ys'` in_mono tshuffle_exchange)
  thus "\<exists>zs\<in>xs \<sha> ys. zs' \<prec> zs"
    by (metis `xs = xs' \<frown> xs''` `ys = ys' \<frown> ys''`)
qed

no_notation tshuffle_words (infix "\<sha>" 75)
notation pshuffle_words (infix "\<sha>" 75)

no_notation tshuffle (infixl "\<Sha>" 75)

definition pshuffle :: "'a plan \<Rightarrow> 'b plan \<Rightarrow> ('a + 'b) plan" (infixl "\<Sha>" 75) where
  "X \<Sha> Y \<equiv> \<Union>{x \<sha> y|x y. x \<in> X \<and> y \<in> Y}"

lemma "zs' \<in> xs' \<sha> ys' \<Longrightarrow> xs' \<in> pclose (Pre xs) \<Longrightarrow> ys' \<in> pclose (Pre ys) \<Longrightarrow> \<exists>zs\<in>(Pre xs) \<sha> (Pre ys). zs' \<in> pclose zs"
  apply simp_all
  apply (erule exE)+
  apply auto
  sledgehammer

lemma "(pclose xs \<Sha> pclose ys) = (xs \<sha> ys)\<^sup>\<dagger>"
  apply (auto simp add: pshuffle_def pclosure_def)
  apply (rename_tac zs xs' ys')
  apply (cases xs)
  apply (simp_all)
  apply (cases ys)
  apply simp_all
  apply (erule disjE)
  apply (erule disjE)
  sledgehammer

fun pshuffle_words :: "'a plist \<Rightarrow> 'b plist \<Rightarrow> ('a + 'b) plan" (infix "\<sha>" 75) where
  "(Pre xs) \<sha> (Pre ys) = Pre ` list_of ` (llist_of xs \<sha> llist_of ys)"
| "(Term xs) \<sha> (Term ys) = Term ` list_of ` (llist_of xs \<sha> llist_of ys)"
| "(Inf xs) \<sha> (Inf ys) = Inf ` stream_of_llist ` (llist_of_stream xs \<sha> llist_of_stream ys)"
| "(Term xs) \<sha> (Inf ys) = Inf ` stream_of_llist ` (llist_of xs \<sha> llist_of_stream ys)"
| "(Inf xs) \<sha> (Term ys) = Inf ` stream_of_llist ` (llist_of_stream xs \<sha> llist_of ys)"
| "(Pre xs) \<sha> (Term ys) = Pre ` list_of ` (llist_of xs \<sha> llist_of ys)"
| "(Term xs) \<sha> (Pre ys) = Pre ` list_of ` (llist_of xs \<sha> llist_of ys)"
| "pshuffle_words xs ys = {}"

end


theory SyntaxSemanticsOfAlgebra

imports
  Main
  "~~/src/HOL/Library/Dlist"
  "Temporal_Faults_Algebra_dlist"

begin

inductive minterm :: "'a set \<Rightarrow> ('a dlist \<times> 'a set) \<Rightarrow> bool"
for G :: "'a set"
where
"Dlist.set xs \<inter> nands = {} \<Longrightarrow> Dlist.set xs \<union> nands = G \<Longrightarrow>
  minterm G (xs, nands)"

definition filter_all_formulas ::
  "'a set \<Rightarrow> ('a dlist \<Rightarrow> 'a set \<Rightarrow> bool) \<Rightarrow> ('a dlist \<times> 'a set) set" where
"filter_all_formulas G P =
  { (xs,nands). minterm G (xs,nands) \<and> P xs nands }"

definition all_formulas_of :: "'a set \<Rightarrow> ('a dlist \<times> 'a set) set" where
"all_formulas_of G = filter_all_formulas G (\<lambda>xs nands. True)"

datatype 'a expression =
  eFalse |
  eTrue |
  eNeutral |
  eVar 'a |
  eNot "'a expression" |
  eAnd "'a expression" "'a expression" |
  eOr "'a expression" "'a expression" |
  eXB "'a expression" "'a expression"

definition dlist_take :: "nat \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
"dlist_take i ds = Dlist (take i (list_of_dlist ds))"

definition dlist_drop :: "nat \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
"dlist_drop i ds = Dlist (drop i (list_of_dlist ds))"

definition minterm_xbefore ::
  "'a set \<Rightarrow> ('a dlist \<times> 'a set) set \<Rightarrow>
  ('a dlist \<times> 'a set) set \<Rightarrow> ('a dlist \<times> 'a set) set" where
"minterm_xbefore G F1 F2 = filter_all_formulas G
  (\<lambda>xs _ . \<exists>i.
    (dlist_take i xs, G - Dlist.set xs) \<in> F1 \<and>
    (dlist_take i xs, G - Dlist.set xs) \<in> F2
  )"

(*
primrec semantics_of ::
  "'a set \<Rightarrow> 'a expression \<Rightarrow> ('a dlist \<times> 'a set) set" where
"semantics_of _ eFalse = {}" |
"semantics_of G eTrue = all_formulas_of G" |
"semantics_of G eNeutral = { (Dlist.empty, G) }" |
"semantics_of G (eVar x) =
  filter_all_formulas G (\<lambda>xs _ . Dlist.member xs x)" |
"semantics_of G (eNot f) = all_formulas_of G - semantics_of G f" |
"semantics_of G (eAnd f1 f2) = semantics_of G f1 \<inter> semantics_of G f2" |
"semantics_of G (eOr f1 f2) = semantics_of G f1 \<union> semantics_of G f2" |
"semantics_of G (eXB f1 f2) =
  minterm_xbefore G (semantics_of G f1) (semantics_of G f2)"
*)

primrec semantics_of :: "'a expression \<Rightarrow> 'a formula" where
"semantics_of eFalse = bot" |
"semantics_of eTrue = top" |
"semantics_of eNeutral = neutral" |
"semantics_of (eVar a) = (Abs_formula {ds. Dlist.member ds a})" |
"semantics_of (eAnd f1 f2) = inf (semantics_of f1) (semantics_of f2)" |
"semantics_of (eOr f1 f2) = sup (semantics_of f1) (semantics_of f2)" |
"semantics_of (eXB f1 f2) = xbefore (semantics_of f1) (semantics_of f2)" |
"semantics_of (eNot f) = - semantics_of f"

definition mk_eXB :: "'a \<Rightarrow> 'a expression \<Rightarrow> 'a expression" where
"mk_eXB x f = eXB (eVar x) f"

definition list_formula_of :: "'a list \<Rightarrow> 'a expression" where
"list_formula_of xs = foldr mk_eXB xs eNeutral"

definition mk_eNand :: "'a \<Rightarrow> 'a expression \<Rightarrow> 'a expression" where
"mk_eNand g f = eAnd (eNot (eVar g)) f"

definition mk_eNands :: "'a set \<Rightarrow> 'a expression" where
"mk_eNands nands =
  Finite_Set.fold mk_eNand eTrue nands"

definition mk_eMinterm ::
  "('a dlist \<times> 'a set) \<Rightarrow> 'a expression \<Rightarrow> 'a expression" where
"mk_eMinterm p f =
  eOr (
    eAnd
      (list_formula_of (list_of_dlist (fst p)))
      (mk_eNands (snd p)))
    f"

definition formula_of :: "('a dlist \<times> 'a set) set \<Rightarrow> 'a expression" where
"formula_of minterms = Finite_Set.fold mk_eMinterm eFalse minterms "

inductive reduce:: "'a expression \<Rightarrow> 'a expression \<Rightarrow> bool" where
reduce_idem: "reduce f f" |
eOr_true: "reduce (eOr eTrue f) eTrue" |
eOr_false: "reduce (eOr eFalse f) f" |
eOr_commute: "reduce (eOr f1 f2) f \<Longrightarrow> reduce (eOr f2 f1) f" |
Or_implies_eOr: "reduce f1 f \<or> reduce f2 f \<Longrightarrow> reduce (eOr f1 f2) f" |
"reduce (eOr f1 f2) f \<Longrightarrow> reduce (eOr (eAnd f1 f) (eAnd f2 f)) f" |
eNot_false: "reduce (eNot eFalse) eTrue" |
eNot_true: "reduce (eNot eTrue) eFalse" |
eNot_eNot: "reduce (eNot (eNot f)) f" |
eAnd_true: "reduce (eAnd eTrue f) f" |
eAnd_false: "reduce (eAnd eFalse f) eFalse" |
eAnd_commute: "reduce (eAnd f1 f2) f \<Longrightarrow> reduce (eAnd f2 f1) f" |
eAnd_implies1: "reduce (eAnd f1 f2) f \<Longrightarrow> reduce f1 f" |
eAnd_implies2: "reduce (eAnd f1 f2) f \<Longrightarrow> reduce f2 f" |
eAnd_eNot: "reduce (eAnd f (eNot f)) eFalse" |
eOr_eNot: "reduce (eOr f (eNot f)) eTrue" |
eXB_neutral_1: "reduce (eXB (eVar a) eNeutral) f" |
eXB_neutral_2: "reduce (eXB eNeutral (eVar a)) f" |
eXB_eOr_eAnd:
  "reduce (eOr (eXB (eVar a) (eVar b)) (eXB (eVar b) (eVar a))) f \<Longrightarrow>
  reduce (eAnd (eVar a) (eVar b)) f" |
eXB_eAnd_eOr:
  "reduce (eAnd (eVar a) (eVar b)) f \<Longrightarrow> reduce (eOr (eXB (eVar a) (eVar b)) (eXB (eVar b) (eVar a))) f"

inductive r2 :: "'a expression \<Rightarrow> 'a expression \<Rightarrow> bool" where
"r2 f f" |
"r2 (eAnd f1 f2) f \<Longrightarrow> r2 f1 f" |
"r2 (eAnd f1 f2) f \<Longrightarrow> r2 f2 f"

lemma "r2 eFalse eTrue \<Longrightarrow> False"

theorem soundness: "reduce f1 f2 \<Longrightarrow> semantics_of f1 = semantics_of f2"
sorry

theorem completeness:
  "semantics_of f = top \<Longrightarrow> reduce f eTrue"
sorry

lemma "a \<noteq> b \<Longrightarrow> reduce
  (eOr
    (eOr (eXB (eVar a) (eVar b)) (eXB (eVar b) (eVar a)))
    (eNot (eAnd (eVar a) (eVar b)))) eTrue"
proof-
  assume "\<not> reduce
  (eOr
    (eOr (eXB (eVar a) (eVar b)) (eXB (eVar b) (eVar a)))
    (eNot (eAnd (eVar a) (eVar b)))) eTrue"
  hence ""

qed

(*
"dlist_xbefore a b xs \<equiv> \<exists>i. a (xs\<dagger>..i) \<and> b (xs\<dagger>i..)"
*)

end