(*  Title:   QuasiBorel.thy
    Author:  Yasuhiko Minamide, Michikazu Hirata, Tokyo Institute of Technology
*)

section \<open>Quasi-Borel Spaces\<close>
theory QuasiBorel
imports "StandardBorel"
begin

subsection \<open> Definitions \<close>

text \<open> We formalize quasi-Borel spaces introduced by Heunen et al.~\<^cite>\<open>"Heunen_2017"\<close>.\<close>

subsubsection \<open> Quasi-Borel Spaces\<close>
definition qbs_closed1 :: "(real \<Rightarrow> 'a) set \<Rightarrow> bool"
  where "qbs_closed1 Mx \<equiv> (\<forall>a \<in> Mx. \<forall>f \<in> real_borel \<rightarrow>\<^sub>M real_borel. a \<circ> f \<in> Mx)"

definition qbs_closed2 :: "['a set, (real \<Rightarrow> 'a) set] \<Rightarrow> bool"
 where "qbs_closed2 X Mx \<equiv> (\<forall>x \<in> X. (\<lambda>r. x) \<in> Mx)"

definition qbs_closed3 :: "(real \<Rightarrow> 'a) set \<Rightarrow> bool"
 where "qbs_closed3 Mx \<equiv> (\<forall>P::real \<Rightarrow> nat. \<forall>Fi::nat \<Rightarrow> real \<Rightarrow> 'a.
                          (\<forall>i. P -` {i} \<in> sets real_borel)
                           \<longrightarrow> (\<forall>i. Fi i \<in> Mx)
                           \<longrightarrow> (\<lambda>r. Fi (P r) r) \<in> Mx)"

lemma separate_measurable:
  fixes P :: "real \<Rightarrow> nat"
  assumes "\<And>i. P -` {i} \<in> sets real_borel"
  shows "P \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
proof -
  have "P \<in> real_borel \<rightarrow>\<^sub>M count_space UNIV"
    by (auto simp add: assms measurable_count_space_eq_countable)
  thus ?thesis
    using measurable_cong_sets sets_borel_eq_count_space by blast
qed

lemma measurable_separate:
  fixes P :: "real \<Rightarrow> nat"
  assumes "P \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
  shows "P -` {i} \<in> sets real_borel"
  by(rule measurable_sets_borel[OF assms borel_singleton[OF sets.empty_sets,of i]])

definition "is_quasi_borel X Mx \<longleftrightarrow> Mx \<subseteq> UNIV \<rightarrow> X \<and> qbs_closed1 Mx \<and> qbs_closed2 X Mx \<and> qbs_closed3 Mx"

lemma is_quasi_borel_intro[simp]:
  assumes "Mx \<subseteq> UNIV \<rightarrow> X"
      and "qbs_closed1 Mx" "qbs_closed2 X Mx" "qbs_closed3 Mx"
    shows "is_quasi_borel X Mx"
  using assms by(simp add: is_quasi_borel_def)

typedef 'a quasi_borel = "{(X::'a set, Mx). is_quasi_borel X Mx}"
proof
  show "(UNIV, UNIV) \<in> {(X::'a set, Mx). is_quasi_borel X Mx}"
    by (simp add: is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def)
qed

definition qbs_space :: "'a quasi_borel \<Rightarrow> 'a set" where
  "qbs_space X \<equiv> fst (Rep_quasi_borel X)"

definition qbs_Mx :: "'a quasi_borel \<Rightarrow> (real \<Rightarrow> 'a) set" where
  "qbs_Mx X \<equiv> snd (Rep_quasi_borel X)"

lemma qbs_decomp :
"(qbs_space X,qbs_Mx X) \<in> {(X::'a set, Mx). is_quasi_borel X Mx}"
  by (simp add: qbs_space_def qbs_Mx_def Rep_quasi_borel[simplified])

lemma qbs_Mx_to_X[dest]:
  assumes "\<alpha> \<in> qbs_Mx X"
  shows "\<alpha> \<in> UNIV \<rightarrow> qbs_space X"
        "\<alpha> r \<in> qbs_space X"
  using qbs_decomp assms by(auto simp: is_quasi_borel_def)

lemma qbs_closed1I:
  assumes "\<And>\<alpha> f. \<alpha> \<in> Mx \<Longrightarrow> f \<in> real_borel \<rightarrow>\<^sub>M real_borel \<Longrightarrow> \<alpha> \<circ> f \<in> Mx"
  shows "qbs_closed1 Mx"
  using assms by(simp add: qbs_closed1_def)

lemma qbs_closed1_dest[simp]:
  assumes "\<alpha> \<in> qbs_Mx X"
      and "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
    shows "\<alpha> \<circ> f \<in> qbs_Mx X"
  using assms qbs_decomp by (auto simp add: is_quasi_borel_def qbs_closed1_def)

lemma qbs_closed2I:
  assumes "\<And>x. x \<in> X \<Longrightarrow> (\<lambda>r. x) \<in> Mx"
  shows "qbs_closed2 X Mx"
  using assms by(simp add: qbs_closed2_def)

lemma qbs_closed2_dest[simp]:
  assumes "x \<in> qbs_space X"
  shows "(\<lambda>r. x) \<in> qbs_Mx X"
  using assms qbs_decomp[of X] by (auto simp add: is_quasi_borel_def qbs_closed2_def)

lemma qbs_closed3I:
  assumes "\<And>(P :: real \<Rightarrow> nat) Fi. (\<And>i. P -` {i} \<in> sets real_borel) \<Longrightarrow> (\<And>i. Fi i \<in> Mx)
                  \<Longrightarrow> (\<lambda>r. Fi (P r) r) \<in> Mx"
  shows "qbs_closed3 Mx"
  using assms by(auto simp: qbs_closed3_def)

lemma qbs_closed3I':
  assumes "\<And>(P :: real \<Rightarrow> nat) Fi. P \<in> real_borel \<rightarrow>\<^sub>M nat_borel \<Longrightarrow> (\<And>i. Fi i \<in> Mx)
                  \<Longrightarrow> (\<lambda>r. Fi (P r) r) \<in> Mx"
  shows "qbs_closed3 Mx"
  using assms by(auto intro!: qbs_closed3I simp: separate_measurable)

lemma qbs_closed3_dest[simp]:
  fixes P::"real \<Rightarrow> nat" and Fi :: "nat \<Rightarrow> real \<Rightarrow> _"
  assumes "\<And>i. P -` {i} \<in> sets real_borel"
      and "\<And>i. Fi i \<in> qbs_Mx X"
    shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
  using assms qbs_decomp[of X] by (auto simp add: is_quasi_borel_def qbs_closed3_def)

lemma qbs_closed3_dest':
  fixes P::"real \<Rightarrow> nat" and Fi :: "nat \<Rightarrow> real \<Rightarrow> _"
  assumes "P \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
      and "\<And>i. Fi i \<in> qbs_Mx X"
    shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
  using qbs_closed3_dest[OF measurable_separate[OF assms(1)] assms(2)] .

lemma qbs_closed3_dest2:
  assumes "countable I"
 and [measurable]: "P \<in> real_borel \<rightarrow>\<^sub>M count_space I"
      and "\<And>i. i \<in> I \<Longrightarrow> Fi i \<in> qbs_Mx X"
    shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
proof -
  have 0:"I \<noteq> {}"
    using measurable_empty_iff[of "count_space I" P real_borel] assms(2)
    by fastforce
  define P' where "P' \<equiv> to_nat_on I \<circ> P"
  define Fi' where "Fi' \<equiv> Fi \<circ> (from_nat_into I)"
  have 1:"P' \<in> real_borel \<rightarrow>\<^sub>M nat_borel"
    by(simp add: P'_def)
  have 2:"\<And>i. Fi' i \<in> qbs_Mx X"
    using assms(3) from_nat_into[OF 0] by(simp add: Fi'_def)
  have "(\<lambda>r. Fi' (P' r) r) \<in> qbs_Mx X"
    using 1 2 measurable_separate by auto
  thus ?thesis
    using from_nat_into_to_nat_on[OF assms(1)] measurable_space[OF assms(2)]
    by(auto simp: Fi'_def P'_def)
qed

lemma qbs_closed3_dest2':
  assumes "countable I"
 and [measurable]: "P \<in> real_borel \<rightarrow>\<^sub>M count_space I"
      and "\<And>i. i \<in> range P \<Longrightarrow> Fi i \<in> qbs_Mx X"
    shows "(\<lambda>r. Fi (P r) r) \<in> qbs_Mx X"
proof -
  have 0:"range P \<inter> I = range P"
    using measurable_space[OF assms(2)] by auto
  have 1:"P \<in> real_borel \<rightarrow>\<^sub>M count_space (range P)"
    using restrict_count_space[of I "range P"] measurable_restrict_space2[OF _ assms(2),of "range P"]
    by(simp add: 0)
  have 2:"countable (range P)"
    using countable_Int2[OF assms(1),of "range P"]
    by(simp add: 0)
  show ?thesis
    by(auto intro!: qbs_closed3_dest2[OF 2 1 assms(3)])
qed

lemma qbs_space_Mx:
 "qbs_space X = {\<alpha> x |x \<alpha>. \<alpha> \<in> qbs_Mx X}"
proof auto
  fix x
  assume 1:"x \<in> qbs_space X"
  show "\<exists>xa \<alpha>. x = \<alpha> xa \<and> \<alpha> \<in> qbs_Mx X"
    by(auto intro!: exI[where x=0] exI[where x="(\<lambda>r. x)"] simp: 1)
qed

lemma qbs_space_eq_Mx:
  assumes "qbs_Mx X = qbs_Mx Y"
  shows "qbs_space X = qbs_space Y"
  by(simp add: qbs_space_Mx assms)

lemma qbs_eqI:
  assumes "qbs_Mx X = qbs_Mx Y"
  shows "X = Y"
  by (metis Rep_quasi_borel_inverse prod.exhaust_sel qbs_Mx_def qbs_space_def assms qbs_space_eq_Mx[OF assms])

subsubsection \<open> Morphism of Quasi-Borel Spaces \<close>
definition qbs_morphism :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> ('a \<Rightarrow> 'b) set" (infixr "\<rightarrow>\<^sub>Q" 60) where
  "X \<rightarrow>\<^sub>Q Y \<equiv> {f \<in> qbs_space X \<rightarrow> qbs_space Y. \<forall>\<alpha> \<in> qbs_Mx X. f \<circ> \<alpha> \<in> qbs_Mx Y}"

lemma qbs_morphismI:
  assumes "\<And>\<alpha>. \<alpha> \<in> qbs_Mx X \<Longrightarrow> f \<circ> \<alpha> \<in> qbs_Mx Y"
  shows "f \<in> X \<rightarrow>\<^sub>Q Y"
proof -
  have "f \<in> qbs_space X \<rightarrow> qbs_space Y"
  proof
    fix x
    assume "x \<in> qbs_space X "
    then have "(\<lambda>r. x) \<in> qbs_Mx X"
      by simp
    hence "f \<circ> (\<lambda>r. x) \<in> qbs_Mx Y"
      using assms by blast
    thus "f x \<in> qbs_space Y"
      by auto
  qed
  thus ?thesis
    using assms by(simp add: qbs_morphism_def)
qed

lemma qbs_morphismE[dest]:
  assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
  shows "f \<in> qbs_space X \<rightarrow> qbs_space Y"
        "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x \<in> qbs_space Y"
        "\<And>\<alpha>. \<alpha> \<in> qbs_Mx X \<Longrightarrow> f \<circ> \<alpha> \<in> qbs_Mx Y"
  using assms by(auto simp add: qbs_morphism_def)

lemma qbs_morphism_ident[simp]:
   "id \<in> X \<rightarrow>\<^sub>Q X"
  by(auto intro: qbs_morphismI)

lemma qbs_morphism_ident'[simp]:
   "(\<lambda>x. x) \<in> X \<rightarrow>\<^sub>Q X"
  using qbs_morphism_ident by(simp add: id_def)

lemma qbs_morphism_comp:
  assumes "f \<in> X \<rightarrow>\<^sub>Q Y" "g \<in> Y \<rightarrow>\<^sub>Q Z"
  shows "g \<circ> f \<in> X \<rightarrow>\<^sub>Q Z"
  using assms by (simp add: comp_assoc Pi_def qbs_morphism_def)

lemma qbs_morphism_cong:
  assumes "\<And>x. x \<in> qbs_space X \<Longrightarrow> f x = g x"
      and "f \<in> X \<rightarrow>\<^sub>Q Y"
    shows "g \<in> X \<rightarrow>\<^sub>Q Y"
proof(rule qbs_morphismI)
  fix \<alpha>
  assume 1:"\<alpha> \<in> qbs_Mx X"
  have "g \<circ> \<alpha> = f \<circ> \<alpha>"
  proof
    fix x
    have "\<alpha> x \<in> qbs_space X"
      using 1 qbs_decomp[of X] by auto
    thus "(g \<circ> \<alpha>) x = (f \<circ> \<alpha>) x"
      using assms(1) by simp
  qed
  thus "g \<circ> \<alpha> \<in> qbs_Mx Y"
    using 1 assms(2) by(simp add: qbs_morphism_def)
qed

lemma qbs_morphism_const:
  assumes "y \<in> qbs_space Y"
  shows "(\<lambda>_. y) \<in> X \<rightarrow>\<^sub>Q Y"
  using assms by (auto intro: qbs_morphismI)

subsubsection \<open> Empty Space \<close>
definition empty_quasi_borel  :: "'a quasi_borel" where
"empty_quasi_borel \<equiv> Abs_quasi_borel ({},{})"

lemma eqb_correct: "Rep_quasi_borel empty_quasi_borel = ({}, {})"
  using Abs_quasi_borel_inverse
  by(auto simp add: Abs_quasi_borel_inverse empty_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)

lemma eqb_space[simp]: "qbs_space empty_quasi_borel = {}"
  by(simp add: qbs_space_def eqb_correct)

lemma eqb_Mx[simp]: "qbs_Mx empty_quasi_borel = {}"
  by(simp add: qbs_Mx_def eqb_correct)

lemma qbs_empty_equiv :"qbs_space X = {} \<longleftrightarrow> qbs_Mx X = {}"
proof(auto)
  fix x
  assume "qbs_Mx X = {}"
     and h:"x \<in> qbs_space X"
  have "(\<lambda>r. x) \<in> qbs_Mx X"
    using h by simp
  thus "False" using \<open>qbs_Mx X = {}\<close> by simp
qed

lemma empty_quasi_borel_iff:
  "qbs_space X = {} \<longleftrightarrow> X = empty_quasi_borel"
  by(auto intro!: qbs_eqI)

subsubsection \<open> Unit Space \<close>
definition unit_quasi_borel :: "unit quasi_borel" ("1\<^sub>Q") where
"unit_quasi_borel \<equiv> Abs_quasi_borel (UNIV,UNIV)"

lemma uqb_correct: "Rep_quasi_borel unit_quasi_borel = (UNIV,UNIV)"
  using Abs_quasi_borel_inverse
  by(auto simp add: unit_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)

lemma uqb_space[simp]: "qbs_space unit_quasi_borel = {()}"
  by(simp add: qbs_space_def UNIV_unit uqb_correct)

lemma uqb_Mx[simp]: "qbs_Mx unit_quasi_borel = {\<lambda>r. ()}"
  by(auto simp add: qbs_Mx_def uqb_correct)

lemma unit_quasi_borel_terminal:
 "\<exists>! f. f \<in> X \<rightarrow>\<^sub>Q unit_quasi_borel"
  by(fastforce simp: qbs_morphism_def)

definition to_unit_quasi_borel :: "'a \<Rightarrow> unit" ("!\<^sub>Q") where
"to_unit_quasi_borel \<equiv> (\<lambda>_.())"

lemma to_unit_quasi_borel_morphism :
 "!\<^sub>Q \<in> X \<rightarrow>\<^sub>Q unit_quasi_borel"
  by(auto simp add: to_unit_quasi_borel_def qbs_morphism_def)

subsubsection \<open> Subspaces \<close>
definition sub_qbs :: "['a quasi_borel, 'a set] \<Rightarrow> 'a quasi_borel" where
"sub_qbs X U \<equiv> Abs_quasi_borel (qbs_space X \<inter> U,{f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X})"

lemma sub_qbs_closed:
  "qbs_closed1 {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
  "qbs_closed2 (qbs_space X \<inter> U) {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
  "qbs_closed3 {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
  unfolding qbs_closed1_def qbs_closed2_def qbs_closed3_def by auto

lemma sub_qbs_correct[simp]: "Rep_quasi_borel (sub_qbs X U) = (qbs_space X \<inter> U,{f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X})"
  by(simp add: Abs_quasi_borel_inverse sub_qbs_def sub_qbs_closed)

lemma sub_qbs_space[simp]: "qbs_space (sub_qbs X U) = qbs_space X \<inter> U"
  by(simp add: qbs_space_def)

lemma sub_qbs_Mx[simp]: "qbs_Mx (sub_qbs X U) = {f \<in> UNIV \<rightarrow> qbs_space X \<inter> U. f \<in> qbs_Mx X}"
  by(simp add: qbs_Mx_def)

lemma sub_qbs:
  assumes "U \<subseteq> qbs_space X"
  shows "(qbs_space (sub_qbs X U), qbs_Mx (sub_qbs X U)) = (U, {f \<in> UNIV \<rightarrow> U. f \<in> qbs_Mx X})"
  using assms by auto

subsubsection \<open> Image Spaces \<close>
definition map_qbs :: "['a \<Rightarrow> 'b] \<Rightarrow> 'a quasi_borel \<Rightarrow> 'b quasi_borel" where
"map_qbs f X = Abs_quasi_borel (f ` (qbs_space X),{\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>})"

lemma map_qbs_f:
 "{\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>} \<subseteq> UNIV \<rightarrow> f ` (qbs_space X)"
  by fastforce

lemma map_qbs_closed1:
 "qbs_closed1 {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
  unfolding qbs_closed1_def
  using qbs_closed1_dest by(fastforce simp: comp_def)

lemma map_qbs_closed2:
 "qbs_closed2 (f ` (qbs_space X)) {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
  unfolding qbs_closed2_def by fastforce

lemma map_qbs_closed3:
 "qbs_closed3 {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
proof(auto simp add: qbs_closed3_def)
  fix P Fi
  assume h:"\<forall>i::nat. P -` {i} \<in> sets real_borel"
           "\<forall>i::nat. \<exists>\<alpha>\<in>qbs_Mx X. Fi i = f \<circ> \<alpha>"
  then obtain \<alpha>i
    where ha: "\<forall>i::nat. \<alpha>i i \<in> qbs_Mx X \<and>  Fi i = f \<circ> (\<alpha>i i)"
    by metis
  hence 1:"(\<lambda>r. \<alpha>i (P r) r) \<in> qbs_Mx X"
    using h(1) by fastforce
  show "\<exists>\<alpha>\<in>qbs_Mx X. (\<lambda>r. Fi (P r) r) = f \<circ> \<alpha>"
    by(auto intro!: bexI[where x="(\<lambda>r. \<alpha>i (P r) r)"] simp add: 1 ha comp_def)
qed

lemma map_qbs_correct[simp]:
 "Rep_quasi_borel (map_qbs f X) = (f ` (qbs_space X),{\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>})"
  unfolding map_qbs_def
  by(simp add: Abs_quasi_borel_inverse map_qbs_f map_qbs_closed1 map_qbs_closed2 map_qbs_closed3)

lemma map_qbs_space[simp]:
 "qbs_space (map_qbs f X) = f ` (qbs_space X)"
  by(simp add: qbs_space_def)

lemma map_qbs_Mx[simp]:
 "qbs_Mx (map_qbs f X) = {\<beta>. \<exists>\<alpha>\<in> qbs_Mx X. \<beta> = f \<circ> \<alpha>}"
  by(simp add: qbs_Mx_def)

inductive_set generating_Mx :: "'a set \<Rightarrow> (real \<Rightarrow> 'a) set \<Rightarrow> (real \<Rightarrow> 'a) set"
  for X :: "'a set" and Mx :: "(real \<Rightarrow> 'a) set"
  where
    Basic: "\<alpha> \<in> Mx \<Longrightarrow> \<alpha> \<in> generating_Mx X Mx"
  | Const: "x \<in> X \<Longrightarrow> (\<lambda>r. x) \<in> generating_Mx X Mx"
  | Comp : "f \<in> real_borel \<rightarrow>\<^sub>M real_borel \<Longrightarrow> \<alpha> \<in> generating_Mx X Mx \<Longrightarrow> \<alpha> \<circ> f \<in> generating_Mx X Mx"
  | Part : "(\<And>i. Fi i \<in> generating_Mx X Mx) \<Longrightarrow> P \<in> real_borel \<rightarrow>\<^sub>M nat_borel \<Longrightarrow> (\<lambda>r. Fi (P r) r) \<in> generating_Mx X Mx"

lemma generating_Mx_to_space:
  assumes "Mx \<subseteq> UNIV \<rightarrow> X"
  shows "generating_Mx X Mx \<subseteq> UNIV \<rightarrow> X"
proof
  fix \<alpha>
  assume "\<alpha> \<in> generating_Mx X Mx"
  then show "\<alpha> \<in> UNIV \<rightarrow> X"
   by(induct rule: generating_Mx.induct) (use assms in auto)
qed

lemma generating_Mx_closed1:
 "qbs_closed1 (generating_Mx X Mx)"
  by (simp add: generating_Mx.Comp qbs_closed1I)

lemma generating_Mx_closed2:
 "qbs_closed2 X (generating_Mx X Mx)"
  by (simp add: generating_Mx.Const qbs_closed2I)

lemma generating_Mx_closed3:
 "qbs_closed3 (generating_Mx X Mx)"
  by(simp add: qbs_closed3I' generating_Mx.Part)

lemma generating_Mx_Mx:
 "generating_Mx (qbs_space X) (qbs_Mx X) = qbs_Mx X"
proof auto
  fix \<alpha>
  assume "\<alpha> \<in> generating_Mx (qbs_space X) (qbs_Mx X)"
  then show "\<alpha> \<in> qbs_Mx X"
    by(rule generating_Mx.induct) (auto intro!: qbs_closed1_dest[simplified comp_def] simp: qbs_closed3_dest')
next
  fix \<alpha>
  assume "\<alpha> \<in> qbs_Mx X"
  then show "\<alpha> \<in> generating_Mx (qbs_space X) (qbs_Mx X)" ..
qed

subsubsection \<open> Ordering of Quasi-Borel Spaces \<close>

instantiation quasi_borel :: (type) order_bot
begin

inductive less_eq_quasi_borel :: "'a quasi_borel \<Rightarrow> 'a quasi_borel \<Rightarrow> bool" where
  "qbs_space X \<subset> qbs_space Y \<Longrightarrow> less_eq_quasi_borel X Y"
| "qbs_space X = qbs_space Y \<Longrightarrow> qbs_Mx Y \<subseteq> qbs_Mx X \<Longrightarrow> less_eq_quasi_borel X Y"

lemma le_quasi_borel_iff:
 "X \<le> Y \<longleftrightarrow> (if qbs_space X = qbs_space Y then qbs_Mx Y \<subseteq> qbs_Mx X else qbs_space X \<subset> qbs_space Y)"
  by(auto elim: less_eq_quasi_borel.cases intro: less_eq_quasi_borel.intros)

definition less_quasi_borel :: "'a quasi_borel \<Rightarrow> 'a quasi_borel \<Rightarrow> bool" where
 "less_quasi_borel X Y \<longleftrightarrow> (X \<le> Y \<and> \<not> Y \<le> X)"

definition bot_quasi_borel :: "'a quasi_borel" where
 "bot_quasi_borel = empty_quasi_borel"

instance
proof
  show "bot \<le> a" for a :: "'a quasi_borel"
    using qbs_empty_equiv
    by(auto simp add: le_quasi_borel_iff bot_quasi_borel_def)
qed (auto simp: le_quasi_borel_iff less_quasi_borel_def split: if_split_asm intro: qbs_eqI)
end

definition inf_quasi_borel :: "['a quasi_borel, 'a quasi_borel] \<Rightarrow> 'a quasi_borel" where
"inf_quasi_borel X X' = Abs_quasi_borel (qbs_space X \<inter> qbs_space X', qbs_Mx X \<inter> qbs_Mx X')"

lemma inf_quasi_borel_correct: "Rep_quasi_borel (inf_quasi_borel X X') = (qbs_space X \<inter> qbs_space X', qbs_Mx X \<inter> qbs_Mx X')"
  by(fastforce intro!: Abs_quasi_borel_inverse
     simp: inf_quasi_borel_def is_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def)

lemma inf_qbs_space[simp]: "qbs_space (inf_quasi_borel X X') = qbs_space X \<inter> qbs_space X'"
  by (simp add: qbs_space_def inf_quasi_borel_correct)

lemma inf_qbs_Mx[simp]: "qbs_Mx (inf_quasi_borel X X') = qbs_Mx X \<inter> qbs_Mx X'"
  by(simp add: qbs_Mx_def inf_quasi_borel_correct)

definition max_quasi_borel :: "'a set \<Rightarrow> 'a quasi_borel" where
"max_quasi_borel X = Abs_quasi_borel (X, UNIV \<rightarrow> X)"

lemma max_quasi_borel_correct: "Rep_quasi_borel (max_quasi_borel X) = (X, UNIV \<rightarrow> X)"
  by(fastforce intro!: Abs_quasi_borel_inverse
   simp: max_quasi_borel_def qbs_closed1_def qbs_closed2_def qbs_closed3_def is_quasi_borel_def)

lemma max_qbs_space[simp]: "qbs_space (max_quasi_borel X) = X"
  by(simp add: qbs_space_def max_quasi_borel_correct)

lemma max_qbs_Mx[simp]: "qbs_Mx (max_quasi_borel X) = UNIV \<rightarrow> X"
  by(simp add: qbs_Mx_def max_quasi_borel_correct)

instantiation quasi_borel :: (type) semilattice_sup
begin

definition sup_quasi_borel :: "'a quasi_borel \<Rightarrow> 'a quasi_borel \<Rightarrow> 'a quasi_borel" where
"sup_quasi_borel X Y \<equiv> (if qbs_space X = qbs_space Y      then inf_quasi_borel X Y
                        else if qbs_space X \<subset> qbs_space Y then Y
                        else if qbs_space Y \<subset> qbs_space X then X
                        else max_quasi_borel (qbs_space X \<union> qbs_space Y))"

instance
proof
  fix X Y :: "'a quasi_borel"
  let ?X = "qbs_space X"
  let ?Y = "qbs_space Y"
  consider "?X = ?Y" | "?X \<subset> ?Y" | "?Y \<subset> ?X" | "?X \<subset> ?X \<union> ?Y \<and> ?Y \<subset> ?X \<union> ?Y"
    by auto
  then show "X \<le> X \<squnion> Y"
  proof(cases)
    case 1
    show ?thesis
      unfolding sup_quasi_borel_def
      by(rule less_eq_quasi_borel.intros(2),simp_all add: 1)
  next
    case 2
    then show ?thesis
      unfolding sup_quasi_borel_def
      by (simp add: less_eq_quasi_borel.intros(1))
  next
    case 3
    then show ?thesis
      unfolding sup_quasi_borel_def
      by auto
  next
    case 4
    then show ?thesis
      unfolding sup_quasi_borel_def
      by(auto simp: less_eq_quasi_borel.intros(1))
  qed
next
  fix X Y :: "'a quasi_borel"
  let ?X = "qbs_space X"
  let ?Y = "qbs_space Y"
  consider "?X = ?Y" | "?X \<subset> ?Y" | "?Y \<subset> ?X" | "?X \<subset> ?X \<union> ?Y \<and> ?Y \<subset> ?X \<union> ?Y"
    by auto
  then show "Y \<le> X \<squnion> Y"
  proof(cases)
    case 1
    show ?thesis
      unfolding sup_quasi_borel_def
      by(rule less_eq_quasi_borel.intros(2)) (simp_all add: 1)
  next
    case 2
    then show ?thesis
      unfolding sup_quasi_borel_def
      by auto
  next
    case 3
    then show ?thesis
      unfolding sup_quasi_borel_def
      by (auto simp add: less_eq_quasi_borel.intros(1))
  next
    case 4
    then show ?thesis
      unfolding sup_quasi_borel_def
      by(auto simp: less_eq_quasi_borel.intros(1))
  qed
next
  fix X Y Z :: "'a quasi_borel"
  assume h:"X \<le> Z" "Y \<le> Z"
  let ?X = "qbs_space X"
  let ?Y = "qbs_space Y"
  let ?Z = "qbs_space Z"
  consider "?X = ?Y" | "?X \<subset> ?Y" | "?Y \<subset> ?X" | "?X \<subset> ?X \<union> ?Y \<and> ?Y \<subset> ?X \<union> ?Y"
    by auto
  then show "sup X Y \<le> Z"
  proof cases
    case 1
    show ?thesis
      unfolding sup_quasi_borel_def
      apply(simp add: 1,rule less_eq_quasi_borel.cases[OF h(1)])
       apply(rule less_eq_quasi_borel.intros(1))
       apply auto[1]
      apply auto
      apply(rule less_eq_quasi_borel.intros(2))
       apply(simp add: 1)
      by(rule less_eq_quasi_borel.cases[OF h(2)]) (auto simp: 1)
  next
    case 2
    then show ?thesis
      unfolding sup_quasi_borel_def
      using h(2) by auto
  next
    case 3
    then show ?thesis
      unfolding sup_quasi_borel_def
      using h(1) by auto
  next
    case 4
    then have [simp]:"?X \<noteq> ?Y" "~ (?X \<subset> ?Y)" "~ (?Y \<subset> ?X)"
      by auto
    have [simp]:"?X \<subseteq> ?Z" "?Y \<subseteq> ?Z"
      by (metis h(1) dual_order.order_iff_strict less_eq_quasi_borel.cases)
         (metis h(2) dual_order.order_iff_strict less_eq_quasi_borel.cases)
    then consider "?X \<union> ?Y = ?Z" | "?X \<union> ?Y \<subset> ?Z"
      by blast
    then show ?thesis
      unfolding sup_quasi_borel_def
      apply cases
       apply simp
       apply(rule less_eq_quasi_borel.intros(2))
        apply simp
       apply auto[1]
      by(simp add: less_eq_quasi_borel.intros(1))
  qed
qed
end

end


section\<open>Option to List and Option to Set\<close>
theory Option_Helpers
imports Main
begin

text\<open>Those are just syntactic helpers.\<close>

definition option2set :: "'a option \<Rightarrow> 'a set" where
  "option2set n \<equiv> (case n of None \<Rightarrow> {} | Some s \<Rightarrow> {s})"

definition option2list :: "'a option \<Rightarrow> 'a list" where
  "option2list n \<equiv> (case n of None \<Rightarrow> [] | Some s \<Rightarrow> [s])"

lemma set_option2list[simp]: "set (option2list k) = option2set k"
  unfolding option2list_def option2set_def by (simp split: option.splits)

lemma option2list_simps[simp]: "option2list (Some x) = [x]" "option2list (None) = []"
  unfolding option2list_def option.simps by(fact refl)+

lemma option2set_None: "option2set None = {}"
  by(simp add: option2set_def)

lemma option2list_map: "option2list (map_option f n) = map f (option2list n)"
  by(simp add: option2list_def split: option.split)

lemma option2set_map: "option2set (map_option f n) = f ` option2set n"
  by(simp add: option2set_def split: option.split)

end


(*  Author: Tobias Nipkow, Dmitriy Traytel *)

section \<open>Framework Instantiations using Marked Regular Expressions\<close>

(*<*)
theory Position_Autos
imports
  Automaton
begin
(*>*)

subsection \<open>Marked Regular Expressions\<close>

type_synonym 'a mrexp = "(bool * 'a) rexp"

abbreviation "strip \<equiv> map_rexp snd"

primrec mrexps :: "'a rexp \<Rightarrow> ('a mrexp) set" where
  "mrexps Zero = {Zero}"
| "mrexps One = {One}"
| "mrexps (Atom a) = {Atom (True, a), Atom (False, a)}"
| "mrexps (Plus r s) = case_prod Plus ` (mrexps r \<times> mrexps s)"
| "mrexps (Times r s) = case_prod Times ` (mrexps r \<times> mrexps s)"
| "mrexps (Star r) = Star ` mrexps r"

lemma finite_mrexps[simp]: "finite (mrexps r)"
by (induction r) auto

lemma strip_mrexps: "strip ` mrexps r = {r}"
by (induction r) (auto simp: set_eq_subset subset_iff image_iff)

fun Lm :: "'a mrexp \<Rightarrow> 'a lang" where
"Lm Zero = {}" |
"Lm One = {}" |
"Lm (Atom(m,a)) = (if m then {[a]} else {})" |
"Lm (Plus r s) = Lm r \<union> Lm s" |
"Lm (Times r s) = Lm r @@ lang(strip s) \<union> Lm s" |
"Lm (Star r) = Lm r @@ star(lang(strip r))"

fun final :: "'a mrexp \<Rightarrow> bool" where
"final Zero = False" |
"final One = False" |
"final (Atom(m,a)) = m" |
"final (Plus r s) = (final r \<or> final s)" |
"final (Times r s) = (final s \<or> nullable s \<and> final r)" |
"final (Star r) = final r"

abbreviation read :: "'a \<Rightarrow> 'a mrexp \<Rightarrow> 'a mrexp" where
"read a \<equiv> map_rexp (\<lambda>(m,x). (m \<and> a=x, x))"

lemma read_mrexps[simp]: "r \<in> mrexps s \<Longrightarrow> read a r \<in> mrexps s"
by (induction s arbitrary: a r) (auto simp: image_iff)

fun follow :: "bool \<Rightarrow> 'a mrexp \<Rightarrow> 'a mrexp" where
"follow m Zero = Zero" |
"follow m One = One" |
"follow m (Atom(_,a)) = Atom(m,a)" |
"follow m (Plus r s) = Plus (follow m r) (follow m s)" |
"follow m (Times r s) =
  Times (follow m r) (follow (final r \<or> m \<and> nullable r) s)" |
"follow m (Star r) = Star(follow (final r \<or> m) r)"

lemma follow_mrexps[simp]: "r \<in> mrexps s \<Longrightarrow> follow b r \<in> mrexps s"
by (induction s arbitrary: b r) (auto simp: image_iff)

lemma strip_read[simp]: "strip (read a r) = strip r"
by (simp add: map_map_rexp split_def)

lemma Nil_notin_Lm[simp]: "[] \<notin> Lm r"
by (induction r) (auto split: if_splits)

lemma Nil_in_lang_strip[simp]: "[] \<in> lang(r) \<longleftrightarrow> [] \<in> lang(strip r)"
by (induction r) auto

lemma strip_follow[simp]: "strip(follow m r) = strip r"
by (induction r arbitrary: m) (auto split: if_splits)

lemma conc_lemma: "[] \<notin> A \<Longrightarrow> {w : A @@ B. w \<noteq> [] \<and> P(hd w)} = {w : A. w \<noteq> [] \<and> P(hd w)} @@ B"
  unfolding conc_def by auto (metis hd_append2)+

lemma Lm_read: "Lm (read a r) = {w : Lm r. w \<noteq> [] \<and> hd w = a}"
proof (induction r)
  case (Times r1 r2) thus ?case
    using conc_lemma[OF Nil_notin_Lm, where P = "\<lambda>x. x=a" and r1 = r1] by auto
next
  case Star thus ?case using conc_lemma[OF Nil_notin_Lm, where P = "\<lambda>x. x=a"] by simp
qed (auto split: if_splits)

lemma tl_conc[simp]: "[] \<notin> A \<Longrightarrow>tl ` (A @@ B) = tl ` A @@ B"
by (fastforce simp: image_def Bex_def tl_append split: list.split)

lemma Nil_in_tl_Lm_if_final[simp]: "final r \<Longrightarrow> [] : tl ` Lm r"
by (induction r) (auto simp: nullable_iff image_Un)

lemma Nil_notin_tl_if_not_final: "\<not> final r \<Longrightarrow> [] \<notin> tl ` Lm r"
by (induction r) (auto simp: nullable_iff Nil_tl singleton_in_conc intro!: image_eqI[rotated])

lemma Lm_follow: "Lm (follow m r) = tl ` Lm r \<union> (if m then lang(strip r) else {}) - {[]}"
proof (induction r arbitrary: m)
  case (Atom mb) thus ?case by (cases mb) auto
next
  case (Times r s) thus ?case
    by (simp add: Un_Diff image_Un conc_Un_distrib nullable_iff
          conc_Diff_if_Nil1 Nil_notin_tl_if_not_final Un_ac)
next
  case (Star r) thus ?case
    by (simp add: Un_Diff conc_Un_distrib
          conc_Diff_if_Nil1 Nil_notin_tl_if_not_final star_Diff_Nil_fold)
qed auto

subsection \<open>Mark Before Atom\<close>

text\<open>Position automaton where mark is placed before atoms.\<close>

abbreviation "empty_mrexp \<equiv> map_rexp (\<lambda>a. (False,a))"

lemma empty_mrexp_mrexps[simp]: "empty_mrexp r \<in> mrexps r"
by (induction r) auto

lemma nullable_empty_mrexp[simp]: "nullable (empty_mrexp r) = nullable r"
  by (induct r) auto

definition "init_b r = (follow True (empty_mrexp r), nullable r)"

lemma init_b_mrexps[simp]: "init_b r \<in> mrexps r \<times> UNIV"
  unfolding init_b_def by auto

fun delta_b where
"delta_b a (r,b) = (let r' = read a r in (follow False r', final r'))"

lemma delta_b_mrexps[simp]: "rb \<in> mrexps r \<times> UNIV \<Longrightarrow> delta_b a rb \<in> mrexps r \<times> UNIV"
by (auto simp: Let_def)

lemma fold_delta_b_init_b_mrexps[simp]: "fold delta_b w (init_b s) \<in> mrexps s \<times> UNIV"
by (induction w arbitrary: s rule: rev_induct) auto

fun L_b where
"L_b (r,b) = Lm r \<union> (if b then {[]} else {})"

abbreviation "final_b \<equiv> snd"

lemma Lm_empty: "Lm (empty_mrexp r) = {}"
by (induction r) auto

lemma final_read_Lm: "final(read a r) \<longleftrightarrow> [a] \<in> Lm r"
by (induction r) (auto simp: nullable_iff concI_if_Nil2 singleton_in_conc split: if_splits)

global_interpretation before: rexp_DFA init_b delta_b final_b L_b
  defines before_closure = before.closure
    and check_eqv_b = before.check_eqv
    and reachable_b = before.reachable
    and automaton_b = before.automaton
    and match_b = before.match
proof (standard, goal_cases)
  case (1 r) show "L_b (init_b r) = lang r"
    by(auto simp add: init_b_def Lm_follow Lm_empty map_map_rexp nullable_iff)
next
  case (2 a rb) show "L_b (delta_b a rb) = Deriv a (L_b rb)"
    by (cases rb) (auto simp add: Deriv_def final_read_Lm image_def Lm_read Lm_follow)
next
  case (3 rb) show  "final_b rb \<longleftrightarrow> [] \<in> L_b rb" by (cases rb) simp
next
  case (4 s)
  have "{fold delta_b w (init_b s) |w. True} \<subseteq> mrexps s \<times> UNIV"
    by (intro subsetI, elim CollectE exE) (simp only: fold_delta_b_init_b_mrexps)
  then show "finite {fold delta_b w (init_b s) |w. True}" by (rule finite_subset) simp
qed

subsection \<open>Mark After Atom\<close>

text\<open>Position automaton where mark is placed after atoms. This is the
Glushkov and McNaughton/Yamada construction.\<close>

definition "init_a r = (True, empty_mrexp r)"

lemma init_a_mrexps[simp]: "init_a r \<in> UNIV \<times> mrexps r"
  unfolding init_a_def by auto

fun delta_a where
"delta_a a (b,r) = (False, read a (follow b r))"

lemma delta_a_mrexps[simp]: "br \<in> UNIV \<times> mrexps r \<Longrightarrow> delta_a a br \<in> UNIV \<times> mrexps r"
by auto

lemma fold_delta_a_init_a_mrexps[simp]: "fold delta_a w (init_a s) \<in> UNIV \<times> mrexps s"
by (induction w arbitrary: s rule: rev_induct) auto

fun final_a where
"final_a (b,r) \<longleftrightarrow> final r \<or> b \<and> nullable r"

fun L_a where
"L_a (b,r) = Lm (follow b r) \<union> (if final_a(b,r)  then {[]} else {})"

lemma nonfinal_empty_mrexp: "\<not> final (empty_mrexp r)"
by (induction r) auto

lemma Cons_eq_tl_iff[simp]: "x # xs = tl ys \<longleftrightarrow> (\<exists>y. ys = y # x # xs)"
by (cases ys) auto

lemma tl_eq_Cons_iff[simp]: "tl ys = x # xs \<longleftrightarrow> (\<exists>y. ys = y # x # xs)"
by (cases ys) auto

global_interpretation after: rexp_DFA init_a delta_a final_a L_a
  defines after_closure = after.closure
    and check_eqv_a = after.check_eqv
    and reachable_a = after.reachable
    and automaton_a = after.automaton
    and match_a = after.match
proof (standard, goal_cases)
  case (1 r) show "L_a (init_a r) = lang r"
    by (auto simp: init_a_def nonfinal_empty_mrexp Lm_follow Lm_empty map_map_rexp nullable_iff)
next
  case (2 a br) show "L_a (delta_a a br) = Deriv a (L_a br)"
    by (cases br) (simp add: Deriv_def final_read_Lm Lm_read Lm_follow,
      fastforce simp: image_def neq_Nil_conv)
next
  case (3 br) show  "final_a br \<longleftrightarrow> [] \<in> L_a br" by (cases br) simp
next
  case (4 s)
  have "{fold delta_a w (init_a s) |w. True} \<subseteq> UNIV \<times> mrexps s"
    by (intro subsetI, elim CollectE exE) (simp only: fold_delta_a_init_a_mrexps)
  then show "finite {fold delta_a w (init_a s) |w. True}" by (rule finite_subset) simp
qed

text \<open>
The ``before'' atomaton is a quotient of the ``after'' automaton.

The proof below follows an informal proof given by Helmut Seidl in personal communication.
\<close>

fun hom_ab where
  "hom_ab (b, r) = (follow b r, final_a (b, r))"

lemma hom_delta: "hom_ab (delta_a x br) = delta_b x (hom_ab br)"
by(cases br) (auto simp add: Let_def)

lemma hom_deltas: "hom_ab (fold delta_a w br) = fold delta_b w (hom_ab br)"
  by (induct w arbitrary: br) (auto simp add: hom_delta)

lemma hom_init: "hom_ab (init_a r) = init_b r"
  unfolding init_a_def init_b_def hom_ab.simps by (simp add: nonfinal_empty_mrexp)

lemma reachable_ab: "reachable_b as r = hom_ab ` reachable_a as r"
  unfolding after.reachable before.reachable by (force simp: hom_init hom_deltas)

theorem card_reachable_ab: "card (reachable_b as r) \<le> card (reachable_a as r)"
  unfolding reachable_ab using after.finite_reachable by (rule card_image_le)

text\<open>The implementation by Fischer et al.:\<close>

(* better: shift b m r and move m b r *)
fun shift :: "bool \<Rightarrow> 'a mrexp \<Rightarrow> 'a \<Rightarrow> 'a mrexp" where
"shift _ One _ = One" |
"shift _ Zero _ = Zero" |
"shift m (Atom (_,x)) c = Atom (m \<and> (x=c),x)" |
"shift m (Plus r s) c = Plus (shift m r c) (shift m s c)" |
"shift m (Times r s) c =
  Times (shift m r c) (shift (final r \<or> m \<and> nullable r) s c)" |
"shift m (Star r) c = Star (shift (final r \<or> m) r c)"

lemma shift_read_follow: "shift m r x = read x (follow m r)"
by (induction m r x rule: shift.induct) auto

text\<open>In the spirit of Asperti, and similarly quadratic because of need
to call final1 in move.\<close>

fun final1 :: "'a mrexp \<Rightarrow> 'a \<Rightarrow> bool" where
"final1 Zero _ = False" |
"final1 One _ = False" |
"final1 (Atom(m,a)) x = (m \<and> a=x)" |
"final1 (Plus r s) x = (final1 r x \<or> final1 s x)" |
"final1 (Times r s) x = (final1 s x \<or> nullable s \<and> final1 r x)" |
"final1 (Star r) x = final1 r x"

fun move :: "'a \<Rightarrow> 'a mrexp \<Rightarrow> bool \<Rightarrow> 'a mrexp" where
"move _ One _ = One" |
"move _ Zero _ = Zero" |
"move c (Atom (_,a)) m = Atom (m, a)" |
"move c (Plus r s) m = Plus (move c r m) (move c s m)" |
"move c (Times r s) m =
  Times (move c r m) (move c s (final1 r c \<or> m \<and> nullable r))" |
"move c (Star r) m = Star (move c r (final1 r c \<or> m))"

lemma nullable_read[simp]: "nullable (read c r) = nullable r"
by (induction r) auto

lemma final_read_final1: "final (read c r) = final1 r c"
by (induction r) auto

lemma move_follow_read: "move c r m = follow m (read c r)"
by (induction c r m rule: move.induct) (auto simp: final_read_final1)

(*<*)
end
(*>*)


theory Weakening
  imports "HOL-Nominal.Nominal"
begin

text \<open>
  A simple proof of the Weakening Property in the simply-typed
  lambda-calculus. The proof is simple, because we can make use
  of the variable convention.\<close>

atom_decl name

text \<open>Terms and Types\<close>

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

nominal_datatype ty =
    TVar "string"
  | TArr "ty" "ty" ("_ \<rightarrow> _" [100,100] 100)

lemma ty_fresh:
  fixes x::"name"
  and   T::"ty"
  shows "x\<sharp>T"
by (nominal_induct T rule: ty.strong_induct)
   (auto simp add: fresh_string)

text \<open>
  Valid contexts (at the moment we have no type for finite
  sets yet, therefore typing-contexts are lists).\<close>

inductive
  valid :: "(name\<times>ty) list \<Rightarrow> bool"
where
    v1[intro]: "valid []"
  | v2[intro]: "\<lbrakk>valid \<Gamma>;x\<sharp>\<Gamma>\<rbrakk>\<Longrightarrow> valid ((x,T)#\<Gamma>)"

equivariance valid

text\<open>Typing judgements\<close>

inductive
  typing :: "(name\<times>ty) list\<Rightarrow>lam\<Rightarrow>ty\<Rightarrow>bool" ("_ \<turnstile> _ : _" [60,60,60] 60)
where
    t_Var[intro]: "\<lbrakk>valid \<Gamma>; (x,T)\<in>set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
  | t_App[intro]: "\<lbrakk>\<Gamma> \<turnstile> t1 : T1\<rightarrow>T2; \<Gamma> \<turnstile> t2 : T1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App t1 t2 : T2"
  | t_Lam[intro]: "\<lbrakk>x\<sharp>\<Gamma>;(x,T1)#\<Gamma> \<turnstile> t : T2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x].t : T1\<rightarrow>T2"

text \<open>
  We derive the strong induction principle for the typing
  relation (this induction principle has the variable convention
  already built-in).\<close>

equivariance typing
nominal_inductive typing
  by (simp_all add: abs_fresh ty_fresh)

text \<open>Abbreviation for the notion of subcontexts.\<close>

abbreviation
  "sub_context" :: "(name\<times>ty) list \<Rightarrow> (name\<times>ty) list \<Rightarrow> bool" ("_ \<subseteq> _" [60,60] 60)
where
  "\<Gamma>1 \<subseteq> \<Gamma>2 \<equiv> \<forall>x T. (x,T)\<in>set \<Gamma>1 \<longrightarrow> (x,T)\<in>set \<Gamma>2"

text \<open>Now it comes: The Weakening Lemma\<close>

text \<open>
  The first version is, after setting up the induction,
  completely automatic except for use of atomize.\<close>

lemma weakening_version1:
  fixes \<Gamma>1 \<Gamma>2::"(name\<times>ty) list"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
by (nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
   (auto | atomize)+

text \<open>
  The second version gives the details for the variable
  and lambda case.\<close>

lemma weakening_version2:
  fixes \<Gamma>1 \<Gamma>2::"(name\<times>ty) list"
  and   t ::"lam"
  and   \<tau> ::"ty"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
proof (nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
  case (t_Var \<Gamma>1 x T)  (* variable case *)
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  moreover
  have "valid \<Gamma>2" by fact
  moreover
  have "(x,T)\<in> set \<Gamma>1" by fact
  ultimately show "\<Gamma>2 \<turnstile> Var x : T" by auto
next
  case (t_Lam x \<Gamma>1 T1 t T2) (* lambda case *)
  have vc: "x\<sharp>\<Gamma>2" by fact   (* variable convention *)
  have ih: "\<lbrakk>valid ((x,T1)#\<Gamma>2); (x,T1)#\<Gamma>1 \<subseteq> (x,T1)#\<Gamma>2\<rbrakk> \<Longrightarrow> (x,T1)#\<Gamma>2 \<turnstile> t:T2" by fact
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  then have "(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#\<Gamma>2" by simp
  moreover
  have "valid \<Gamma>2" by fact
  then have "valid ((x,T1)#\<Gamma>2)" using vc by (simp add: v2)
  ultimately have "(x,T1)#\<Gamma>2 \<turnstile> t : T2" using ih by simp
  with vc show "\<Gamma>2 \<turnstile> Lam [x].t : T1\<rightarrow>T2" by auto
qed (auto) (* app case *)

text\<open>
  The original induction principle for the typing relation
  is not strong enough - even this simple lemma fails to be
  simple ;o)\<close>

lemma weakening_not_straigh_forward:
  fixes \<Gamma>1 \<Gamma>2::"(name\<times>ty) list"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
proof (induct arbitrary: \<Gamma>2)
  case (t_Var \<Gamma>1 x T) (* variable case still works *)
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  moreover
  have "valid \<Gamma>2" by fact
  moreover
  have "(x,T) \<in> (set \<Gamma>1)" by fact
  ultimately show "\<Gamma>2 \<turnstile> Var x : T" by auto
next
  case (t_Lam x \<Gamma>1 T1 t T2) (* lambda case *)
  (* These are all assumptions available in this case*)
  have a0: "x\<sharp>\<Gamma>1" by fact
  have a1: "(x,T1)#\<Gamma>1 \<turnstile> t : T2" by fact
  have a2: "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  have a3: "valid \<Gamma>2" by fact
  have ih: "\<And>\<Gamma>3. \<lbrakk>valid \<Gamma>3; (x,T1)#\<Gamma>1 \<subseteq> \<Gamma>3\<rbrakk> \<Longrightarrow> \<Gamma>3 \<turnstile> t : T2" by fact
  have "(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#\<Gamma>2" using a2 by simp
  moreover
  have "valid ((x,T1)#\<Gamma>2)" using v2 (* fails *)
    oops

text\<open>
  To show that the proof with explicit renaming is not simple,
  here is the proof without using the variable convention. It
  crucially depends on the equivariance property of the typing
  relation.

\<close>

lemma weakening_with_explicit_renaming:
  fixes \<Gamma>1 \<Gamma>2::"(name\<times>ty) list"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
proof (induct arbitrary: \<Gamma>2)
  case (t_Lam x \<Gamma>1 T1 t T2) (* lambda case *)
  have fc0: "x\<sharp>\<Gamma>1" by fact
  have ih: "\<And>\<Gamma>3. \<lbrakk>valid \<Gamma>3; (x,T1)#\<Gamma>1 \<subseteq> \<Gamma>3\<rbrakk> \<Longrightarrow> \<Gamma>3 \<turnstile> t : T2" by fact
  obtain c::"name" where fc1: "c\<sharp>(x,t,\<Gamma>1,\<Gamma>2)"  (* we obtain a fresh name *)
    by (rule exists_fresh) (auto simp add: fs_name1)
  have "Lam [c].([(c,x)]\<bullet>t) = Lam [x].t" using fc1 (* we then alpha-rename the lambda-abstraction *)
    by (auto simp add: lam.inject alpha fresh_prod fresh_atm)
  moreover
  have "\<Gamma>2 \<turnstile> Lam [c].([(c,x)]\<bullet>t) : T1 \<rightarrow> T2" (* we can then alpha-rename our original goal *)
  proof -
    (* we establish (x,T1)#\<Gamma>1 \<subseteq> (x,T1)#([(c,x)]\<bullet>\<Gamma>2) and valid ((x,T1)#([(c,x)]\<bullet>\<Gamma>2)) *)
    have "(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#([(c,x)]\<bullet>\<Gamma>2)"
    proof -
      have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
      then have "[(c,x)]\<bullet>((x,T1)#\<Gamma>1 \<subseteq> (x,T1)#([(c,x)]\<bullet>\<Gamma>2))" using fc0 fc1
        by (perm_simp add: eqvts calc_atm perm_fresh_fresh ty_fresh)
      then show "(x,T1)#\<Gamma>1 \<subseteq> (x,T1)#([(c,x)]\<bullet>\<Gamma>2)" by (rule perm_boolE)
    qed
    moreover
    have "valid ((x,T1)#([(c,x)]\<bullet>\<Gamma>2))"
    proof -
      have "valid \<Gamma>2" by fact
      then show "valid ((x,T1)#([(c,x)]\<bullet>\<Gamma>2))" using fc1
        by (auto intro!: v2 simp add: fresh_left calc_atm eqvts)
    qed
    (* these two facts give us by induction hypothesis the following *)
    ultimately have "(x,T1)#([(c,x)]\<bullet>\<Gamma>2) \<turnstile> t : T2" using ih by simp
    (* we now apply renamings to get to our goal *)
    then have "[(c,x)]\<bullet>((x,T1)#([(c,x)]\<bullet>\<Gamma>2) \<turnstile> t : T2)" by (rule perm_boolI)
    then have "(c,T1)#\<Gamma>2 \<turnstile> ([(c,x)]\<bullet>t) : T2" using fc1
      by (perm_simp add: eqvts calc_atm perm_fresh_fresh ty_fresh)
    then show "\<Gamma>2 \<turnstile> Lam [c].([(c,x)]\<bullet>t) : T1 \<rightarrow> T2" using fc1 by auto
  qed
  ultimately show "\<Gamma>2 \<turnstile> Lam [x].t : T1 \<rightarrow> T2" by simp
qed (auto) (* var and app cases *)

text \<open>
  Moral: compare the proof with explicit renamings to weakening_version1
  and weakening_version2, and imagine you are proving something more substantial
  than the weakening lemma.\<close>

end


(* Author: Tobias Nipkow *)

section \<open>Unbalanced Tree Implementation of Map\<close>

theory Tree_Map
imports
  Tree_Set
  Map_by_Ordered
begin

fun lookup :: "('a::linorder*'b) tree \<Rightarrow> 'a \<Rightarrow> 'b option" where
"lookup Leaf x = None" |
"lookup (Node l (a,b) r) x =
  (case cmp x a of LT \<Rightarrow> lookup l x | GT \<Rightarrow> lookup r x | EQ \<Rightarrow> Some b)"

fun update :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a*'b) tree \<Rightarrow> ('a*'b) tree" where
"update x y Leaf = Node Leaf (x,y) Leaf" |
"update x y (Node l (a,b) r) = (case cmp x a of
   LT \<Rightarrow> Node (update x y l) (a,b) r |
   EQ \<Rightarrow> Node l (x,y) r |
   GT \<Rightarrow> Node l (a,b) (update x y r))"

fun delete :: "'a::linorder \<Rightarrow> ('a*'b) tree \<Rightarrow> ('a*'b) tree" where
"delete x Leaf = Leaf" |
"delete x (Node l (a,b) r) = (case cmp x a of
  LT \<Rightarrow> Node (delete x l) (a,b) r |
  GT \<Rightarrow> Node l (a,b) (delete x r) |
  EQ \<Rightarrow> if r = Leaf then l else let (ab',r') = del_min r in Node l ab' r')"

subsection "Functional Correctness Proofs"

lemma lookup_map_of:
  "sorted1(inorder t) \<Longrightarrow> lookup t x = map_of (inorder t) x"
by (induction t) (auto simp: map_of_simps split: option.split)

lemma inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update a b t) = upd_list a b (inorder t)"
by(induction t) (auto simp: upd_list_simps)

lemma inorder_delete:
  "sorted1(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(induction t) (auto simp: del_list_simps del_minD split: prod.splits)

interpretation Map_by_Ordered
where empty = Leaf and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 thus ?case by(simp add: lookup_map_of)
next
  case 3 thus ?case by(simp add: inorder_update)
next
  case 4 thus ?case by(simp add: inorder_delete)
qed auto

end


theory material_implication imports Main begin

text {*
  Proving Material Implication in propositional calculus
*}

lemma "(P\<longrightarrow>Q) = (\<not>P\<or>Q)"
  apply (rule iffI)
   apply(rule classical)
   apply(erule impE)
    apply(rule classical)
    apply(erule notE)
  apply(rule disjI1)
    apply assumption
   apply(rule disjI2)
   apply assumption
  apply(erule disjE)
   apply(rule impI)
   apply (erule notE)
  apply assumption
  apply(rule impI)
  apply assumption
  done


(*  Title:      HOL/HOLCF/ex/Powerdomain_ex.thy
    Author:     Brian Huffman
*)

section {* Powerdomain examples *}

theory Powerdomain_ex
imports HOLCF
begin

subsection {* Monadic sorting example *}

domain ordering = LT | EQ | GT

definition
  compare :: "int lift \<rightarrow> int lift \<rightarrow> ordering" where
  "compare = (FLIFT x y. if x < y then LT else if x = y then EQ else GT)"

definition
  is_le :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
  "is_le = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> TT | GT \<Rightarrow> FF)"

definition
  is_less :: "int lift \<rightarrow> int lift \<rightarrow> tr" where
  "is_less = (\<Lambda> x y. case compare\<cdot>x\<cdot>y of LT \<Rightarrow> TT | EQ \<Rightarrow> FF | GT \<Rightarrow> FF)"

definition
  r1 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
  "r1 = (\<Lambda> (x,_) (y,_). case compare\<cdot>x\<cdot>y of
          LT \<Rightarrow> {TT}\<natural> |
          EQ \<Rightarrow> {TT, FF}\<natural> |
          GT \<Rightarrow> {FF}\<natural>)"

definition
  r2 :: "(int lift \<times> 'a) \<rightarrow> (int lift \<times> 'a) \<rightarrow> tr convex_pd" where
  "r2 = (\<Lambda> (x,_) (y,_). {is_le\<cdot>x\<cdot>y, is_less\<cdot>x\<cdot>y}\<natural>)"

lemma r1_r2: "r1\<cdot>(x,a)\<cdot>(y,b) = (r2\<cdot>(x,a)\<cdot>(y,b) :: tr convex_pd)"
apply (simp add: r1_def r2_def)
apply (simp add: is_le_def is_less_def)
apply (cases "compare\<cdot>x\<cdot>y")
apply simp_all
done

subsection {* Picking a leaf from a tree *}

domain 'a tree =
  Node (lazy "'a tree") (lazy "'a tree") |
  Leaf (lazy "'a")

fixrec
  mirror :: "'a tree \<rightarrow> 'a tree"
where
  mirror_Leaf: "mirror\<cdot>(Leaf\<cdot>a) = Leaf\<cdot>a"
| mirror_Node: "mirror\<cdot>(Node\<cdot>l\<cdot>r) = Node\<cdot>(mirror\<cdot>r)\<cdot>(mirror\<cdot>l)"

lemma mirror_strict [simp]: "mirror\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec
  pick :: "'a tree \<rightarrow> 'a convex_pd"
where
  pick_Leaf: "pick\<cdot>(Leaf\<cdot>a) = {a}\<natural>"
| pick_Node: "pick\<cdot>(Node\<cdot>l\<cdot>r) = pick\<cdot>l \<union>\<natural> pick\<cdot>r"

lemma pick_strict [simp]: "pick\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

lemma pick_mirror: "pick\<cdot>(mirror\<cdot>t) = pick\<cdot>t"
by (induct t) (simp_all add: convex_plus_ac)

fixrec tree1 :: "int lift tree"
where "tree1 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
                   \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"

fixrec tree2 :: "int lift tree"
where "tree2 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>(Leaf\<cdot>(Def 2)))
                   \<cdot>(Node\<cdot>\<bottom>\<cdot>(Leaf\<cdot>(Def 4)))"

fixrec tree3 :: "int lift tree"
where "tree3 = Node\<cdot>(Node\<cdot>(Leaf\<cdot>(Def 1))\<cdot>tree3)
                   \<cdot>(Node\<cdot>(Leaf\<cdot>(Def 3))\<cdot>(Leaf\<cdot>(Def 4)))"

declare tree1.simps tree2.simps tree3.simps [simp del]

lemma pick_tree1:
  "pick\<cdot>tree1 = {Def 1, Def 2, Def 3, Def 4}\<natural>"
apply (subst tree1.simps)
apply simp
apply (simp add: convex_plus_ac)
done

lemma pick_tree2:
  "pick\<cdot>tree2 = {Def 1, Def 2, \<bottom>, Def 4}\<natural>"
apply (subst tree2.simps)
apply simp
apply (simp add: convex_plus_ac)
done

lemma pick_tree3:
  "pick\<cdot>tree3 = {Def 1, \<bottom>, Def 3, Def 4}\<natural>"
apply (subst tree3.simps)
apply simp
apply (induct rule: tree3.induct)
apply simp
apply simp
apply (simp add: convex_plus_ac)
apply simp
apply (simp add: convex_plus_ac)
done

end


theory ex3_12 imports Main "~~/src/HOL/IMP/AExp" begin

type_synonym reg = nat
datatype instr0 = LDI0 val | LD0 vname | MV0 reg | ADD0 reg
type_synonym reg_st = "reg \<Rightarrow> int"

fun exec1 :: "instr0 \<Rightarrow> state \<Rightarrow> reg_st \<Rightarrow> reg_st" where
"exec1 (LDI0 n) _ f =  f(0 := n)" |
"exec1 (LD0 x) s f = f(0 := s x)" |
"exec1 (MV0 r) _ f = f(r := f 0)" |
"exec1 (ADD0 r) _ f = f(0 := f r + f 0)"

fun exec :: "instr0 list \<Rightarrow> state \<Rightarrow> reg_st \<Rightarrow> reg_st" where
"exec [] _ f = f" |
"exec (i#is) s f = exec is s (exec1 i s f)"

lemma exec_append[simp]:
  "exec (is1@is2) s f = exec is2 s (exec is1 s f)"
apply(induction is1 arbitrary: s f)
apply (auto)
done

(* "comp a r" uses temporary register r' where r' > r *)
fun comp :: "aexp \<Rightarrow> reg \<Rightarrow> instr0 list" where
"comp (N n) r = [LDI0 n]" |
"comp (V x) r = [LD0 x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) r = comp e\<^sub>1 r @ [MV0 (r+1)] @ comp e\<^sub>2 (r+1) @ [ADD0 (r+1)]"

theorem exec_comp: "exec (comp a r) s rs 0 = aval a s"
apply(induction a arbitrary: s rs r)
apply (auto)
done

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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_46
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun y :: "Nat => Nat => bool" where
  "y (Z) (Z) = True"
| "y (Z) (S z2) = False"
| "y (S x2) (Z) = False"
| "y (S x2) (S y22) = y x2 y22"

fun x :: "bool => bool => bool" where
  "x True y2 = True"
| "x False y2 = y2"

fun elem :: "Nat => Nat list => bool" where
  "elem z (nil2) = False"
| "elem z (cons2 z2 xs) = x (y z z2) (elem z xs)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) y2 = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

fun insert :: "Nat => Nat list => Nat list" where
  "insert z (nil2) = cons2 z (nil2)"
| "insert z (cons2 z2 xs) =
     (if t2 z z2 then cons2 z (cons2 z2 xs) else cons2 z2 (insert z xs))"

theorem property0 :
  "((z = y2) ==> (elem z (insert y2 z2)))"
  oops

end


theory Submission
  imports Defs
begin

text \<open>Some auxiliary lemmas\<close>

lemma map2_update1:
  "map2 f (xs[n:=k]) ys = (map2 f xs ys)[n:=f k (ys ! n)]"
  by (metis (no_types, lifting) case_prod_conv list_update_id map_update zip_update)

lemma map2_update2:
  "map2 f xs (ys[n:=k]) = (map2 f xs ys)[n:=f (xs ! n) k]"
  by (metis (no_types, lifting) case_prod_conv list_update_id map_update zip_update)

lemma (in ab_group_add) sum_list_update:
  "k < size xs \<Longrightarrow> sum_list (xs[k := x]) = sum_list xs + x - xs ! k"
  by(induction xs arbitrary: k) (auto simp: add_ac add_diff_eq split: nat.split)

lemma sum_list_update':
  fixes xs :: "rat list"
  shows "k < size xs \<Longrightarrow> sum_list (xs[k := x]) = sum_list xs + x - xs ! k"
  by(induction xs arbitrary: k) (auto split: nat.split)

lemma sum_list_distrib:
  fixes xs gcs lcs :: "('a::ring) list"
  assumes "length gcs = length xs" "length lcs = length xs"
  shows
  "sum_list (map2 (*) (map2 (+) gcs lcs) xs) =
  sum_list (map2 (*) gcs xs) + sum_list (map2 (*) lcs xs)"
  using assms
  apply (induction "length xs" arbitrary: xs gcs lcs)
  apply simp
  subgoal for x xs cgs cls
    apply (cases xs, simp)
    apply (cases cgs, simp)
    apply (cases cls, simp)
    apply (simp add:algebra_simps)
    done
  done

lemma (in ring) sum_list2_aux:
  assumes "length gcs = length xs" "n < length xs"
  shows "sum_list (map2 (*) gcs xs) = sum_list (map2 (*) (gcs[n := 0]) xs) + (gcs ! n * xs ! n)"
  using assms by (simp add: map2_update1 sum_list_update)

lemmas GZL_defs = GZL_def G_def Z_def L_def

lemma GZL_set:
  assumes "GZL ps n = triple a b c"
  shows "set ps = set a \<union> set b \<union> set c"
  using assms unfolding GZL_defs by (auto split: ineq.splits)

lemma GZL_sorting_sat:
  "triple_sat (GZL ps n) xs \<longleftrightarrow> pol_sat ps xs"
  using GZL_set unfolding triple_sat_def pol_sat_def by (auto split: triple.splits)

context
  fixes N :: nat \<comment> \<open>Number of coefficients/variables\<close>
begin

definition
  "pol_lengths ps = (\<forall>p \<in> set ps. (case p of (ineq cs k) \<Rightarrow> length cs = N))"

definition
  "triple_lengths \<equiv> \<lambda>triple gs zs ls \<Rightarrow> pol_lengths gs \<and> pol_lengths zs \<and> pol_lengths ls"

context
  fixes n :: nat \<comment> \<open>Index of variable to be eliminated\<close>
  assumes n_bound[simp, intro]: "n < N"
begin

abbreviation
  "G_inv \<equiv> \<lambda>ineq gcs gk \<Rightarrow> gcs!n = 1"

abbreviation
  "Z_inv \<equiv> \<lambda>ineq gcs gk \<Rightarrow> gcs!n = 0"

abbreviation
  "L_inv \<equiv> \<lambda>ineq gcs gk \<Rightarrow> gcs!n = -1"

abbreviation
  "GS_inv gs \<equiv> \<forall>g \<in> set gs. G_inv g"

abbreviation
  "ZS_inv gs \<equiv> \<forall>g \<in> set gs. Z_inv g"

abbreviation
  "LS_inv gs \<equiv> \<forall>g \<in> set gs. L_inv g"

definition
  "GZL_inv \<equiv> \<lambda>triple gs zs ls \<Rightarrow> GS_inv gs \<and> ZS_inv zs \<and> LS_inv ls"

definition GZL_sorted where
  "GZL_sorted \<equiv> \<lambda>triple gs zs ls \<Rightarrow>
  (\<forall>g \<in> set gs. case g of ineq cs k \<Rightarrow> cs ! n > 0) \<and>
  (\<forall>g \<in> set zs. case g of ineq cs k \<Rightarrow> cs ! n = 0) \<and>
  (\<forall>g \<in> set ls. case g of ineq cs k \<Rightarrow> cs ! n < 0)"

lemma GZL_sorts:
  "GZL_sorted (GZL ps n)"
  unfolding GZL_defs GZL_sorted_def by (auto split: triple.splits ineq.splits)

context
  fixes xs :: "rat list"
  assumes len_xs[simp]: "length xs = N"
begin

paragraph \<open>@{term list_div}\<close>

lemma GZL_sorting_lengths:
  "pol_lengths ps \<Longrightarrow> triple_lengths (GZL ps n)"
  unfolding triple_lengths_def GZL_defs pol_lengths_def by (auto split:ineq.splits)

lemma list_div_sat [simp]: "cn > 0 \<Longrightarrow>  eval_term (list_div cs cn) xs = (eval_term cs xs)/cn"
  unfolding list_div_def
  unfolding eval_term_def
  \<comment> \<open>Simon: This could actually be an interesting simple task by itself.\<close>
  apply (induction cs arbitrary:xs)
  apply (auto simp:zip_Cons1 split:list.splits)
  apply (simp add:field_simps)
  done

lemma ineq_div_sat [simp]: "(cs!n) \<noteq> 0 \<Longrightarrow>
  ineq_sat (ineq_div (ineq cs k) n) xs = ineq_sat (ineq cs k) xs"
  unfolding ineq_div_def
  unfolding ineq_sat_def
  by (simp add: divide_le_cancel)

paragraph \<open>@{term pol_div}\<close>

lemma pol_div_sat [simp]:
"(\<forall>p \<in> set ps. (case p of ineq cs k \<Rightarrow> cs!n \<noteq> 0)) \<Longrightarrow>
pol_sat (pol_div ps n) xs = pol_sat ps xs"
  unfolding pol_div_def pol_sat_def
  by simp (metis (mono_tags, lifting) ineq_div_sat ineq.case ineq.exhaust)

paragraph \<open>@{term GZL_div}\<close>

lemma GZL_div_triple_lengths:
  assumes "triple_lengths ps"
  shows "triple_lengths (GZL_div ps n)"
  using assms
  unfolding GZL_div_def triple_lengths_def pol_lengths_def pol_div_def ineq_div_def list_div_def
  by (force split: ineq.split triple.split)

lemma G_inv_ineq_div:
  "G_inv (ineq_div (ineq gcs k) n)" if "gcs!n > 0" "length gcs = N"
  unfolding ineq_div_def list_div_def using that by simp

lemma L_inv_ineq_div:
  "L_inv (ineq_div (ineq gcs k) n)" if "gcs!n < 0" "length gcs = N"
  unfolding ineq_div_def list_div_def using that by simp

lemma GZL_inv:
  assumes "triple_lengths ps" "GZL_sorted ps"
  shows "GZL_inv (GZL_div ps n)"
  using assms
  unfolding triple_lengths_def GZL_sorted_def GZL_div_def GZL_inv_def pol_div_def pol_lengths_def
   apply (auto split:triple.split)
  subgoal for _ _ _ g
    by (cases g) (auto intro!: G_inv_ineq_div)
  subgoal for _ _ _ l
    by (cases l) (auto intro!: L_inv_ineq_div)
  done

lemma GZL_div_sat:
  "n < length xs \<Longrightarrow> GZL_sorted ps \<Longrightarrow> triple_sat (GZL_div ps n) xs = triple_sat ps xs"
  unfolding GZL_div_def triple_sat_def GZL_sorted_def
  apply (simp split: triple.split_asm)
  apply (subst pol_div_sat)
  subgoal
    by (auto split:ineq.splits)
  apply (subst pol_div_sat)
  apply (auto split: ineq.split)
  done

\<comment> \<open>Phase 3: @{term GZL_product}\<close>
lemma ineq_add_assoc:
"
  length gcs = N \<Longrightarrow>
  length lcs = N \<Longrightarrow>
  ineq_sat (ineq_add (ineq gcs gk) (ineq lcs lk)) xs \<longleftrightarrow>
  eval_term gcs xs + eval_term lcs xs \<le> gk + lk"
  unfolding ineq_add_def ineq_sat_def eval_term_def by (simp add: sum_list_distrib)

\<comment> \<open>Also, possible exercise.\<close>
lemma eval_term_sum_update_cancel:
  "length gcs = N \<Longrightarrow> length lcs = N \<Longrightarrow> gcs!n = 1 \<Longrightarrow> lcs!n = -1 \<Longrightarrow>
  eval_term (gcs[n := 0]) xs + eval_term (lcs[n := 0]) xs = eval_term gcs xs + eval_term lcs xs"
  unfolding eval_term_def
  apply -
  apply (subst (3) sum_list2_aux[where n = n]; simp)
  apply (subst (2) sum_list2_aux[where n = n]; simp)
  done

theorem ineq_add_cancel':
  assumes "length gcs = N" "gcs!n = 1" "length lcs = N" "lcs!n = -1"
  shows
  "ineq_sat (ineq_add (ineq gcs gk) (ineq lcs lk)) xs \<longleftrightarrow>
  eval_term (gcs[n := 0]) xs + eval_term (lcs[n := 0]) xs \<le> gk + lk"
  using assms by (simp add: ineq_add_assoc eval_term_sum_update_cancel)

theorem eval_term_nth_split':
  assumes "length gcs = N"
  shows "eval_term gcs (xs[n := t]) = eval_term (gcs[n := 0]) xs + gcs!n * t"
  using assms unfolding eval_term_def
  by (smt (z3) sum_list2_aux lambda_zero len_xs length_list_update list_update_id map2_update2
        n_bound nth_list_update_eq)

lemma term_pairing_if:
  assumes
    "GS_inv gs" "LS_inv ls" "pol_lengths gs" "pol_lengths ls"
    "pol_sat gs (xs[n:=t])" "pol_sat ls (xs[n:=t])"
  shows "pol_sat (term_pairing gs ls) xs"
proof -
  have "ineq_sat (ineq_add y x) xs"
    if "y \<in> set gs" "x \<in> set ls" "x = ineq lcs lk" "y = ineq gcs gk" for x y lcs gcs lk gk
  proof -
    from that assms(5,6) have "ineq_sat x (xs[n:=t])" "ineq_sat y (xs[n:=t])"
      unfolding pol_sat_def  by auto
    moreover have "length lcs = N" "length gcs = N"
      using assms that unfolding pol_lengths_def by auto
    moreover have "lcs!n = -1" "gcs!n = 1"
      using assms(1,2) that by auto
    ultimately show ?thesis
      unfolding \<open>x = _\<close> \<open>y = _\<close>
      by - (subst ineq_add_cancel', assumption+,
            simp add: eval_term_nth_split' ineq_sat_def ineq_add_def)
  qed
  then show ?thesis
    unfolding term_pairing_def
    unfolding pol_sat_def
    unfolding pol_add_def
    apply (clarsimp split: ineq.split)
    subgoal for x y
      using assms
      apply (cases x)
      apply (cases y)
      apply simp
      done
    done
qed

lemma term_pairing_only_if1:
  assumes
    "ls \<noteq> []" "GS_inv gs" "LS_inv ls" "pol_lengths gs" "pol_lengths ls"
    "pol_sat (term_pairing gs ls) xs"
  shows "\<exists>t. pol_sat gs (xs[n:=t]) \<and> pol_sat ls (xs[n:=t])"
proof -
  let ?L = "{eval_term (lcs[n:=0]) xs - lk | lcs lk. ineq lcs lk \<in> set ls}"
  let ?t = "Max ?L"
  have "finite ?L"
    using [[simproc add: finite_Collect]] by (auto intro!: injI finite_vimageI)
  have *: "eval_term (lcs[n:=0]) xs - lk \<le> gk - eval_term (gcs[n:=0]) xs"
    if "ineq lcs lk \<in> set ls" "ineq gcs gk \<in> set gs" for lcs gcs lk gk
  proof -
    from that \<open>pol_sat _ _\<close> have "ineq_sat (ineq_add (ineq gcs gk) (ineq lcs lk)) xs"
      unfolding pol_sat_def term_pairing_def pol_add_def by auto
    with that assms show ?thesis
      by (subst (asm) ineq_add_cancel') (auto simp: pol_lengths_def)
  qed
  obtain lcs1 lk1 where t: "?t = eval_term (lcs1[n:=0]) xs - lk1" "ineq lcs1 lk1 \<in> set ls"
  (* s/h *)
  proof -
    have f1: "\<forall>p. p (Max (Collect p)::rat) \<or> infinite (Collect p) \<or> {} = Collect p"
      using Max_eq_iff by blast
    have "\<exists>rs r. ineq rs r \<in> set ls"
      by (metis assms(1) ex_in_conv ineq.exhaust set_empty2)
    then show thesis
      using f1 \<open>finite {eval_term (lcs[n := 0]) xs - lk |lcs lk. ineq lcs lk \<in> set ls}\<close> that by auto
  qed
  have "pol_sat ls (xs[n:=?t])"
  proof -
    have "eval_term lcs (xs[n := ?t]) \<le> lk" if prems: "ineq lcs lk \<in> set ls" for lcs lk
    proof -
      from prems assms have "length lcs = N"
        unfolding pol_lengths_def by auto
      moreover from prems assms have "lcs!n = -1"
        by auto
      moreover from prems \<open>finite ?L\<close> have "eval_term (lcs[n:=0]) xs - lk \<le> ?t"
        by (intro Max_ge) auto
      ultimately show "eval_term lcs (xs[n := ?t]) \<le> lk"
        by (simp add: eval_term_nth_split')
    qed
    then show ?thesis
      unfolding pol_sat_def ineq_sat_def by (clarsimp split: ineq.split)
  qed
  moreover have "pol_sat gs (xs[n:=?t])"
  proof -
    have "eval_term gcs (xs[n := ?t]) \<le> gk" if prems: "ineq gcs gk \<in> set gs" for gcs gk
    proof -
      from prems assms have "length gcs = N"
        unfolding pol_lengths_def by auto
      moreover from prems assms have "gcs!n = 1"
        by auto
      moreover from prems have "?t \<le> gk - eval_term (gcs[n:=0]) xs"
        using * t(1) t(2) by presburger
      ultimately show ?thesis
        by (simp add: eval_term_nth_split')
    qed
    then show ?thesis
      unfolding pol_sat_def ineq_sat_def by (clarsimp split: ineq.split)
  qed
  ultimately show ?thesis
    by blast
qed

lemma term_pairing_only_if2:
  assumes
    "ls = []" "GS_inv gs" "LS_inv ls" "pol_lengths gs" "pol_lengths ls"
    "pol_sat (term_pairing gs ls) xs"
  shows "\<exists>t. pol_sat gs (xs[n:=t]) \<and> pol_sat ls (xs[n:=t])"
proof (cases "gs = []")
  case True
  with assms show ?thesis
    unfolding pol_sat_def by auto
next
  case False
  let ?G = "{gk - eval_term (gcs[n:=0]) xs | gcs gk. ineq gcs gk \<in> set gs}"
  let ?t = "Min ?G"
  have "finite ?G"
    using [[simproc add: finite_Collect]] by (auto intro!: injI finite_vimageI)
  have "pol_sat gs (xs[n:=?t])"
  proof -
    have "eval_term gcs (xs[n := ?t]) \<le> gk" if prems: "ineq gcs gk \<in> set gs" for gcs gk
    proof -
      from prems assms have "length gcs = N"
        unfolding pol_lengths_def by auto
      moreover from prems assms have "gcs!n = 1"
        by auto
      moreover from prems \<open>finite ?G\<close> have "?t \<le> gk - eval_term (gcs[n:=0]) xs"
        by (intro Min_le) auto
      ultimately show ?thesis
        by (simp add: eval_term_nth_split')
    qed
    then show ?thesis
      unfolding pol_sat_def ineq_sat_def by (clarsimp split: ineq.split)
  qed
  with assms show ?thesis
    unfolding pol_sat_def by auto
qed

lemma term_pairing_iff:
"GS_inv gs \<Longrightarrow> LS_inv ls \<Longrightarrow> pol_lengths gs \<Longrightarrow> pol_lengths ls \<Longrightarrow>
 pol_sat (term_pairing gs ls) xs = (\<exists>t. pol_sat gs (xs[n:=t]) \<and> pol_sat ls (xs[n:=t]))"
  using term_pairing_only_if1 term_pairing_only_if2 term_pairing_if by metis

lemma GZL_product_sat_iff:
  assumes "GZL_inv (triple gs zs ls)" "triple_lengths (triple gs zs ls)"
  shows "pol_sat (GZL_product (triple gs zs ls)) xs =
    (\<exists>t. triple_sat (triple gs zs ls) (xs[n := t]))"
proof -
  from assms have "ZS_inv zs"
    unfolding GZL_inv_def by simp
  then have "pol_sat zs (xs[n := t]) = pol_sat zs xs" for t
    unfolding pol_sat_def ineq_sat_def eval_term_def
    by (auto split: ineq.split)
       (metis (mono_tags, lifting) ineq.case list_update_id map2_update2 mult_zero_left)+
  moreover have "pol_sat (zs @ term_pairing gs ls) xs
    \<longleftrightarrow> pol_sat zs xs \<and> pol_sat (term_pairing gs ls) xs"
    unfolding pol_sat_def by auto
  ultimately show ?thesis
    using assms unfolding GZL_inv_def triple_lengths_def
    unfolding GZL_product_def triple_sat_def
    by (auto simp add: term_pairing_iff)
qed

theorem FM_preserves_solution':
  assumes "pol_lengths ps" "pol_sat ps (xs[n := t])"
  shows "pol_sat (FM ps n) xs"
  by (metis (mono_tags, lifting) Submission.GZL_div_sat GZL_div_def GZL_div_triple_lengths GZL_inv
        GZL_product_sat_iff GZL_def GZL_sorting_lengths GZL_sorting_sat GZL_sorts
        len_xs length_list_update n_bound FM_def triple.simps(2) assms)

theorem FM_sat_has_solution':
  assumes "pol_lengths ps" "pol_sat (FM ps n) xs"
  shows "\<exists>t. pol_sat ps (xs[n := t])"
  by (metis (mono_tags, lifting) Submission.GZL_div_sat GZL_div_def GZL_div_triple_lengths GZL_inv
        GZL_product_sat_iff GZL_def GZL_sorting_lengths GZL_sorting_sat GZL_sorts
        len_xs length_list_update n_bound FM_def triple.simps(2) assms)

theorem FM_sat_equivalent:
  assumes "pol_lengths ps"
  shows "pol_sat (FM ps n) xs \<longleftrightarrow> (\<exists>t. pol_sat ps (xs[n := t]))"
  using FM_preserves_solution' FM_sat_has_solution' assms by metis

end
end
end

theorem ineq_add_cancel:
  assumes "length gcs = length xs" "n < length xs" "gcs!n = 1" "length lcs = length xs" "lcs!n = -1"
  shows
  "ineq_sat (ineq_add (ineq gcs gk) (ineq lcs lk)) xs \<longleftrightarrow>
  eval_term (gcs[n := 0]) xs + eval_term (lcs[n := 0]) xs \<le> gk + lk"
  using assms by (intro ineq_add_cancel') (auto simp: pol_lengths_def)

theorem eval_term_nth_split:
  assumes "length gcs = length xs" "n < length xs"
  shows "eval_term gcs (xs[n := t]) = eval_term (gcs[n := 0]) xs + gcs!n * t"
  using assms by (intro eval_term_nth_split') (auto simp: pol_lengths_def)

theorem FM_preserves_solution:
  assumes "\<forall>p \<in> set ps. (case p of (ineq cs k) \<Rightarrow> length cs = length xs)" "n < length xs"
    "pol_sat ps (xs[n := t])"
  shows "pol_sat (FM ps n) xs"
  using assms by (intro FM_preserves_solution') (auto simp: pol_lengths_def)

theorem FM_sat_has_solution:
  assumes "\<forall>p \<in> set ps. (case p of (ineq cs k) \<Rightarrow> length cs = length xs)" "n < length xs"
    "pol_sat (FM ps n) xs"
  shows "\<exists>t. pol_sat ps (xs[n := t])"
  using assms by (intro FM_sat_has_solution') (auto simp: pol_lengths_def)

end


(*  Title:      HOL/Induct/Infinitely_Branching_Tree.thy
    Author:     Stefan Berghofer, TU Muenchen
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>Infinitely branching trees\<close>

theory Infinitely_Branching_Tree
imports MainRLT
begin

datatype 'a tree =
    Atom 'a
  | Branch "nat \<Rightarrow> 'a tree"

primrec map_tree :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a tree \<Rightarrow> 'b tree"
  where
    "map_tree f (Atom a) = Atom (f a)"
  | "map_tree f (Branch ts) = Branch (\<lambda>x. map_tree f (ts x))"

lemma tree_map_compose: "map_tree g (map_tree f t) = map_tree (g \<circ> f) t"
  by (induct t) simp_all

primrec exists_tree :: "('a \<Rightarrow> bool) \<Rightarrow> 'a tree \<Rightarrow> bool"
  where
    "exists_tree P (Atom a) = P a"
  | "exists_tree P (Branch ts) = (\<exists>x. exists_tree P (ts x))"

lemma exists_map:
  "(\<And>x. P x \<Longrightarrow> Q (f x)) \<Longrightarrow>
    exists_tree P ts \<Longrightarrow> exists_tree Q (map_tree f ts)"
  by (induct ts) auto

subsection\<open>The Brouwer ordinals, as in ZF/Induct/Brouwer.thy.\<close>

datatype brouwer = Zero | Succ brouwer | Lim "nat \<Rightarrow> brouwer"

text \<open>Addition of ordinals\<close>
primrec add :: "brouwer \<Rightarrow> brouwer \<Rightarrow> brouwer"
  where
    "add i Zero = i"
  | "add i (Succ j) = Succ (add i j)"
  | "add i (Lim f) = Lim (\<lambda>n. add i (f n))"

text \<open>Multiplication of ordinals\<close>
primrec mult :: "brouwer \<Rightarrow> brouwer \<Rightarrow> brouwer"
  where
    "mult i Zero = Zero"
  | "mult i (Succ j) = add (mult i j) i"
  | "mult i (Lim f) = Lim (\<lambda>n. mult i (f n))"

lemma add_mult_distrib: "mult i (add j k) = add (mult i j) (mult i k)"
  by (induct k) (auto simp add: add_assoc)

lemma mult_assoc: "mult (mult i j) k = mult i (mult j k)"
  by (induct k) (auto simp add: add_mult_distrib)

text \<open>We could probably instantiate some axiomatic type classes and use
  the standard infix operators.\<close>

subsection \<open>A WF Ordering for The Brouwer ordinals (Michael Compton)\<close>

text \<open>To use the function package we need an ordering on the Brouwer
  ordinals.  Start with a predecessor relation and form its transitive
  closure.\<close>

definition brouwer_pred :: "(brouwer \<times> brouwer) set"
  where "brouwer_pred = (\<Union>i. {(m, n). n = Succ m \<or> (\<exists>f. n = Lim f \<and> m = f i)})"

definition brouwer_order :: "(brouwer \<times> brouwer) set"
  where "brouwer_order = brouwer_pred\<^sup>+"

lemma wf_brouwer_pred: "wf brouwer_pred"
  unfolding wf_def brouwer_pred_def
  apply clarify
  apply (induct_tac x)
    apply blast+
  done

lemma wf_brouwer_order[simp]: "wf brouwer_order"
  unfolding brouwer_order_def
  by (rule wf_trancl[OF wf_brouwer_pred])

lemma [simp]: "(f n, Lim f) \<in> brouwer_order"
  by (auto simp add: brouwer_order_def brouwer_pred_def)

text \<open>Example of a general function\<close>
function add2 :: "brouwer \<Rightarrow> brouwer \<Rightarrow> brouwer"
  where
    "add2 i Zero = i"
  | "add2 i (Succ j) = Succ (add2 i j)"
  | "add2 i (Lim f) = Lim (\<lambda>n. add2 i (f n))"
  by pat_completeness auto
termination
  by (relation "inv_image brouwer_order snd") auto

lemma add2_assoc: "add2 (add2 i j) k = add2 i (add2 j k)"
  by (induct k) auto

end


(*  Author:     Tobias Nipkow
    Copyright   1994 TU Muenchen
*)

section \<open>Quicksort with function package\<close>

theory Quicksort
imports "~~/src/HOL/Library/Multiset"
begin

context linorder
begin

fun quicksort :: "'a list \<Rightarrow> 'a list" where
  "quicksort []     = []"
| "quicksort (x#xs) = quicksort [y\<leftarrow>xs. \<not> x\<le>y] @ [x] @ quicksort [y\<leftarrow>xs. x\<le>y]"

lemma quicksort_permutes [simp]:
  "mset (quicksort xs) = mset xs"
  by (induct xs rule: quicksort.induct) (simp_all add: ac_simps)

lemma set_quicksort [simp]: "set (quicksort xs) = set xs"
proof -
  have "set_mset (mset (quicksort xs)) = set_mset (mset xs)"
    by simp
  then show ?thesis by (simp only: set_mset_mset)
qed

lemma sorted_quicksort: "sorted (quicksort xs)"
  by (induct xs rule: quicksort.induct) (auto simp add: sorted_Cons sorted_append not_le less_imp_le)

theorem sort_quicksort:
  "sort = quicksort"
  by (rule ext, rule properties_for_sort) (fact quicksort_permutes sorted_quicksort)+

end

end