section \<open>Stochastic Dominance\<close>

theory Stochastic_Dominance
imports
  Complex_Main
  "HOL-Probability.Probability"
  Lotteries
  Preference_Profiles
  Utility_Functions
begin

subsection \<open>Definition of Stochastic Dominance\<close>

text \<open>
  This is the definition of stochastic dominance. It lifts a preference relation
  on alternatives to the stochastic dominance ordering on lotteries.
\<close>
definition SD :: "'alt relation \<Rightarrow> 'alt lottery relation" where
  "p \<succeq>[SD(R)] q \<longleftrightarrow> p \<in> lotteries_on {x. R x x} \<and> q \<in> lotteries_on {x. R x x} \<and>
      (\<forall>x. R x x \<longrightarrow> measure_pmf.prob p {y. y \<succeq>[R] x} \<ge>
                       measure_pmf.prob q {y. y \<succeq>[R] x})"

lemma SD_empty [simp]: "SD (\<lambda>_ _. False) = (\<lambda>_ _. False)"
  by (auto simp: fun_eq_iff SD_def lotteries_on_def set_pmf_not_empty)

text \<open>
  Stochastic dominance over any relation is a preorder.
\<close>
lemma SD_refl: "p \<preceq>[SD(R)] p \<longleftrightarrow> p \<in> lotteries_on {x. R x x}"
  by (simp add: SD_def)

lemma SD_trans [simp, trans]: "p \<preceq>[SD(R)] q \<Longrightarrow> q \<preceq>[SD(R)] r \<Longrightarrow> p \<preceq>[SD(R)] r"
  unfolding SD_def by (auto intro: order.trans)

lemma SD_is_preorder: "preorder_on (lotteries_on {x. R x x}) (SD R)"
  by unfold_locales (auto simp: SD_def intro: order.trans)

context preorder_on
begin

lemma SD_preorder:
   "p \<succeq>[SD(le)] q \<longleftrightarrow> p \<in> lotteries_on carrier \<and> q \<in> lotteries_on carrier \<and>
      (\<forall>x\<in>carrier. measure_pmf.prob p (preferred_alts le x) \<ge>
                     measure_pmf.prob q (preferred_alts le x))"
  by (simp add: SD_def preferred_alts_def carrier_eq)

lemma SD_preorderI [intro?]:
  assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  assumes "\<And>x. x \<in> carrier \<Longrightarrow>
             measure_pmf.prob p (preferred_alts le x) \<ge> measure_pmf.prob q (preferred_alts le x)"
  shows   "p \<succeq>[SD(le)] q"
  using assms by (simp add: SD_preorder)

lemma SD_preorderD:
  assumes "p \<succeq>[SD(le)] q"
  shows   "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  and      "\<And>x. x \<in> carrier \<Longrightarrow>
             measure_pmf.prob p (preferred_alts le x) \<ge> measure_pmf.prob q (preferred_alts le x)"
  using assms unfolding SD_preorder by simp_all

lemma SD_refl' [simp]: "p \<preceq>[SD(le)] p \<longleftrightarrow> p \<in> lotteries_on carrier"
  by (simp add: SD_def carrier_eq)

lemma SD_is_preorder': "preorder_on (lotteries_on carrier) (SD(le))"
  using SD_is_preorder[of le] by (simp add: carrier_eq)

lemma SD_singleton_left:
  assumes "x \<in> carrier" "q \<in> lotteries_on carrier"
  shows   "return_pmf x \<preceq>[SD(le)] q \<longleftrightarrow> (\<forall>y\<in>set_pmf q. x \<preceq>[le] y)"
proof
  assume SD: "return_pmf x \<preceq>[SD(le)] q"
  from assms SD_preorderD(3)[OF SD, of x]
    have "measure_pmf.prob (return_pmf x) (preferred_alts le x) \<le>
            measure_pmf.prob q (preferred_alts le x)" by simp
  also from assms have "measure_pmf.prob (return_pmf x) (preferred_alts le x) = 1"
    by (simp add: indicator_def)
  finally have "AE y in q. y \<succeq>[le] x"
    by (simp add: measure_pmf.measure_ge_1_iff measure_pmf.prob_eq_1 preferred_alts_def)
  thus "\<forall>y\<in>set_pmf q. y \<succeq>[le] x" by (simp add: AE_measure_pmf_iff)
next
  assume A: "\<forall>y\<in>set_pmf q. x \<preceq>[le] y"
  show "return_pmf x \<preceq>[SD(le)] q"
  proof (rule SD_preorderI)
    fix y assume y: "y \<in> carrier"
    show "measure_pmf.prob (return_pmf x) (preferred_alts le y)
              \<le> measure_pmf.prob q (preferred_alts le y)"
    proof (cases "y \<preceq>[le] x")
      case True
      from True A have "measure_pmf.prob q (preferred_alts le y) = 1"
        by (auto simp: AE_measure_pmf_iff measure_pmf.prob_eq_1 preferred_alts_def intro: trans)
      thus ?thesis by simp
    qed (simp_all add: preferred_alts_def indicator_def measure_nonneg)
  qed (insert assms, simp_all add: lotteries_on_def)
qed

lemma SD_singleton_right:
  assumes x: "x \<in> carrier" and q: "q \<in> lotteries_on carrier"
  shows   "q \<preceq>[SD(le)] return_pmf x \<longleftrightarrow> (\<forall>y\<in>set_pmf q. y \<preceq>[le] x)"
proof safe
  fix y assume SD: "q \<preceq>[SD(le)] return_pmf x" and y: "y \<in> set_pmf q"
  from y assms have [simp]: "y \<in> carrier" by (auto simp: lotteries_on_def)

  from y have "0 < measure_pmf.prob q (preferred_alts le y)"
    by (rule measure_pmf_posI) simp_all
  also have "\<dots> \<le> measure_pmf.prob (return_pmf x) (preferred_alts le y)"
    by (rule SD_preorderD(3)[OF SD]) simp_all
  finally show "y \<preceq>[le] x"
    by (auto simp: indicator_def preferred_alts_def split: if_splits)
next
  assume A: "\<forall>y\<in>set_pmf q. y \<preceq>[le] x"
  show "q \<preceq>[SD(le)] return_pmf x"
  proof (rule SD_preorderI)
    fix y assume y: "y \<in> carrier"
    show "measure_pmf.prob q (preferred_alts le y) \<le>
            measure_pmf.prob (return_pmf x) (preferred_alts le y)"
    proof (cases "y \<preceq>[le] x")
      case False
      with A show ?thesis
        by (auto simp: preferred_alts_def indicator_def measure_le_0_iff
                       measure_pmf.prob_eq_0 AE_measure_pmf_iff intro: trans)
    qed (simp_all add: indicator_def preferred_alts_def)
  qed (insert assms, simp_all add: lotteries_on_def)
qed

lemma SD_strict_singleton_left:
  assumes "x \<in> carrier" "q \<in> lotteries_on carrier"
  shows   "return_pmf x \<prec>[SD(le)] q \<longleftrightarrow> (\<forall>y\<in>set_pmf q. x \<preceq>[le] y) \<and> (\<exists>y\<in>set_pmf q. (x \<prec>[le] y))"
  using assms by (auto simp add: strongly_preferred_def SD_singleton_left SD_singleton_right)

lemma SD_strict_singleton_right:
  assumes "x \<in> carrier" "q \<in> lotteries_on carrier"
  shows   "q \<prec>[SD(le)] return_pmf x \<longleftrightarrow> (\<forall>y\<in>set_pmf q. y \<preceq>[le] x) \<and> (\<exists>y\<in>set_pmf q. (y \<prec>[le] x))"
  using assms by (auto simp add: strongly_preferred_def SD_singleton_left SD_singleton_right)

lemma SD_singleton [simp]:
  "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> return_pmf x \<preceq>[SD(le)] return_pmf y \<longleftrightarrow> x \<preceq>[le] y"
  by (subst SD_singleton_left) (simp_all add: lotteries_on_def)

lemma SD_strict_singleton [simp]:
  "x \<in> carrier \<Longrightarrow> y \<in> carrier \<Longrightarrow> return_pmf x \<prec>[SD(le)] return_pmf y \<longleftrightarrow> x \<prec>[le] y"
  by (simp add: strongly_preferred_def)

end

context pref_profile_wf
begin

context
fixes i assumes i: "i \<in> agents"
begin

interpretation Ri: preorder_on alts "R i" by (simp add: i)

lemmas SD_singleton_left = Ri.SD_singleton_left
lemmas SD_singleton_right = Ri.SD_singleton_right
lemmas SD_strict_singleton_left = Ri.SD_strict_singleton_left
lemmas SD_strict_singleton_right = Ri.SD_strict_singleton_right
lemmas SD_singleton = Ri.SD_singleton
lemmas SD_strict_singleton = Ri.SD_strict_singleton

end
end

lemmas (in pref_profile_wf) [simp] = SD_singleton SD_strict_singleton

subsection \<open>Stochastic Dominance for preference profiles\<close>

context pref_profile_wf
begin

lemma SD_pref_profile:
  assumes "i \<in> agents"
  shows   "p \<succeq>[SD(R i)] q \<longleftrightarrow> p \<in> lotteries_on alts \<and> q \<in> lotteries_on alts \<and>
             (\<forall>x\<in>alts. measure_pmf.prob p (preferred_alts (R i) x) \<ge>
                         measure_pmf.prob q (preferred_alts (R i) x))"
proof -
  from assms interpret total_preorder_on alts "R i" by simp
  have "preferred_alts (R i) x = {y. y \<succeq>[R i] x}" for x using not_outside
    by (auto simp: preferred_alts_def)
  thus ?thesis by (simp add: SD_preorder preferred_alts_def)
qed

lemma SD_pref_profileI [intro?]:
  assumes "i \<in> agents" "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
  assumes "\<And>x. x \<in> alts \<Longrightarrow>
             measure_pmf.prob p (preferred_alts (R i) x) \<ge>
             measure_pmf.prob q (preferred_alts (R i) x)"
  shows   "p \<succeq>[SD(R i)] q"
  using assms by (simp add: SD_pref_profile)

lemma SD_pref_profileD:
  assumes "i \<in> agents" "p \<succeq>[SD(R i)] q"
  shows   "p \<in> lotteries_on alts" "q \<in> lotteries_on alts"
  and     "\<And>x. x \<in> alts \<Longrightarrow>
             measure_pmf.prob p (preferred_alts (R i) x) \<ge>
             measure_pmf.prob q (preferred_alts (R i) x)"
  using assms by (simp_all add: SD_pref_profile)

end

subsection \<open>SD efficient lotteries\<close>

definition SD_efficient :: "('agent, 'alt) pref_profile \<Rightarrow> 'alt lottery \<Rightarrow> bool" where
  SD_efficient_auxdef:
    "SD_efficient R p \<longleftrightarrow> \<not>(\<exists>q\<in>lotteries_on {x. \<exists>i. R i x x}. q \<succ>[Pareto (SD \<circ> R)] p)"

context pref_profile_wf
begin

sublocale SD: preorder_family agents "lotteries_on alts" "SD \<circ> R" unfolding o_def
  by (intro preorder_family.intro SD_is_preorder)
     (simp_all add: preorder_on.SD_is_preorder' prefs_undefined')

text \<open>
  A lottery is considered SD-efficient if there is no other lottery such that
  all agents weakly prefer the other lottery (w.r.t. stochastic dominance) and at least
  one agent strongly prefers the other lottery.
\<close>
lemma SD_efficient_def:
  "SD_efficient R p \<longleftrightarrow> \<not>(\<exists>q\<in>lotteries_on alts. q \<succ>[Pareto (SD \<circ> R)] p)"
proof -
  have "SD_efficient R p \<longleftrightarrow> \<not>(\<exists>q\<in>lotteries_on {x. \<exists>i. R i x x}. q \<succ>[Pareto (SD \<circ> R)] p)"
    unfolding SD_efficient_auxdef ..
  also from nonempty_agents obtain i where i: "i \<in> agents" by blast
  with preorder_on.refl[of alts "R i"]
    have "{x. \<exists>i. R i x x} = alts" by (auto intro!: exI[of _ i] not_outside)
  finally show ?thesis .
qed

lemma SD_efficient_def':
  "SD_efficient R p \<longleftrightarrow>
     \<not>(\<exists>q\<in>lotteries_on alts. (\<forall>i\<in>agents. q \<succeq>[SD(R i)] p) \<and> (\<exists>i\<in>agents. q \<succ>[SD(R i)] p))"
  unfolding SD_efficient_def SD.Pareto_iff strongly_preferred_def [abs_def] by auto

lemma SD_inefficientI:
  assumes "q \<in> lotteries_on alts" "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p"
          "i \<in> agents" "q \<succ>[SD(R i)] p"
  shows   "\<not>SD_efficient R p"
  using assms unfolding SD_efficient_def' by blast

lemma SD_inefficientI':
  assumes "q \<in> lotteries_on alts" "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p"
          "\<exists>i \<in> agents. q \<succ>[SD(R i)] p"
  shows   "\<not>SD_efficient R p"
  using assms unfolding SD_efficient_def' by blast

lemma SD_inefficientE:
  assumes "\<not>SD_efficient R p"
  obtains q i where
    "q \<in> lotteries_on alts" "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p"
    "i \<in> agents" "q \<succ>[SD(R i)] p"
  using assms unfolding SD_efficient_def' by blast

lemma SD_efficientD:
  assumes "SD_efficient R p" "q \<in> lotteries_on alts"
      and "\<And>i. i \<in> agents \<Longrightarrow> q \<succeq>[SD(R i)] p" "\<exists>i\<in>agents. \<not>(q \<preceq>[SD(R i)] p)"
  shows False
  using assms unfolding SD_efficient_def' strongly_preferred_def by blast

lemma SD_efficient_singleton_iff:
  assumes [simp]: "x \<in> alts"
  shows   "SD_efficient R (return_pmf x) \<longleftrightarrow> x \<notin> pareto_losers R"
proof -
  {
    assume x: "x \<in> pareto_losers R"
    from pareto_losersE[OF x] guess y . note y = this
    from y have "\<not>SD_efficient R (return_pmf x)"
      by (intro SD_inefficientI'[of "return_pmf y"]) (force simp: Pareto_strict_iff)+
  } moreover {
    assume "\<not>SD_efficient R (return_pmf x)"
    from SD_inefficientE[OF this] guess q i . note q = this
    moreover from q obtain y where "y \<in> set_pmf q" "y \<succ>[R i] x"
      by (auto simp: SD_strict_singleton_left)
    ultimately have "y \<succ>[Pareto(R)] x"
      by (fastforce simp: Pareto_strict_iff SD_singleton_left)
    hence "x \<in> pareto_losers R" by simp
  }
  ultimately show ?thesis by blast
qed

end

subsection \<open>Equivalence proof\<close>

text \<open>
  We now show that a lottery is preferred w.r.t. Stochastic Dominance iff
  it yields more expected utility for all compatible utility functions.
\<close>

context finite_total_preorder_on
begin

abbreviation "is_vnm_utility \<equiv> vnm_utility carrier le"

lemma utility_weak_ranking_index:
  "is_vnm_utility (\<lambda>x. real (length (weak_ranking le) - weak_ranking_index x))"
proof
  fix x y assume xy: "x \<in> carrier" "y \<in> carrier"
  with this[THEN nth_weak_ranking_index(1)] this[THEN nth_weak_ranking_index(2)]
    show "(real (length (weak_ranking le) - weak_ranking_index x)
            \<le> real (length (weak_ranking le) - weak_ranking_index y)) \<longleftrightarrow> le x y"
    by (simp add: le_diff_iff')
qed

(*
  TODO: one direction could probably be generalised to weakly consistent
  utility functions
*)
lemma SD_iff_expected_utilities_le:
  assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  shows   "p \<preceq>[SD(le)] q \<longleftrightarrow>
             (\<forall>u. is_vnm_utility u \<longrightarrow> measure_pmf.expectation p u \<le> measure_pmf.expectation q u)"
proof safe
  fix u assume SD: "p \<preceq>[SD(le)] q" and is_utility: "is_vnm_utility u"
  from is_utility interpret vnm_utility carrier le u .
  define xs where "xs = weak_ranking le"
  have le: "is_weak_ranking xs" "le = of_weak_ranking xs"
    by (simp_all add: xs_def weak_ranking_total_preorder)

  let ?pref = "\<lambda>p x. measure_pmf.prob p {y. x \<preceq>[le] y}" and
      ?pref' = "\<lambda>p x. measure_pmf.prob p {y. x \<prec>[le] y}"
  define f where "f i = (SOME x. x \<in> xs ! i)" for i
  have xs_wf: "is_weak_ranking xs"
    by (simp add: xs_def weak_ranking_total_preorder)
  hence f: "f i \<in> xs ! i" if "i < length xs" for i
    using that unfolding f_def is_weak_ranking_def
    by (intro someI_ex[of "\<lambda>x. x \<in> xs ! i"]) (auto simp: set_conv_nth)
  have f': "f i \<in> carrier" if "i < length xs" for i
    using that f weak_ranking_Union unfolding xs_def by (auto simp: set_conv_nth)
  define n where "n = length xs - 1"
  from assms weak_ranking_Union have carrier_nonempty: "carrier \<noteq> {}" and "xs \<noteq> []"
    by (auto simp: xs_def lotteries_on_def set_pmf_not_empty)
  hence n: "length xs = Suc n" and xs_nonempty: "xs \<noteq> []" by (auto simp add: n_def)
  have SD': "?pref p (f i) \<le> ?pref q (f i)" if "i < length xs" for i
    using f'[OF that] SD by (auto simp: SD_preorder preferred_alts_def)
  have f_le: "le (f i) (f j) \<longleftrightarrow> i \<ge> j" if "i < length xs" "j < length xs" for i j
    using that weak_ranking_index_unique[OF xs_wf that(1) _ f]
               weak_ranking_index_unique[OF xs_wf that(2) _ f]
    by (auto simp add: le intro: f elim!: of_weak_ranking.cases intro!: of_weak_ranking.intros)

  have "measure_pmf.expectation p u =
          (\<Sum>i<n. (u (f i) - u (f (Suc i))) * ?pref p (f i)) + u (f n)"
    if p: "p \<in> lotteries_on carrier" for p
  proof -
    from p have "measure_pmf.expectation p u =
                   (\<Sum>i<length xs. u (f i) * measure_pmf.prob p (xs ! i))"
      by (simp add: f_def expected_utility_weak_ranking xs_def sum_list_sum_nth atLeast0LessThan)
    also have "\<dots> = (\<Sum>i<length xs. u (f i) * (?pref p (f i) - ?pref' p (f i)))"
    proof (intro sum.cong HOL.refl)
      fix i assume i: "i \<in> {..<length xs}"
      have "?pref p (f i) - ?pref' p (f i) =
              measure_pmf.prob p ({y. f i \<preceq>[le] y} - {y. f i \<prec>[le] y})"
        by (subst measure_pmf.finite_measure_Diff [symmetric])
           (auto simp: strongly_preferred_def)
      also have "{y. f i \<preceq>[le] y} - {y. f i \<prec>[le] y} =
                   {y. f i \<preceq>[le] y \<and> y \<preceq>[le] f i}" (is "_ = ?A")
        by (auto simp: strongly_preferred_def)
      also have "\<dots> = xs ! i"
      proof safe
        fix x assume le: "le (f i) x" "le x (f i)"
        from i f show "x \<in> xs ! i"
          by (intro weak_ranking_eqclass2[OF _ _ le]) (auto simp: xs_def)
      next
        fix x assume "x \<in> xs ! i"
        from weak_ranking_eqclass1[OF _ this f] weak_ranking_eqclass1[OF _ f this] i
          show "le x (f i)" "le (f i) x" by (simp_all add: xs_def)
      qed
      finally show "u (f i) * measure_pmf.prob p (xs ! i) =
                      u (f i) * (?pref p (f i) - ?pref' p (f i))" by simp
    qed
    also have "\<dots> = (\<Sum>i<length xs. u (f i) * ?pref p (f i)) -
                      (\<Sum>i<length xs. u (f i) * ?pref' p (f i))"
      by (simp add: sum_subtractf ring_distribs)
    also have "(\<Sum>i<length xs. u (f i) * ?pref p (f i)) =
                 (\<Sum>i<n. u (f i) * ?pref p (f i)) + u (f n) * ?pref p (f n)" (is "_ = ?sum")
      by (simp add: n)
    also have "(\<Sum>i<length xs. u (f i) * ?pref' p (f i)) =
                 (\<Sum>i<n. u (f (Suc i)) * ?pref' p (f (Suc i))) + u (f 0) * ?pref' p (f 0)"
      unfolding n sum.lessThan_Suc_shift by simp
    also have "(\<Sum>i<n. u (f (Suc i)) * ?pref' p (f (Suc i))) =
                 (\<Sum>i<n. u (f (Suc i)) * ?pref p (f i))"
    proof (intro sum.cong HOL.refl)
      fix i assume i: "i \<in> {..<n}"
      have "f (Suc i) \<prec>[le] y \<longleftrightarrow> f i \<preceq>[le] y" for y
      proof (cases "y \<in> carrier")
        assume "y \<in> carrier"
        with weak_ranking_Union obtain j where j: "j < length xs" "y \<in> xs ! j"
          by (auto simp: set_conv_nth xs_def)
        with weak_ranking_eqclass1[OF _ f j(2)] weak_ranking_eqclass1[OF _ j(2) f]
          have iff: "le y z \<longleftrightarrow> le (f j) z" "le z y \<longleftrightarrow> le z (f j)" for z
          by (auto intro: trans simp: xs_def)
        thus ?thesis using i j unfolding n_def
          by (auto simp: iff f_le strongly_preferred_def)
      qed (insert not_outside, auto simp: strongly_preferred_def)
      thus "u (f (Suc i)) * ?pref' p (f (Suc i)) = u (f (Suc i)) * ?pref p (f i)" by simp
    qed
    also have "?sum - (\<dots> + u (f 0) * ?pref' p (f 0)) =
      (\<Sum>i<n. (u (f i) - u (f (Suc i))) * ?pref p (f i)) -
       u (f 0) * ?pref' p (f 0) + u (f n) * ?pref p (f n)"
         by (simp add: ring_distribs sum_subtractf)
    also have "{y. f 0 \<prec>[le] y} = {}"
      using hd_weak_ranking[of "f 0"] xs_nonempty f not_outside
      by (auto simp: hd_conv_nth xs_def strongly_preferred_def)
    also have "{y. le (f n) y} = carrier"
      using last_weak_ranking[of "f n"] xs_nonempty f not_outside
      by (auto simp: last_conv_nth xs_def n_def)
    also from p have "measure_pmf.prob p carrier = 1"
      by (subst measure_pmf.prob_eq_1)
         (auto simp: AE_measure_pmf_iff lotteries_on_def)
    finally show ?thesis by simp
  qed

  from assms[THEN this] show "measure_pmf.expectation p u \<le> measure_pmf.expectation q u"
    unfolding SD_preorder n_def using f'
    by (auto intro!: sum_mono mult_left_mono SD' simp: utility_le_iff f_le)

next
  assume "\<forall>u. is_vnm_utility u \<longrightarrow> measure_pmf.expectation p u \<le> measure_pmf.expectation q u"
  hence expected_utility_le: "measure_pmf.expectation p u \<le> measure_pmf.expectation q u"
    if "is_vnm_utility u" for u using that by blast
  define xs where "xs = weak_ranking le"
  have le: "le = of_weak_ranking xs" and [simp]: "is_weak_ranking xs"
    by (simp_all add: xs_def weak_ranking_total_preorder)
  have carrier: "carrier = \<Union>(set xs)"
    by (simp add: xs_def weak_ranking_Union)
  from assms have carrier_nonempty: "carrier \<noteq> {}"
    by (auto simp: lotteries_on_def set_pmf_not_empty)

  {
    fix x assume x: "x \<in> carrier"
    let ?idx = "\<lambda>y. length xs - weak_ranking_index y"
    have preferred_subset_carrier: "{y. le x y} \<subseteq> carrier"
      using not_outside x by auto
    have "measure_pmf.prob p {y. le x y} / real (length xs) \<le>
             measure_pmf.prob q {y. le x y} / real (length xs)"
    proof (rule field_le_epsilon)
      fix \<epsilon> :: real assume \<epsilon>: "\<epsilon> > 0"
      define u where "u y = indicator {y. y \<succeq>[le] x} y + \<epsilon> * ?idx y" for y
      have is_utility: "is_vnm_utility u" unfolding u_def xs_def
      proof (intro vnm_utility.add_left vnm_utility.scaled utility_weak_ranking_index)
        fix y z assume "le y z"
        thus "indicator {y. y \<succeq>[le] x} y \<le> (indicator {y. y \<succeq>[le] x} z :: real)"
          by (auto intro: trans simp: indicator_def split: if_splits)
      qed fact+

      have "(\<Sum>y|le x y. pmf p y) \<le>
              (\<Sum>y|le x y. pmf p y) + \<epsilon> * (\<Sum>y\<in>carrier. ?idx y * pmf p y)"
        using \<epsilon> by (auto intro!: mult_nonneg_nonneg sum_nonneg pmf_nonneg)
      also from expected_utility_le is_utility have
        "measure_pmf.expectation p u \<le> measure_pmf.expectation q u" .
      with assms
        have "(\<Sum>a\<in>carrier. u a * pmf p a) \<le> (\<Sum>a\<in>carrier. u a * pmf q a)"
        by (subst (asm) (1 2) integral_measure_pmf[OF finite_carrier])
           (auto simp: lotteries_on_def set_pmf_eq ac_simps)
      hence "(\<Sum>y|le x y. pmf p y) + \<epsilon> * (\<Sum>y\<in>carrier. ?idx y * pmf p y) \<le>
             (\<Sum>y|le x y. pmf q y) + \<epsilon> * (\<Sum>y\<in>carrier. ?idx y * pmf q y)"
        using x preferred_subset_carrier not_outside
        by (simp add: u_def sum.distrib finite_carrier algebra_simps sum_distrib_left Int_absorb1 cong: rev_conj_cong)
      also have "(\<Sum>y\<in>carrier. ?idx y * pmf q y) \<le> (\<Sum>y\<in>carrier. length xs * pmf q y)"
        by (intro sum_mono mult_right_mono) (simp_all add: pmf_nonneg)
      also have "\<dots> = measure_pmf.expectation q (\<lambda>_. length xs)"
        using assms by (subst integral_measure_pmf[OF finite_carrier])
                       (auto simp: lotteries_on_def set_pmf_eq ac_simps)
      also have "\<dots> = length xs" by simp
      also have "(\<Sum>y | le x y. pmf p y) = measure_pmf.prob p {y. le x y}"
        using finite_subset[OF preferred_subset_carrier finite_carrier]
        by (simp add: measure_measure_pmf_finite)
      also have "(\<Sum>y | le x y. pmf q y) = measure_pmf.prob q {y. le x y}"
        using finite_subset[OF preferred_subset_carrier finite_carrier]
        by (simp add: measure_measure_pmf_finite)
      finally show "measure_pmf.prob p {y. le x y} / length xs \<le>
                      measure_pmf.prob q {y. le x y} / length xs + \<epsilon>"
        using \<epsilon> by (simp add: divide_simps)
    qed
    moreover from carrier_nonempty carrier have "xs \<noteq> []" by auto
    ultimately have "measure_pmf.prob p {y. le x y} \<le>
                       measure_pmf.prob q {y. le x y}"
      by (simp add: field_simps)
  }
  with assms show "p \<preceq>[SD(le)] q" unfolding SD_preorder preferred_alts_def by blast
qed

lemma not_strict_SD_iff:
  assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  shows   "\<not>(p \<prec>[SD(le)] q) \<longleftrightarrow>
             (\<exists>u. is_vnm_utility u \<and> measure_pmf.expectation q u \<le> measure_pmf.expectation p u)"
proof
  let ?E = "measure_pmf.expectation :: 'a pmf \<Rightarrow> _ \<Rightarrow> real"
  assume "\<exists>u. is_vnm_utility u \<and> ?E p u \<ge> ?E q u"
  then obtain u where u: "is_vnm_utility u" "?E p u \<ge> ?E q u" by blast
  interpret u: vnm_utility carrier le u by fact

  show "\<not> p \<prec>[SD le] q"
  proof
    assume less: "p \<prec>[SD le] q"
    with assms have pq: "?E p u \<le> ?E q u" if "is_vnm_utility u" for u
      using that by (auto simp: SD_iff_expected_utilities_le strongly_preferred_def)
    with u have u_eq: "?E p u = ?E q u" by (intro antisym) simp_all
    from less assms obtain u' where u': "is_vnm_utility u'" "?E p u' < ?E q u'"
      by (auto simp: SD_iff_expected_utilities_le strongly_preferred_def not_le)
    interpret u': vnm_utility carrier le u' by fact

    have "\<exists>\<epsilon>>0. is_vnm_utility (\<lambda>x. u x - \<epsilon> * u' x)"
      by (intro u.diff_epsilon antisym u'.utility_le)
    then guess \<epsilon> by (elim exE conjE) note \<epsilon> = this
    define u'' where "u'' x = u x - \<epsilon> * u' x" for x
    interpret u'': vnm_utility carrier le u'' unfolding u''_def by fact
    have exp_u'': "?E p u'' = ?E p u - \<epsilon> * ?E p u'" if "p \<in> lotteries_on carrier" for p using that
      by (subst (1 2 3) integral_measure_pmf[of carrier])
         (auto simp: lotteries_on_def u''_def algebra_simps sum_subtractf sum_distrib_left)
    from assms \<epsilon> have "?E p u'' > ?E q u''"
      by (simp_all add: exp_u'' algebra_simps u_eq u')
    with pq[OF u''.vnm_utility_axioms] show False by simp
  qed
qed (insert assms utility_weak_ranking_index,
     auto simp: strongly_preferred_def SD_iff_expected_utilities_le not_le not_less intro: antisym)

lemma strict_SD_iff:
  assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  shows   "(p \<prec>[SD(le)] q) \<longleftrightarrow>
             (\<forall>u. is_vnm_utility u \<longrightarrow> measure_pmf.expectation p u < measure_pmf.expectation q u)"
  using not_strict_SD_iff[OF assms] by auto

end

end


theory Chapter13_5
imports Main "~~/src/HOL/Library/Lattice_Syntax"
begin

text{*
\setcounter{exercise}{10}

\begin{exercise}
Take the Isabelle theories that define commands, big-step semantics,
annotated commands and the collecting semantics and extend them with a
nondeterministic choice construct. Start with Exercise~\ref{exe:IMP:OR}
and extend type @{text com}, then extend type @{text acom} with a
corresponding construct:
\begin{alltt}
  Or "'a acom" "'a acom" 'a     ("_ OR// _//{_}"  [60, 61, 0] 60)
\end{alltt}
Finally extend function @{text Step}. Update proofs as well.
Hint: think of @{text OR} as a nondeterministic conditional without a test.
\end{exercise}

\exercise
Prove the following lemmas in a detailed and readable style:
*}

lemma fixes x0 :: "'a :: order"
assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y"  and  "f q \<le> q"  and  "x0 \<le> q"
shows "(f ^^ i) x0 \<le> q"
(* your definition/proof here *)

lemma fixes x0 :: "'a :: order"
assumes "\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y" and "x0 \<le> f x0"
shows "(f ^^ i) x0 \<le> (f ^^ (i+1)) x0"
(* your definition/proof here *)

text{*
\endexercise

\exercise% needs Lattice_Syntax
Let @{typ 'a} be a complete lattice and
let @{text "f :: 'a \<Rightarrow> 'a"} be a monotone function.
Give a readable proof that if @{text P} is a set of pre-fixpoints of @{text f}
then @{text"\<Sqinter>P"} is also a pre-fixpoint of @{text f}:
*}

lemma fixes P :: "'a::complete_lattice set"
assumes "mono f" and "\<forall>p \<in> P. f p \<le> p"
shows "f(\<Sqinter> P) \<le> \<Sqinter> P"
(* your definition/proof here *)

text{*
Sledgehammer should give you a proof you can start from.
\endexercise
*}

end


(*  Title:      HOL/Hahn_Banach/Zorn_Lemma.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Zorn's Lemma\<close>

theory Zorn_Lemma
imports Main
begin

text \<open>
  Zorn's Lemmas states: if every linear ordered subset of an ordered set \<open>S\<close>
  has an upper bound in \<open>S\<close>, then there exists a maximal element in \<open>S\<close>. In
  our application, \<open>S\<close> is a set of sets ordered by set inclusion. Since the
  union of a chain of sets is an upper bound for all elements of the chain,
  the conditions of Zorn's lemma can be modified: if \<open>S\<close> is non-empty, it
  suffices to show that for every non-empty chain \<open>c\<close> in \<open>S\<close> the union of \<open>c\<close>
  also lies in \<open>S\<close>.
\<close>

theorem Zorn's_Lemma:
  assumes r: "\<And>c. c \<in> chains S \<Longrightarrow> \<exists>x. x \<in> c \<Longrightarrow> \<Union>c \<in> S"
    and aS: "a \<in> S"
  shows "\<exists>y \<in> S. \<forall>z \<in> S. y \<subseteq> z \<longrightarrow> z = y"
proof (rule Zorn_Lemma2)
  show "\<forall>c \<in> chains S. \<exists>y \<in> S. \<forall>z \<in> c. z \<subseteq> y"
  proof
    fix c assume "c \<in> chains S"
    show "\<exists>y \<in> S. \<forall>z \<in> c. z \<subseteq> y"
    proof cases
      txt \<open>If \<open>c\<close> is an empty chain, then every element in \<open>S\<close> is an upper
        bound of \<open>c\<close>.\<close>

      assume "c = {}"
      with aS show ?thesis by fast

      txt \<open>If \<open>c\<close> is non-empty, then \<open>\<Union>c\<close> is an upper bound of \<open>c\<close>, lying in
        \<open>S\<close>.\<close>
    next
      assume "c \<noteq> {}"
      show ?thesis
      proof
        show "\<forall>z \<in> c. z \<subseteq> \<Union>c" by fast
        show "\<Union>c \<in> S"
        proof (rule r)
          from \<open>c \<noteq> {}\<close> show "\<exists>x. x \<in> c" by fast
          show "c \<in> chains S" by fact
        qed
      qed
    qed
  qed
qed

end


(*  Title:      ZF/Induct/PropLog.thy
    Author:     Tobias Nipkow & Lawrence C Paulson
    Copyright   1993  University of Cambridge
*)

section \<open>Meta-theory of propositional logic\<close>

theory PropLog imports ZF begin

text \<open>
  Datatype definition of propositional logic formulae and inductive
  definition of the propositional tautologies.

  Inductive definition of propositional logic.  Soundness and
  completeness w.r.t.\ truth-tables.

  Prove: If \<open>H |= p\<close> then \<open>G |= p\<close> where \<open>G \<in>
  Fin(H)\<close>
\<close>

subsection \<open>The datatype of propositions\<close>

consts
  propn :: i

datatype propn =
    Fls
  | Var ("n \<in> nat")    (\<open>#_\<close> [100] 100)
  | Imp ("p \<in> propn", "q \<in> propn")    (infixr \<open>\<Rightarrow>\<close> 90)

subsection \<open>The proof system\<close>

consts thms     :: "i \<Rightarrow> i"

abbreviation
  thms_syntax :: "[i,i] \<Rightarrow> o"    (infixl \<open>|-\<close> 50)
  where "H |- p \<equiv> p \<in> thms(H)"

inductive
  domains "thms(H)" \<subseteq> "propn"
  intros
    H:  "\<lbrakk>p \<in> H;  p \<in> propn\<rbrakk> \<Longrightarrow> H |- p"
    K:  "\<lbrakk>p \<in> propn;  q \<in> propn\<rbrakk> \<Longrightarrow> H |- p\<Rightarrow>q\<Rightarrow>p"
    S:  "\<lbrakk>p \<in> propn;  q \<in> propn;  r \<in> propn\<rbrakk>
         \<Longrightarrow> H |- (p\<Rightarrow>q\<Rightarrow>r) \<Rightarrow> (p\<Rightarrow>q) \<Rightarrow> p\<Rightarrow>r"
    DN: "p \<in> propn \<Longrightarrow> H |- ((p\<Rightarrow>Fls) \<Rightarrow> Fls) \<Rightarrow> p"
    MP: "\<lbrakk>H |- p\<Rightarrow>q;  H |- p;  p \<in> propn;  q \<in> propn\<rbrakk> \<Longrightarrow> H |- q"
  type_intros "propn.intros"

declare propn.intros [simp]

subsection \<open>The semantics\<close>

subsubsection \<open>Semantics of propositional logic.\<close>

consts
  is_true_fun :: "[i,i] \<Rightarrow> i"
primrec
  "is_true_fun(Fls, t) = 0"
  "is_true_fun(Var(v), t) = (if v \<in> t then 1 else 0)"
  "is_true_fun(p\<Rightarrow>q, t) = (if is_true_fun(p,t) = 1 then is_true_fun(q,t) else 1)"

definition
  is_true :: "[i,i] \<Rightarrow> o"  where
  "is_true(p,t) \<equiv> is_true_fun(p,t) = 1"
  \<comment> \<open>this definition is required since predicates can't be recursive\<close>

lemma is_true_Fls [simp]: "is_true(Fls,t) \<longleftrightarrow> False"
  by (simp add: is_true_def)

lemma is_true_Var [simp]: "is_true(#v,t) \<longleftrightarrow> v \<in> t"
  by (simp add: is_true_def)

lemma is_true_Imp [simp]: "is_true(p\<Rightarrow>q,t) \<longleftrightarrow> (is_true(p,t)\<longrightarrow>is_true(q,t))"
  by (simp add: is_true_def)

subsubsection \<open>Logical consequence\<close>

text \<open>
  For every valuation, if all elements of \<open>H\<close> are true then so
  is \<open>p\<close>.
\<close>

definition
  logcon :: "[i,i] \<Rightarrow> o"    (infixl \<open>|=\<close> 50)  where
  "H |= p \<equiv> \<forall>t. (\<forall>q \<in> H. is_true(q,t)) \<longrightarrow> is_true(p,t)"

text \<open>
  A finite set of hypotheses from \<open>t\<close> and the \<open>Var\<close>s in
  \<open>p\<close>.
\<close>

consts
  hyps :: "[i,i] \<Rightarrow> i"
primrec
  "hyps(Fls, t) = 0"
  "hyps(Var(v), t) = (if v \<in> t then {#v} else {#v\<Rightarrow>Fls})"
  "hyps(p\<Rightarrow>q, t) = hyps(p,t) \<union> hyps(q,t)"

subsection \<open>Proof theory of propositional logic\<close>

lemma thms_mono: "G \<subseteq> H \<Longrightarrow> thms(G) \<subseteq> thms(H)"
    unfolding thms.defs
  apply (rule lfp_mono)
    apply (rule thms.bnd_mono)+
  apply (assumption | rule univ_mono basic_monos)+
  done

lemmas thms_in_pl = thms.dom_subset [THEN subsetD]

inductive_cases ImpE: "p\<Rightarrow>q \<in> propn"

lemma thms_MP: "\<lbrakk>H |- p\<Rightarrow>q;  H |- p\<rbrakk> \<Longrightarrow> H |- q"
  \<comment> \<open>Stronger Modus Ponens rule: no typechecking!\<close>
  apply (rule thms.MP)
     apply (erule asm_rl thms_in_pl thms_in_pl [THEN ImpE])+
  done

lemma thms_I: "p \<in> propn \<Longrightarrow> H |- p\<Rightarrow>p"
  \<comment> \<open>Rule is called \<open>I\<close> for Identity Combinator, not for Introduction.\<close>
  apply (rule thms.S [THEN thms_MP, THEN thms_MP])
      apply (rule_tac [5] thms.K)
       apply (rule_tac [4] thms.K)
         apply simp_all
  done

subsubsection \<open>Weakening, left and right\<close>

lemma weaken_left: "\<lbrakk>G \<subseteq> H;  G|-p\<rbrakk> \<Longrightarrow> H|-p"
  \<comment> \<open>Order of premises is convenient with \<open>THEN\<close>\<close>
  by (erule thms_mono [THEN subsetD])

lemma weaken_left_cons: "H |- p \<Longrightarrow> cons(a,H) |- p"
  by (erule subset_consI [THEN weaken_left])

lemmas weaken_left_Un1  = Un_upper1 [THEN weaken_left]
lemmas weaken_left_Un2  = Un_upper2 [THEN weaken_left]

lemma weaken_right: "\<lbrakk>H |- q;  p \<in> propn\<rbrakk> \<Longrightarrow> H |- p\<Rightarrow>q"
  by (simp_all add: thms.K [THEN thms_MP] thms_in_pl)

subsubsection \<open>The deduction theorem\<close>

theorem deduction: "\<lbrakk>cons(p,H) |- q;  p \<in> propn\<rbrakk> \<Longrightarrow>  H |- p\<Rightarrow>q"
  apply (erule thms.induct)
      apply (blast intro: thms_I thms.H [THEN weaken_right])
     apply (blast intro: thms.K [THEN weaken_right])
    apply (blast intro: thms.S [THEN weaken_right])
   apply (blast intro: thms.DN [THEN weaken_right])
  apply (blast intro: thms.S [THEN thms_MP [THEN thms_MP]])
  done

subsubsection \<open>The cut rule\<close>

lemma cut: "\<lbrakk>H|-p;  cons(p,H) |- q\<rbrakk> \<Longrightarrow>  H |- q"
  apply (rule deduction [THEN thms_MP])
    apply (simp_all add: thms_in_pl)
  done

lemma thms_FlsE: "\<lbrakk>H |- Fls; p \<in> propn\<rbrakk> \<Longrightarrow> H |- p"
  apply (rule thms.DN [THEN thms_MP])
   apply (rule_tac [2] weaken_right)
    apply (simp_all add: propn.intros)
  done

lemma thms_notE: "\<lbrakk>H |- p\<Rightarrow>Fls;  H |- p;  q \<in> propn\<rbrakk> \<Longrightarrow> H |- q"
  by (erule thms_MP [THEN thms_FlsE])

subsubsection \<open>Soundness of the rules wrt truth-table semantics\<close>

theorem soundness: "H |- p \<Longrightarrow> H |= p"
    unfolding logcon_def
  apply (induct set: thms)
      apply auto
  done

subsection \<open>Completeness\<close>

subsubsection \<open>Towards the completeness proof\<close>

lemma Fls_Imp: "\<lbrakk>H |- p\<Rightarrow>Fls; q \<in> propn\<rbrakk> \<Longrightarrow> H |- p\<Rightarrow>q"
  apply (frule thms_in_pl)
  apply (rule deduction)
   apply (rule weaken_left_cons [THEN thms_notE])
     apply (blast intro: thms.H elim: ImpE)+
  done

lemma Imp_Fls: "\<lbrakk>H |- p;  H |- q\<Rightarrow>Fls\<rbrakk> \<Longrightarrow> H |- (p\<Rightarrow>q)\<Rightarrow>Fls"
  apply (frule thms_in_pl)
  apply (frule thms_in_pl [of concl: "q\<Rightarrow>Fls"])
  apply (rule deduction)
   apply (erule weaken_left_cons [THEN thms_MP])
   apply (rule consI1 [THEN thms.H, THEN thms_MP])
    apply (blast intro: weaken_left_cons elim: ImpE)+
  done

lemma hyps_thms_if:
    "p \<in> propn \<Longrightarrow> hyps(p,t) |- (if is_true(p,t) then p else p\<Rightarrow>Fls)"
  \<comment> \<open>Typical example of strengthening the induction statement.\<close>
  apply simp
  apply (induct_tac p)
    apply (simp_all add: thms_I thms.H)
  apply (safe elim!: Fls_Imp [THEN weaken_left_Un1] Fls_Imp [THEN weaken_left_Un2])
  apply (blast intro: weaken_left_Un1 weaken_left_Un2 weaken_right Imp_Fls)+
  done

lemma logcon_thms_p: "\<lbrakk>p \<in> propn;  0 |= p\<rbrakk> \<Longrightarrow> hyps(p,t) |- p"
  \<comment> \<open>Key lemma for completeness; yields a set of assumptions satisfying \<open>p\<close>\<close>
  apply (drule hyps_thms_if)
  apply (simp add: logcon_def)
  done

text \<open>
  For proving certain theorems in our new propositional logic.
\<close>

lemmas propn_SIs = propn.intros deduction
  and propn_Is = thms_in_pl thms.H thms.H [THEN thms_MP]

text \<open>
  The excluded middle in the form of an elimination rule.
\<close>

lemma thms_excluded_middle:
    "\<lbrakk>p \<in> propn;  q \<in> propn\<rbrakk> \<Longrightarrow> H |- (p\<Rightarrow>q) \<Rightarrow> ((p\<Rightarrow>Fls)\<Rightarrow>q) \<Rightarrow> q"
  apply (rule deduction [THEN deduction])
    apply (rule thms.DN [THEN thms_MP])
     apply (best intro!: propn_SIs intro: propn_Is)+
  done

lemma thms_excluded_middle_rule:
  "\<lbrakk>cons(p,H) |- q;  cons(p\<Rightarrow>Fls,H) |- q;  p \<in> propn\<rbrakk> \<Longrightarrow> H |- q"
  \<comment> \<open>Hard to prove directly because it requires cuts\<close>
  apply (rule thms_excluded_middle [THEN thms_MP, THEN thms_MP])
     apply (blast intro!: propn_SIs intro: propn_Is)+
  done

subsubsection \<open>Completeness -- lemmas for reducing the set of assumptions\<close>

text \<open>
  For the case \<^prop>\<open>hyps(p,t)-cons(#v,Y) |- p\<close> we also have \<^prop>\<open>hyps(p,t)-{#v} \<subseteq> hyps(p, t-{v})\<close>.
\<close>

lemma hyps_Diff:
    "p \<in> propn \<Longrightarrow> hyps(p, t-{v}) \<subseteq> cons(#v\<Rightarrow>Fls, hyps(p,t)-{#v})"
  by (induct set: propn) auto

text \<open>
  For the case \<^prop>\<open>hyps(p,t)-cons(#v \<Rightarrow> Fls,Y) |- p\<close> we also have
  \<^prop>\<open>hyps(p,t)-{#v\<Rightarrow>Fls} \<subseteq> hyps(p, cons(v,t))\<close>.
\<close>

lemma hyps_cons:
    "p \<in> propn \<Longrightarrow> hyps(p, cons(v,t)) \<subseteq> cons(#v, hyps(p,t)-{#v\<Rightarrow>Fls})"
  by (induct set: propn) auto

text \<open>Two lemmas for use with \<open>weaken_left\<close>\<close>

lemma cons_Diff_same: "B-C \<subseteq> cons(a, B-cons(a,C))"
  by blast

lemma cons_Diff_subset2: "cons(a, B-{c}) - D \<subseteq> cons(a, B-cons(c,D))"
  by blast

text \<open>
  The set \<^term>\<open>hyps(p,t)\<close> is finite, and elements have the form
  \<^term>\<open>#v\<close> or \<^term>\<open>#v\<Rightarrow>Fls\<close>; could probably prove the stronger
  \<^prop>\<open>hyps(p,t) \<in> Fin(hyps(p,0) \<union> hyps(p,nat))\<close>.
\<close>

lemma hyps_finite: "p \<in> propn \<Longrightarrow> hyps(p,t) \<in> Fin(\<Union>v \<in> nat. {#v, #v\<Rightarrow>Fls})"
  by (induct set: propn) auto

lemmas Diff_weaken_left = Diff_mono [OF _ subset_refl, THEN weaken_left]

text \<open>
  Induction on the finite set of assumptions \<^term>\<open>hyps(p,t0)\<close>.  We
  may repeatedly subtract assumptions until none are left!
\<close>

lemma completeness_0_lemma [rule_format]:
    "\<lbrakk>p \<in> propn;  0 |= p\<rbrakk> \<Longrightarrow> \<forall>t. hyps(p,t) - hyps(p,t0) |- p"
  apply (frule hyps_finite)
  apply (erule Fin_induct)
   apply (simp add: logcon_thms_p Diff_0)
  txt \<open>inductive step\<close>
  apply safe
   txt \<open>Case \<^prop>\<open>hyps(p,t)-cons(#v,Y) |- p\<close>\<close>
   apply (rule thms_excluded_middle_rule)
     apply (erule_tac [3] propn.intros)
    apply (blast intro: cons_Diff_same [THEN weaken_left])
   apply (blast intro: cons_Diff_subset2 [THEN weaken_left]
     hyps_Diff [THEN Diff_weaken_left])
  txt \<open>Case \<^prop>\<open>hyps(p,t)-cons(#v \<Rightarrow> Fls,Y) |- p\<close>\<close>
  apply (rule thms_excluded_middle_rule)
    apply (erule_tac [3] propn.intros)
   apply (blast intro: cons_Diff_subset2 [THEN weaken_left]
     hyps_cons [THEN Diff_weaken_left])
  apply (blast intro: cons_Diff_same [THEN weaken_left])
  done

subsubsection \<open>Completeness theorem\<close>

lemma completeness_0: "\<lbrakk>p \<in> propn;  0 |= p\<rbrakk> \<Longrightarrow> 0 |- p"
  \<comment> \<open>The base case for completeness\<close>
  apply (rule Diff_cancel [THEN subst])
  apply (blast intro: completeness_0_lemma)
  done

lemma logcon_Imp: "\<lbrakk>cons(p,H) |= q\<rbrakk> \<Longrightarrow> H |= p\<Rightarrow>q"
  \<comment> \<open>A semantic analogue of the Deduction Theorem\<close>
  by (simp add: logcon_def)

lemma completeness:
     "H \<in> Fin(propn) \<Longrightarrow> p \<in> propn \<Longrightarrow> H |= p \<Longrightarrow> H |- p"
  apply (induct arbitrary: p set: Fin)
   apply (safe intro!: completeness_0)
  apply (rule weaken_left_cons [THEN thms_MP])
   apply (blast intro!: logcon_Imp propn.intros)
  apply (blast intro: propn_Is)
  done

theorem thms_iff: "H \<in> Fin(propn) \<Longrightarrow> H |- p \<longleftrightarrow> H |= p \<and> p \<in> propn"
  by (blast intro: soundness completeness thms_in_pl)

end


section \<open>Deciding the Generalized Multiset Ordering is NP-hard\<close>

text \<open>We prove that satisfiability of conjunctive normal forms (a NP-hard problem) can
  be encoded into a multiset-comparison problem of linear size. Therefore multiset-set comparisons
  are NP-hard as well.\<close>

theory
  Multiset_Ordering_NP_Hard
imports
  Multiset_Ordering_More
  Propositional_Formula
  Weighted_Path_Order.Multiset_Extension2_Impl (* for executability *)
begin

subsection \<open>Definition of the Encoding\<close>

text \<open>The multiset-elements are either annotated variables or indices (of clauses).
  We basically follow the proof in \<^cite>\<open>"RPO_NPC"\<close> where these elements are encoded as terms
  (and the relation is some fixed recursive path order).\<close>

datatype Annotation = Unsigned | Positive | Negative

type_synonym 'a ms_elem = "('a \<times> Annotation) + nat"

fun ms_elem_of_lit :: "'a \<times> bool \<Rightarrow> 'a ms_elem" where
  "ms_elem_of_lit (x,True) = Inl (x,Positive)"
| "ms_elem_of_lit (x,False) = Inl (x,Negative)"

definition vars_of_cnf :: "'a cnf \<Rightarrow> 'a list" where
  "vars_of_cnf = (remdups o concat o map (map fst))"

text \<open>We encode a CNF into a multiset-problem, i.e., a quadruple (xs, ys, S, NS) where
  xs and ys are the lists to compare, and S and NS are underlying relations of the generalized multiset ordering.
  In the encoding, we add the strict relation S to the non-strict relation NS as this is a somewhat more
  natural order. In particular, the relations S and NS are precisely those that are obtained when using
  the mentioned recursive path order of \<^cite>\<open>"RPO_NPC"\<close>.\<close>

definition multiset_problem_of_cnf :: "'a cnf \<Rightarrow>
  ('a ms_elem list \<times>
   'a ms_elem list \<times>
   ('a ms_elem \<times> 'a ms_elem)list \<times>
   ('a ms_elem \<times> 'a ms_elem)list)" where
  "multiset_problem_of_cnf cnf = (let
     xs = vars_of_cnf cnf;
     cs = [0 ..< length cnf];
     S = List.maps (\<lambda> i. map (\<lambda> l. (ms_elem_of_lit l, Inr i)) (cnf ! i)) cs;
     NS = List.maps (\<lambda> x. [(Inl (x,Positive), Inl (x,Unsigned)), (Inl (x,Negative), Inl (x,Unsigned))]) xs
     in (List.maps (\<lambda> x. [Inl (x,Positive), Inl (x,Negative)]) xs,
         map (\<lambda> x. Inl (x,Unsigned)) xs @ map Inr cs,
         S, NS @ S))"

subsection \<open>Soundness of the Encoding\<close>

lemma multiset_problem_of_cnf:
  assumes "multiset_problem_of_cnf cnf = (left, right, S, NSS)"
  shows "(\<exists> \<beta>. eval_cnf \<beta> cnf)
     \<longleftrightarrow> ((mset left, mset right) \<in> ns_mul_ext (set NSS) (set S))"
  "cnf \<noteq> [] \<Longrightarrow> (\<exists> \<beta>. eval_cnf \<beta> cnf)
     \<longleftrightarrow> ((mset left, mset right) \<in> s_mul_ext (set NSS) (set S))"
proof -
  define xs where "xs = vars_of_cnf cnf"
  define cs where "cs = [0 ..< length cnf]"
  define NS :: "('a ms_elem \<times> 'a ms_elem)list" where "NS = concat (map (\<lambda> x. [(Inl (x,Positive), Inl (x,Unsigned)), (Inl (x,Negative), Inl (x,Unsigned))]) xs)"
  note res = assms[unfolded multiset_problem_of_cnf_def Let_def List.maps_def, folded xs_def cs_def]
  have S: "S = concat (map (\<lambda> i. map (\<lambda> l. (ms_elem_of_lit l, Inr i)) (cnf ! i)) cs)"
    using res by auto
  have NSS: "NSS = NS @ S" unfolding S NS_def using res by auto
  have left: "left = concat (map (\<lambda> x. [Inl (x,Positive), Inl (x,Negative)]) xs)"
    using res by auto
  let ?nsright = "map (\<lambda> x. Inl (x,Unsigned)) xs"
  let ?sright = "map Inr cs :: 'a ms_elem list"
  have right: "right = ?nsright @ ?sright"
    using res by auto

  text \<open>We first consider completeness: if the formula is sat, then the lists are decreasing w.r.t. the multiset-order.\<close>
  {
    assume "(\<exists> \<beta>. eval_cnf \<beta> cnf)"
    then obtain \<beta> where sat: "eval \<beta> (formula_of_cnf cnf)" unfolding eval_cnf_def by auto
    define f :: "'a ms_elem \<Rightarrow> bool" where
      "f = (\<lambda> c. case c of (Inl (x,sign)) \<Rightarrow> (\<beta> x \<longleftrightarrow> sign = Negative))"
    let ?nsleft = "filter f left"
    let ?sleft = "filter (Not o f) left"
    have id_left: "mset left = mset ?nsleft + mset ?sleft" by simp
    have id_right: "mset right = mset ?nsright + mset ?sright" unfolding right by auto
    have nsleft: "?nsleft = map (\<lambda> x. ms_elem_of_lit (x, \<not> (\<beta> x))) xs"
      unfolding left f_def by (induct xs, auto)
    have sleft: "?sleft = map (\<lambda> x. ms_elem_of_lit (x,\<beta> x)) xs"
      unfolding left f_def by (induct xs, auto)
    have len: "length ?nsleft = length ?nsright" unfolding nsleft by simp
    {
      fix i
      assume i: "i < length ?nsright"
      define x where "x = xs ! i"
      have x: "x \<in> set xs" unfolding x_def using i by auto
      have "(?nsleft ! i, ?nsright ! i) = (ms_elem_of_lit (x,\<not> \<beta> x), Inl (x,Unsigned))"
        unfolding nsleft x_def using i by auto
      also have "\<dots> \<in> set NS" unfolding NS_def using x by (cases "\<beta> x", auto)
      finally have "(?nsleft ! i, ?nsright ! i) \<in> set NSS" unfolding NSS by auto
    } note non_strict = this
    {
      fix t
      assume "t \<in> set ?sright"
      then obtain i where i: "i \<in> set cs" and t: "t = Inr i" by auto
      define c where "c = cnf ! i"
      from i have ii: "i < length cnf" unfolding cs_def by auto
      have c: "c \<in> set cnf" using i unfolding c_def cs_def by auto
      from sat[unfolded formula_of_cnf_def] c
      have "eval \<beta> (Disj (map formula_of_lit c))" unfolding o_def by auto
      then obtain l where l: "l \<in> set c" and eval: "eval \<beta> (formula_of_lit l)"
        by auto
      obtain x b where "l = (x, b)" by (cases l, auto)
      with eval have lx: "l = (x, \<beta> x)" by (cases b, auto)
      from l c lx have x: "x \<in> set xs" unfolding xs_def vars_of_cnf_def by force
      have mem: "(ms_elem_of_lit l) \<in> set ?sleft" unfolding sleft lx using x by auto
      have "\<exists> s \<in> set ?sleft. (s,t) \<in> set S"
      proof (intro bexI[OF _ mem])
        show "(ms_elem_of_lit l, t) \<in> set S"
          unfolding t S cs_def using ii l c_def
          by (auto intro!: bexI[of _ i])
      qed
    } note strict = this

    have NS: "((mset left, mset right) \<in> ns_mul_ext (set NSS) (set S))"
      by (intro ns_mul_ext_intro[OF id_left id_right len non_strict strict])
    {
      assume ne: "cnf \<noteq> []"
      then obtain c where c: "c \<in> set cnf" by (cases cnf, auto)
      with sat[unfolded formula_of_cnf_def]
      have "eval \<beta> (Disj (map formula_of_lit c))" by auto
      then obtain x where x: "x \<in> set xs"
        using c unfolding vars_of_cnf_def xs_def by (cases c; cases "snd (hd c)"; force)
      have S: "((mset left, mset right) \<in> s_mul_ext (set NSS) (set S))"
      proof (intro s_mul_ext_intro[OF id_left id_right len non_strict _ strict])
        show "?sleft \<noteq> []"  unfolding sleft using x by auto
      qed
    } note S = this
    note NS S
  } note one_direction = this

  text \<open>We next consider soundness: if the lists are decreasing w.r.t. the multiset-order, then
    the cnf is sat.\<close>
  {
    assume "((mset left, mset right) \<in> ns_mul_ext (set NSS) (set S))
      \<or> ((mset left, mset right) \<in> s_mul_ext (set NSS) (set S))"
    hence "((mset left, mset right) \<in> ns_mul_ext (set NSS) (set S))"
      using s_ns_mul_ext by auto
    also have "ns_mul_ext (set NSS) (set S) = ns_mul_ext (set NS) (set S)"
      unfolding NSS set_append by (rule ns_mul_ext_NS_union_S)
    finally have "(mset left, mset right) \<in> ns_mul_ext (set NS) (set S)" .
    from ns_mul_ext_elim[OF this]
    obtain ns_left s_left ns_right s_right
      where id_left: "mset left = mset ns_left + mset s_left"
       and id_right: "mset right = mset ns_right + mset s_right"
       and len: "length ns_left = length ns_right"
       and ns: "\<And> i. i<length ns_right \<Longrightarrow> (ns_left ! i, ns_right ! i) \<in> set NS"
       and s: "\<And> t. t\<in>set s_right \<Longrightarrow> \<exists>s\<in>set s_left. (s, t) \<in> set S" by blast

    text \<open>This is the satisfying assignment\<close>
    define \<beta> where "\<beta> x = (ms_elem_of_lit (x,True) \<in> set s_left)" for x
    {
      fix c
      assume ccnf: "c \<in> set cnf"
      then obtain i where i: "i \<in> set cs"
        and c_def: "c = cnf ! i"
        and ii: "i < length cnf"
        unfolding cs_def set_conv_nth by force

      from i have "Inr i \<in># mset right" unfolding right by auto
      from this[unfolded id_right] have "Inr i \<in> set ns_right \<or> Inr i \<in> set s_right" by auto
      hence "Inr i \<in> set s_right" using ns[unfolded NSS NS_def]
        unfolding set_conv_nth[of ns_right] by force
      from s[OF this] obtain s where sleft: "s \<in> set s_left" and si: "(s, Inr i) \<in> set S" by auto
      from si[unfolded S, simplified] obtain l where
        lc: "l \<in> set c" and sl: "s = ms_elem_of_lit l" unfolding c_def cs_def using ii by blast
      obtain x b where lxb: "l = (x,b)" by force
      from lc lxb ccnf have x: "x \<in> set xs" unfolding xs_def vars_of_cnf_def by force
      have "\<exists>l\<in>set c. eval \<beta> (formula_of_lit l)"
      proof (intro bexI[OF _ lc])
        from sleft[unfolded sl lxb]
        have mem: "ms_elem_of_lit (x, b) \<in> set s_left" by auto
        have "\<beta> x = b"
        proof (cases b)
          case True
          thus ?thesis unfolding \<beta>_def using mem by auto
        next
          case False
          show ?thesis
          proof (rule ccontr)
            assume "\<beta> x \<noteq> b"
            with False have "\<beta> x" by auto
            with False mem
            have "ms_elem_of_lit (x, True) \<in> set s_left"
              "ms_elem_of_lit (x, False) \<in> set s_left"
              unfolding \<beta>_def by auto
            hence mem: "ms_elem_of_lit (x, b) \<in> set s_left" for b by (cases b, auto)

            have dist: "distinct left" unfolding left
              by (intro distinct_concat, auto simp: distinct_map xs_def vars_of_cnf_def cs_def intro!: inj_onI)
            from id_left have "mset left = mset (ns_left @ s_left)" by auto
            from mset_eq_imp_distinct_iff[OF this] dist have "set ns_left \<inter> set s_left = {}" by auto
            with mem have nmem: "ms_elem_of_lit (x,b) \<notin> set ns_left" for b by auto
            have "Inl (x, Unsigned) \<in># mset right" unfolding right using x by auto
            from this[unfolded id_right]
            have "Inl (x, Unsigned) \<in> set ns_right \<union> set s_right" by auto
            with s[unfolded S] have "Inl (x, Unsigned) \<in> set ns_right" by auto
            with ns obtain s where pair: "(s, Inl (x, Unsigned)) \<in> set NS" and sns: "s \<in> set ns_left"
              unfolding set_conv_nth[of ns_right] using len by force
            from pair[unfolded NSS] have pair: "(s, Inl (x, Unsigned)) \<in> set NS" by auto
            from pair[unfolded NS_def, simplified] have "s = Inl (x, Positive) \<or> s = Inl (x, Negative)" by auto
            from sns this nmem[of True] nmem[of False] show False by auto
          qed
        qed
        thus "eval \<beta> (formula_of_lit l)" unfolding lxb by (cases b, auto)
      qed
    }
    hence "eval \<beta> (formula_of_cnf cnf)" unfolding formula_of_cnf_def o_def by auto
    hence "\<exists> \<beta>. eval_cnf \<beta> cnf" unfolding eval_cnf_def by auto
  } note other_direction = this

  from one_direction other_direction show "(\<exists> \<beta>. eval_cnf \<beta> cnf)
     \<longleftrightarrow> ((mset left, mset right) \<in> ns_mul_ext (set NSS) (set S))"
    by blast
  show "cnf \<noteq> [] \<Longrightarrow> (\<exists> \<beta>. eval_cnf \<beta> cnf)
     \<longleftrightarrow> ((mset left, mset right) \<in> s_mul_ext (set NSS) (set S))"
    using one_direction other_direction by blast
qed

lemma multiset_problem_of_cnf_mul_ext:
  assumes "multiset_problem_of_cnf cnf = (xs, ys, S, NS)"
  and non_trivial: "cnf \<noteq> []"
  shows "(\<exists> \<beta>. eval_cnf \<beta> cnf)
     \<longleftrightarrow> mul_ext (\<lambda> a b. ((a,b) \<in> set S, (a,b) \<in> set NS)) xs ys = (True,True)"
proof -
  have "(\<exists> \<beta>. eval_cnf \<beta> cnf) = ((\<exists> \<beta>. eval_cnf \<beta> cnf) \<and> (\<exists> \<beta>. eval_cnf \<beta> cnf))"
    by simp
  also have "\<dots> = (((mset xs, mset ys) \<in> s_mul_ext (set NS) (set S)) \<and> ((mset xs, mset ys) \<in> ns_mul_ext (set NS) (set S)))"
    by (subst multiset_problem_of_cnf(1)[symmetric, OF assms(1)], subst multiset_problem_of_cnf(2)[symmetric, OF assms], simp)
  also have "\<dots> = (mul_ext (\<lambda> a b. ((a,b) \<in> set S, (a,b) \<in> set NS)) xs ys = (True,True))"
    unfolding mul_ext_def Let_def by auto
  finally show ?thesis .
qed

subsection \<open>Size of Encoding is Linear\<close>

lemma size_of_multiset_problem_of_cnf: assumes "multiset_problem_of_cnf cnf = (xs, ys, S, NS)"
  and "size_cnf cnf = s"
shows "length xs \<le> 2 * s" "length ys \<le> 2 * s" "length S \<le> s" "length NS \<le> 3 * s"
proof -
  define vs where "vs = vars_of_cnf cnf"
  have lvs: "length vs \<le> s" unfolding assms(2)[symmetric] vs_def vars_of_cnf_def o_def size_cnf_def
    by (rule order.trans[OF length_remdups_leq], induct cnf, auto)
  have lcnf: "length cnf \<le> s" using assms(2) unfolding size_cnf_def by auto
  note res = assms(1)[unfolded multiset_problem_of_cnf_def Let_def List.maps_def, folded vs_def, simplified]
  have xs: "xs = concat (map (\<lambda>x. [Inl (x, Positive), Inl (x, Negative)]) vs)" using res by auto
  have "length xs \<le> length vs + length vs" unfolding xs by (induct vs, auto)
  also have "\<dots> \<le> 2 * s" using lvs by auto
  finally show "length xs \<le> 2 * s" .
  have "length ys = length (map (\<lambda>x. Inl (x, Unsigned)) vs @ map Inr [0..<length cnf])" using res by auto
  also have "\<dots> \<le> 2 * s" using lvs lcnf by auto
  finally show "length ys \<le> 2 * s" .
  have S: "S = concat (map (\<lambda>i. map (\<lambda>l. (ms_elem_of_lit l, Inr i)) (cnf ! i)) [0..<length cnf])"
    using res by simp
  have "length S = sum_list (map length cnf)"
    unfolding S length_concat map_map o_def length_map
    by (rule arg_cong[of _ _ sum_list], intro nth_equalityI, auto)
  also have "\<dots> \<le> s" using assms(2) unfolding size_cnf_def by auto
  finally show S: "length S \<le> s" .
  have NS: "NS = concat (map (\<lambda>x. [(Inl (x, Positive), Inl (x, Unsigned)), (Inl (x, Annotation.Negative), Inl (x, Unsigned))]) vs) @ S"
    using res by auto
  have "length NS = 2 * length vs + length S"
    unfolding NS by (induct vs, auto)
  also have "\<dots> \<le> 3 * s" using lvs S by auto
  finally show "length NS \<le> 3 * s" .
qed

subsection \<open>Check Executability\<close>

value (code) "case multiset_problem_of_cnf [
  [(''x'',True),(''y'',False)],              \<comment> \<open>clause 0\<close>
  [(''x'',False)],                           \<comment> \<open>clause 1\<close>
  [(''y'',True),(''z'',True)],               \<comment> \<open>clause 2\<close>
  [(''x'',True),(''y'',True),(''z'',False)]] \<comment> \<open>clause 3\<close>
   of (left,right,S,NS) \<Rightarrow> (''SAT: '', mul_ext (\<lambda> x y. ((x,y) \<in> set S, (x,y) \<in> set NS)) left right = (True,True),
      ''Encoding: '', left, '' >mul '', right, ''strict element order: '', S,''non-strict: '', NS)"

end


section\<open>Renaming of variables in internalized formulas\<close>

theory Renaming
  imports
    Nat_Miscellanea
    "ZF-Constructible.Formula"
begin

lemma app_nm :
  assumes "n\<in>nat" "m\<in>nat" "f\<in>n\<rightarrow>m" "x \<in> nat"
  shows "f`x \<in> nat"
proof(cases "x\<in>n")
  case True
  then show ?thesis using assms in_n_in_nat apply_type by simp
next
  case False
  then show ?thesis using assms apply_0 domain_of_fun by simp
qed

subsection\<open>Renaming of free variables\<close>

definition
  union_fun :: "[i,i,i,i] \<Rightarrow> i" where
  "union_fun(f,g,m,p) \<equiv> \<lambda>j \<in> m \<union> p  . if j\<in>m then f`j else g`j"

lemma union_fun_type:
  assumes "f \<in> m \<rightarrow> n"
    "g \<in> p \<rightarrow> q"
  shows "union_fun(f,g,m,p) \<in> m \<union> p \<rightarrow> n \<union> q"
proof -
  let ?h="union_fun(f,g,m,p)"
  have
    D: "?h`x \<in> n \<union> q" if "x \<in> m \<union> p" for x
  proof (cases "x \<in> m")
    case True
    then have
      "x \<in> m \<union> p" by simp
    with \<open>x\<in>m\<close>
    have "?h`x = f`x"
      unfolding union_fun_def  beta by simp
    with \<open>f \<in> m \<rightarrow> n\<close> \<open>x\<in>m\<close>
    have "?h`x \<in> n" by simp
    then show ?thesis ..
  next
    case False
    with \<open>x \<in> m \<union> p\<close>
    have "x \<in> p"
      by auto
    with \<open>x\<notin>m\<close>
    have "?h`x = g`x"
      unfolding union_fun_def using beta by simp
    with \<open>g \<in> p \<rightarrow> q\<close> \<open>x\<in>p\<close>
    have "?h`x \<in> q" by simp
    then show ?thesis ..
  qed
  have A:"function(?h)" unfolding union_fun_def using function_lam by simp
  have " x\<in> (m \<union> p) \<times> (n \<union> q)" if "x\<in> ?h" for x
    using that lamE[of x "m \<union> p" _ "x \<in> (m \<union> p) \<times> (n \<union> q)"] D unfolding union_fun_def
    by auto
  then have B:"?h \<subseteq> (m \<union> p) \<times> (n \<union> q)" ..
  have "m \<union> p \<subseteq> domain(?h)"
    unfolding union_fun_def using domain_lam by simp
  with A B
  show ?thesis using  Pi_iff [THEN iffD2] by simp
qed

lemma union_fun_action :
  assumes
    "env \<in> list(M)"
    "env' \<in> list(M)"
    "length(env) = m \<union> p"
    "\<forall> i . i \<in> m \<longrightarrow>  nth(f`i,env') = nth(i,env)"
    "\<forall> j . j \<in> p \<longrightarrow> nth(g`j,env') = nth(j,env)"
  shows "\<forall> i . i \<in> m \<union> p \<longrightarrow>
          nth(i,env) = nth(union_fun(f,g,m,p)`i,env')"
proof -
  let ?h = "union_fun(f,g,m,p)"
  have "nth(x, env) = nth(?h`x,env')" if "x \<in> m \<union> p" for x
    using that
  proof (cases "x\<in>m")
    case True
    with \<open>x\<in>m\<close>
    have "?h`x = f`x"
      unfolding union_fun_def  beta by simp
    with assms \<open>x\<in>m\<close>
    have "nth(x,env) = nth(?h`x,env')" by simp
    then show ?thesis .
  next
    case False
    with \<open>x \<in> m \<union> p\<close>
    have
      "x \<in> p" "x\<notin>m"  by auto
    then
    have "?h`x = g`x"
      unfolding union_fun_def beta by simp
    with assms \<open>x\<in>p\<close>
    have "nth(x,env) = nth(?h`x,env')" by simp
    then show ?thesis .
  qed
  then show ?thesis by simp
qed

lemma id_fn_type :
  assumes "n \<in> nat"
  shows "id(n) \<in> n \<rightarrow> n"
  unfolding id_def using \<open>n\<in>nat\<close> by simp

lemma id_fn_action:
  assumes "n \<in> nat" "env\<in>list(M)"
  shows "\<And> j . j < n \<Longrightarrow> nth(j,env) = nth(id(n)`j,env)"
proof -
  show "nth(j,env) = nth(id(n)`j,env)" if "j < n" for j using that \<open>n\<in>nat\<close> ltD by simp
qed

definition
  sum :: "[i,i,i,i,i] \<Rightarrow> i" where
  "sum(f,g,m,n,p) \<equiv> \<lambda>j \<in> m#+p  . if j<m then f`j else (g`(j#-m))#+n"

lemma sum_inl:
  assumes "m \<in> nat" "n\<in>nat"
    "f \<in> m\<rightarrow>n" "x \<in> m"
  shows "sum(f,g,m,n,p)`x = f`x"
proof -
  from \<open>m\<in>nat\<close>
  have "m\<le>m#+p"
    using add_le_self[of m] by simp
  with assms
  have "x\<in>m#+p"
    using ltI[of x m] lt_trans2[of x m "m#+p"] ltD by simp
  from assms
  have "x<m"
    using ltI by simp
  with \<open>x\<in>m#+p\<close>
  show ?thesis unfolding sum_def by simp
qed

lemma sum_inr:
  assumes "m \<in> nat" "n\<in>nat" "p\<in>nat"
    "g\<in>p\<rightarrow>q" "m \<le> x" "x < m#+p"
  shows "sum(f,g,m,n,p)`x = g`(x#-m)#+n"
proof -
  from assms
  have "x\<in>nat"
    using in_n_in_nat[of "m#+p"] ltD
    by simp
  with assms
  have "\<not> x<m"
    using not_lt_iff_le[THEN iffD2] by simp
  from assms
  have "x\<in>m#+p"
    using ltD by simp
  with \<open>\<not> x<m\<close>
  show ?thesis unfolding sum_def by simp
qed

lemma sum_action :
  assumes "m \<in> nat" "n\<in>nat" "p\<in>nat" "q\<in>nat"
    "f \<in> m\<rightarrow>n" "g\<in>p\<rightarrow>q"
    "env \<in> list(M)"
    "env' \<in> list(M)"
    "env1 \<in> list(M)"
    "env2 \<in> list(M)"
    "length(env) = m"
    "length(env1) = p"
    "length(env') = n"
    "\<And> i . i < m \<Longrightarrow> nth(i,env) = nth(f`i,env')"
    "\<And> j. j < p \<Longrightarrow> nth(j,env1) = nth(g`j,env2)"
  shows "\<forall> i . i < m#+p \<longrightarrow>
          nth(i,env@env1) = nth(sum(f,g,m,n,p)`i,env'@env2)"
proof -
  let ?h = "sum(f,g,m,n,p)"
  from \<open>m\<in>nat\<close> \<open>n\<in>nat\<close> \<open>q\<in>nat\<close>
  have "m\<le>m#+p" "n\<le>n#+q" "q\<le>n#+q"
    using add_le_self[of m]  add_le_self2[of n q] by simp_all
  from \<open>p\<in>nat\<close>
  have "p = (m#+p)#-m" using diff_add_inverse2 by simp
  have "nth(x, env @ env1) = nth(?h`x,env'@env2)" if "x<m#+p" for x
  proof (cases "x<m")
    case True
    then
    have 2: "?h`x= f`x" "x\<in>m" "f`x \<in> n" "x\<in>nat"
      using assms sum_inl ltD apply_type[of f m _ x] in_n_in_nat by simp_all
    with \<open>x<m\<close> assms
    have "f`x < n" "f`x<length(env')"  "f`x\<in>nat"
      using ltI in_n_in_nat by simp_all
    with 2 \<open>x<m\<close> assms
    have "nth(x,env@env1) = nth(x,env)"
      using nth_append[OF \<open>env\<in>list(M)\<close>] \<open>x\<in>nat\<close> by simp
    also
    have
      "... = nth(f`x,env')"
      using 2 \<open>x<m\<close> assms by simp
    also
    have "... = nth(f`x,env'@env2)"
      using nth_append[OF \<open>env'\<in>list(M)\<close>] \<open>f`x<length(env')\<close> \<open>f`x \<in>nat\<close> by simp
    also
    have "... = nth(?h`x,env'@env2)"
      using 2 by simp
    finally
    have "nth(x, env @ env1) = nth(?h`x,env'@env2)" .
    then show ?thesis .
  next
    case False
    have "x\<in>nat"
      using that in_n_in_nat[of "m#+p" x] ltD \<open>p\<in>nat\<close> \<open>m\<in>nat\<close> by simp
    with \<open>length(env) = m\<close>
    have "m\<le>x" "length(env) \<le> x"
      using not_lt_iff_le \<open>m\<in>nat\<close> \<open>\<not>x<m\<close> by simp_all
    with \<open>\<not>x<m\<close> \<open>length(env) = m\<close>
    have 2 : "?h`x= g`(x#-m)#+n"  "\<not> x <length(env)"
      unfolding sum_def
      using  sum_inr that beta ltD by simp_all
    from assms \<open>x\<in>nat\<close> \<open>p=m#+p#-m\<close>
    have "x#-m < p"
      using diff_mono[OF _ _ _ \<open>x<m#+p\<close> \<open>m\<le>x\<close>] by simp
    then have "x#-m\<in>p" using ltD by simp
    with \<open>g\<in>p\<rightarrow>q\<close>
    have "g`(x#-m) \<in> q"  by simp
    with \<open>q\<in>nat\<close> \<open>length(env') = n\<close>
    have "g`(x#-m) < q" "g`(x#-m)\<in>nat" using ltI in_n_in_nat by simp_all
    with \<open>q\<in>nat\<close> \<open>n\<in>nat\<close>
    have "(g`(x#-m))#+n <n#+q" "n \<le> g`(x#-m)#+n" "\<not> g`(x#-m)#+n < length(env')"
      using add_lt_mono1[of "g`(x#-m)" _ n,OF _ \<open>q\<in>nat\<close>]
        add_le_self2[of n] \<open>length(env') = n\<close>
      by simp_all
    from assms \<open>\<not> x < length(env)\<close> \<open>length(env) = m\<close>
    have "nth(x,env @ env1) = nth(x#-m,env1)"
      using nth_append[OF \<open>env\<in>list(M)\<close> \<open>x\<in>nat\<close>] by simp
    also
    have "... = nth(g`(x#-m),env2)"
      using assms \<open>x#-m < p\<close> by simp
    also
    have "... = nth((g`(x#-m)#+n)#-length(env'),env2)"
      using  \<open>length(env') = n\<close>
        diff_add_inverse2 \<open>g`(x#-m)\<in>nat\<close>
      by simp
    also
    have "... = nth((g`(x#-m)#+n),env'@env2)"
      using  nth_append[OF \<open>env'\<in>list(M)\<close>] \<open>n\<in>nat\<close> \<open>\<not> g`(x#-m)#+n < length(env')\<close>
      by simp
    also
    have "... = nth(?h`x,env'@env2)"
      using 2 by simp
    finally
    have "nth(x, env @ env1) = nth(?h`x,env'@env2)" .
    then show ?thesis .
  qed
  then show ?thesis by simp
qed

lemma sum_type  :
  assumes "m \<in> nat" "n\<in>nat" "p\<in>nat" "q\<in>nat"
    "f \<in> m\<rightarrow>n" "g\<in>p\<rightarrow>q"
  shows "sum(f,g,m,n,p) \<in> (m#+p) \<rightarrow> (n#+q)"
proof -
  let ?h = "sum(f,g,m,n,p)"
  from \<open>m\<in>nat\<close> \<open>n\<in>nat\<close> \<open>q\<in>nat\<close>
  have "m\<le>m#+p" "n\<le>n#+q" "q\<le>n#+q"
    using add_le_self[of m]  add_le_self2[of n q] by simp_all
  from \<open>p\<in>nat\<close>
  have "p = (m#+p)#-m" using diff_add_inverse2 by simp
  {fix x
    assume 1: "x\<in>m#+p" "x<m"
    with 1 have "?h`x= f`x" "x\<in>m"
      using assms sum_inl ltD by simp_all
    with \<open>f\<in>m\<rightarrow>n\<close>
    have "?h`x \<in> n" by simp
    with \<open>n\<in>nat\<close> have "?h`x < n" using ltI by simp
    with \<open>n\<le>n#+q\<close>
    have "?h`x < n#+q" using lt_trans2 by simp
    then
    have "?h`x \<in> n#+q"  using ltD by simp
  }
  then have 1:"?h`x \<in> n#+q" if "x\<in>m#+p" "x<m" for x using that .
  {fix x
    assume 1: "x\<in>m#+p" "m\<le>x"
    then have "x<m#+p" "x\<in>nat" using ltI in_n_in_nat[of "m#+p"] ltD by simp_all
    with 1
    have 2 : "?h`x= g`(x#-m)#+n"
      using assms sum_inr ltD by simp_all
    from assms \<open>x\<in>nat\<close> \<open>p=m#+p#-m\<close>
    have "x#-m < p" using diff_mono[OF _ _ _ \<open>x<m#+p\<close> \<open>m\<le>x\<close>] by simp
    then have "x#-m\<in>p" using ltD by simp
    with \<open>g\<in>p\<rightarrow>q\<close>
    have "g`(x#-m) \<in> q"  by simp
    with \<open>q\<in>nat\<close> have "g`(x#-m) < q" using ltI by simp
    with \<open>q\<in>nat\<close>
    have "(g`(x#-m))#+n <n#+q" using add_lt_mono1[of "g`(x#-m)" _ n,OF _ \<open>q\<in>nat\<close>] by simp
    with 2
    have "?h`x \<in> n#+q"  using ltD by simp
  }
  then have 2:"?h`x \<in> n#+q" if "x\<in>m#+p" "m\<le>x" for x using that .
  have
    D: "?h`x \<in> n#+q" if "x\<in>m#+p" for x
    using that
  proof (cases "x<m")
    case True
    then show ?thesis using 1 that by simp
  next
    case False
    with \<open>m\<in>nat\<close> have "m\<le>x" using not_lt_iff_le that in_n_in_nat[of "m#+p"] by simp
    then show ?thesis using 2 that by simp
  qed
  have A:"function(?h)" unfolding sum_def using function_lam by simp
  have " x\<in> (m #+ p) \<times> (n #+ q)" if "x\<in> ?h" for x
    using that lamE[of x "m#+p" _ "x \<in> (m #+ p) \<times> (n #+ q)"] D unfolding sum_def
    by auto
  then have B:"?h \<subseteq> (m #+ p) \<times> (n #+ q)" ..
  have "m #+ p \<subseteq> domain(?h)"
    unfolding sum_def using domain_lam by simp
  with A B
  show ?thesis using  Pi_iff [THEN iffD2] by simp
qed

lemma sum_type_id :
  assumes
    "f \<in> length(env)\<rightarrow>length(env')"
    "env \<in> list(M)"
    "env' \<in> list(M)"
    "env1 \<in> list(M)"
  shows
    "sum(f,id(length(env1)),length(env),length(env'),length(env1)) \<in>
        (length(env)#+length(env1)) \<rightarrow> (length(env')#+length(env1))"
  using assms length_type id_fn_type sum_type
  by simp

lemma sum_type_id_aux2 :
  assumes
    "f \<in> m\<rightarrow>n"
    "m \<in> nat" "n \<in> nat"
    "env1 \<in> list(M)"
  shows
    "sum(f,id(length(env1)),m,n,length(env1)) \<in>
        (m#+length(env1)) \<rightarrow> (n#+length(env1))"
  using assms id_fn_type sum_type
  by auto

lemma sum_action_id :
  assumes
    "env \<in> list(M)"
    "env' \<in> list(M)"
    "f \<in> length(env)\<rightarrow>length(env')"
    "env1 \<in> list(M)"
    "\<And> i . i < length(env) \<Longrightarrow> nth(i,env) = nth(f`i,env')"
  shows "\<And> i . i < length(env)#+length(env1) \<Longrightarrow>
          nth(i,env@env1) = nth(sum(f,id(length(env1)),length(env),length(env'),length(env1))`i,env'@env1)"
proof -
  from assms
  have "length(env)\<in>nat" (is "?m \<in> _") by simp
  from assms have "length(env')\<in>nat" (is "?n \<in> _") by simp
  from assms have "length(env1)\<in>nat" (is "?p \<in> _") by simp
  note lenv = id_fn_action[OF \<open>?p\<in>nat\<close> \<open>env1\<in>list(M)\<close>]
  note lenv_ty = id_fn_type[OF \<open>?p\<in>nat\<close>]
  {
    fix i
    assume "i < length(env)#+length(env1)"
    have "nth(i,env@env1) = nth(sum(f,id(length(env1)),?m,?n,?p)`i,env'@env1)"
      using sum_action[OF \<open>?m\<in>nat\<close> \<open>?n\<in>nat\<close> \<open>?p\<in>nat\<close> \<open>?p\<in>nat\<close> \<open>f\<in>?m\<rightarrow>?n\<close>
          lenv_ty \<open>env\<in>list(M)\<close> \<open>env'\<in>list(M)\<close>
          \<open>env1\<in>list(M)\<close> \<open>env1\<in>list(M)\<close> _
          _ _  assms(5) lenv
          ] \<open>i<?m#+length(env1)\<close> by simp
  }
  then show "\<And> i . i < ?m#+length(env1) \<Longrightarrow>
          nth(i,env@env1) = nth(sum(f,id(?p),?m,?n,?p)`i,env'@env1)" by simp
qed

lemma sum_action_id_aux :
  assumes
    "f \<in> m\<rightarrow>n"
    "env \<in> list(M)"
    "env' \<in> list(M)"
    "env1 \<in> list(M)"
    "length(env) = m"
    "length(env') = n"
    "length(env1) = p"
    "\<And> i . i < m \<Longrightarrow> nth(i,env) = nth(f`i,env')"
  shows "\<And> i . i < m#+length(env1) \<Longrightarrow>
          nth(i,env@env1) = nth(sum(f,id(length(env1)),m,n,length(env1))`i,env'@env1)"
  using assms length_type id_fn_type sum_action_id
  by auto

definition
  sum_id :: "[i,i] \<Rightarrow> i" where
  "sum_id(m,f) \<equiv> sum(\<lambda>x\<in>1.x,f,1,1,m)"

lemma sum_id0 : "m\<in>nat\<Longrightarrow>sum_id(m,f)`0 = 0"
  by(unfold sum_id_def,subst sum_inl,auto)

lemma sum_idS : "p\<in>nat \<Longrightarrow> q\<in>nat \<Longrightarrow> f\<in>p\<rightarrow>q \<Longrightarrow> x \<in> p \<Longrightarrow> sum_id(p,f)`(succ(x)) = succ(f`x)"
  by(subgoal_tac "x\<in>nat",unfold sum_id_def,subst sum_inr,
      simp_all add:ltI,simp_all add: app_nm in_n_in_nat)

lemma sum_id_tc_aux :
  "p \<in> nat \<Longrightarrow>  q \<in> nat \<Longrightarrow> f \<in> p \<rightarrow> q \<Longrightarrow> sum_id(p,f) \<in> 1#+p \<rightarrow> 1#+q"
  by (unfold sum_id_def,rule sum_type,simp_all)

lemma sum_id_tc :
  "n \<in> nat \<Longrightarrow> m \<in> nat \<Longrightarrow> f \<in> n \<rightarrow> m \<Longrightarrow> sum_id(n,f) \<in> succ(n) \<rightarrow> succ(m)"
  by(rule ssubst[of  "succ(n) \<rightarrow> succ(m)" "1#+n \<rightarrow> 1#+m"],
      simp,rule sum_id_tc_aux,simp_all)

subsection\<open>Renaming of formulas\<close>

consts   ren :: "i\<Rightarrow>i"
primrec
  "ren(Member(x,y)) =
      (\<lambda> n \<in> nat . \<lambda> m \<in> nat. \<lambda>f \<in> n \<rightarrow> m. Member (f`x, f`y))"

"ren(Equal(x,y)) =
      (\<lambda> n \<in> nat . \<lambda> m \<in> nat. \<lambda>f \<in> n \<rightarrow> m. Equal (f`x, f`y))"

"ren(Nand(p,q)) =
      (\<lambda> n \<in> nat . \<lambda> m \<in> nat. \<lambda>f \<in> n \<rightarrow> m. Nand (ren(p)`n`m`f, ren(q)`n`m`f))"

"ren(Forall(p)) =
      (\<lambda> n \<in> nat . \<lambda> m \<in> nat. \<lambda>f \<in> n \<rightarrow> m. Forall (ren(p)`succ(n)`succ(m)`sum_id(n,f)))"

lemma arity_meml : "l \<in> nat \<Longrightarrow> Member(x,y) \<in> formula \<Longrightarrow> arity(Member(x,y)) \<le> l \<Longrightarrow> x \<in> l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_memr : "l \<in> nat \<Longrightarrow> Member(x,y) \<in> formula \<Longrightarrow> arity(Member(x,y)) \<le> l \<Longrightarrow> y \<in> l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_eql : "l \<in> nat \<Longrightarrow> Equal(x,y) \<in> formula \<Longrightarrow> arity(Equal(x,y)) \<le> l \<Longrightarrow> x \<in> l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma arity_eqr : "l \<in> nat \<Longrightarrow> Equal(x,y) \<in> formula \<Longrightarrow> arity(Equal(x,y)) \<le> l \<Longrightarrow> y \<in> l"
  by(simp,rule subsetD,rule le_imp_subset,assumption,simp)
lemma  nand_ar1 : "p \<in> formula \<Longrightarrow> q\<in>formula \<Longrightarrow>arity(p) \<le> arity(Nand(p,q))"
  by (simp,rule Un_upper1_le,simp+)
lemma nand_ar2 : "p \<in> formula \<Longrightarrow> q\<in>formula \<Longrightarrow>arity(q) \<le> arity(Nand(p,q))"
  by (simp,rule Un_upper2_le,simp+)

lemma nand_ar1D : "p \<in> formula \<Longrightarrow> q\<in>formula \<Longrightarrow> arity(Nand(p,q)) \<le> n \<Longrightarrow> arity(p) \<le> n"
  by(auto simp add:  le_trans[OF Un_upper1_le[of "arity(p)" "arity(q)"]])
lemma nand_ar2D : "p \<in> formula \<Longrightarrow> q\<in>formula \<Longrightarrow> arity(Nand(p,q)) \<le> n \<Longrightarrow> arity(q) \<le> n"
  by(auto simp add:  le_trans[OF Un_upper2_le[of "arity(p)" "arity(q)"]])

lemma ren_tc : "p \<in> formula \<Longrightarrow>
  (\<And> n m f . n \<in> nat \<Longrightarrow> m \<in> nat \<Longrightarrow> f \<in> n\<rightarrow>m \<Longrightarrow>  ren(p)`n`m`f \<in> formula)"
  by (induct set:formula,auto simp add: app_nm sum_id_tc)

lemma arity_ren :
  fixes "p"
  assumes "p \<in> formula"
  shows "\<And> n m f . n \<in> nat \<Longrightarrow> m \<in> nat \<Longrightarrow> f \<in> n\<rightarrow>m \<Longrightarrow> arity(p) \<le> n \<Longrightarrow> arity(ren(p)`n`m`f)\<le>m"
  using assms
proof (induct set:formula)
  case (Member x y)
  then have "f`x \<in> m" "f`y \<in> m"
    using Member assms by (simp add: arity_meml apply_funtype,simp add:arity_memr apply_funtype)
  then show ?case using Member by (simp add: Un_least_lt ltI)
next
  case (Equal x y)
  then have "f`x \<in> m" "f`y \<in> m"
    using Equal assms by (simp add: arity_eql apply_funtype,simp add:arity_eqr apply_funtype)
  then show ?case using Equal by (simp add: Un_least_lt ltI)
next
  case (Nand p q)
  then have "arity(p)\<le>arity(Nand(p,q))"
    "arity(q)\<le>arity(Nand(p,q))"
    by (subst  nand_ar1,simp,simp,simp,subst nand_ar2,simp+)
  then have "arity(p)\<le>n"
    and "arity(q)\<le>n" using Nand
    by (rule_tac j="arity(Nand(p,q))" in le_trans,simp,simp)+
  then have "arity(ren(p)`n`m`f) \<le> m" and  "arity(ren(q)`n`m`f) \<le> m"
    using Nand by auto
  then show ?case using Nand by (simp add:Un_least_lt)
next
  case (Forall p)
  from Forall have "succ(n)\<in>nat"  "succ(m)\<in>nat" by auto
  from Forall have 2: "sum_id(n,f) \<in> succ(n)\<rightarrow>succ(m)" by (simp add:sum_id_tc)
  from Forall have 3:"arity(p) \<le> succ(n)" by (rule_tac n="arity(p)" in natE,simp+)
  then have "arity(ren(p)`succ(n)`succ(m)`sum_id(n,f))\<le>succ(m)" using
      Forall \<open>succ(n)\<in>nat\<close> \<open>succ(m)\<in>nat\<close> 2 by force
  then show ?case using Forall 2 3 ren_tc arity_type pred_le by auto
qed

lemma arity_forallE : "p \<in> formula \<Longrightarrow> m \<in> nat \<Longrightarrow> arity(Forall(p)) \<le> m \<Longrightarrow> arity(p) \<le> succ(m)"
  by(rule_tac n="arity(p)" in natE,erule arity_type,simp+)

lemma env_coincidence_sum_id :
  assumes "m \<in> nat" "n \<in> nat"
    "\<rho> \<in> list(A)" "\<rho>' \<in> list(A)"
    "f \<in> n \<rightarrow> m"
    "\<And> i . i < n \<Longrightarrow> nth(i,\<rho>) = nth(f`i,\<rho>')"
    "a \<in> A" "j \<in> succ(n)"
  shows "nth(j,Cons(a,\<rho>)) = nth(sum_id(n,f)`j,Cons(a,\<rho>'))"
proof -
  let ?g="sum_id(n,f)"
  have "succ(n) \<in> nat" using \<open>n\<in>nat\<close> by simp
  then have "j \<in> nat" using \<open>j\<in>succ(n)\<close> in_n_in_nat by blast
  then have "nth(j,Cons(a,\<rho>)) = nth(?g`j,Cons(a,\<rho>'))"
  proof (cases rule:natE[OF \<open>j\<in>nat\<close>])
    case 1
    then show ?thesis using assms sum_id0 by simp
  next
    case (2 i)
    with \<open>j\<in>succ(n)\<close> have "succ(i)\<in>succ(n)" by simp
    with \<open>n\<in>nat\<close> have "i \<in> n" using nat_succD assms by simp
    have "f`i\<in>m" using \<open>f\<in>n\<rightarrow>m\<close> apply_type \<open>i\<in>n\<close> by simp
    then have "f`i \<in> nat" using in_n_in_nat \<open>m\<in>nat\<close> by simp
    have "nth(succ(i),Cons(a,\<rho>)) = nth(i,\<rho>)" using \<open>i\<in>nat\<close> by simp
    also have "... = nth(f`i,\<rho>')" using assms \<open>i\<in>n\<close> ltI by simp
    also have "... = nth(succ(f`i),Cons(a,\<rho>'))" using \<open>f`i\<in>nat\<close> by simp
    also have "... = nth(?g`succ(i),Cons(a,\<rho>'))"
      using assms sum_idS[OF \<open>n\<in>nat\<close> \<open>m\<in>nat\<close>  \<open>f\<in>n\<rightarrow>m\<close> \<open>i \<in> n\<close>] cases by simp
    finally have "nth(succ(i),Cons(a,\<rho>)) = nth(?g`succ(i),Cons(a,\<rho>'))" .
    then show ?thesis using \<open>j=succ(i)\<close> by simp
  qed
  then show ?thesis .
qed

lemma sats_iff_sats_ren :
  fixes "\<phi>"
  assumes "\<phi> \<in> formula"
  shows  "\<lbrakk>  n \<in> nat ; m \<in> nat ; \<rho> \<in> list(M) ; \<rho>' \<in> list(M) ; f \<in> n \<rightarrow> m ;
            arity(\<phi>) \<le> n ;
            \<And> i . i < n \<Longrightarrow> nth(i,\<rho>) = nth(f`i,\<rho>') \<rbrakk> \<Longrightarrow>
         sats(M,\<phi>,\<rho>) \<longleftrightarrow> sats(M,ren(\<phi>)`n`m`f,\<rho>')"
  using \<open>\<phi> \<in> formula\<close>
proof(induct \<phi> arbitrary:n m \<rho> \<rho>' f)
  case (Member x y)
  have "ren(Member(x,y))`n`m`f = Member(f`x,f`y)" using Member assms arity_type by force
  moreover
  have "x \<in> n" using Member arity_meml by simp
  moreover
  have "y \<in> n" using Member arity_memr by simp
  ultimately
  show ?case using Member ltI by simp
next
  case (Equal x y)
  have "ren(Equal(x,y))`n`m`f = Equal(f`x,f`y)" using Equal assms arity_type by force
  moreover
  have "x \<in> n" using Equal arity_eql by simp
  moreover
  have "y \<in> n" using Equal arity_eqr by simp
  ultimately show ?case using Equal ltI by simp
next
  case (Nand p q)
  have "ren(Nand(p,q))`n`m`f = Nand(ren(p)`n`m`f,ren(q)`n`m`f)" using Nand by simp
  moreover
  have "arity(p) \<le> n" using Nand nand_ar1D by simp
  moreover from this
  have "i \<in> arity(p) \<Longrightarrow> i \<in> n" for i using subsetD[OF le_imp_subset[OF \<open>arity(p) \<le> n\<close>]] by simp
  moreover from this
  have "i \<in> arity(p) \<Longrightarrow> nth(i,\<rho>) = nth(f`i,\<rho>')" for i using Nand ltI by simp
  moreover from this
  have "sats(M,p,\<rho>) \<longleftrightarrow> sats(M,ren(p)`n`m`f,\<rho>')" using \<open>arity(p)\<le>n\<close> Nand by simp
  have "arity(q) \<le> n" using Nand nand_ar2D by simp
  moreover from this
  have "i \<in> arity(q) \<Longrightarrow> i \<in> n" for i using subsetD[OF le_imp_subset[OF \<open>arity(q) \<le> n\<close>]] by simp
  moreover from this
  have "i \<in> arity(q) \<Longrightarrow> nth(i,\<rho>) = nth(f`i,\<rho>')" for i using Nand ltI by simp
  moreover from this
  have "sats(M,q,\<rho>) \<longleftrightarrow> sats(M,ren(q)`n`m`f,\<rho>')" using assms \<open>arity(q)\<le>n\<close> Nand by simp
  ultimately
  show ?case using Nand by simp
next
  case (Forall p)
  have 0:"ren(Forall(p))`n`m`f = Forall(ren(p)`succ(n)`succ(m)`sum_id(n,f))"
    using Forall by simp
  have 1:"sum_id(n,f) \<in> succ(n) \<rightarrow> succ(m)" (is "?g \<in> _") using sum_id_tc Forall by simp
  then have 2: "arity(p) \<le> succ(n)"
    using Forall le_trans[of _ "succ(pred(arity(p)))"] succpred_leI by simp
  have "succ(n)\<in>nat" "succ(m)\<in>nat" using Forall by auto
  then have A:"\<And> j .j < succ(n) \<Longrightarrow> nth(j, Cons(a, \<rho>)) = nth(?g`j, Cons(a, \<rho>'))" if "a\<in>M" for a
    using that env_coincidence_sum_id Forall ltD by force
  have
    "sats(M,p,Cons(a,\<rho>)) \<longleftrightarrow> sats(M,ren(p)`succ(n)`succ(m)`?g,Cons(a,\<rho>'))" if "a\<in>M" for a
  proof -
    have C:"Cons(a,\<rho>) \<in> list(M)" "Cons(a,\<rho>')\<in>list(M)" using Forall that by auto
    have "sats(M,p,Cons(a,\<rho>)) \<longleftrightarrow> sats(M,ren(p)`succ(n)`succ(m)`?g,Cons(a,\<rho>'))"
      using Forall(2)[OF \<open>succ(n)\<in>nat\<close> \<open>succ(m)\<in>nat\<close> C(1) C(2) 1 2 A[OF \<open>a\<in>M\<close>]] by simp
    then show ?thesis .
  qed
  then show ?case using Forall 0 1 2 by simp
qed

end


(*  Title:      ZF/WF.thy
    Author:     Tobias Nipkow and Lawrence C Paulson
    Copyright   1994  University of Cambridge

Derived first for transitive relations, and finally for arbitrary WF relations
via wf_trancl and trans_trancl.

It is difficult to derive this general case directly, using r^+ instead of
r.  In is_recfun, the two occurrences of the relation must have the same
form.  Inserting r^+ in the_recfun or wftrec yields a recursion rule with
r^+ -`` {a} instead of r-``{a}.  This recursion rule is stronger in
principle, but harder to use, especially to prove wfrec_eclose_eq in
epsilon.ML.  Expanding out the definition of wftrec in wfrec would yield
a mess.
*)

section{*Well-Founded Recursion*}

theory WF imports Trancl begin

definition
  wf           :: "i=>o"  where
    (*r is a well-founded relation*)
    "wf(r) == \<forall>Z. Z=0 | (\<exists>x\<in>Z. \<forall>y. <y,x>:r \<longrightarrow> ~ y \<in> Z)"

definition
  wf_on        :: "[i,i]=>o"                      ("wf[_]'(_')")  where
    (*r is well-founded on A*)
    "wf_on(A,r) == wf(r \<inter> A*A)"

definition
  is_recfun    :: "[i, i, [i,i]=>i, i] =>o"  where
    "is_recfun(r,a,H,f) == (f = (\<lambda>x\<in>r-``{a}. H(x, restrict(f, r-``{x}))))"

definition
  the_recfun   :: "[i, i, [i,i]=>i] =>i"  where
    "the_recfun(r,a,H) == (THE f. is_recfun(r,a,H,f))"

definition
  wftrec :: "[i, i, [i,i]=>i] =>i"  where
    "wftrec(r,a,H) == H(a, the_recfun(r,a,H))"

definition
  wfrec :: "[i, i, [i,i]=>i] =>i"  where
    (*public version.  Does not require r to be transitive*)
    "wfrec(r,a,H) == wftrec(r^+, a, %x f. H(x, restrict(f,r-``{x})))"

definition
  wfrec_on     :: "[i, i, i, [i,i]=>i] =>i"       ("wfrec[_]'(_,_,_')")  where
    "wfrec[A](r,a,H) == wfrec(r \<inter> A*A, a, H)"

subsection{*Well-Founded Relations*}

subsubsection{*Equivalences between @{term wf} and @{term wf_on}*}

lemma wf_imp_wf_on: "wf(r) ==> wf[A](r)"
by (unfold wf_def wf_on_def, force)

lemma wf_on_imp_wf: "[|wf[A](r); r \<subseteq> A*A|] ==> wf(r)"
by (simp add: wf_on_def subset_Int_iff)

lemma wf_on_field_imp_wf: "wf[field(r)](r) ==> wf(r)"
by (unfold wf_def wf_on_def, fast)

lemma wf_iff_wf_on_field: "wf(r) \<longleftrightarrow> wf[field(r)](r)"
by (blast intro: wf_imp_wf_on wf_on_field_imp_wf)

lemma wf_on_subset_A: "[| wf[A](r);  B<=A |] ==> wf[B](r)"
by (unfold wf_on_def wf_def, fast)

lemma wf_on_subset_r: "[| wf[A](r); s<=r |] ==> wf[A](s)"
by (unfold wf_on_def wf_def, fast)

lemma wf_subset: "[|wf(s); r<=s|] ==> wf(r)"
by (simp add: wf_def, fast)

subsubsection{*Introduction Rules for @{term wf_on}*}

text{*If every non-empty subset of @{term A} has an @{term r}-minimal element
   then we have @{term "wf[A](r)"}.*}
lemma wf_onI:
 assumes prem: "!!Z u. [| Z<=A;  u \<in> Z;  \<forall>x\<in>Z. \<exists>y\<in>Z. <y,x>:r |] ==> False"
 shows         "wf[A](r)"
apply (unfold wf_on_def wf_def)
apply (rule equals0I [THEN disjCI, THEN allI])
apply (rule_tac Z = Z in prem, blast+)
done

text{*If @{term r} allows well-founded induction over @{term A}
   then we have @{term "wf[A](r)"}.   Premise is equivalent to
  @{prop "!!B. \<forall>x\<in>A. (\<forall>y. <y,x>: r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B ==> A<=B"} *}
lemma wf_onI2:
 assumes prem: "!!y B. [| \<forall>x\<in>A. (\<forall>y\<in>A. <y,x>:r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B;   y \<in> A |]
                       ==> y \<in> B"
 shows         "wf[A](r)"
apply (rule wf_onI)
apply (rule_tac c=u in prem [THEN DiffE])
  prefer 3 apply blast
 apply fast+
done

subsubsection{*Well-founded Induction*}

text{*Consider the least @{term z} in @{term "domain(r)"} such that
  @{term "P(z)"} does not hold...*}
lemma wf_induct_raw:
    "[| wf(r);
        !!x.[| \<forall>y. <y,x>: r \<longrightarrow> P(y) |] ==> P(x) |]
     ==> P(a)"
apply (unfold wf_def)
apply (erule_tac x = "{z \<in> domain(r). ~ P(z)}" in allE)
apply blast
done

lemmas wf_induct = wf_induct_raw [rule_format, consumes 1, case_names step, induct set: wf]

text{*The form of this rule is designed to match @{text wfI}*}
lemma wf_induct2:
    "[| wf(r);  a \<in> A;  field(r)<=A;
        !!x.[| x \<in> A;  \<forall>y. <y,x>: r \<longrightarrow> P(y) |] ==> P(x) |]
     ==>  P(a)"
apply (erule_tac P="a \<in> A" in rev_mp)
apply (erule_tac a=a in wf_induct, blast)
done

lemma field_Int_square: "field(r \<inter> A*A) \<subseteq> A"
by blast

lemma wf_on_induct_raw [consumes 2, induct set: wf_on]:
    "[| wf[A](r);  a \<in> A;
        !!x.[| x \<in> A;  \<forall>y\<in>A. <y,x>: r \<longrightarrow> P(y) |] ==> P(x)
     |]  ==>  P(a)"
apply (unfold wf_on_def)
apply (erule wf_induct2, assumption)
apply (rule field_Int_square, blast)
done

lemmas wf_on_induct =
  wf_on_induct_raw [rule_format, consumes 2, case_names step, induct set: wf_on]

text{*If @{term r} allows well-founded induction
   then we have @{term "wf(r)"}.*}
lemma wfI:
    "[| field(r)<=A;
        !!y B. [| \<forall>x\<in>A. (\<forall>y\<in>A. <y,x>:r \<longrightarrow> y \<in> B) \<longrightarrow> x \<in> B;  y \<in> A|]
               ==> y \<in> B |]
     ==>  wf(r)"
apply (rule wf_on_subset_A [THEN wf_on_field_imp_wf])
apply (rule wf_onI2)
 prefer 2 apply blast
apply blast
done

subsection{*Basic Properties of Well-Founded Relations*}

lemma wf_not_refl: "wf(r) ==> <a,a> \<notin> r"
by (erule_tac a=a in wf_induct, blast)

lemma wf_not_sym [rule_format]: "wf(r) ==> \<forall>x. <a,x>:r \<longrightarrow> <x,a> \<notin> r"
by (erule_tac a=a in wf_induct, blast)

(* @{term"[| wf(r);  <a,x> \<in> r;  ~P ==> <x,a> \<in> r |] ==> P"} *)
lemmas wf_asym = wf_not_sym [THEN swap]

lemma wf_on_not_refl: "[| wf[A](r); a \<in> A |] ==> <a,a> \<notin> r"
by (erule_tac a=a in wf_on_induct, assumption, blast)

lemma wf_on_not_sym [rule_format]:
     "[| wf[A](r);  a \<in> A |] ==> \<forall>b\<in>A. <a,b>:r \<longrightarrow> <b,a>\<notin>r"
apply (erule_tac a=a in wf_on_induct, assumption, blast)
done

lemma wf_on_asym:
     "[| wf[A](r);  ~Z ==> <a,b> \<in> r;
         <b,a> \<notin> r ==> Z; ~Z ==> a \<in> A; ~Z ==> b \<in> A |] ==> Z"
by (blast dest: wf_on_not_sym)

(*Needed to prove well_ordI.  Could also reason that wf[A](r) means
  wf(r \<inter> A*A);  thus wf( (r \<inter> A*A)^+ ) and use wf_not_refl *)
lemma wf_on_chain3:
     "[| wf[A](r); <a,b>:r; <b,c>:r; <c,a>:r; a \<in> A; b \<in> A; c \<in> A |] ==> P"
apply (subgoal_tac "\<forall>y\<in>A. \<forall>z\<in>A. <a,y>:r \<longrightarrow> <y,z>:r \<longrightarrow> <z,a>:r \<longrightarrow> P",
       blast)
apply (erule_tac a=a in wf_on_induct, assumption, blast)
done

text{*transitive closure of a WF relation is WF provided
  @{term A} is downward closed*}
lemma wf_on_trancl:
    "[| wf[A](r);  r-``A \<subseteq> A |] ==> wf[A](r^+)"
apply (rule wf_onI2)
apply (frule bspec [THEN mp], assumption+)
apply (erule_tac a = y in wf_on_induct, assumption)
apply (blast elim: tranclE, blast)
done

lemma wf_trancl: "wf(r) ==> wf(r^+)"
apply (simp add: wf_iff_wf_on_field)
apply (rule wf_on_subset_A)
 apply (erule wf_on_trancl)
 apply blast
apply (rule trancl_type [THEN field_rel_subset])
done

text{*@{term "r-``{a}"} is the set of everything under @{term a} in @{term r}*}

lemmas underI = vimage_singleton_iff [THEN iffD2]
lemmas underD = vimage_singleton_iff [THEN iffD1]

subsection{*The Predicate @{term is_recfun}*}

lemma is_recfun_type: "is_recfun(r,a,H,f) ==> f \<in> r-``{a} -> range(f)"
apply (unfold is_recfun_def)
apply (erule ssubst)
apply (rule lamI [THEN rangeI, THEN lam_type], assumption)
done

lemmas is_recfun_imp_function = is_recfun_type [THEN fun_is_function]

lemma apply_recfun:
    "[| is_recfun(r,a,H,f); <x,a>:r |] ==> f`x = H(x, restrict(f,r-``{x}))"
apply (unfold is_recfun_def)
  txt{*replace f only on the left-hand side*}
apply (erule_tac P = "%x.?t(x) = ?u" in ssubst)
apply (simp add: underI)
done

lemma is_recfun_equal [rule_format]:
     "[| wf(r);  trans(r);  is_recfun(r,a,H,f);  is_recfun(r,b,H,g) |]
      ==> <x,a>:r \<longrightarrow> <x,b>:r \<longrightarrow> f`x=g`x"
apply (frule_tac f = f in is_recfun_type)
apply (frule_tac f = g in is_recfun_type)
apply (simp add: is_recfun_def)
apply (erule_tac a=x in wf_induct)
apply (intro impI)
apply (elim ssubst)
apply (simp (no_asm_simp) add: vimage_singleton_iff restrict_def)
apply (rule_tac t = "%z. H (?x,z) " in subst_context)
apply (subgoal_tac "\<forall>y\<in>r-``{x}. \<forall>z. <y,z>:f \<longleftrightarrow> <y,z>:g")
 apply (blast dest: transD)
apply (simp add: apply_iff)
apply (blast dest: transD intro: sym)
done

lemma is_recfun_cut:
     "[| wf(r);  trans(r);
         is_recfun(r,a,H,f);  is_recfun(r,b,H,g);  <b,a>:r |]
      ==> restrict(f, r-``{b}) = g"
apply (frule_tac f = f in is_recfun_type)
apply (rule fun_extension)
  apply (blast dest: transD intro: restrict_type2)
 apply (erule is_recfun_type, simp)
apply (blast dest: transD intro: is_recfun_equal)
done

subsection{*Recursion: Main Existence Lemma*}

lemma is_recfun_functional:
     "[| wf(r); trans(r); is_recfun(r,a,H,f); is_recfun(r,a,H,g) |]  ==>  f=g"
by (blast intro: fun_extension is_recfun_type is_recfun_equal)

lemma the_recfun_eq:
    "[| is_recfun(r,a,H,f);  wf(r);  trans(r) |] ==> the_recfun(r,a,H) = f"
apply (unfold the_recfun_def)
apply (blast intro: is_recfun_functional)
done

(*If some f satisfies is_recfun(r,a,H,-) then so does the_recfun(r,a,H) *)
lemma is_the_recfun:
    "[| is_recfun(r,a,H,f);  wf(r);  trans(r) |]
     ==> is_recfun(r, a, H, the_recfun(r,a,H))"
by (simp add: the_recfun_eq)

lemma unfold_the_recfun:
     "[| wf(r);  trans(r) |] ==> is_recfun(r, a, H, the_recfun(r,a,H))"
apply (rule_tac a=a in wf_induct, assumption)
apply (rename_tac a1)
apply (rule_tac f = "\<lambda>y\<in>r-``{a1}. wftrec (r,y,H)" in is_the_recfun)
  apply typecheck
apply (unfold is_recfun_def wftrec_def)
  --{*Applying the substitution: must keep the quantified assumption!*}
apply (rule lam_cong [OF refl])
apply (drule underD)
apply (fold is_recfun_def)
apply (rule_tac t = "%z. H(?x,z)" in subst_context)
apply (rule fun_extension)
  apply (blast intro: is_recfun_type)
 apply (rule lam_type [THEN restrict_type2])
  apply blast
 apply (blast dest: transD)
apply atomize
apply (frule spec [THEN mp], assumption)
apply (subgoal_tac "<xa,a1> \<in> r")
 apply (drule_tac x1 = xa in spec [THEN mp], assumption)
apply (simp add: vimage_singleton_iff
                 apply_recfun is_recfun_cut)
apply (blast dest: transD)
done

subsection{*Unfolding @{term "wftrec(r,a,H)"}*}

lemma the_recfun_cut:
     "[| wf(r);  trans(r);  <b,a>:r |]
      ==> restrict(the_recfun(r,a,H), r-``{b}) = the_recfun(r,b,H)"
by (blast intro: is_recfun_cut unfold_the_recfun)

(*NOT SUITABLE FOR REWRITING: it is recursive!*)
lemma wftrec:
    "[| wf(r);  trans(r) |] ==>
          wftrec(r,a,H) = H(a, \<lambda>x\<in>r-``{a}. wftrec(r,x,H))"
apply (unfold wftrec_def)
apply (subst unfold_the_recfun [unfolded is_recfun_def])
apply (simp_all add: vimage_singleton_iff [THEN iff_sym] the_recfun_cut)
done

subsubsection{*Removal of the Premise @{term "trans(r)"}*}

(*NOT SUITABLE FOR REWRITING: it is recursive!*)
lemma wfrec:
    "wf(r) ==> wfrec(r,a,H) = H(a, \<lambda>x\<in>r-``{a}. wfrec(r,x,H))"
apply (unfold wfrec_def)
apply (erule wf_trancl [THEN wftrec, THEN ssubst])
 apply (rule trans_trancl)
apply (rule vimage_pair_mono [THEN restrict_lam_eq, THEN subst_context])
 apply (erule r_into_trancl)
apply (rule subset_refl)
done

(*This form avoids giant explosions in proofs.  NOTE USE OF == *)
lemma def_wfrec:
    "[| !!x. h(x)==wfrec(r,x,H);  wf(r) |] ==>
     h(a) = H(a, \<lambda>x\<in>r-``{a}. h(x))"
apply simp
apply (elim wfrec)
done

lemma wfrec_type:
    "[| wf(r);  a \<in> A;  field(r)<=A;
        !!x u. [| x \<in> A;  u \<in> Pi(r-``{x}, B) |] ==> H(x,u) \<in> B(x)
     |] ==> wfrec(r,a,H) \<in> B(a)"
apply (rule_tac a = a in wf_induct2, assumption+)
apply (subst wfrec, assumption)
apply (simp add: lam_type underD)
done

lemma wfrec_on:
 "[| wf[A](r);  a \<in> A |] ==>
         wfrec[A](r,a,H) = H(a, \<lambda>x\<in>(r-``{a}) \<inter> A. wfrec[A](r,x,H))"
apply (unfold wf_on_def wfrec_on_def)
apply (erule wfrec [THEN trans])
apply (simp add: vimage_Int_square cons_subset_iff)
done

text{*Minimal-element characterization of well-foundedness*}
lemma wf_eq_minimal:
     "wf(r) \<longleftrightarrow> (\<forall>Q x. x \<in> Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. <y,z>:r \<longrightarrow> y\<notin>Q))"
by (unfold wf_def, blast)

end


theory T167
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T88
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory T89
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end