theory Test_Code_Generation_Real_Approx
imports
  Environment_Executable
  "~~/src/HOL/Library/Code_Real_Approx_By_Float"
begin

type_synonym segment = "(real*real)*real*real"

text \<open>TODO: missing in \<open>Code_Real_Approx_By_Float\<close> or is there some deeper reason?
  Perhaps Florians recent (March/April 2017) changes to codegen?\<close>

lemmas
  real_less_eq_code[code del]
  real_less_code[code del]

text \<open>TODO: adapt \<open>Code_Real_Approx_By_Float\<close> and its @{const \<open>Realfract\<close>}
    to the "new" \<open>Code_Target_Int\<close> setup using @{typ integer}\<close>

definition Realfract :: "integer \<Rightarrow> integer \<Rightarrow> real"
  where "Realfract p q = real_of_integer p / real_of_integer q"

theorem univ_unfold_at_0:
  assumes "1 < m"
  shows "(\<forall>i::nat. Suc i < m \<longrightarrow> P i) \<longleftrightarrow> (P 0 \<and> (\<forall>i::nat. 1 \<le> i \<and> Suc i < m \<longrightarrow> P i))"
proof
  assume 0: "\<forall>i. Suc i < m \<longrightarrow> P i"
  with assms have c1: "P 0" by auto
  with assms 0 have c2: "(\<forall>i::nat. 1 \<le> i \<and> Suc i < m \<longrightarrow> P i)" by auto
  with c1 show " P 0 \<and> (\<forall>i. 1 \<le> i \<and> Suc i < m \<longrightarrow> P i)" by auto
next
  show "P 0 \<and> (\<forall>i. 1 \<le> i \<and> Suc i < m \<longrightarrow> P i) \<Longrightarrow> \<forall>i. Suc i < m \<longrightarrow> P i" using assms
      by (metis One_nat_def le_add2 le_add_same_cancel2 le_eq_less_or_eq le_simps(3))
qed

lemma polychain_polychain2[code]:
  "polychain xs = polychain2 xs"
proof (induction xs rule:polychain2.induct)
  case 1
  then show ?case by auto
next
  case (2 x)
  then show ?case by auto
next
  case (3 x y zs)
  note case3 = this
  have "1 < length (x # y # zs)" by auto
  have "polychain (x # y # zs) = (snd ((x # y # zs) ! 0) = fst ((x # y # zs) ! Suc 0) \<and>
                                 (\<forall>i. 1 \<le> i \<and> Suc i < length (x # y # zs) \<longrightarrow> snd ((x # y # zs) ! i) = fst ((x # y # zs) ! Suc i)))"
    unfolding polychain_def univ_unfold_at_0[OF `1 < length (x # y # zs)`, where P="\<lambda>i. snd ((x # y # zs) ! i) = (fst ((x # y # zs) ! Suc i))"]
    by auto
  also have "... = (snd x = fst y \<and> polychain (y # zs))" unfolding polychain_def by auto
  finally have "polychain (x # y # zs) = (snd x = fst y \<and> polychain (y # zs))" by auto
  with case3 show ?case  by auto
qed

definition points_le :: "segment list" where
  "points_le = [((0,0), (1,0)), ((1,0), (2,0)), ((2,0), (3,0))]"

theorem pple: "polychain points_le" unfolding points_le_def by eval

theorem univ_unfold_at_0':
  assumes "0 < m"
  shows "(\<forall>i::nat. i < m \<longrightarrow> P i) \<longleftrightarrow> (P 0 \<and> (\<forall>i::nat. 1 \<le> i \<and> i < m \<longrightarrow> P i))"
proof
  assume 0: "\<forall>i<m. P i"
  with assms have "P 0" by auto
  from 0 have "(\<forall>i::nat. 1 \<le> i \<and> i < m \<longrightarrow> P i)" by auto
  with `P 0` show "P 0 \<and> (\<forall>i. 1 \<le> i \<and> i < m \<longrightarrow> P i)" by auto
next
  assume " P 0 \<and> (\<forall>i. 1 \<le> i \<and> i < m \<longrightarrow> P i)"
  with assms show "\<forall>i<m. P i"
    by (metis less_one not_less)
qed

fun monotone_polychain2 :: "((real \<times> real) \<times> real \<times> real) list \<Rightarrow> bool" where
  "monotone_polychain2 [] = True" |
  "monotone_polychain2 (x # xs) = (if fst (fst x) < fst (snd x) then monotone_polychain2 xs else False)"

lemma monotone_polychain2:
  "(\<forall>i<length xs. fst (fst (xs ! i)) < fst (snd (xs ! i))) = monotone_polychain2 xs"
proof (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  note case_cons = this
  have "0 < length (a # xs)" by auto
  have "(\<forall>i<length (a # xs). fst (fst ((a # xs) ! i)) < fst (snd ((a # xs) ! i))) =
    (fst (fst a) < fst (snd a) \<and> (\<forall>i < length xs. fst (fst (xs ! i)) < fst (snd (xs ! i))))"
    unfolding univ_unfold_at_0'[OF `0 < length (a #xs)`, where P="\<lambda>x. fst (fst ((a # xs) ! x)) < fst (snd ((a # xs) ! x))"]
    by auto
  with case_cons show ?case by auto
qed

lemma monotone_polychain_monotone_polychain2 [code]:
  "monotone_polychain xs = (polychain2 xs \<and> monotone_polychain2 xs)"
  unfolding monotone_polychain_def polychain_polychain2 monotone_polychain2 by auto

theorem mple: "monotone_polychain points_le" unfolding points_le_def by eval

global_interpretation llsb: lanelet_simple_boundary points_le
  defines left_rectangle_intersect = llsb.rectangle_intersect
  using points_le_def by (unfold_locales) (auto simp add:pple mple)

definition points_ri :: "segment list" where
  "points_ri = [((0,1), (1,1)), ((1,1), (2,1)), ((2,1), (3,1))]"

theorem ppri: "polychain points_ri" unfolding points_ri_def by eval
theorem mpri: "monotone_polychain points_ri" unfolding points_ri_def by eval

global_interpretation rlsb: lanelet_simple_boundary points_ri
  defines right_rectangle_intersect = rlsb.rectangle_intersect
  using points_ri_def by (unfold_locales) (auto simp add:ppri mpri)

theorem pathstart_boundary [code]:
  "pathstart_boundary [x] = fst x"
  "pathstart_boundary (x # y # zs) = fst x"
  unfolding pathstart_boundary_def points_path2_def by auto

theorem pathfinish_boundary [code]:
  "pathfinish_boundary [x] = snd x"
  "pathfinish_boundary (x # y # zs) = pathfinish_boundary (y # zs)"
  unfolding pathfinish_boundary_def points_path2_def by auto

theorem "pathfinish_boundary points_ri = (3,1)" by eval

value [code] "above_and_inside_polychains points_le (3,1)"

global_interpretation l: lanelet points_ri points_le
  defines right = l.direction_right and pida = l.point_in_drivable_area and
          vertices_inside = l.vertices_inside and
          intersect_left_boundary = l.intersect_left_boundary and
          intersect_right_boundary = l.intersect_right_boundary and
          intersect_boundaris = l.intersect_boundaries and
          lines_inside = l.lines_inside and rect_inside = l.rectangle_inside
  by (unfold_locales) (eval+)

value [code] "right"
value [code] "pida (1,0.5)"

term "rotation_matrix'"

term "rotate_rect"

definition rectangle_test :: "rectangle" where
  "rectangle_test \<equiv> \<lparr>Xcoord = 0.0, Ycoord = 0.0, Orient = 0.0, Length = 3.0, Width = 1.5\<rparr>"

ML \<open>
val get_vertices = @{code get_vertices}
val rectangle_test = @{code rectangle_test}
val vertices = get_vertices rectangle_test
\<close>

value [code] "rect_inside rectangle_test"
value [code] "right_rectangle_intersect rectangle_test"
value [code] "left_rectangle_intersect rectangle_test"

definition bound0 where "bound0 = points_le"
definition bound1 where "bound1 = points_ri"
definition bound2 :: "segment list" where
  "bound2 = [((0,2), (1,2)), ((1,2), (2,2)), ((2,2), (3,2))]"
definition bound3 :: "segment list" where
  "bound3 = [((0,3), (1,3)), ((1,3), (2,3)), ((2,3), (3,3))]"

definition boundaries where "boundaries = [bound0, bound1, bound2]"

theorem lb: "lane boundaries" unfolding lane_def by eval

end


(*  Title:   Measure_as_QuasiBorel_Measure.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection \<open> Measure as QBS Measure\<close>
theory Measure_as_QuasiBorel_Measure
  imports "Pair_QuasiBorel_Measure"

begin

lemma distr_id':
  assumes "sets N = sets M"
          "f \<in> N \<rightarrow>\<^sub>M N"
      and "\<And>x. x \<in> space N \<Longrightarrow> f x = x"
    shows "distr N M f = N"
proof(rule measure_eqI)
  fix A
  assume 0:"A \<in> sets (distr N M f)"
  then have 1:"A \<subseteq> space N"
    by (auto simp: assms(1) sets.sets_into_space)

  have 2:"A \<in> sets M"
    using 0 by simp
  have 3:"f \<in> N \<rightarrow>\<^sub>M M"
    using assms(2) by(simp add: measurable_cong_sets[OF _ assms(1)])
  have "f -` A \<inter> space N = A"
  proof -
    have "f -` A = A \<union> {x. x \<notin> space N \<and> f x \<in> A}"
    proof(standard;standard)
      fix x
      assume h:"x \<in> f -` A"
      consider "x \<in> A" | "x \<notin> A"
        by auto
      thus "x \<in> A \<union> {x. x \<notin> space N \<and> f x \<in> A}"
      proof cases
        case 1
        then show ?thesis
          by simp
      next
        case 2
        have "x \<notin> space N"
        proof(rule ccontr)
          assume "\<not> x \<notin> space N"
          then have "x \<in> space N"
            by simp
          hence "f x = x"
            by(simp add: assms(3))
          hence "f x \<notin> A"
            by(simp add: 2)
          thus False
            using h by simp
        qed
        thus ?thesis
          using h by simp
      qed
    next
      fix x
      show "x \<in> A \<union> {x. x \<notin> space N \<and> f x \<in> A} \<Longrightarrow> x \<in> f -` A"
        using 1 assms by auto
    qed
    thus ?thesis
      using "1" by blast
  qed
  thus "emeasure (distr N M f) A = emeasure N A"
    by(simp add: emeasure_distr[OF 3 2])
qed (simp add: assms(1))

text \<open> Every probability measure on a standard Borel space can be represented as a measure on
       a quasi-Borel space~\cite{Heunen_2017}, Proposition 23.\<close>
locale standard_borel_prob_space = standard_borel P + p:prob_space P
  for P :: "'a measure"
begin

sublocale qbs_prob "measure_to_qbs P" g "distr P real_borel f"
  by(auto intro!: qbs_probI p.prob_space_distr)

lift_definition as_qbs_measure :: "'a qbs_prob_space" is
"(measure_to_qbs P, g, distr P real_borel f)"
  by simp

lemma as_qbs_measure_retract:
  assumes [measurable]:"a \<in> P \<rightarrow>\<^sub>M real_borel"
      and [measurable]:"b \<in> real_borel \<rightarrow>\<^sub>M P"
      and [simp]:"\<And>x. x \<in> space P \<Longrightarrow> (b \<circ> a) x = x"
    shows "qbs_prob (measure_to_qbs P) b (distr P real_borel a)"
          "as_qbs_measure = qbs_prob_space (measure_to_qbs P, b, distr P real_borel a)"
proof -
  interpret pqp: pair_qbs_prob "measure_to_qbs P" g "distr P real_borel f" "measure_to_qbs P" b "distr P real_borel a"
    by(auto intro!: qbs_probI p.prob_space_distr simp: pair_qbs_prob_def)
  show "qbs_prob (measure_to_qbs P) b (distr P real_borel a)"
       "as_qbs_measure = qbs_prob_space (measure_to_qbs P, b, distr P real_borel a)"
    by(auto intro!: pqp.qbs_prob_space_eq
          simp: distr_distr distr_id'[OF standard_borel_lr_sets_ident[symmetric]] distr_id'[OF standard_borel_lr_sets_ident[symmetric] _ assms(3)] pqp.qp2.qbs_prob_axioms as_qbs_measure.abs_eq)
qed

lemma measure_as_qbs_measure_qbs:
 "qbs_prob_space_qbs as_qbs_measure = measure_to_qbs P"
  by transfer auto

lemma measure_as_qbs_measure_image:
 "as_qbs_measure \<in> monadP_qbs_Px (measure_to_qbs P)"
  by(auto simp: measure_as_qbs_measure_qbs monadP_qbs_Px_def)

lemma as_qbs_measure_as_measure[simp]:
 "distr (distr P real_borel f) (qbs_to_measure (measure_to_qbs P)) g = P"
  by(auto intro!: distr_id'[OF standard_borel_lr_sets_ident[symmetric]] simp : qbs_prob_t_measure_def distr_distr )

lemma measure_as_qbs_measure_recover:
 "qbs_prob_measure as_qbs_measure = P"
  by transfer (simp add: qbs_prob_t_measure_def)

end

lemma(in standard_borel) qbs_prob_measure_recover:
  assumes "q \<in> monadP_qbs_Px (measure_to_qbs M)"
  shows "standard_borel_prob_space.as_qbs_measure (qbs_prob_measure q) = q"
proof -
  obtain \<alpha> \<mu> where hq:
  "q = qbs_prob_space (measure_to_qbs M, \<alpha>, \<mu>)" "qbs_prob (measure_to_qbs M) \<alpha> \<mu>"
    using rep_monadP_qbs_Px[OF assms] by auto
  then interpret qp: qbs_prob "measure_to_qbs M" \<alpha> \<mu> by simp
  interpret sp: standard_borel_prob_space "distr \<mu> (qbs_to_measure (measure_to_qbs M)) \<alpha>"
    using qp.in_Mx
    by(auto intro!: prob_space.prob_space_distr
           simp: standard_borel_prob_space_def standard_borel_sets[OF sets_distr[of \<mu> "qbs_to_measure (measure_to_qbs M)" \<alpha>,simplified standard_borel_lr_sets_ident,symmetric]])
  interpret st: standard_borel "distr \<mu> M \<alpha>"
    by(auto intro!: standard_borel_sets)
  have [measurable]:"st.g \<in> real_borel \<rightarrow>\<^sub>M M"
    using measurable_distr_eq2 st.g_meas by blast
  show ?thesis
    by(auto intro!: pair_qbs_prob.qbs_prob_space_eq
          simp add: hq(1) sp.as_qbs_measure.abs_eq pair_qbs_prob_def qp.qbs_prob_axioms sp.qbs_prob_axioms)
     (simp_all add: measure_to_qbs_cong_sets[OF sets_distr[of \<mu> "qbs_to_measure (measure_to_qbs M)" \<alpha>,simplified standard_borel_lr_sets_ident]])
qed

lemma(in standard_borel_prob_space) ennintegral_as_qbs_ennintegral:
  assumes "k \<in> borel_measurable P"
  shows "(\<integral>\<^sup>+\<^sub>Q x. k x \<partial>as_qbs_measure) = (\<integral>\<^sup>+ x. k x \<partial>P)"
proof -
  have 1:"k \<in> measure_to_qbs P \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    using assms by auto
  thus ?thesis
    by(simp add: as_qbs_measure.abs_eq qbs_prob_ennintegral_def2[OF 1])
qed

lemma(in standard_borel_prob_space) integral_as_qbs_integral:
 "(\<integral>\<^sub>Q x. k x \<partial>as_qbs_measure) = (\<integral> x. k x \<partial>P)"
  by(simp add: as_qbs_measure.abs_eq qbs_prob_integral_def2)

lemma(in standard_borel) measure_with_args_morphism:
  assumes [measurable]:"\<mu> \<in> X \<rightarrow>\<^sub>M prob_algebra M"
  shows "standard_borel_prob_space.as_qbs_measure \<circ> \<mu> \<in> measure_to_qbs X \<rightarrow>\<^sub>Q monadP_qbs (measure_to_qbs M)"
proof(auto intro!: qbs_morphismI)
  fix \<alpha>
  assume h[measurable]:"\<alpha> \<in> real_borel \<rightarrow>\<^sub>M X"
  have "\<forall>r. (standard_borel_prob_space.as_qbs_measure \<circ> \<mu> \<circ> \<alpha>) r = qbs_prob_space (measure_to_qbs M, g, ((\<lambda>l. distr (\<mu> l) real_borel f) \<circ> \<alpha>) r)"
  proof auto
    fix r
    interpret sp: standard_borel_prob_space "\<mu> (\<alpha> r)"
      using measurable_space[OF assms measurable_space[OF h]]
      by(simp add: standard_borel_prob_space_def space_prob_algebra)
    have 1[measurable_cong]: "sets (\<mu> (\<alpha> r)) = sets M"
      using measurable_space[OF assms measurable_space[OF h]] by(simp add: space_prob_algebra)
    have 2:"f \<in> \<mu> (\<alpha> r) \<rightarrow>\<^sub>M real_borel" "g \<in> real_borel \<rightarrow>\<^sub>M \<mu> (\<alpha> r)" "\<And>x. x \<in> space (\<mu> (\<alpha> r)) \<Longrightarrow> (g \<circ> f) x = x"
      using measurable_space[OF assms measurable_space[OF h]]
      by(simp_all add: standard_borel_prob_space_def sets_eq_imp_space_eq[OF 1])
    show "standard_borel_prob_space.as_qbs_measure (\<mu> (\<alpha> r)) = qbs_prob_space (measure_to_qbs M, g, distr (\<mu> (\<alpha> r)) real_borel f)"
      by(simp add: sp.as_qbs_measure_retract[OF 2] measure_to_qbs_cong_sets[OF  subprob_measurableD(2)[OF measurable_prob_algebraD[OF assms] measurable_space[OF h]]])
  qed
  thus "standard_borel_prob_space.as_qbs_measure \<circ> \<mu> \<circ> \<alpha> \<in> monadP_qbs_MPx (measure_to_qbs M)"
    by(auto intro!: bexI[where x=g] bexI[where x="(\<lambda>l. distr (\<mu> l) real_borel f) \<circ> \<alpha>"] simp: monadP_qbs_MPx_def in_MPx_def)
qed

lemma(in standard_borel) measure_with_args_recover:
  assumes "\<mu> \<in> space X \<rightarrow> space (prob_algebra M)"
      and "x \<in> space X"
    shows "qbs_prob_measure (standard_borel_prob_space.as_qbs_measure (\<mu> x)) = \<mu> x"
    using standard_borel_sets[of "\<mu> x"] funcset_mem[OF assms]
    by(simp add: standard_borel_prob_space_def space_prob_algebra standard_borel_prob_space.measure_as_qbs_measure_recover)

subsection \<open>Example of Probability Measures\<close>
text \<open>Probability measures on $\mathbb{R}$ can be represented as probability measures on the quasi-Borel space $\mathbb{R}$.\<close>
subsubsection \<open> Normal Distribution \<close>
definition normal_distribution :: "real \<times> real \<Rightarrow> real measure" where
"normal_distribution \<mu>\<sigma> = (if 0 < (snd \<mu>\<sigma>) then density lborel (\<lambda>x. ennreal (normal_density (fst \<mu>\<sigma>) (snd \<mu>\<sigma>) x))
                                      else return lborel 0)"

lemma normal_distribution_measurable:
 "normal_distribution \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G=borel])
  fix A :: "real set"
  assume h:"A \<in> sets borel"
  have "(\<lambda>x. emeasure (normal_distribution x) A) = (\<lambda>x. if 0 < (snd x) then emeasure (density lborel (\<lambda>r. ennreal (normal_density (fst x) (snd x) r))) A
                                                                                else emeasure (return lborel 0) A)"
    by(auto simp add: normal_distribution_def)
  also have "... \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)"
  proof(rule measurable_If)
    have [simp]:"(\<lambda>x. indicat_real A (snd x)) \<in> borel_measurable ((borel \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M borel)"
    proof -
      have "(\<lambda>x. indicat_real A (snd x)) = indicat_real A \<circ> snd"
        by auto
      also have "... \<in> borel_measurable ((borel \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M borel)"
        by (meson borel_measurable_indicator h measurable_comp measurable_snd)
      finally show ?thesis .
    qed
    have "(\<lambda>x. emeasure (density lborel (\<lambda>r. ennreal (normal_density (fst x) (snd x) r))) A) = (\<lambda>x. set_nn_integral lborel A (\<lambda>r. ennreal (normal_density (fst x) (snd x) r)))"
      using h by(auto intro!: emeasure_density)
    also have "... = (\<lambda>x. \<integral>\<^sup>+r. ennreal (normal_density (fst x) (snd x) r * indicat_real A r)\<partial>lborel)"
      by(simp add: nn_integral_set_ennreal)
    also have "... \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)"
      apply(auto intro!: lborel.borel_measurable_nn_integral
                   simp: split_beta' measurable_cong_sets[OF sets_pair_measure_cong[OF refl sets_lborel]] )
      unfolding normal_density_def
      by(rule borel_measurable_times) simp_all
    finally show "(\<lambda>x. emeasure (density lborel (\<lambda>r. ennreal (normal_density (fst x) (snd x) r))) A) \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)" .
  qed simp_all
  finally show "(\<lambda>x. emeasure (normal_distribution x) A) \<in> borel_measurable (borel \<Otimes>\<^sub>M borel)" .
qed (auto simp add: sets.sigma_sets_eq[of borel,simplified] sets.Int_stable prob_space_normal_density normal_distribution_def prob_space_return)

definition qbs_normal_distribution :: "real \<Rightarrow> real \<Rightarrow> real qbs_prob_space" where
"qbs_normal_distribution \<equiv> curry (standard_borel_prob_space.as_qbs_measure \<circ> normal_distribution)"

lemma qbs_normal_distribution_morphism:
 "qbs_normal_distribution \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<real>\<^sub>Q (monadP_qbs \<real>\<^sub>Q)"
  unfolding qbs_normal_distribution_def
  by(rule curry_preserves_morphisms[OF real.measure_with_args_morphism[OF normal_distribution_measurable,simplified r_preserves_product]])

context
  fixes \<mu> \<sigma> :: real
  assumes sigma:"\<sigma> > 0"
begin

interpretation n_dist:standard_borel_prob_space "normal_distribution (\<mu>,\<sigma>)"
  by(simp add: standard_borel_prob_space_def sigma prob_space_normal_density normal_distribution_def)

lemma qbs_normal_distribution_def2:
 "qbs_normal_distribution \<mu> \<sigma> = n_dist.as_qbs_measure"
  by(simp add: qbs_normal_distribution_def)

lemma qbs_normal_distribution_integral:
 "(\<integral>\<^sub>Q x. f x \<partial> (qbs_normal_distribution \<mu> \<sigma>)) = (\<integral> x. f x \<partial> (density lborel (\<lambda>x. ennreal (normal_density \<mu> \<sigma> x))))"
  by(simp add: qbs_normal_distribution_def2 n_dist.integral_as_qbs_integral)
    (simp add: normal_distribution_def sigma)

lemma qbs_normal_distribution_expectation:
  assumes "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
    shows "(\<integral>\<^sub>Q x. f x \<partial> (qbs_normal_distribution \<mu> \<sigma>)) = (\<integral> x. normal_density \<mu> \<sigma> x * f x \<partial> lborel)"
  by(simp add: qbs_normal_distribution_integral assms integral_real_density integral_density)

end

subsubsection \<open> Uniform Distribution \<close>
definition interval_uniform_distribution :: "real \<Rightarrow> real \<Rightarrow> real measure" where
"interval_uniform_distribution a b \<equiv> (if a < b then uniform_measure lborel {a<..<b}
                                               else return lborel 0)"

lemma sets_interval_uniform_distribution[measurable_cong]:
 "sets (interval_uniform_distribution a b) = borel"
  by(simp add: interval_uniform_distribution_def)

lemma interval_uniform_distribution_meaurable:
 "(\<lambda>r. interval_uniform_distribution (fst r) (snd r)) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M prob_algebra real_borel"
proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G="range (\<lambda>(a, b). {a<..<b})"])
  show "sets real_borel = sigma_sets UNIV (range (\<lambda>(a, b). {a<..<b}))"
    by(simp add: borel_eq_box)
next
  show "Int_stable (range (\<lambda>(a, b). {a<..<b::real}))"
    by(fastforce intro!: Int_stableI simp: split_beta' image_iff)
next
  show "range (\<lambda>(a, b). {a<..<b}) \<subseteq> Pow UNIV"
    by simp
next
  fix a
  show "prob_space (interval_uniform_distribution (fst a) (snd a))"
    by(simp add: interval_uniform_distribution_def prob_space_return prob_space_uniform_measure)
next
  fix a
  show " sets (interval_uniform_distribution (fst a) (snd a)) = sets real_borel"
    by(simp add: interval_uniform_distribution_def)
next
  fix A
  assume "A \<in> range (\<lambda>(a, b). {a<..<b::real})"
  then obtain a b where ha:"A = {a<..<b}" by auto
  consider  "b \<le> a" | "a < b" by fastforce
  then show "(\<lambda>x. emeasure (interval_uniform_distribution (fst x) (snd x)) A) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M ennreal_borel"
             (is "?f \<in> ?meas")
  proof cases
    case 1
    then show ?thesis
      by(simp add: ha)
  next
    case h2:2
    have "?f = (\<lambda>x. if fst x < snd x then ennreal (min (snd x) b - max (fst x) a) / ennreal (snd x - fst x) else indicator A 0)"
    proof(standard; auto simp: interval_uniform_distribution_def ha)
      fix x y :: real
      assume hxy:"x < y"
      consider "b \<le> x" | "a \<le> x \<and> x < b" | "x < a \<and> a < y" | "y \<le> a"
        using h2 by fastforce
      thus "emeasure lborel ({max x a<..<min y b}) / ennreal (y - x) = ennreal (min y b - max x a) / ennreal (y - x)"
        by cases (use hxy ennreal_neg h2 in auto)
    qed
    also have "... \<in> ?meas"
      by simp
    finally show ?thesis .
  qed
qed

definition qbs_interval_uniform_distribution :: "real \<Rightarrow> real \<Rightarrow> real qbs_prob_space" where
"qbs_interval_uniform_distribution \<equiv> curry (standard_borel_prob_space.as_qbs_measure \<circ> (\<lambda>r. interval_uniform_distribution (fst r) (snd r)))"

lemma qbs_interval_uniform_distribution_morphism:
 "qbs_interval_uniform_distribution \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<real>\<^sub>Q (monadP_qbs \<real>\<^sub>Q)"
  unfolding qbs_interval_uniform_distribution_def
  using curry_preserves_morphisms[OF real.measure_with_args_morphism[OF interval_uniform_distribution_meaurable,simplified r_preserves_product]] .

context
  fixes a b :: real
  assumes a_less_than_b:"a < b"
begin

definition "ab_qbs_uniform_distribution \<equiv> qbs_interval_uniform_distribution a b"

interpretation ab_u_dist: standard_borel_prob_space "interval_uniform_distribution a b"
  by(auto intro!: prob_space_uniform_measure simp: interval_uniform_distribution_def standard_borel_prob_space_def prob_space_return)

lemma qbs_interval_uniform_distribution_def2:
 "ab_qbs_uniform_distribution = ab_u_dist.as_qbs_measure"
  by(simp add: qbs_interval_uniform_distribution_def ab_qbs_uniform_distribution_def)

lemma qbs_uniform_distribution_expectation:
  assumes "f \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  shows "(\<integral>\<^sup>+\<^sub>Q x. f x \<partial>ab_qbs_uniform_distribution) = (\<integral>\<^sup>+x \<in> {a<..<b}. f x \<partial>lborel) / (b - a)"
        (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<integral>\<^sup>+x. f x \<partial>(interval_uniform_distribution a b))"
    using assms by(auto simp: qbs_interval_uniform_distribution_def2 intro!:ab_u_dist.ennintegral_as_qbs_ennintegral dest:ab_u_dist.qbs_morphism_dest[simplified measure_to_qbs_cong_sets[OF sets_interval_uniform_distribution]])
  also have "... = ?rhs"
    using assms
    by(auto simp: interval_uniform_distribution_def a_less_than_b intro!:nn_integral_uniform_measure[where M=lborel and S="{a<..<b}",simplified emeasure_lborel_Ioo[OF order.strict_implies_order[OF a_less_than_b]]])
  finally show ?thesis .
qed

end

subsubsection \<open> Bernoulli Distribution \<close>
definition qbs_bernoulli :: "real \<Rightarrow> bool qbs_prob_space" where
"qbs_bernoulli \<equiv> standard_borel_prob_space.as_qbs_measure \<circ> (\<lambda>x. measure_pmf (bernoulli_pmf x))"

lemma bernoulli_measurable:
 "(\<lambda>x. measure_pmf (bernoulli_pmf x)) \<in> real_borel \<rightarrow>\<^sub>M prob_algebra bool_borel"
proof(rule measurable_prob_algebra_generated[where \<Omega>=UNIV and G=UNIV],simp_all)
  fix A :: "bool set"
  have "A \<subseteq> {True,False}"
    by auto
  then consider "A = {}" | "A = {True}" | "A = {False}" | "A = {False,True}"
    by auto
  thus "(\<lambda>a. emeasure (measure_pmf (bernoulli_pmf a)) A) \<in> borel_measurable borel"
    by(cases,simp_all add: emeasure_measure_pmf_finite bernoulli_pmf.rep_eq UNIV_bool[symmetric])
qed (auto simp add: sets_borel_eq_count_space Int_stable_def measure_pmf.prob_space_axioms)

lemma qbs_bernoulli_morphism:
 "qbs_bernoulli \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q monadP_qbs \<bool>\<^sub>Q"
  using bool.measure_with_args_morphism[OF bernoulli_measurable]
  by (simp add: qbs_bernoulli_def)

lemma qbs_bernoulli_measure:
 "qbs_prob_measure (qbs_bernoulli p) = measure_pmf (bernoulli_pmf p)"
  using bool.measure_with_args_recover[of "\<lambda>x. measure_pmf (bernoulli_pmf x)" real_borel p] bernoulli_measurable
  by(simp add: measurable_def qbs_bernoulli_def)

context
  fixes p :: real
  assumes pgeq_0[simp]:"0 \<le> p" and pleq_1[simp]:"p \<le> 1"
begin

lemma qbs_bernoulli_expectation:
  "(\<integral>\<^sub>Q x. f x \<partial>qbs_bernoulli p) = f True * p + f False * (1 - p)"
  by(simp add: qbs_prob_integral_def2 qbs_bernoulli_measure)

end

end


chapter \<open>Rosser Formulas\<close>

text \<open>The Rosser formula is a modification of the Gödel formula that
is undecidable assuming consistency only (not $\omega$-consistency).\<close>

(*<*)
theory Rosser_Formula
  imports Diagonalization Goedel_Formula
begin
(*>*)

locale Rosser_Form =
Deduct2_with_PseudoOrder
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  prv bprv
  Lq
  +
Repr_Neg
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  num
  prv bprv
  enc
  N
  +
Repr_SelfSubst
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  S
  +
HBL1
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  P
  for
    var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
    and Var FvarsT substT Fvars subst
    and num
    and eql cnj imp all exi
    and fls
    and prv bprv
    and Lq
    and dsj
    and enc ("\<langle>_\<rangle>")
    and N S P

locale Rosser_Form_Proofs =
Deduct2_with_PseudoOrder
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  dsj
  num
  prv bprv
  Lq
  +
Repr_Neg
  var trm fmla Var FvarsT substT Fvars subst
  eql cnj imp all exi
  fls
  num
  prv bprv
  enc
  N
  +
Repr_SelfSubst
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  S
  +
CleanRepr_Proofs
  var trm fmla Var FvarsT substT Fvars subst
  num
  eql cnj imp all exi
  prv bprv
  enc
  fls
  dsj
  "proof" prfOf
  encPf
  Pf
  for
    var :: "'var set" and trm :: "'trm set" and fmla :: "'fmla set"
    and Var FvarsT substT Fvars subst
    and num
    and eql cnj imp all exi
    and fls
    and prv bprv
    and Lq
    and dsj and "proof" :: "'proof set" and prfOf
    and enc ("\<langle>_\<rangle>")
    and N
    and S
    and encPf Pf

context Rosser_Form_Proofs
begin

definition R where "R = all zz (imp (LLq (Var zz) (Var yy))
                                     (all xx' (imp (NN (Var xx) (Var xx'))
                                                   (neg (PPf (Var zz) (Var xx'))))))"

definition RR where "RR t1 t2 = psubst R [(t1,yy), (t2,xx)]"

lemma R[simp,intro!]: "R \<in> fmla" unfolding R_def by auto

lemma RR_def2:
  "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> xx \<notin> FvarsT t1 \<Longrightarrow> RR t1 t2 = subst (subst R t1 yy) t2 xx"
  unfolding RR_def by (rule psubst_eq_rawpsubst2[simplified]) auto

definition P' where "P' = exi yy (cnj (PPf (Var yy) (Var xx)) (RR (Var yy) (Var xx)))"

definition PP' where "PP' t = subst P' t xx"

lemma Fvars_R[simp]: "Fvars R = {xx,yy}" unfolding R_def by auto

lemma P'[simp,intro!]: "P' \<in> fmla" unfolding P'_def by (auto simp: PPf_def2 RR_def2)

lemma Fvars_P'[simp]: "Fvars P' = {xx}" unfolding P'_def by (auto simp: PPf_def2 RR_def2)

lemma PP'[simp,intro!]: "t \<in> trm \<Longrightarrow> PP' t \<in> fmla"
  unfolding PP'_def by auto

lemma RR[simp,intro]: "t1 \<in> trm \<Longrightarrow> t2 \<in> trm \<Longrightarrow> RR t1 t2 \<in> fmla"
  by (auto simp: RR_def)

lemma RR_simps[simp]:
   "n \<in> num \<Longrightarrow> subst (RR (Var yy) (Var xx)) n xx = RR (Var yy) n"
   "m \<in> num \<Longrightarrow> n \<in> num \<Longrightarrow> subst (RR (Var yy) m) n yy = RR n m"
  by (simp add: RR_def2 subst2_fresh_switch)+

text \<open>The Rosser modification of the Gödel formula\<close>
definition \<phi>R :: 'fmla where "\<phi>R \<equiv> diag (neg P')"

lemma \<phi>R[simp,intro!]: "\<phi>R \<in> fmla" and Fvars_\<phi>R[simp]: "Fvars \<phi>R = {}"
  unfolding \<phi>R_def wrepr.PP_def by auto

lemma bprv_\<phi>R_eqv:
  "bprv (eqv \<phi>R (neg (PP' \<langle>\<phi>R\<rangle>)))"
  unfolding \<phi>R_def PP'_def using bprv_diag_eqv[of "neg P'"] by simp

lemma bprv_imp_\<phi>R:
  "bprv (imp (neg (PP' \<langle>\<phi>R\<rangle>)) \<phi>R)"
  by (rule B.prv_imp_eqvER) (auto intro: bprv_\<phi>R_eqv)

lemma prv_\<phi>R_eqv:
  "prv (eqv \<phi>R (neg (PP' \<langle>\<phi>R\<rangle>)))"
  using dwf_dwfd.d_dwf.bprv_prv'[OF _ bprv_\<phi>R_eqv, simplified] .

lemma prv_imp_\<phi>R:
  "prv (imp (neg (PP' \<langle>\<phi>R\<rangle>)) \<phi>R)"
  by (rule prv_imp_eqvER) (auto intro: prv_\<phi>R_eqv)

end \<comment> \<open>context @{locale Rosser_Form}\<close>

sublocale Rosser_Form_Proofs < Rosser_Form where P = P
  by standard

sublocale Rosser_Form_Proofs < Goedel_Form where P = P
  by standard

(*<*)
end
(*>*)


(*  Title:      Sequents/LK0.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

There may be printing problems if a seqent is in expanded normal form
(eta-expanded, beta-contracted).
*)

section {* Classical First-Order Sequent Calculus *}

theory LK0
imports Sequents
begin

class "term"
default_sort "term"

consts

  Trueprop       :: "two_seqi"

  True         :: o
  False        :: o
  equal        :: "['a,'a] => o"     (infixl "=" 50)
  Not          :: "o => o"           ("~ _" [40] 40)
  conj         :: "[o,o] => o"       (infixr "&" 35)
  disj         :: "[o,o] => o"       (infixr "|" 30)
  imp          :: "[o,o] => o"       (infixr "-->" 25)
  iff          :: "[o,o] => o"       (infixr "<->" 25)
  The          :: "('a => o) => 'a"  (binder "THE " 10)
  All          :: "('a => o) => o"   (binder "ALL " 10)
  Ex           :: "('a => o) => o"   (binder "EX " 10)

syntax
 "_Trueprop"    :: "two_seqe" ("((_)/ |- (_))" [6,6] 5)

parse_translation {* [(@{syntax_const "_Trueprop"}, K (two_seq_tr @{const_syntax Trueprop}))] *}
print_translation {* [(@{const_syntax Trueprop}, K (two_seq_tr' @{syntax_const "_Trueprop"}))] *}

abbreviation
  not_equal  (infixl "~=" 50) where
  "x ~= y == ~ (x = y)"

notation (xsymbols)
  Not  ("\<not> _" [40] 40) and
  conj  (infixr "\<and>" 35) and
  disj  (infixr "\<or>" 30) and
  imp  (infixr "\<longrightarrow>" 25) and
  iff  (infixr "\<longleftrightarrow>" 25) and
  All  (binder "\<forall>" 10) and
  Ex  (binder "\<exists>" 10) and
  not_equal  (infixl "\<noteq>" 50)

notation (HTML output)
  Not  ("\<not> _" [40] 40) and
  conj  (infixr "\<and>" 35) and
  disj  (infixr "\<or>" 30) and
  All  (binder "\<forall>" 10) and
  Ex  (binder "\<exists>" 10) and
  not_equal  (infixl "\<noteq>" 50)

axiomatization where

  (*Structural rules: contraction, thinning, exchange [Soren Heilmann] *)

  contRS: "$H |- $E, $S, $S, $F ==> $H |- $E, $S, $F" and
  contLS: "$H, $S, $S, $G |- $E ==> $H, $S, $G |- $E" and

  thinRS: "$H |- $E, $F ==> $H |- $E, $S, $F" and
  thinLS: "$H, $G |- $E ==> $H, $S, $G |- $E" and

  exchRS: "$H |- $E, $R, $S, $F ==> $H |- $E, $S, $R, $F" and
  exchLS: "$H, $R, $S, $G |- $E ==> $H, $S, $R, $G |- $E" and

  cut:   "[| $H |- $E, P;  $H, P |- $E |] ==> $H |- $E" and

  (*Propositional rules*)

  basic: "$H, P, $G |- $E, P, $F" and

  conjR: "[| $H|- $E, P, $F;  $H|- $E, Q, $F |] ==> $H|- $E, P&Q, $F" and
  conjL: "$H, P, Q, $G |- $E ==> $H, P & Q, $G |- $E" and

  disjR: "$H |- $E, P, Q, $F ==> $H |- $E, P|Q, $F" and
  disjL: "[| $H, P, $G |- $E;  $H, Q, $G |- $E |] ==> $H, P|Q, $G |- $E" and

  impR:  "$H, P |- $E, Q, $F ==> $H |- $E, P-->Q, $F" and
  impL:  "[| $H,$G |- $E,P;  $H, Q, $G |- $E |] ==> $H, P-->Q, $G |- $E" and

  notR:  "$H, P |- $E, $F ==> $H |- $E, ~P, $F" and
  notL:  "$H, $G |- $E, P ==> $H, ~P, $G |- $E" and

  FalseL: "$H, False, $G |- $E" and

  True_def: "True == False-->False" and
  iff_def:  "P<->Q == (P-->Q) & (Q-->P)"

axiomatization where
  (*Quantifiers*)

  allR:  "(!!x.$H |- $E, P(x), $F) ==> $H |- $E, ALL x. P(x), $F" and
  allL:  "$H, P(x), $G, ALL x. P(x) |- $E ==> $H, ALL x. P(x), $G |- $E" and

  exR:   "$H |- $E, P(x), $F, EX x. P(x) ==> $H |- $E, EX x. P(x), $F" and
  exL:   "(!!x.$H, P(x), $G |- $E) ==> $H, EX x. P(x), $G |- $E" and

  (*Equality*)
  refl:  "$H |- $E, a=a, $F" and
  subst: "\<And>G H E. $H(a), $G(a) |- $E(a) ==> $H(b), a=b, $G(b) |- $E(b)"

  (* Reflection *)

axiomatization where
  eq_reflection:  "|- x=y ==> (x==y)" and
  iff_reflection: "|- P<->Q ==> (P==Q)"

  (*Descriptions*)

axiomatization where
  The: "[| $H |- $E, P(a), $F;  !!x.$H, P(x) |- $E, x=a, $F |] ==>
          $H |- $E, P(THE x. P(x)), $F"

definition If :: "[o, 'a, 'a] => 'a" ("(if (_)/ then (_)/ else (_))" 10)
  where "If(P,x,y) == THE z::'a. (P --> z=x) & (~P --> z=y)"

(** Structural Rules on formulas **)

(*contraction*)

lemma contR: "$H |- $E, P, P, $F ==> $H |- $E, P, $F"
  by (rule contRS)

lemma contL: "$H, P, P, $G |- $E ==> $H, P, $G |- $E"
  by (rule contLS)

(*thinning*)

lemma thinR: "$H |- $E, $F ==> $H |- $E, P, $F"
  by (rule thinRS)

lemma thinL: "$H, $G |- $E ==> $H, P, $G |- $E"
  by (rule thinLS)

(*exchange*)

lemma exchR: "$H |- $E, Q, P, $F ==> $H |- $E, P, Q, $F"
  by (rule exchRS)

lemma exchL: "$H, Q, P, $G |- $E ==> $H, P, Q, $G |- $E"
  by (rule exchLS)

ML {*
(*Cut and thin, replacing the right-side formula*)
fun cutR_tac ctxt s i =
  res_inst_tac ctxt [(("P", 0), s) ] @{thm cut} i  THEN  rtac @{thm thinR} i

(*Cut and thin, replacing the left-side formula*)
fun cutL_tac ctxt s i =
  res_inst_tac ctxt [(("P", 0), s)] @{thm cut} i  THEN  rtac @{thm thinL} (i+1)
*}

(** If-and-only-if rules **)
lemma iffR:
    "[| $H,P |- $E,Q,$F;  $H,Q |- $E,P,$F |] ==> $H |- $E, P <-> Q, $F"
  apply (unfold iff_def)
  apply (assumption | rule conjR impR)+
  done

lemma iffL:
    "[| $H,$G |- $E,P,Q;  $H,Q,P,$G |- $E |] ==> $H, P <-> Q, $G |- $E"
  apply (unfold iff_def)
  apply (assumption | rule conjL impL basic)+
  done

lemma iff_refl: "$H |- $E, (P <-> P), $F"
  apply (rule iffR basic)+
  done

lemma TrueR: "$H |- $E, True, $F"
  apply (unfold True_def)
  apply (rule impR)
  apply (rule basic)
  done

(*Descriptions*)
lemma the_equality:
  assumes p1: "$H |- $E, P(a), $F"
    and p2: "!!x. $H, P(x) |- $E, x=a, $F"
  shows "$H |- $E, (THE x. P(x)) = a, $F"
  apply (rule cut)
   apply (rule_tac [2] p2)
  apply (rule The, rule thinR, rule exchRS, rule p1)
  apply (rule thinR, rule exchRS, rule p2)
  done

(** Weakened quantifier rules.  Incomplete, they let the search terminate.**)

lemma allL_thin: "$H, P(x), $G |- $E ==> $H, ALL x. P(x), $G |- $E"
  apply (rule allL)
  apply (erule thinL)
  done

lemma exR_thin: "$H |- $E, P(x), $F ==> $H |- $E, EX x. P(x), $F"
  apply (rule exR)
  apply (erule thinR)
  done

(*The rules of LK*)

lemmas [safe] =
  iffR iffL
  notR notL
  impR impL
  disjR disjL
  conjR conjL
  FalseL TrueR
  refl basic
ML {* val prop_pack = Cla.get_pack @{context} *}

lemmas [safe] = exL allR
lemmas [unsafe] = the_equality exR_thin allL_thin
ML {* val LK_pack = Cla.get_pack @{context} *}

ML {*
  val LK_dup_pack =
    Cla.put_pack prop_pack @{context}
    |> fold_rev Cla.add_safe @{thms allR exL}
    |> fold_rev Cla.add_unsafe @{thms allL exR the_equality}
    |> Cla.get_pack;
*}

method_setup fast_prop =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack prop_pack ctxt))) *}

method_setup fast_dup =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack LK_dup_pack ctxt))) *}

method_setup best_dup =
  {* Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.best_tac (Cla.put_pack LK_dup_pack ctxt))) *}

method_setup lem = {*
  Attrib.thm >> (fn th => fn _ =>
    SIMPLE_METHOD' (fn i =>
      rtac (@{thm thinR} RS @{thm cut}) i THEN
      REPEAT (rtac @{thm thinL} i) THEN
      rtac th i))
*}

lemma mp_R:
  assumes major: "$H |- $E, $F, P --> Q"
    and minor: "$H |- $E, $F, P"
  shows "$H |- $E, Q, $F"
  apply (rule thinRS [THEN cut], rule major)
  apply step
  apply (rule thinR, rule minor)
  done

lemma mp_L:
  assumes major: "$H, $G |- $E, P --> Q"
    and minor: "$H, $G, Q |- $E"
  shows "$H, P, $G |- $E"
  apply (rule thinL [THEN cut], rule major)
  apply step
  apply (rule thinL, rule minor)
  done

(** Two rules to generate left- and right- rules from implications **)

lemma R_of_imp:
  assumes major: "|- P --> Q"
    and minor: "$H |- $E, $F, P"
  shows "$H |- $E, Q, $F"
  apply (rule mp_R)
   apply (rule_tac [2] minor)
  apply (rule thinRS, rule major [THEN thinLS])
  done

lemma L_of_imp:
  assumes major: "|- P --> Q"
    and minor: "$H, $G, Q |- $E"
  shows "$H, P, $G |- $E"
  apply (rule mp_L)
   apply (rule_tac [2] minor)
  apply (rule thinRS, rule major [THEN thinLS])
  done

(*Can be used to create implications in a subgoal*)
lemma backwards_impR:
  assumes prem: "$H, $G |- $E, $F, P --> Q"
  shows "$H, P, $G |- $E, Q, $F"
  apply (rule mp_L)
   apply (rule_tac [2] basic)
  apply (rule thinR, rule prem)
  done

lemma conjunct1: "|-P&Q ==> |-P"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma conjunct2: "|-P&Q ==> |-Q"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma spec: "|- (ALL x. P(x)) ==> |- P(x)"
  apply (erule thinR [THEN cut])
  apply fast
  done

(** Equality **)

lemma sym: "|- a=b --> b=a"
  by (safe add!: subst)

lemma trans: "|- a=b --> b=c --> a=c"
  by (safe add!: subst)

(* Symmetry of equality in hypotheses *)
lemmas symL = sym [THEN L_of_imp]

(* Symmetry of equality in hypotheses *)
lemmas symR = sym [THEN R_of_imp]

lemma transR: "[| $H|- $E, $F, a=b;  $H|- $E, $F, b=c |] ==> $H|- $E, a=c, $F"
  by (rule trans [THEN R_of_imp, THEN mp_R])

(* Two theorms for rewriting only one instance of a definition:
   the first for definitions of formulae and the second for terms *)

lemma def_imp_iff: "(A == B) ==> |- A <-> B"
  apply unfold
  apply (rule iff_refl)
  done

lemma meta_eq_to_obj_eq: "(A == B) ==> |- A = B"
  apply unfold
  apply (rule refl)
  done

(** if-then-else rules **)

lemma if_True: "|- (if True then x else y) = x"
  unfolding If_def by fast

lemma if_False: "|- (if False then x else y) = y"
  unfolding If_def by fast

lemma if_P: "|- P ==> |- (if P then x else y) = x"
  apply (unfold If_def)
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma if_not_P: "|- ~P ==> |- (if P then x else y) = y"
  apply (unfold If_def)
  apply (erule thinR [THEN cut])
  apply fast
  done

end


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

header {* The \isa{wind} Method *}

theory
  xMethods_Window

imports
  xHOL_Syntax
  xMethods_Multi_Prover

begin

text {*

When reasoning calculationally it is useful to be able
to derive implications through manipulation of subterms.
This relies on the monotonicity properties of the various
constructors and enables a simple form of window inference.

*}

subsection {* Theory data support *}

text {*

Our approach to supporting windowing is to introduce a new
reasoning set containing all the introduction rules needed
to decompose relational goals.
We also find it useful to include some simplifier rules to
transform goals into simple logical terms. This can greatly
reduce the number of windowing rules needed, by removing the
need to reproduce all of the logic windowing rules in different
contexts. The obvious case is in normalising set membership goals.

*}

declare_mprover "wind"

(*  not safe

declaration {*

K (MProver.map_cs "wind" (fn cs => #2 (("wind", cs) maddSafter ("window into function arguments", MProver.farg_tac))))

*}

declaration {*

K (MProver.map_cs "wind" (fn cs => #2 (("wind", cs) maddSafter ("window into monotonic functions in the premises", (resolve_tac [@{thm monoD}] THEN' assume_tac)))))

*}

*)

subsection {* Some Boolean windowing rules *}

text {*

Initially, we populate the windowing reasoning set with the basic boolean
window inference rules. These rules describe the interactions between the
implication and logic equivalence relations and the basic boolean operators.

*}

declare conj_ac [msimp(wind)]

lemma [mintro!(wind)]: "(C \<turnstile> A \<Rightarrow> B) \<turnstile> A \<and> C \<Rightarrow> B \<and> C"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Rightarrow> B) \<turnstile> A \<and> C \<Rightarrow> C \<and> B"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Rightarrow> B) \<turnstile> C \<and> A \<Rightarrow> C \<and> B"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Rightarrow> B) \<turnstile> C \<and> A \<Rightarrow> B \<and> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> A \<Rightarrow> A \<and> B"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> A \<Rightarrow> B \<and> A"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> A \<and> B \<Rightarrow> A"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> B \<and> A \<Rightarrow> A"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Leftrightarrow> B) \<turnstile> A \<and> C \<Leftrightarrow> B \<and> C"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Leftrightarrow> B) \<turnstile> A \<and> C \<Leftrightarrow> C \<and> B"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Leftrightarrow> B) \<turnstile> C \<and> A \<Leftrightarrow> C \<and> B"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Leftrightarrow> B) \<turnstile> C \<and> A \<Leftrightarrow> B \<and> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> A \<and> B \<Leftrightarrow> A"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> B \<and> A \<Leftrightarrow> A"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> A \<Leftrightarrow> A \<and> B"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> B) \<turnstile> A \<Leftrightarrow> B \<and> A"
  by (auto)

declare disj_ac [msimp(wind)]

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A \<Rightarrow> B) \<turnstile> A \<or> C \<Rightarrow> B \<or> C"
  by (auto)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A \<Rightarrow> B) \<turnstile> A \<or> C \<Rightarrow> C \<or> B"
  by (auto)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A \<Rightarrow> B) \<turnstile> C \<or> A \<Rightarrow> C \<or> B"
  by (auto)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A \<Rightarrow> B) \<turnstile> C \<or> A \<Rightarrow> B \<or> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> C) \<turnstile> A \<or> C \<Rightarrow> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> C) \<turnstile> C \<or> A \<Rightarrow> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> C) \<turnstile> C \<Rightarrow> A \<or> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> C) \<turnstile> C \<Rightarrow> C \<or> A"
  by (auto)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A \<Leftrightarrow> B) \<turnstile> A \<or> C \<Leftrightarrow> B \<or> C"
  by (auto)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A \<Leftrightarrow> B) \<turnstile> A \<or> C \<Leftrightarrow> C \<or> B"
  by (auto)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A \<Leftrightarrow> B) \<turnstile> C \<or> A \<Leftrightarrow> C \<or> B"
  by (auto)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A \<Leftrightarrow> B) \<turnstile> C \<or> A \<Leftrightarrow> B \<or> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> C) \<turnstile> A \<or> C \<Leftrightarrow> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> C) \<turnstile> C \<or> A \<Leftrightarrow> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> C) \<turnstile> C \<Leftrightarrow> A \<or> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<turnstile> C) \<turnstile> C \<Leftrightarrow> C \<or> A"
  by (auto)

lemma [mintro!(wind)]: "A \<Rightarrow> B \<turnstile> \<not> B \<Rightarrow> \<not> A"
  by (auto)

lemma [mintro!(wind)]: "A \<Leftrightarrow> B \<turnstile> \<not> B \<Leftrightarrow> \<not> A"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Rightarrow> B) \<turnstile> (C \<Rightarrow> A) \<Rightarrow> (C \<Rightarrow> B)"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> \<not> A) \<turnstile> (C \<Rightarrow> A) \<Rightarrow> \<not> C"
  by (auto)

lemma [mintro!(wind)]: "\<not> C \<Rightarrow> (C \<Rightarrow> B)"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> A \<Leftrightarrow> B) \<turnstile> (C \<Rightarrow> A) \<Leftrightarrow> (C \<Rightarrow> B)"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> \<not>A) \<turnstile> (C \<Rightarrow> A) \<Leftrightarrow> \<not>C"
  by (auto)

lemma [mintro!(wind)]: "(C \<turnstile> \<not>B) \<turnstile> \<not>C \<Leftrightarrow> (C \<Rightarrow> B)"
  by (auto)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A \<Rightarrow> B) \<turnstile> (B \<Rightarrow> C) \<Rightarrow> (A \<Rightarrow> C)"
  by (blast)

lemma [mintro!(wind)]: "C \<Rightarrow> (A \<Rightarrow> C)"
  by (blast)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> B) \<turnstile> (B \<Rightarrow> C) \<Rightarrow> C"
  by (blast)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A \<Leftrightarrow> B) \<turnstile> (A \<Rightarrow> C) \<Leftrightarrow> (B \<Rightarrow> C)"
  by (auto)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> B) \<turnstile> C \<Leftrightarrow> (B \<Rightarrow> C)"
  by (auto)

lemma [mintro!(wind)]: "(\<not> C \<turnstile> A) \<turnstile> (A \<Rightarrow> C) \<Leftrightarrow> C"
  by (auto)

lemma [mintro!(wind)]: "(A \<Leftrightarrow> B) \<turnstile> (C \<Leftrightarrow> A) \<Rightarrow> (C \<Leftrightarrow> B)"
  by (auto)

lemma [mintro!(wind)]: "(A \<Leftrightarrow> B) \<turnstile> (C \<Leftrightarrow> A) \<Rightarrow> (B \<Leftrightarrow> C)"
  by (auto)

lemma [mintro!(wind)]: "(A \<Leftrightarrow> B) \<turnstile> (A \<Leftrightarrow> C) \<Rightarrow> (B \<Leftrightarrow> C)"
  by (auto)

lemma [mintro!(wind)]: "(A \<Leftrightarrow> B) \<turnstile> (A \<Leftrightarrow> C) \<Rightarrow> (C \<Leftrightarrow> B)"
  by (auto)

lemma [mintro!(wind)]: "A \<turnstile> (C \<Leftrightarrow> A) \<Rightarrow> C"
  by (blast)

lemma [mintro!(wind)]: "A \<turnstile> (A \<Leftrightarrow> C) \<Rightarrow> C"
  by (auto)

lemma [mintro!(wind)]: "B \<turnstile> C \<Rightarrow> (C \<Leftrightarrow> B)"
  by (auto)

lemma [mintro!(wind)]: "B \<turnstile> C \<Rightarrow> (B \<Leftrightarrow> C)"
  by (auto)

lemma [mintro!(wind)]: "(A \<Leftrightarrow> B) \<turnstile> (C \<Leftrightarrow> A) \<Leftrightarrow> (C \<Leftrightarrow> B)"
  by (auto)

lemma [mintro!(wind)]: "(A \<Leftrightarrow> B) \<turnstile> (C \<Leftrightarrow> A) \<Leftrightarrow> (B \<Leftrightarrow> C)"
  by (auto)

lemma [mintro!(wind)]: "(A \<Leftrightarrow> B) \<turnstile> (A \<Leftrightarrow> C) \<Leftrightarrow> (B \<Leftrightarrow> C)"
  by (auto)

lemma [mintro!(wind)]: "(A \<Leftrightarrow> B) \<turnstile> (A \<Leftrightarrow> C) \<Leftrightarrow> (C \<Leftrightarrow> B)"
  by (auto)

lemma [mintro!(wind)]: "A \<turnstile> (C \<Leftrightarrow> A) \<Leftrightarrow> C"
  by (auto)

lemma [mintro!(wind)]: "B \<turnstile> C \<Leftrightarrow> (B \<Leftrightarrow> C)"
  by (auto)

lemma [mintro!(wind)]: "A \<turnstile> (A \<Leftrightarrow> C) \<Leftrightarrow> C"
  by (auto)

lemma [mintro!(wind)]: "B \<turnstile> C \<Leftrightarrow> (C \<Leftrightarrow> B)"
  by (auto)

lemma [mintro!(wind)]: "(\<And> x \<bullet> A x \<Rightarrow> B x) \<turnstile> (\<forall> x \<bullet> A x) \<Rightarrow> (\<forall> x \<bullet> B x)"
  by (auto)

lemma [mintro!(wind)]: "(\<And> x \<bullet> A x \<Leftrightarrow> B x) \<turnstile> (\<forall> x \<bullet> A x) \<Leftrightarrow> (\<forall> x \<bullet> B x)"
  by (auto)

lemma [mintro!(wind)]: "(\<And> x \<bullet> A x \<Rightarrow> B x) \<turnstile> (\<exists> x \<bullet> A x) \<Rightarrow> (\<exists> x \<bullet> B x)"
  by (auto)

lemma [mintro!(wind)]: "(\<And> x \<bullet> A x \<Leftrightarrow> B x) \<turnstile> (\<exists> x \<bullet> A x) \<Leftrightarrow> (\<exists> x \<bullet> B x)"
  by (auto)

lemma [mintro!(wind)]: "(\<And> x \<bullet> A x \<Leftrightarrow> B x) \<turnstile> (\<exists>\<subone> x \<bullet> A x) \<Leftrightarrow> (\<exists>\<subone> x \<bullet> B x)"
  by (auto)

lemma [mintro!(wind)]: "y = z \<turnstile> x = y \<Leftrightarrow> x = z"
  by (auto)

lemma [mintro!(wind)]: "y = z \<turnstile> y = x \<Leftrightarrow> x = z"
  by (auto)

lemma [mintro!(wind)]: "y = z \<turnstile> x = y \<Leftrightarrow> z = x"
  by (auto)

lemma [mintro!(wind)]: "y = z \<turnstile> y = x \<Leftrightarrow> z = x"
  by (auto)

lemma [mintro!(wind)]: "(b \<turnstile> A = C) \<turnstile> \<if> b \<then> A \<else> B \<fi> = \<if> b \<then> C \<else> B \<fi>"
  by (auto)

lemma [mintro!(wind)]: "(\<not>b \<turnstile> B = C) \<turnstile> \<if> b \<then> A \<else> B \<fi> = \<if> b \<then> A \<else> C \<fi>"
  by (auto)

lemma [mintro!(wind)]: "(b = c) \<turnstile> \<if> b \<then> A \<else> B \<fi> = \<if> c \<then> A \<else> B \<fi>"
  by (auto)

lemma [mintro!(wind)]:
  fixes
    Pf :: "'a \<rightarrow> 'b \<rightarrow> \<bool> \<times> 'c" and
    Qg :: "'a \<rightarrow> 'b \<rightarrow> \<bool> \<times> 'c"
  assumes
    a1: "(\<And> x \<bullet> eind (Pf x) = eind (Qg x))"
  shows
    "eind (prod_case Pf) = eind (prod_case Qg)"
  apply (rule ext)
  apply (auto simp add: eind_def)
proof -
  fix
    a b
  assume
    b1: "fst (Pf a b)"
  show
    "(\<exists> a' b' \<bullet> snd (Pf a b) = snd (Qg a' b') \<and> fst (Qg a' b'))"
    apply (rule exI [of _ "a"])
    apply (subst a1 [of "a", simplified eind_def, THEN fun_cong, of "snd (Pf a b)", symmetric])
    apply (rule exI [of _ "b"])
    apply (simp add: b1)
    done
next
  fix
    a b
  assume
    b1: "fst (Qg a b)"
  show
    "(\<exists> a' b' \<bullet> snd (Qg a b) = snd (Pf a' b') \<and> fst (Pf a' b'))"
    apply (rule exI [of _ "a"])
    apply (subst a1 [of "a", simplified eind_def, THEN fun_cong, of "snd (Qg a b)"])
    apply (rule exI [of _ "b"])
    apply (simp add: b1)
    done
qed

lemma [mintro!(wind)]:
  "(Q \<turnstile> u = v) \<turnstile> eind (\<olambda> _ \<bullet> (Q, u)) = eind (\<olambda> _ \<bullet> (Q, v))"
  by (auto simp add: eind_def)

lemma [mintro!(wind)]:
  "(Q \<Leftrightarrow> P) \<turnstile> eind (\<olambda> _ \<bullet> (Q, u)) = eind (\<olambda> _ \<bullet> (P, u))"
  by (auto simp add: eind_def)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> Collect P = Collect Q"
  by (auto)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> Inf P = Inf Q"
  by (auto)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> Sup P = Sup Q"
  by (auto)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> Inter P = Inter Q"
  by (auto)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> Union P = Union Q"
  by (auto)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> The P = The Q"
  by (auto)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> Eps P = Eps Q"
  by (auto)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> Least P = Least Q"
  by (auto)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> Greatest P = Greatest Q"
  by (auto)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> Setsum P = Setsum Q"
  by (auto)

lemma [mintro!(wind)]: "(\<And> x \<bullet> x \<in> P \<turnstile> t x = u x) \<turnstile> setsum t P = setsum u P"
  by (auto)

lemma [mintro!(wind)]: "P = Q \<turnstile> setsum t P = setsum t Q"
  by (auto)

lemma [mintro!(wind)]: "(P = Q) \<turnstile> Setprod P = Setprod Q"
  by (auto)

lemma [mintro!(wind)]: "(\<And> x \<bullet> x \<in> P \<turnstile> t x = u x) \<turnstile> setprod t P = setprod u P"
  by (auto)

lemma [mintro!(wind)]: "P = Q \<turnstile> setprod t P = setprod t Q"
  by (auto)

end


theory ActivationLanguage

imports Complex_Main
begin

section {* A term in the language  *}

class term_predicate = boolean_algebra +
  fixes implies_pred :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  fixes tautology :: "'a \<Rightarrow> 'a"

instantiation bool :: term_predicate
begin
  definition
    "implies_pred a b = (a \<longrightarrow> b)"

  definition
    "tautology a = (a = True)"
instance proof
qed
end

datatype ('n, 'f) Mode =
  Nominal "'n option" |
  Failure 'f |
  NonDeterministic "('n, 'f) Mode" "('n, 'f) Mode"

typedef ('e::term_predicate, 'n, 'f) Expression =
  "UNIV::(('e \<times> (('n, 'f) Mode)) list set)" by simp

abbreviation Expression_to_predicate_list ::
  "('e::term_predicate, 'n, 'f) Expression \<Rightarrow> 'e list" where
  "Expression_to_predicate_list E \<equiv> map fst (Rep_Expression E)"

subsection {* Healthiness 1: no term is false *}

primrec Expression_healthiness_1_list ::
  "(('e::term_predicate) \<times> (('n, 'f) Mode)) list \<Rightarrow>
    ('e \<times> (('n, 'f) Mode)) list" where
  "Expression_healthiness_1_list [] = []" |
  "Expression_healthiness_1_list (t # ts) =
    (if fst t = bot
      then Expression_healthiness_1_list ts
      else t # Expression_healthiness_1_list ts)"

definition Expression_healthiness_1 ::
  "('e::term_predicate, 'n, 'f) Expression \<Rightarrow>
    ('e, 'n, 'f) Expression"  ("H\<^sub>1") where
    "Expression_healthiness_1 E =
      Abs_Expression (Expression_healthiness_1_list (Rep_Expression E))"

definition Expression_health_1 ::
  "('e::term_predicate, 'n, 'f) Expression \<Rightarrow> bool" where
  "Expression_health_1 E = (Expression_healthiness_1 (E) = E)"

subsection {* Healthiness 2: no term intersection (true at the same time) *}

definition Expression_healthiness_2_list_fixpred1 ::
  "'e::term_predicate \<Rightarrow> ('e \<times> (('n, 'f) Mode)) list \<Rightarrow> 'e" where
  "Expression_healthiness_2_list_fixpred1 p ts =
    fold (\<lambda>t exp. inf (fst t) (tautology (implies_pred (fst t) p)) ) ts bot"

definition Expression_healthiness_2_list_fixpred2 ::
  "nat \<Rightarrow> ('e::term_predicate \<times> (('n, 'f) Mode)) list \<Rightarrow> 'e" where
  "Expression_healthiness_2_list_fixpred2 i ts =
    (let p = (fst (ts!i)) in
    inf p
      (- Expression_healthiness_2_list_fixpred1 p
        ((take i ts) @ (drop (Suc i) ts))))"

primrec Expression_healthiness_2_list_fixpred3 ::
  "nat \<Rightarrow> ('e::term_predicate \<times> (('n, 'f) Mode)) list \<Rightarrow>
    ('e \<times> (('n, 'f) Mode)) list" where
  "Expression_healthiness_2_list_fixpred3 0 _ = []" |
  "Expression_healthiness_2_list_fixpred3 (Suc i) ts =
    (Expression_healthiness_2_list_fixpred3 i ts) @ [(Expression_healthiness_2_list_fixpred2 i ts, snd (ts!i))]"

definition Expression_healthiness_2_list_fixpred ::
  "('e::term_predicate \<times> (('n, 'f) Mode)) list \<Rightarrow>
    ('e \<times> (('n, 'f) Mode)) list" where
  "Expression_healthiness_2_list_fixpred ts = Expression_healthiness_2_list_fixpred3 (length ts) ts"

lemma "A \<noteq> B \<Longrightarrow> Expression_healthiness_2_list_fixpred
  [(A, Nominal (Some 1)),
  (B, Nominal (Some 2)),
  (A \<and> \<not> B, Nominal (Some 3)),
  (A \<or> B, Nominal (Some 4))] =
  [(A \<and> B, Nominal (Some 1)),
  (B, Nominal (Some 2)),
  (A \<and> \<not> B, Nominal (Some 3)),
  (False, Nominal (Some 4))]"
unfolding Expression_healthiness_2_list_fixpred_def
by (auto simp add: Expression_healthiness_2_list_fixpred2_def Expression_healthiness_2_list_fixpred1_def implies_pred_bool_def tautology_bool_def)

primrec Expression_healthiness_2_list_fixout ::
  "nat \<Rightarrow> (('e::term_predicate) \<times> (('n, 'f) Mode)) list \<Rightarrow>
    ('e \<times> (('n, 'f) Mode)) list" where
  "Expression_healthiness_2_list_fixout 0 l = l" |
  "Expression_healthiness_2_list_fixout (Suc n) l =
    Expression_healthiness_2_list_fixout n
      (Expression_healthiness_2_list_fixout_one (length l - n))"

primrec Expression_healthiness_2_list_fixout_one ::
  "('e::term_predicate) \<times> (('n, 'f) Mode) \<Rightarrow> ('e \<times> (('n, 'f) Mode)) list \<Rightarrow>
    ('e \<times> (('n, 'f) Mode)) list" where
  "Expression_healthiness_2_list_fixout_one _ [] = []" |
  "Expression_healthiness_2_list_fixout_one t1 (t2 # ts) =
    (if implies_bool (fst t2) (fst t1)
      then (fst t2, NonDeterministic (snd t2) (snd t1)) #
        Expression_healthiness_2_list_fixout_one t1 ts
      else t2 # Expression_healthiness_2_list_fixout_one t1 ts)"

definition Expression_healthiness_2 ::
  "('e::term_predicate, 'n, 'f) Expression \<Rightarrow>
    ('e, 'n, 'f) Expression"  ("H\<^sub>2") where
    "Expression_healthiness_2 E =
      Abs_Expression (Expression_healthiness_2_list (Rep_Expression E))"

definition Expression_health_2 ::
  "('e::term_predicate, 'n, 'f) Expression \<Rightarrow> bool" where
  "Expression_health_2 E = (Expression_healthiness_2 (E) = E)"

subsection {* Healthiness 3: tautology (disjunction of all terms forms a tautology) *}

primrec Expression_healthiness_3_list ::
  "('e::term_predicate) \<Rightarrow> ('e \<times> (('n, 'f) Mode)) list \<Rightarrow>
    ('e \<times> (('n, 'f) Mode)) list" where
  "Expression_healthiness_3_list ptaut [] =
    (if tautology ptaut then [] else [(- ptaut, Nominal None)])" |
  "Expression_healthiness_3_list ptaut (t # ts) =
    t # Expression_healthiness_3_list (sup (fst t) ptaut) ts"

definition Expression_healthiness_3 ::
  "('e::term_predicate, 'n, 'f) Expression \<Rightarrow>
    ('e::term_predicate, 'n, 'f) Expression"  ("H\<^sub>3") where
    "Expression_healthiness_3 E =
      Abs_Expression (
        Expression_healthiness_3_list bot (Rep_Expression E))"

definition Expression_health_3 ::
  "('e::term_predicate, 'n, 'f) Expression \<Rightarrow> bool" where
  "Expression_health_3 E = (Expression_healthiness_3 (E) = E)"

(* TODO: predicates over expressions (see old notebook) *)

(*** old definitions ***)

primrec h1_aux1 ::
  "('e::term_predicate \<times> ('n, 'f) Mode) \<Rightarrow> ('e \<times> ('n, 'f) Mode) list \<Rightarrow>
    ('e \<times> ('n, 'f) Mode) list" where
"h1_aux1 _ [] = []" |
"h1_aux1 t1 (t2 # E) =
  (if implies_bool (fst t2) (fst t1) then
    (if snd t1 = snd t2
      then h1_aux1 t1 E
      else (inf (fst t1) (- (fst t2)), snd t2) # h1_aux1 t1 E)
    else t2 # h1_aux1 t1 E
  )"

definition Expression_healthiness_1 ::
  "('e::term_predicate, 'n, 'f) Expression \<Rightarrow> bool" ("H\<^sub>1") where
  "Expression_healthiness_1 E =
    (\<forall> (p1,m1) \<in> set (Rep_Expression E).
    (\<forall> (p2,m2) \<in> set (Rep_Expression E).
      implies p1 p2 \<longrightarrow> m1 = m2 ))"

subsection {* Healthiness 2 *}

definition Expression_healthiness_2 ::
  "('e::term_predicate, 'n, 'f) Expression \<Rightarrow>
    ('e::term_predicate, 'n, 'f) Expression" ("H\<^sub>2") where
  "Expression_healthiness_2 E =
    (let missing =
      (not (fold or (Expression_to_predicate_list E) term_false), Nominal None)
      in Abs_Expression (missing # (Rep_Expression E)))"

subsection {* Healthiness condition *}

definition Expression_healthiness ("H") where
  "Expression_healthiness = H\<^sub>1 \<circ> H\<^sub>2"

(* ======= ANTIGO*)

text {* It's the main datatype for the theories.  *}
datatype ('a, 'b) IfValue =
  Value 'b
  | If 'a "('a, 'b) IfValue" "('a, 'b) IfValue"

text {* An IfValue as a @{term "boolean_algebra"}*}

notation
  bot ("\<bottom>") and
  top ("\<top>") and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65)

primrec IfValue2boolean_algebra ::
  "('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'c::boolean_algebra) \<Rightarrow> ('a, 'b) IfValue \<Rightarrow> 'c"
where
  "IfValue2boolean_algebra f _ (Value b) = (if f b then \<top> else \<bottom>)" |
  "IfValue2boolean_algebra f g (If a t e) =
    (g a \<sqinter> (IfValue2boolean_algebra f g t)) \<squnion> (- g a \<sqinter> IfValue2boolean_algebra f g e)"

no_notation
  bot ("\<bottom>") and
  top ("\<top>") and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65)

type_synonym 'a IfValueEnv = "('a * bool) list"

definition agree :: "('a \<Rightarrow> bool) \<Rightarrow> 'a IfValueEnv \<Rightarrow> bool" where
"agree s env = (\<forall>x b. map_of env x = Some b \<longrightarrow> s x = b)"

lemma agree_Nil: "agree s []"
by(simp add: agree_def)

lemma agree_Cons: "distinct(map fst env) \<Longrightarrow> x \<notin> set(map fst env)
  \<Longrightarrow> agree s ((x,b) # env) = ((if b then s x else \<not> s x) \<and> agree s env)"
by(auto simp: agree_def image_iff)

lemma agreeDT:
  "\<lbrakk> agree s env; distinct (map fst env) \<rbrakk> \<Longrightarrow> (x,True) \<in> set env \<Longrightarrow> s x"
by(simp add: agree_def)

lemma agreeDF:
  "\<lbrakk> agree s env; distinct (map fst env) \<rbrakk> \<Longrightarrow> (x,False) \<in> set env \<Longrightarrow> \<not> s x"
by(simp add: agree_def)

definition mkIF :: "'a \<Rightarrow> ('a, 'b) IfValue \<Rightarrow> ('a, 'b) IfValue \<Rightarrow>
  ('a, 'b) IfValue" where
"mkIF x t1 t2 = (if t1 = t2 then t1 else If x t1 t2)"

fun reduce :: "'a IfValueEnv \<Rightarrow> ('a, 'b) IfValue \<Rightarrow>
  ('a, 'b) IfValue" where
"reduce env (If x t1 t2) = (case map_of env x of
     None \<Rightarrow> mkIF x (reduce ((x,True)#env) t1) (reduce ((x,False)#env) t2) |
     Some b \<Rightarrow> reduce env (if b then t1 else t2))" |
"reduce _ t = t"

primrec normif :: "'a IfValueEnv \<Rightarrow> ('a, 'b) IfValue \<Rightarrow>
  ('a, 'b) IfValue \<Rightarrow> ('a, 'b) IfValue \<Rightarrow> ('a, 'b) IfValue" where
"normif env (Value b) t1 t2 = Value b" |
"normif env (If x t1 t2) t3 t4 =
  (case map_of env x of
     None \<Rightarrow> mkIF x (normif ((x,True) # env) t1 t3 t4) (normif ((x,False) # env) t2 t3 t4) |
     Some b \<Rightarrow> if b then normif env t1 t3 t4 else normif env t2 t3 t4)"

fun reduced :: "('a, 'b) IfValue \<Rightarrow> 'a set \<Rightarrow> bool" where
"reduced (If x t1 t2) X =
  (x \<notin> X \<and> t1 \<noteq> t2 \<and> reduced t1 (insert x X) \<and> reduced t2 (insert x X))" |
"reduced _ _ = True"

lemma reduced_antimono: "X \<subseteq> Y \<Longrightarrow> reduced t Y \<Longrightarrow> reduced t X"
apply(induction t arbitrary: X Y)
by auto (metis insert_mono)+

lemma reduced_mkIF: "x \<notin> X \<Longrightarrow>
  reduced t1 (insert x X) \<Longrightarrow> reduced t2 (insert x X) \<Longrightarrow> reduced (mkIF x t1 t2) X"
by(auto simp: mkIF_def intro:reduced_antimono)

lemma reduced_reduce:
  "distinct(map fst env) \<Longrightarrow> reduced (reduce env t) (fst ` set env)"
proof(induction t arbitrary: env)
  case (If x t1 t2)
  thus ?case using If.IH(1)[of "(x, True) # env"] If.IH(2)[of "(x, False) # env"]
    by(auto simp: map_of_eq_None_iff image_iff reduced_mkIF split: option.split)
qed auto

lemma reduced_normif:
  "distinct(map fst env) \<Longrightarrow> reduced (normif env t t1 t2) (fst ` set env)"
proof(induction t arbitrary: t1 t2 env)
  case (If x s1 s2)
  thus ?case using If.IH(1)[of "(x, True) # env"] If.IH(2)[of "(x, False) # env"]
    by(auto simp: reduced_mkIF map_of_eq_None_iff split: option.split)
qed (auto simp: reduced_reduce)

subsection {* Introducing operation modes and activation expression. *}

datatype ('f, 'a) OperationalMode =
  Nominal real
  | Failure 'f
  | Var 'a

type_synonym ('a, 'f, 'b) ActivationExpression =
  "('a, ('f, 'b) OperationalMode) IfValue"

subsection {* Value and Reduction comparison *}

primrec val_IfValue :: "('a \<Rightarrow> bool) \<Rightarrow> ('a, 'b) IfValue \<Rightarrow> 'b"
where
  "val_IfValue _ (Value v) = v" |
  "val_IfValue active (If a t e) =
    (if active a then val_IfValue active t else val_IfValue active e)"

lemma val_mkIF: "val_IfValue s (mkIF x t1 t2) = val_IfValue s (If x t1 t2)"
apply (auto simp: mkIF_def Let_def)
done

theorem val_reduce: "agree s env \<Longrightarrow> distinct(map fst env) \<Longrightarrow>
  val_IfValue s (reduce env t) = val_IfValue s t"
apply(induct t arbitrary: s env)
apply(auto simp: map_of_eq_None_iff val_mkIF agree_Cons Let_def
  dest: agreeDT agreeDF split: option.splits)
done

lemma same_val_if_reduced:
  "reduced t X \<Longrightarrow> \<forall>x. x \<notin> X \<longrightarrow> s1 x = s2 x \<Longrightarrow>
  val_IfValue s1 t = val_IfValue s2 t"
by(induction t arbitrary: X) auto

subsection {* Introducing if-value-predicates. *}

primrec IfValuePredicate :: "('b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) IfValue \<Rightarrow>
  ('a, 'b) IfValue \<Rightarrow> ('a, 'b) IfValue \<Rightarrow> ('a, 'b) IfValue"
where
  "IfValuePredicate P (Value b) t1 t2 = (if P b then t1 else t2)" |
  "IfValuePredicate P (If a t1 t2) t3 t4 =
    If a (IfValuePredicate P t1 t3 t4) (IfValuePredicate P t2 t3 t4)"

notation (output) IfValuePredicate ("_\<^sub>P \<surd> _ \<oslash> _" 80)

fun nominal_op ::
  "('f, 'b) OperationalMode \<Rightarrow> ('f, 'b) OperationalMode \<Rightarrow>
  (real \<Rightarrow> real \<Rightarrow> bool) \<Rightarrow>
  (('f, 'b) OperationalMode \<Rightarrow> ('f, 'b) OperationalMode \<Rightarrow> bool) \<Rightarrow> bool"
where
  "nominal_op (Nominal a) (Nominal b) f _ = (f a b)" |
  "nominal_op (Failure _) (Nominal _) _ _ = False" |
  "nominal_op (Nominal _) (Failure _) _ _ = False" |
  "nominal_op a b _ g = (g a b)"

definition lte_Values :: "('f, 'b) OperationalMode \<Rightarrow> ('f, 'b) OperationalMode \<Rightarrow> bool"
where
  "lte_Values a b \<equiv> nominal_op a b (op \<le>) (op =)"

abbreviation gte_Values :: "('f, 'b) OperationalMode \<Rightarrow> ('f, 'b) OperationalMode \<Rightarrow> bool"
where
  "gte_Values a b \<equiv> lte_Values b a"

definition lt_Values :: "('f, 'b) OperationalMode \<Rightarrow> ('f, 'b) OperationalMode \<Rightarrow> bool"
where
  "lt_Values a b \<equiv> nominal_op a b (op <) (\<lambda> _ _. False)"

abbreviation gt_Values :: "('f, 'b) OperationalMode \<Rightarrow> ('f, 'b) OperationalMode \<Rightarrow> bool"
where
  "gt_Values a b \<equiv> lt_Values b a"

abbreviation eq_Values :: "('f, 'b) OperationalMode \<Rightarrow> ('f, 'b) OperationalMode \<Rightarrow> bool"
where
  "eq_Values a b \<equiv> (a = b)"

notation (output) lte_Values  (infix "\<le>" 50)
notation (output) gte_Values  (infix "\<ge>" 50)
notation (output) lt_Values  (infix "<" 50)
notation (output) gt_Values  (infix ">" 50)
notation (output) eq_Values  (infix "=" 50)

end


theory StackDeterminism
imports StackEvaluate
begin

theorem determinism [elim]: "\<Sigma> \<leadsto>\<^sub>s \<Sigma>' \<Longrightarrow> \<Sigma> \<leadsto>\<^sub>s \<Sigma>'' \<Longrightarrow> \<Sigma>' = \<Sigma>''"
  proof (induction \<Sigma> \<Sigma>' rule: evaluate.induct)
  case (ev_var x s h)
    thus ?case by (induction "StackState (Eval (Var x)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_abs t e s h)
    thus ?case by (induction "StackState (Eval (Abs t e)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_app e\<^sub>1 e\<^sub>2 s h)
    thus ?case by (induction "StackState (Eval (App e\<^sub>1 e\<^sub>2)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_let e\<^sub>1 e\<^sub>2 s h)
    thus ?case by (induction "StackState (Eval (Let e\<^sub>1 e\<^sub>2)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_rec vs s h)
    thus ?case by (induction "StackState (Eval (Rec vs)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_proj e l s h)
    thus ?case by (induction "StackState (Eval (Proj e l)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_inj l ts x s h)
    thus ?case
      by (induction "StackState (Eval (Inj l ts x)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_case e t cs s h)
    thus ?case
      by (induction "StackState (Eval (Case e t cs)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_fold t x s h)
    thus ?case by (induction "StackState (Eval (Fold t x)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_unfold t e s h)
    thus ?case
      by (induction "StackState (Eval (Unfold t e)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_tyabs k e s h)
    thus ?case by (induction "StackState (Eval (TyAbs k e)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_tyapp e t s h)
    thus ?case by (induction "StackState (Eval (TyApp e t)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ev_tylet t e s h)
    thus ?case by (induction "StackState (Eval (TyLet t e)) s h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ret_ref v x s h)
    thus ?case
      by (induction "StackState (Return v) (SRef x # s) h" \<Sigma>'' rule: evaluate.induct) simp_all
  next case (ret_app t e\<^sub>1 e\<^sub>2 s h)
    thus ?case
      by (induction "StackState (Return (VAbs t e\<^sub>1)) (SApp e\<^sub>2 # s) h" \<Sigma>'' rule: evaluate.induct)
         simp_all
  next case (ret_proj xs l x s h)
    with ret_proj(2) show ?case
      by (induction "StackState (Return (VRec xs)) (SProj l # s) h" \<Sigma>'' rule: evaluate.induct)
         simp_all
  next case (ret_case cs l e ts x t s h)
    with ret_case(2) show ?case
      by (induction "StackState (Return (VInj l ts x)) (SCase t cs # s) h" \<Sigma>''
          rule: evaluate.induct)
         simp_all
  next case (ret_unfold t x s h)
    thus ?case
      by (induction "StackState (Return (VFold t x)) (SUnfold t # s) h" \<Sigma>'' rule: evaluate.induct)
         simp_all
  next case (ret_tyapp k e t s h)
    thus ?case
      by (induction "StackState (Return (VTyAbs k e)) (STyApp t # s) h" \<Sigma>'' rule: evaluate.induct)
         simp_all
  qed

end


section \<open>Prisms\<close>

theory Prisms
  imports Main
begin

record ('v, 's) prism =
  prism_match :: "'s \<Rightarrow> 'v option" ("match\<index>")
  prism_build :: "'v \<Rightarrow> 's" ("build\<index>")

locale wb_prism =
  fixes x :: "('v, 's) prism" (structure)
  assumes match_build: "match (build v) = Some v"
  and build_match: "match s = Some v \<Longrightarrow> s = build v"
begin

  lemma build_match_iff: "match s = Some v \<longleftrightarrow> s = build v"
    using build_match match_build by blast

  lemma range_build: "range build = dom match"
    using build_match match_build by fastforce
end

definition prism_suml :: "('a, 'a + 'b) prism" where
"prism_suml = \<lparr> prism_match = (\<lambda> v. case v of Inl x \<Rightarrow> Some x | _ \<Rightarrow> None), prism_build = Inl \<rparr>"

lemma wb_prim_suml: "wb_prism prism_suml"
  apply (unfold_locales)
  apply (simp_all add: prism_suml_def sum.case_eq_if)
  apply (metis option.inject option.simps(3) sum.collapse(1))
done

definition prism_diff :: "('a, 's) prism \<Rightarrow> ('b, 's) prism \<Rightarrow> bool" (infix "\<nabla>" 50) where
"prism_diff X Y = (range build\<^bsub>X\<^esub> \<inter> range build\<^bsub>Y\<^esub> = {})"

lemma prism_diff_build: "X \<nabla> Y \<Longrightarrow> build\<^bsub>X\<^esub> u \<noteq> build\<^bsub>Y\<^esub> v"
  by (simp add: disjoint_iff_not_equal prism_diff_def)

definition prism_plus :: "('a, 's) prism \<Rightarrow> ('b, 's) prism \<Rightarrow> ('a + 'b, 's) prism" (infixl "+\<^sub>P" 85) where
"X +\<^sub>P Y = \<lparr> prism_match = (\<lambda> s. case (match\<^bsub>X\<^esub> s, match\<^bsub>Y\<^esub> s) of
                                 (Some u, _) \<Rightarrow> Some (Inl u) |
                                 (None, Some v) \<Rightarrow> Some (Inr v) |
                                 (None, None) \<Rightarrow> None),
           prism_build = (\<lambda> v. case v of Inl x \<Rightarrow> build\<^bsub>X\<^esub> x | Inr y \<Rightarrow> build\<^bsub>Y\<^esub> y) \<rparr>"
end