(*
  File:    SDS_Automation.thy
  Author:  Manuel Eberl <manuel@pruvisto.org>

  This theory provides a number of commands to automatically derive restrictions on the
  results of Social Decision Schemes fulfilling properties like Anonymity, Neutrality,
  Ex-post- or SD-efficiency, and SD-Strategy-Proofness.
*)

section \<open>Automatic Fact Gathering for Social Decision Schemes\<close>

theory SDS_Automation
  imports
    Preference_Profile_Cmd
    QSOpt_Exact
    "../Social_Decision_Schemes"
keywords
  "derive_orbit_equations"
  "derive_support_conditions"
  "derive_ex_post_conditions"
  "find_inefficient_supports"
  "prove_inefficient_supports"
  "derive_strategyproofness_conditions" :: thy_goal
begin

text \<open>
  We now provide the following commands to automatically derive restrictions on the results
  of Social Decision Schemes satisfying Anonymity, Neutrality, Efficiency, or Strategy-Proofness:
  \begin{description}
    \item[@{command derive_orbit_equations}] to derive equalities arising from automorphisms of the
      given profiles due to Anonymity and Neutrality
    \item[@{command derive_ex_post_conditions}] to find all Pareto losers and the given profiles and
      derive the facts that they must be assigned probability 0 by any \textit{ex-post}-efficient
      SDS
    \item[@{command find_inefficient_supports}] to use Linear Programming to find all minimal SD-inefficient
      (but not \textit{ex-post}-inefficient) supports in the given profiles and output a
      corresponding witness lottery for each of them
    \item[@{command prove_inefficient_supports}] to prove a specified set of support conditions arising from
      \textit{ex-post}- or \textit{SD}-Efficiency. For conditions arising from \textit{SD}-Efficiency,
      a witness lottery must be specified (e.\,g. as computed by @{command derive_orbit_equations}).
    \item[@{command derive_support_conditions}] to automatically find and prove all support conditions
      arising from \textit{ex-post-} and \textit{SD}-Efficiency
    \item [@{command derive_strategyproofness_conditions}] to automatically derive all conditions
      arising from weak Strategy-Proofness and any manipulations between the given preference
      profiles. An optional maximum manipulation size can be specified.
  \end{description}
  All commands except @{command find_inefficient_supports} open a proof state and leave behind
  proof obligations for the user to discharge. This should always be possible using the Simplifier,
  possibly with a few additional rules, depending on the context.

\<close>

lemma disj_False_right: "P \<or> False \<longleftrightarrow> P" by simp

lemmas multiset_add_ac = add_ac[where ?'a = "'a multiset"]

lemma less_or_eq_real:
  "(x::real) < y \<or> x = y \<longleftrightarrow> x \<le> y" "x < y \<or> y = x \<longleftrightarrow> x \<le> y" by linarith+

lemma multiset_Diff_single_normalize:
  fixes a c assumes "a \<noteq> c"
  shows   "({#a#} + B) - {#c#} = {#a#} + (B - {#c#})"
  using assms by auto

lemma ex_post_efficient_aux:
  assumes "prefs_from_table_wf agents alts xss" "R \<equiv> prefs_from_table xss"
  assumes "i \<in> agents" "\<forall>i\<in>agents. y \<succeq>[prefs_from_table xss i] x" "\<not>y \<preceq>[prefs_from_table xss i] x"
  shows   "ex_post_efficient_sds agents alts sds \<longrightarrow> pmf (sds R) x = 0"
proof
  assume ex_post: "ex_post_efficient_sds agents alts sds"
  from assms(1,2) have wf: "pref_profile_wf agents alts R"
    by (simp add: pref_profile_from_tableI')
  from ex_post interpret ex_post_efficient_sds agents alts sds .
  from assms(2-) show "pmf (sds R) x = 0"
    by (intro ex_post_efficient''[OF wf, of i x y]) simp_all
qed

lemma SD_inefficient_support_aux:
  assumes R: "prefs_from_table_wf agents alts xss" "R \<equiv> prefs_from_table xss"
  assumes as: "as \<noteq> []" "set as \<subseteq> alts" "distinct as" "A = set as"
  assumes ys: "\<forall>x\<in>set (map snd ys). 0 \<le> x" "sum_list (map snd ys) = 1" "set (map fst ys) \<subseteq> alts"
  assumes i: "i \<in> agents"
  assumes SD1: "\<forall>i\<in>agents. \<forall>x\<in>alts.
    sum_list (map snd (filter (\<lambda>y. prefs_from_table xss i x (fst y)) ys)) \<ge>
    real (length (filter (prefs_from_table xss i x) as)) / real (length as)"
  assumes SD2: "\<exists>x\<in>alts. sum_list (map snd (filter (\<lambda>y. prefs_from_table xss i x (fst y)) ys)) >
                        real (length (filter (prefs_from_table xss i x) as)) / real (length as)"
  shows   "sd_efficient_sds agents alts sds \<longrightarrow> (\<exists>x\<in>A. pmf (sds R) x = 0)"
proof
  assume "sd_efficient_sds agents alts sds"
  from R have wf: "pref_profile_wf agents alts R"
    by (simp add: pref_profile_from_tableI')
  then interpret pref_profile_wf agents alts R .
  interpret sd_efficient_sds agents alts sds by fact
  from ys have ys': "pmf_of_list_wf ys" by (intro pmf_of_list_wfI) auto

  {
    fix i x assume "x \<in> alts" "i \<in> agents"
    with ys' have "lottery_prob (pmf_of_list ys) (preferred_alts (R i) x) =
      sum_list (map snd (filter (\<lambda>y. prefs_from_table xss i x (fst y)) ys))"
      by (subst measure_pmf_of_list) (simp_all add: preferred_alts_def R)
  } note A = this
  {
    fix i x assume "x \<in> alts" "i \<in> agents"
    with as have "lottery_prob (pmf_of_set (set as)) (preferred_alts (R i) x) =
      real (card (set as \<inter> preferred_alts (R i) x)) / real (card (set as))"
      by (subst measure_pmf_of_set) simp_all
    also have "set as \<inter> preferred_alts (R i) x = set (filter (\<lambda>y. R i x y) as)"
      by (auto simp add: preferred_alts_def)
    also have "card \<dots> = length (filter (\<lambda>y. R i x y) as)"
      by (intro distinct_card distinct_filter assms)
    also have "card (set as) = length as" by (intro distinct_card assms)
    finally have "lottery_prob (pmf_of_set (set as)) (preferred_alts (R i) x) =
      real (length (filter (prefs_from_table xss i x) as)) / real (length as)"
      by (simp add: R)
  } note B = this

  from wf show "\<exists>x\<in>A. pmf (sds R) x = 0"
  proof (rule SD_inefficient_support')
    from ys ys' show lottery1: "pmf_of_list ys \<in> lotteries" by (intro pmf_of_list_lottery)
    show i: "i \<in> agents" by fact
    from as have lottery2: "pmf_of_set (set as) \<in> lotteries"
      by (intro pmf_of_set_lottery) simp_all
    from i as SD2 lottery1 lottery2 show "\<not>SD (R i) (pmf_of_list ys) (pmf_of_set A)"
      by (subst preorder_on.SD_preorder[of alts]) (auto simp: A B not_le)
    from as SD1 lottery1 lottery2
      show "\<forall>i\<in>agents. SD (R i) (pmf_of_set A) (pmf_of_list ys)"
        by safe (auto simp: preorder_on.SD_preorder[of alts] A B)
  qed (insert as, simp_all)
qed

definition pref_classes where
  "pref_classes alts le = preferred_alts le ` alts - {alts}"

primrec pref_classes_lists where
  "pref_classes_lists [] = {}"
| "pref_classes_lists (xs#xss) = insert (\<Union>(set (xs#xss))) (pref_classes_lists xss)"

fun pref_classes_lists_aux where
  "pref_classes_lists_aux acc [] = {}"
| "pref_classes_lists_aux acc (xs#xss) = insert acc (pref_classes_lists_aux (acc \<union> xs) xss)"

lemma pref_classes_lists_append:
  "pref_classes_lists (xs @ ys) = (\<union>) (\<Union>(set ys)) ` pref_classes_lists xs \<union> pref_classes_lists ys"
  by (induction xs) auto

lemma pref_classes_lists_aux:
  assumes "is_weak_ranking xss" "acc \<inter> (\<Union>(set xss)) = {}"
  shows  "pref_classes_lists_aux acc xss =
            (insert acc ((\<lambda>A. A \<union> acc) ` pref_classes_lists (rev xss)) - {acc \<union> \<Union>(set xss)})"
using assms
proof (induction acc xss rule: pref_classes_lists_aux.induct [case_names Nil Cons])
  case (Cons acc xs xss)
  from Cons.prems have A: "acc \<inter> (xs \<union> \<Union>(set xss)) = {}" "xs \<noteq> {}"
    by (simp_all add: is_weak_ranking_Cons)
  from Cons.prems have "pref_classes_lists_aux (acc \<union> xs) xss =
                          insert (acc \<union> xs) ((\<lambda>A. A \<union> (acc \<union> xs)) `pref_classes_lists (rev xss)) -
                          {acc \<union> xs \<union> \<Union>(set xss)}"
    by (intro Cons.IH) (auto simp: is_weak_ranking_Cons)
  with Cons.prems have "pref_classes_lists_aux acc (xs # xss) =
      insert acc (insert (acc \<union> xs) ((\<lambda>A. A \<union> (acc \<union> xs)) ` pref_classes_lists (rev xss)) -
         {acc \<union> (xs \<union> \<Union>(set xss))})"
    by (simp_all add: is_weak_ranking_Cons pref_classes_lists_append image_image Un_ac)
  also from  A have "\<dots> = insert acc (insert (acc \<union> xs) ((\<lambda>x. x \<union> (acc \<union> xs)) `
                            pref_classes_lists (rev xss))) - {acc \<union> (xs \<union> \<Union>(set xss))}"
    by blast
  finally show ?case
    by (simp_all add: pref_classes_lists_append image_image Un_ac)
qed simp_all

lemma pref_classes_list_aux_hd_tl:
  assumes "is_weak_ranking xss" "xss \<noteq> []"
  shows   "pref_classes_lists_aux (hd xss) (tl xss) = pref_classes_lists (rev xss) - {\<Union>(set xss)}"
proof -
  from assms have A: "xss = hd xss # tl xss" by simp
  from assms have "hd xss \<inter> \<Union>(set (tl xss)) = {} \<and> is_weak_ranking (tl xss)"
    by (subst (asm) A, subst (asm) is_weak_ranking_Cons) simp_all
  hence "pref_classes_lists_aux (hd xss) (tl xss) =
           insert (hd xss) ((\<lambda>A. A \<union> hd xss) ` pref_classes_lists (rev (tl xss))) -
           {hd xss \<union> \<Union>(set (tl xss))}" by (intro pref_classes_lists_aux) simp_all
  also have "hd xss \<union> \<Union>(set (tl xss)) = \<Union>(set xss)" by (subst (3) A, subst set_simps) simp_all
  also have "insert (hd xss) ((\<lambda>A. A \<union> hd xss) ` pref_classes_lists (rev (tl xss))) =
               pref_classes_lists (rev (tl xss) @ [hd xss])"
    by (subst pref_classes_lists_append) auto
  also have "rev (tl xss) @ [hd xss] = rev xss" by (subst (3) A) (simp only: rev.simps)
  finally show ?thesis .
qed

lemma pref_classes_of_weak_ranking_aux:
  assumes "is_weak_ranking xss"
  shows   "of_weak_ranking_Collect_ge xss ` (\<Union>(set xss)) = pref_classes_lists xss"
proof safe
  fix X x assume "x \<in> X" "X \<in> set xss"
  with assms show "of_weak_ranking_Collect_ge xss x \<in> pref_classes_lists xss"
    by (induction xss) (auto simp: is_weak_ranking_Cons of_weak_ranking_Collect_ge_Cons')
next
  fix x assume "x \<in> pref_classes_lists xss"
  with assms show "x \<in> of_weak_ranking_Collect_ge xss ` \<Union>(set xss)"
  proof (induction xss)
    case (Cons xs xss)
    from Cons.prems consider "x = xs \<union> \<Union>(set xss)" | "x \<in> pref_classes_lists xss" by auto
    thus ?case
    proof cases
      assume "x = xs \<union> \<Union>(set xss)"
      with Cons.prems show ?thesis
        by (auto simp: is_weak_ranking_Cons of_weak_ranking_Collect_ge_Cons')
    next
      assume x: "x \<in> pref_classes_lists xss"
      from Cons.prems x have "x \<in> of_weak_ranking_Collect_ge xss ` \<Union>(set xss)"
        by (intro Cons.IH) (simp_all add: is_weak_ranking_Cons)
      moreover from Cons.prems have "xs \<inter> \<Union>(set xss) = {}"
        by (simp add: is_weak_ranking_Cons)
      ultimately have "x \<in> of_weak_ranking_Collect_ge xss `
                         ((xs \<union> \<Union>(set xss)) \<inter> {x. x \<notin> xs})" by blast
      thus ?thesis by (simp add: of_weak_ranking_Collect_ge_Cons')
    qed
  qed simp_all
qed

lemma eval_pref_classes_of_weak_ranking:
  assumes "\<Union>(set xss) = alts" "is_weak_ranking xss" "alts \<noteq> {}"
  shows   "pref_classes alts (of_weak_ranking xss) = pref_classes_lists_aux (hd xss) (tl xss)"
proof -
  have "pref_classes alts (of_weak_ranking xss) =
               preferred_alts (of_weak_ranking xss) ` (\<Union>(set (rev xss))) - {\<Union>(set xss)}"
    by (simp add: pref_classes_def assms)
  also {
    have "of_weak_ranking_Collect_ge (rev xss) ` (\<Union>(set (rev xss))) = pref_classes_lists (rev xss)"
      using assms by (intro pref_classes_of_weak_ranking_aux) simp_all
    also have "of_weak_ranking_Collect_ge (rev xss) = preferred_alts (of_weak_ranking xss)"
      by (intro ext) (simp_all add: of_weak_ranking_Collect_ge_def preferred_alts_def)
    finally have "preferred_alts (of_weak_ranking xss) ` (\<Union>(set (rev xss))) =
                    pref_classes_lists (rev xss)" .
  }
  also from assms have "pref_classes_lists (rev xss) - {\<Union>(set xss)} =
                          pref_classes_lists_aux (hd xss) (tl xss)"
    by (intro pref_classes_list_aux_hd_tl [symmetric]) auto
  finally show ?thesis by simp
qed

context preorder_on
begin

lemma SD_iff_pref_classes:
  assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  shows   "p \<preceq>[SD(le)] q \<longleftrightarrow>
             (\<forall>A\<in>pref_classes carrier le. measure_pmf.prob p A \<le> measure_pmf.prob q A)"
proof safe
  fix A assume "p \<preceq>[SD(le)] q" "A \<in> pref_classes carrier le"
  thus "measure_pmf.prob p A \<le> measure_pmf.prob q A"
    by (auto simp: SD_preorder pref_classes_def)
next
  assume A: "\<forall>A\<in>pref_classes carrier le. measure_pmf.prob p A \<le> measure_pmf.prob q A"
  show "p \<preceq>[SD(le)] q"
  proof (rule SD_preorderI)
    fix x assume x: "x \<in> carrier"
    show "measure_pmf.prob p (preferred_alts le x)
             \<le> measure_pmf.prob q (preferred_alts le x)"
    proof (cases "preferred_alts le x = carrier")
      case False
      with x have "preferred_alts le x \<in> pref_classes carrier le"
        unfolding pref_classes_def by (intro DiffI imageI) simp_all
      with A show ?thesis by simp
    next
      case True
      from assms have "measure_pmf.prob p carrier = 1" "measure_pmf.prob q carrier = 1"
        by (auto simp: measure_pmf.prob_eq_1 lotteries_on_def AE_measure_pmf_iff)
      with True show ?thesis by simp
    qed
  qed (insert assms, simp_all)
qed

end

lemma (in strategyproof_an_sds) strategyproof':
  assumes wf: "is_pref_profile R" "total_preorder_on alts Ri'" and i: "i \<in> agents"
  shows   "(\<exists>A\<in>pref_classes alts (R i). lottery_prob (sds (R(i := Ri'))) A <
                        lottery_prob (sds R) A) \<or>
           (\<forall>A\<in>pref_classes alts (R i). lottery_prob (sds (R(i := Ri'))) A =
                        lottery_prob (sds R) A)"
proof -
  from wf(1) interpret R: pref_profile_wf agents alts R .
  from i interpret total_preorder_on alts "R i" by simp
  from assms have "\<not> manipulable_profile R i Ri'" by (intro strategyproof)
  moreover from wf i have "sds R \<in> lotteries" "sds (R(i := Ri')) \<in> lotteries"
    by (simp_all add: sds_wf)
  ultimately show ?thesis
    by (fastforce simp: manipulable_profile_def strongly_preferred_def
                        SD_iff_pref_classes not_le not_less)
qed

lemma pref_classes_lists_aux_finite:
  "A \<in> pref_classes_lists_aux acc xss \<Longrightarrow> finite acc \<Longrightarrow> (\<And>A. A \<in> set xss \<Longrightarrow> finite A)
      \<Longrightarrow> finite A"
  by (induction acc xss rule: pref_classes_lists_aux.induct) auto

lemma strategyproof_aux:
  assumes wf: "prefs_from_table_wf agents alts xss1" "R1 = prefs_from_table xss1"
              "prefs_from_table_wf agents alts xss2" "R2 = prefs_from_table xss2"
  assumes sds: "strategyproof_an_sds agents alts sds" and i: "i \<in> agents" and j: "j \<in> agents"
  assumes eq:  "R1(i := R2 j) = R2" "the (map_of xss1 i) = xs"
               "pref_classes_lists_aux (hd xs) (tl xs) = ps"
  shows   "(\<exists>A\<in>ps. (\<Sum>x\<in>A. pmf (sds R2) x) < (\<Sum>x\<in>A. pmf (sds R1) x)) \<or>
           (\<forall>A\<in>ps. (\<Sum>x\<in>A. pmf (sds R2) x) = (\<Sum>x\<in>A. pmf (sds R1) x))"
proof -
  from sds interpret strategyproof_an_sds agents alts sds .
  let ?Ri' = "R2 j"
  from wf j have wf': "is_pref_profile R1" "total_preorder_on alts ?Ri'"
    by (auto intro: pref_profile_from_tableI pref_profile_wf.prefs_wf'(1))

  from wf(1) i have "i \<in> set (map fst xss1)" by (simp add: prefs_from_table_wf_def)
  with prefs_from_table_wfD(3)[OF wf(1)] eq
    have "xs \<in> set (map snd xss1)" by force
  note xs = prefs_from_table_wfD(2)[OF wf(1)] prefs_from_table_wfD(5,6)[OF wf(1) this]

  {
    fix p A assume A: "A \<in> pref_classes_lists_aux (hd xs) (tl xs)"
    from xs have "xs \<noteq> []" by auto
    with xs have "finite A"
      by (intro pref_classes_lists_aux_finite[OF A])
         (auto simp: is_finite_weak_ranking_def list.set_sel)
    hence "lottery_prob p A = (\<Sum>x\<in>A. pmf p x)"
      by (rule measure_measure_pmf_finite)
  } note A = this

  from strategyproof'[OF wf' i] eq have
    "(\<exists>A\<in>pref_classes alts (R1 i). lottery_prob (sds R2) A < lottery_prob (sds R1) A) \<or>
     (\<forall>A\<in>pref_classes alts (R1 i). lottery_prob (sds R2) A = lottery_prob (sds R1) A)"
    by simp
  also from wf eq i have "R1 i = of_weak_ranking xs"
    by (simp add: prefs_from_table_map_of)
  also from xs have "pref_classes alts (of_weak_ranking xs) = pref_classes_lists_aux (hd xs) (tl xs)"
    unfolding is_finite_weak_ranking_def by (intro eval_pref_classes_of_weak_ranking) simp_all
  finally show ?thesis by (simp add: A eq)
qed

lemma strategyproof_aux':
  assumes wf: "prefs_from_table_wf agents alts xss1" "R1 \<equiv> prefs_from_table xss1"
              "prefs_from_table_wf agents alts xss2" "R2 \<equiv> prefs_from_table xss2"
  assumes sds: "strategyproof_an_sds agents alts sds" and i: "i \<in> agents" and j: "j \<in> agents"
  assumes perm: "list_permutes ys alts"
  defines "\<sigma> \<equiv> permutation_of_list ys" and "\<sigma>' \<equiv> inverse_permutation_of_list ys"
  defines "xs \<equiv> the (map_of xss1 i)"
  defines xs': "xs' \<equiv> map ((`) \<sigma>) (the (map_of xss2 j))"
  defines "Ri' \<equiv> of_weak_ranking xs'"
  assumes distinct_ps: "\<forall>A\<in>ps. distinct A"
  assumes eq:  "mset (map snd xss1) - {#the (map_of xss1 i)#} + {#xs'#} =
                  mset (map (map ((`) \<sigma>) \<circ> snd) xss2)"
               "pref_classes_lists_aux (hd xs) (tl xs) = set ` ps"
  shows   "list_permutes ys alts \<and>
             ((\<exists>A\<in>ps. (\<Sum>x\<leftarrow>A. pmf (sds R2) (\<sigma>' x)) < (\<Sum>x\<leftarrow>A. pmf (sds R1) x)) \<or>
              (\<forall>A\<in>ps. (\<Sum>x\<leftarrow>A. pmf (sds R2) (\<sigma>' x)) = (\<Sum>x\<leftarrow>A. pmf (sds R1) x)))"
            (is "_ \<and> ?th")
proof
  from perm have perm': "\<sigma> permutes alts" by (simp add: \<sigma>_def)
  from sds interpret strategyproof_an_sds agents alts sds .
  from wf(3) j have "j \<in> set (map fst xss2)" by (simp add: prefs_from_table_wf_def)
  with prefs_from_table_wfD(3)[OF wf(3)]
    have xs'_aux: "the (map_of xss2 j) \<in> set (map snd xss2)" by force
  with wf(3) have xs'_aux': "is_finite_weak_ranking (the (map_of xss2 j))"
    by (auto simp: prefs_from_table_wf_def)
  hence *: "is_weak_ranking xs'" unfolding xs'
    by (intro is_weak_ranking_map_inj permutes_inj_on[OF perm'])
       (auto simp add: is_finite_weak_ranking_def)
  moreover from * xs'_aux' have "is_finite_weak_ranking xs'"
    by (auto simp: xs' is_finite_weak_ranking_def)
  moreover from prefs_from_table_wfD(5)[OF wf(3) xs'_aux]
    have "\<Union>(set xs') = alts" unfolding xs'
    by (simp add: image_Union [symmetric] permutes_image[OF perm'])
  ultimately have wf_xs': "is_weak_ranking xs'" "is_finite_weak_ranking xs'" "\<Union>(set xs') = alts"
    by (simp_all add: is_finite_weak_ranking_def)
  from this wf j have wf': "is_pref_profile R1" "total_preorder_on alts Ri'"
                      "is_pref_profile R2" "finite_total_preorder_on alts Ri'"
    unfolding Ri'_def by (auto intro: pref_profile_from_tableI pref_profile_wf.prefs_wf'(1)
                                 total_preorder_of_weak_ranking)

 interpret R1: pref_profile_wf agents alts R1 by fact
 interpret R2: pref_profile_wf agents alts R2 by fact

  from wf(1) i have "i \<in> set (map fst xss1)" by (simp add: prefs_from_table_wf_def)
  with prefs_from_table_wfD(3)[OF wf(1)] eq(2)
    have "xs \<in> set (map snd xss1)" unfolding xs_def by force
  note xs = prefs_from_table_wfD(2)[OF wf(1)] prefs_from_table_wfD(5,6)[OF wf(1) this]

  from wf i wf' wf_xs' xs eq
    have eq': "anonymous_profile (R1(i := Ri')) = image_mset (map ((`) \<sigma>)) (anonymous_profile R2)"
    by (subst R1.anonymous_profile_update)
       (simp_all add: Ri'_def weak_ranking_of_weak_ranking mset_map multiset.map_comp xs_def
          anonymise_prefs_from_table prefs_from_table_map_of)

  {
    fix p A assume A: "A \<in> pref_classes_lists_aux (hd xs) (tl xs)"
    from xs have "xs \<noteq> []" by auto
    with xs have "finite A"
      by (intro pref_classes_lists_aux_finite[OF A])
         (auto simp: is_finite_weak_ranking_def list.set_sel)
    hence "lottery_prob p A = (\<Sum>x\<in>A. pmf p x)"
      by (rule measure_measure_pmf_finite)
  } note A = this

  from strategyproof'[OF wf'(1,2) i] eq' have
    "(\<exists>A\<in>pref_classes alts (R1 i). lottery_prob (sds (R1(i := Ri'))) A < lottery_prob (sds R1) A) \<or>
     (\<forall>A\<in>pref_classes alts (R1 i). lottery_prob (sds (R1(i := Ri'))) A = lottery_prob (sds R1) A)"
    by simp
  also from eq' i have "sds (R1(i := Ri')) = map_pmf \<sigma> (sds R2)"
    unfolding \<sigma>_def by (intro sds_anonymous_neutral permutation_of_list_permutes perm wf'
                              pref_profile_wf.wf_update eq)
  also from wf eq i have "R1 i = of_weak_ranking xs"
    by (simp add: prefs_from_table_map_of xs_def)
  also from xs have "pref_classes alts (of_weak_ranking xs) = pref_classes_lists_aux (hd xs) (tl xs)"
    unfolding is_finite_weak_ranking_def by (intro eval_pref_classes_of_weak_ranking) simp_all
  finally have "(\<exists>A\<in>ps. (\<Sum>x\<leftarrow>A. pmf (map_pmf \<sigma> (sds R2)) x) < (\<Sum>x\<leftarrow>A. pmf (sds R1) x)) \<or>
                (\<forall>A\<in>ps. (\<Sum>x\<leftarrow>A. pmf (map_pmf \<sigma> (sds R2)) x) = (\<Sum>x\<leftarrow>A. pmf (sds R1) x))"
    using distinct_ps
    by (simp add: A eq sum.distinct_set_conv_list del: measure_map_pmf)
  also from perm' have "pmf (map_pmf \<sigma> (sds R2)) = (\<lambda>x. pmf (sds R2) (inv \<sigma> x))"
    using pmf_map_inj'[of \<sigma> _ "inv \<sigma> x" for x]
    by (simp add: fun_eq_iff permutes_inj permutes_inverses)
  also from perm have "inv \<sigma> = \<sigma>'" unfolding \<sigma>_def \<sigma>'_def
    by (rule inverse_permutation_of_list_correct [symmetric])
  finally show ?th .
qed fact+

ML_file \<open>randomised_social_choice.ML\<close>
ML_file \<open>sds_automation.ML\<close>

end


theory Degeneralization_Refine
imports Degeneralization Refine
begin

  lemma degen_param[param]: "(degen, degen) \<in> \<langle>S \<rightarrow> bool_rel\<rangle> list_rel \<rightarrow> S \<times>\<^sub>r nat_rel \<rightarrow> bool_rel"
  proof (intro fun_relI)
    fix cs ds ak bl
    assume "(cs, ds) \<in> \<langle>S \<rightarrow> bool_rel\<rangle> list_rel" "(ak, bl) \<in>  S \<times>\<^sub>r nat_rel"
    then show "(degen cs ak, degen ds bl) \<in> bool_rel"
      unfolding degen_def list_rel_def fun_rel_def list_all2_conv_all_nth
      by (cases "snd ak < length cs") (auto 0 3)
  qed

  lemma count_param[param]: "(Degeneralization.count, Degeneralization.count) \<in>
    \<langle>A \<rightarrow> bool_rel\<rangle> list_rel \<rightarrow> A \<rightarrow> nat_rel \<rightarrow> nat_rel"
    unfolding count_def null_def[symmetric] by parametricity

end


(* Author: Alexander Maletzky *)

section \<open>Sample Computations with the F4 Algorithm\<close>

theory F4_Examples
  imports F4 Algorithm_Schema_Impl Jordan_Normal_Form.Gauss_Jordan_IArray_Impl Code_Target_Rat
begin

text \<open>We only consider scalar polynomials here, but vector-polynomials could be handled, too.\<close>

subsection \<open>Preparations\<close>

primrec remdups_wrt_rev :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'a list" where
  "remdups_wrt_rev f [] vs = []" |
  "remdups_wrt_rev f (x # xs) vs =
    (let fx = f x in if List.member vs fx then remdups_wrt_rev f xs vs else x # (remdups_wrt_rev f xs (fx # vs)))"

lemma remdups_wrt_rev_notin: "v \<in> set vs \<Longrightarrow> v \<notin> f ` set (remdups_wrt_rev f xs vs)"
proof (induct xs arbitrary: vs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  from Cons(2) have 1: "v \<notin> f ` set (remdups_wrt_rev f xs vs)" by (rule Cons(1))
  from Cons(2) have "v \<in> set (f x # vs)" by simp
  hence 2: "v \<notin> f ` set (remdups_wrt_rev f xs (f x # vs))" by (rule Cons(1))
  from Cons(2) show ?case by (auto simp: Let_def 1 2 List.member_def)
qed

lemma distinct_remdups_wrt_rev: "distinct (map f (remdups_wrt_rev f xs vs))"
proof (induct xs arbitrary: vs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  show ?case by (simp add: Let_def Cons(1) remdups_wrt_rev_notin)
qed

lemma map_of_remdups_wrt_rev':
  "map_of (remdups_wrt_rev fst xs vs) k = map_of (filter (\<lambda>x. fst x \<notin> set vs) xs) k"
proof (induct xs arbitrary: vs)
  case Nil
  show ?case by simp
next
  case (Cons x xs)
  show ?case
  proof (simp add: Let_def List.member_def Cons, intro impI)
    assume "k \<noteq> fst x"
    have "map_of (filter (\<lambda>y. fst y \<noteq> fst x \<and> fst y \<notin> set vs) xs) =
          map_of (filter (\<lambda>y. fst y \<noteq> fst x) (filter (\<lambda>y. fst y \<notin> set vs) xs))"
      by (simp only: filter_filter conj_commute)
    also have "... = map_of (filter (\<lambda>y. fst y \<notin> set vs) xs) |` {y. y \<noteq> fst x}" by (rule map_of_filter)
    finally show "map_of (filter (\<lambda>y. fst y \<noteq> fst x \<and> fst y \<notin> set vs) xs) k =
                  map_of (filter (\<lambda>y. fst y \<notin> set vs) xs) k"
      by (simp add: restrict_map_def \<open>k \<noteq> fst x\<close>)
  qed
qed

corollary map_of_remdups_wrt_rev: "map_of (remdups_wrt_rev fst xs []) = map_of xs"
  by (rule ext, simp add: map_of_remdups_wrt_rev')

lemma (in term_powerprod) compute_list_to_poly [code]:
  "list_to_poly ts cs = distr\<^sub>0 DRLEX (remdups_wrt_rev fst (zip ts cs) [])"
  by (rule poly_mapping_eqI,
      simp add: lookup_list_to_poly list_to_fun_def distr\<^sub>0_def oalist_of_list_ntm_def
        oa_ntm.lookup_oalist_of_list distinct_remdups_wrt_rev lookup_dflt_def map_of_remdups_wrt_rev)

lemma (in ordered_term) compute_Macaulay_list [code]:
  "Macaulay_list ps =
     (let ts = Keys_to_list ps in
      filter (\<lambda>p. p \<noteq> 0) (mat_to_polys ts (row_echelon (polys_to_mat ts ps)))
     )"
  by (simp add: Macaulay_list_def Macaulay_mat_def Let_def)

declare conversep_iff [code]

derive (eq) ceq poly_mapping
derive (no) ccompare poly_mapping
derive (dlist) set_impl poly_mapping
derive (no) cenum poly_mapping

derive (eq) ceq rat
derive (no) ccompare rat
derive (dlist) set_impl rat
derive (no) cenum rat

global_interpretation punit': gd_powerprod "ord_pp_punit cmp_term" "ord_pp_strict_punit cmp_term"
  rewrites "punit.adds_term = (adds)"
  and "punit.pp_of_term = (\<lambda>x. x)"
  and "punit.component_of_term = (\<lambda>_. ())"
  and "punit.monom_mult = monom_mult_punit"
  and "punit.mult_scalar = mult_scalar_punit"
  and "punit'.punit.min_term = min_term_punit"
  and "punit'.punit.lt = lt_punit cmp_term"
  and "punit'.punit.lc = lc_punit cmp_term"
  and "punit'.punit.tail = tail_punit cmp_term"
  and "punit'.punit.ord_p = ord_p_punit cmp_term"
  and "punit'.punit.ord_strict_p = ord_strict_p_punit cmp_term"
  and "punit'.punit.keys_to_list = keys_to_list_punit cmp_term"
  for cmp_term :: "('a::nat, 'b::{nat,add_wellorder}) pp nat_term_order"

  defines max_punit = punit'.ordered_powerprod_lin.max
  and max_list_punit = punit'.ordered_powerprod_lin.max_list
  and find_adds_punit = punit'.punit.find_adds
  and trd_aux_punit = punit'.punit.trd_aux
  and trd_punit = punit'.punit.trd
  and spoly_punit = punit'.punit.spoly
  and count_const_lt_components_punit = punit'.punit.count_const_lt_components
  and count_rem_components_punit = punit'.punit.count_rem_components
  and const_lt_component_punit = punit'.punit.const_lt_component
  and full_gb_punit = punit'.punit.full_gb
  and add_pairs_single_sorted_punit = punit'.punit.add_pairs_single_sorted
  and add_pairs_punit = punit'.punit.add_pairs
  and canon_pair_order_aux_punit = punit'.punit.canon_pair_order_aux
  and canon_basis_order_punit = punit'.punit.canon_basis_order
  and new_pairs_sorted_punit = punit'.punit.new_pairs_sorted
  and product_crit_punit = punit'.punit.product_crit
  and chain_ncrit_punit = punit'.punit.chain_ncrit
  and chain_ocrit_punit = punit'.punit.chain_ocrit
  and apply_icrit_punit = punit'.punit.apply_icrit
  and apply_ncrit_punit = punit'.punit.apply_ncrit
  and apply_ocrit_punit = punit'.punit.apply_ocrit
  and Keys_to_list_punit = punit'.punit.Keys_to_list
  and sym_preproc_addnew_punit = punit'.punit.sym_preproc_addnew
  and sym_preproc_aux_punit = punit'.punit.sym_preproc_aux
  and sym_preproc_punit = punit'.punit.sym_preproc
  and Macaulay_mat_punit = punit'.punit.Macaulay_mat
  and Macaulay_list_punit = punit'.punit.Macaulay_list
  and pdata_pairs_to_list_punit = punit'.punit.pdata_pairs_to_list
  and Macaulay_red_punit = punit'.punit.Macaulay_red
  and f4_sel_aux_punit = punit'.punit.f4_sel_aux
  and f4_sel_punit = punit'.punit.f4_sel
  and f4_red_aux_punit = punit'.punit.f4_red_aux
  and f4_red_punit = punit'.punit.f4_red
  and f4_aux_punit = punit'.punit.f4_aux_punit
  and f4_punit = punit'.punit.f4_punit
  subgoal by (fact gd_powerprod_ord_pp_punit)
  subgoal by (fact punit_adds_term)
  subgoal by (simp add: id_def)
  subgoal by (fact punit_component_of_term)
  subgoal by (simp only: monom_mult_punit_def)
  subgoal by (simp only: mult_scalar_punit_def)
  subgoal using min_term_punit_def by fastforce
  subgoal by (simp only: lt_punit_def ord_pp_punit_alt)
  subgoal by (simp only: lc_punit_def ord_pp_punit_alt)
  subgoal by (simp only: tail_punit_def ord_pp_punit_alt)
  subgoal by (simp only: ord_p_punit_def ord_pp_strict_punit_alt)
  subgoal by (simp only: ord_strict_p_punit_def ord_pp_strict_punit_alt)
  subgoal by (simp only: keys_to_list_punit_def ord_pp_punit_alt)
  done

subsection \<open>Computations\<close>

experiment begin interpretation trivariate\<^sub>0_rat .

lemma
  "lt_punit DRLEX (X\<^sup>2 * Z ^ 3 + 3 * X\<^sup>2 * Y) = sparse\<^sub>0 [(0, 2), (2, 3)]"
  by eval

lemma
  "lc_punit DRLEX (X\<^sup>2 * Z ^ 3 + 3 * X\<^sup>2 * Y) = 1"
  by eval

lemma
  "tail_punit DRLEX (X\<^sup>2 * Z ^ 3 + 3 * X\<^sup>2 * Y) = 3 * X\<^sup>2 * Y"
  by eval

lemma
  "ord_strict_p_punit DRLEX (X\<^sup>2 * Z ^ 4 - 2 * Y ^ 3 * Z\<^sup>2) (X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2)"
  by eval

lemma
  "f4_punit DRLEX
    [
     (X\<^sup>2 * Z ^ 4 - 2 * Y ^ 3 * Z\<^sup>2, ()),
     (Y\<^sup>2 * Z + 2 * Z ^ 3, ())
    ] () =
    [
     (X\<^sup>2 * Y\<^sup>2 * Z\<^sup>2 + 4 * Y ^ 3 * Z\<^sup>2, ()),
     (X\<^sup>2 * Z ^ 4 - 2 * Y ^ 3 * Z\<^sup>2, ()),
     (Y\<^sup>2 * Z + 2 * Z ^ 3, ()),
     (X\<^sup>2 * Y ^ 4 * Z + 4 * Y ^ 5 * Z, ())
    ]"
  by eval

lemma
  "f4_punit DRLEX
    [
     (X\<^sup>2 + Y\<^sup>2 + Z\<^sup>2 - 1, ()),
     (X * Y - Z - 1, ()),
     (Y\<^sup>2 + X, ()),
     (Z\<^sup>2 + X, ())
    ] () =
    [
     (1, ())
    ]"
  by eval

end

value [code] "length (f4_punit DRLEX (map (\<lambda>p. (p, ())) ((cyclic DRLEX 4)::(_ \<Rightarrow>\<^sub>0 rat) list)) ())"

value [code] "length (f4_punit DRLEX (map (\<lambda>p. (p, ())) ((katsura DRLEX 2)::(_ \<Rightarrow>\<^sub>0 rat) list)) ())"

end (* theory *)


section \<open>Canonicalization Phase\<close>

theory CanonicalizationTreeProofs
  imports
    CanonicalizationTree
    Proofs.StampEvalThms
begin

lemma neutral_rewrite_helper:
      "valid_value x (IntegerStamp b lo hi) \<longrightarrow> intval_mul x (IntVal b (1)) = x"
  and "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_add x (IntVal b (0)) = x"
  and "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_sub x (IntVal b (0)) = x"
  and "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_xor x (IntVal b (0)) = x"
  and "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_or x (IntVal b (0)) = x"
  using valid_int_stamp_gives by fastforce+

lemma annihilator_rewrite_helper:
  shows "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_mul x (IntVal b 0) = IntVal b 0"
  and   "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_and x (IntVal b 0) = IntVal b 0"
  using valid_int_stamp_gives by fastforce+

text \<open>The -1 annihilator of OR is a bit harder to prove, because the upper bits are zeroed.\<close>
lemma annihilator_rewrite_helper2:
     "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_or x (IntVal b (neg_one b)) = IntVal b (neg_one b)"
  using valid_int_stamp_gives
  by (metis intval_or.simps(1) neg_one.simps neg_one_value new_int_bin.simps take_bit_eq_mask word_ao_absorbs(4))

lemma idempotent_rewrite_helper:
  shows "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_and x x = x"
  and   "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_or  x x = x"
  using valid_int_stamp_gives
  by fastforce+

value "size (v::32 word)"

experiment begin
lemma CanonicalizeBinaryProof:
  assumes "CanonicalizeBinaryOp before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeBinaryOp.induct)
  case (binary_const_fold x val1 y val2 val op)
  then show ?case by auto
next
  case (binary_fold_yneutral y c op stampx x stampy)
  obtain xval where x_eval: "[m, p] \<turnstile> x \<mapsto> xval"
    using binary_fold_yneutral.prems(2) by auto
  then have "bin_eval op xval c = xval"
    using neutral_rewrite_helper binary_fold_yneutral.hyps(2-3,6-) is_IntegerStamp_def
    sorry (*by (metis ConstantExpr Value.distinct(5) valid_value.simps(34))*)
  then show ?case
    by (metis binary_fold_yneutral.hyps(1) binary_fold_yneutral.prems(1) binary_fold_yneutral.prems(2) x_eval
          BinaryExprE ConstantExprE evalDet)
next
  case (binary_fold_yzero32 y c op stampx x stampy)
  obtain xval where x_eval: "[m, p] \<turnstile> x \<mapsto> xval"
    using binary_fold_yzero32.prems(1) by auto
  then have "bin_eval op xval c = c"
    using annihilator_rewrite_helper binary_fold_yzero32.hyps is_IntegerStamp_def
    sorry
  then show ?case
    by (metis BinaryExprE ConstantExprE binary_fold_yzero32.hyps(1) binary_fold_yzero32.prems(1) binary_fold_yzero32.prems(2) evalDet x_eval)

next
  case (binary_fold_yzero64 y c op stampx x stampy)
  obtain xval where x_eval: "[m, p] \<turnstile> x \<mapsto> xval"
    using binary_fold_yzero64.prems(1) by auto
  then have "bin_eval op xval c = c"
    using annihilator_rewrite_helper
    sorry
  then show ?case
    by (metis BinaryExprE ConstantExprE binary_fold_yzero64.hyps(1)
        binary_fold_yzero64.prems(1) binary_fold_yzero64.prems(2) evalDet x_eval)

next
  case (binary_idempotent op x)
  obtain xval where x_eval: "[m, p] \<turnstile> x \<mapsto> xval"
    using binary_idempotent.prems(1) by auto
  then have "bin_eval op xval xval = xval"
    using idempotent_rewrite_helper binary_idempotent.hyps
    sorry
  then show ?case
    by (metis BinaryExprE binary_idempotent.prems(1) binary_idempotent.prems(2) evalDet x_eval)

qed
end

lemma CanonicalizeUnaryProof:
  assumes "CanonicalizeUnaryOp before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeUnaryOp.induct)
  case (unary_const_fold val' op val)
  then show ?case by auto
qed

lemma mul_rewrite_helper:
  shows "valid_value x (IntegerStamp 64 lo hi) \<Longrightarrow> intval_mul x (IntVal 64 (-1)) = intval_negate x"
  using valid_int_stamp_gives by fastforce+

text \<open>As usual, the general case is harder to prove, because upper bits are zeroed.\<close>
lemma mul_rewrite_helper32:
  shows "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_mul x (IntVal b (neg_one b)) = intval_negate x"
  using valid_int_stamp_gives
  by (smt (verit, ccfv_threshold) intval_mul.simps(1) intval_negate.simps(1) mult_minus1_right neg_one.simps new_int.simps new_int_bin.simps take_bit_minus_one_eq_mask take_bit_mult take_bit_of_int unsigned_take_bit_eq word_mult_def)

(* or a more manual proof:
lemma mul_rewrite_helper32:
  shows "valid_value x (IntegerStamp b lo hi) \<Longrightarrow> intval_mul x (new_int b (-1)) = intval_negate x"
proof -
  assume v: "valid_value x (IntegerStamp b lo hi)"
  then obtain ix where ix: "x = IntVal b ix"
    by (metis valid_int_stamp_gives)
  then show "intval_mul x (new_int b (-1)) = intval_negate x"
    unfolding ix intval_mul.simps new_int_bin.simps new_int.simps
    by (simp; smt (verit, ccfv_threshold) ix mult_minus1_right of_int_mult take_bit_minus_one_eq_mask take_bit_mult take_bit_of_int uint_take_bit_eq v valid_int_fits word_of_int_uint)
qed
*)

experiment begin
lemma CanonicalizeMulProof:
  assumes "CanonicalizeMul before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeMul.induct)
  show ?thesis
    using ConstantExprE BinaryExprE bin_eval.simps evalDet mul_rewrite_helper
    sorry
qed
end

lemma valid_int_stamp_both:
  assumes 1: "valid_value x (IntegerStamp b lox hix)"
  and     2: "valid_value y (IntegerStamp b loy hiy)"
  obtains ix iy where "x = IntVal b ix"
     and "take_bit b ix = ix"
     and "y = IntVal b iy"
     and "take_bit b iy = iy"
  using assms valid_int_stamp_gives by metis

(* (x - y) + y \<Rightarrow> x *)
(*  x + (y - x) \<Rightarrow> y *)
(* (-x + y) \<Rightarrow> (y - x) *)
(* (x + (-y)) \<Rightarrow> (x - y) *)
lemma add_rewrites_helper:
  assumes 1:"valid_value x (IntegerStamp b lox hix)"
  and     2:"valid_value y (IntegerStamp b loy hiy)"
  shows "intval_add (intval_sub x y) y = x \<and>
         intval_add x (intval_sub y x) = y \<and>
         intval_add (intval_negate x) y = intval_sub y x \<and>
         intval_add x (intval_negate y) = intval_sub x y"
  using valid_int_stamp_both[OF 1 2]
  by fastforce

experiment begin
lemma CanonicalizeAddProof:
  assumes "CanonicalizeAdd before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeAdd.induct)
  case (add_xsub x a y stampa stampy)
  then show ?case
    using BinaryExprE Stamp.collapse(1) bin_eval.simps(1) bin_eval.simps(3)
        evalDet intval_add_sym add_rewrites_helper(1)
    sorry
next
  case (add_ysub y a x stampa stampx)
  then show ?case sorry (*
    by (metis is_IntegerStamp_def add_ysub.hyps add_ysub.prems evalDet BinaryExprE Stamp.sel(1)
        bin_eval.simps(1) bin_eval.simps(3) stamp_implies_valid_value intval_add_sym add_rewrites_helper(2))*)
next
  case (add_xnegate nx x stampx stampy y)
  then show ?case sorry (*
    by (smt (verit, del_insts) BinaryExprE Stamp.sel(1) UnaryExprE add_rewrites_helper(4)
        bin_eval.simps(1) bin_eval.simps(3) evalDet stamp_implies_valid_value intval_add_sym is_IntegerStamp_def unary_eval.simps(2)) *)
next
  case (add_ynegate ny y stampx x stampy)
  then show ?case sorry (*
    by (smt (verit) BinaryExprE Stamp.sel(1) UnaryExprE add_rewrites_helper(4) bin_eval.simps(1)
        bin_eval.simps(3) evalDet stamp_implies_valid_value is_IntegerStamp_def unary_eval.simps(2)) *)
qed

(* (x + y) - y \<Rightarrow> x *)
(* (x + y) - x \<Rightarrow> y *)
(* (x - y) - x \<Rightarrow> (-y) *)
(* x - (x + y) \<Rightarrow> (-y) *)
(* y - (x + y) \<Rightarrow> (-x) *)
(* x - (x - y) \<Rightarrow> y *)
(* x - (-y) \<Rightarrow> x + y *)
lemma sub_rewrites_helper:
  assumes 1:"valid_value x (IntegerStamp b lox hix)"
  and     2:"valid_value y (IntegerStamp b loy hiy)"

  shows "intval_sub (intval_add x y) y  = x"
  and   "intval_sub (intval_add x y) x  = y"
  and   "intval_sub (intval_sub x y) x  = intval_negate y"
  and   "intval_sub x (intval_add x y)  = intval_negate y"
  and   "intval_sub y (intval_add x y)  = intval_negate x"
  and   "intval_sub x (intval_sub x y)  = y"
  and   "intval_sub x (intval_negate y) = intval_add x y"
  using valid_int_stamp_both[OF 1 2] by fastforce+

(* x - x \<Rightarrow> 0 *)
(* 0 - x \<Rightarrow> -x *)
lemma sub_single_rewrites_helper:
  assumes "valid_value x (IntegerStamp b lox hix)"
  shows   "intval_sub x x = IntVal b 0"
  and     "intval_sub (IntVal b 0) x = intval_negate x"
  using assms valid_int_stamp_gives by fastforce+

lemma CanonicalizeSubProof:
  assumes "CanonicalizeSub before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeSub.induct)
  case (sub_same64 stampx x lo hi)
  show ?case sorry (*
    using ConstantExprE BinaryExprE  bin_eval.simps evalDet sub_same64.prems sub_single_rewrites_helper
      stamp_implies_valid_value sub_same64.hyps(1) sub_same64.hyps(2)
    by (auto; metis) *)
next
  case (sub_left_add1 x a b stampa stampb)
  then show ?case sorry (*
    by (metis BinaryExprE Stamp.collapse(1) bin_eval.simps(1) bin_eval.simps(3) evalDet
        stamp_implies_valid_value sub_rewrites_helper(1)) *)
next
  case (sub_left_add2 x a b stampa stampb)
  then show ?case sorry (*
    by (metis BinaryExprE Stamp.collapse(1) bin_eval.simps(1) bin_eval.simps(3) evalDet
        stamp_implies_valid_value sub_rewrites_helper(2)) *)
next
  case (sub_left_sub x a b stampa stampb)
  then show ?case sorry (*
    by (smt (verit) BinaryExprE Stamp.sel(1) UnaryExprE bin_eval.simps(3) evalDet
        stamp_implies_valid_value is_IntegerStamp_def sub_rewrites_helper(3) unary_eval.simps(2)) *)
next
  case (sub_right_add1 y a b stampa stampb)
  then show ?case sorry (*
    by (smt (verit) BinaryExprE Stamp.sel(1) UnaryExprE bin_eval.simps(1) bin_eval.simps(3) evalDet
        stamp_implies_valid_value is_IntegerStamp_def sub_rewrites_helper(4) unary_eval.simps(2)) *)
next
  case (sub_right_add2 y a b stampa stampb)
  then show ?case sorry (*
    by (smt (verit) BinaryExprE Stamp.sel(1) UnaryExprE bin_eval.simps(1) bin_eval.simps(3) evalDet
        stamp_implies_valid_value is_IntegerStamp_def sub_rewrites_helper(5) unary_eval.simps(2)) *)
next
  case (sub_right_sub y a b stampa stampb)
  then show ?case sorry (*
    by (metis BinaryExprE Stamp.sel(1) bin_eval.simps(3) evalDet
        stamp_implies_valid_value is_IntegerStamp_def sub_rewrites_helper(6)) *)
next
  case (sub_xzero64 stampx x lo hi)
  then show ?case sorry (*
    using ConstantExprE BinaryExprE  bin_eval.simps evalDet sub_xzero64.prems sub_single_rewrites_helper
      stamp_implies_valid_value sub_xzero64.hyps(1) sub_xzero64.hyps(2)
    by (auto; metis) *)
next
  case (sub_y_negate nb b stampa a stampb)
  then show ?case sorry (*
    by (smt (verit, best) BinaryExprE Stamp.sel(1) UnaryExprE bin_eval.simps(1) bin_eval.simps(3) evalDet
        stamp_implies_valid_value is_IntegerStamp_def sub_rewrites_helper(7) unary_eval.simps(2)) *)
qed

(* -(x-y) = (x-y) *)
lemma negate_xsuby_helper:
  assumes "valid_value x (IntegerStamp b lox hix)"
  and "valid_value y (IntegerStamp b loy hiy)"
  shows "intval_negate (intval_sub x y) = intval_sub y x"
  using valid_int_stamp_both[OF assms]
  by (smt (verit, ccfv_threshold) ab_group_add_class.ab_diff_conv_add_uminus add.commute add_diff_cancel_left' diff_0 intval_negate.simps(1) intval_sub.simps(1) new_int.simps new_int_bin.simps take_bit_dist_subR)

(* -(-x) = x *)
lemma negate_negate_helper:
  assumes "valid_value x (IntegerStamp b lox hix)"
  shows "intval_negate (intval_negate x) = x"
  using valid_int_stamp_gives
  by (metis (no_types, opaque_lifting) add.inverse_inverse assms diff_0 intval_negate.simps(1) new_int.simps take_bit_dist_subR)

lemma CanonicalizeNegateProof:
  assumes "CanonicalizeNegate before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeNegate.induct)
  case (negate_negate nx x)
  thus ?case sorry (*
    by (metis UnaryExprE evalDet stamp_implies_valid_value is_IntegerStamp_def negate_negate_helper unary_eval.simps(2)) *)
next
  case (negate_sub e x y stampx stampy)
  thus ?case sorry (*
    by (smt (verit) BinaryExprE Stamp.sel(1) UnaryExprE bin_eval.simps(3) evalDet stamp_implies_valid_value
        is_IntegerStamp_def negate_xsuby_helper unary_eval.simps(2)) *)
qed
end

(* TODO: a better name for this? *)
experiment begin
lemma word_helper:
  shows "\<And> x :: 32 word. \<not>(- x <s 0 \<and> x <s 0)"
  and   "\<And> x :: 64 word. \<not>(- x <s 0 \<and> x <s 0)"
  and   "\<And> x :: 32 word. \<not> - x <s 0 \<and> \<not> x <s 0 \<Longrightarrow> 2 * x = 0"
  and   "\<And> x :: 64 word. \<not> - x <s 0 \<and> \<not> x <s 0 \<Longrightarrow> 2 * x = 0"
  apply (case_tac[!] "x")
  apply auto+
  sorry

(* abs(-x) = abs(x) *)
(* abs(abs(x)) = abs(x)
lemma abs_rewrite_helper:
  assumes "valid_value (IntegerStamp b lox hix) x"
  shows "intval_abs (intval_negate x) = intval_abs x"
  and "intval_abs (intval_abs x) = intval_abs x"
  apply (case_tac[!] "x")
  using word_helper apply auto+
  done
*)

lemma abs_abs_is_abs:
  assumes 1: "valid_value x (IntegerStamp b lox hix)"
  shows "intval_abs (intval_abs x) = intval_abs x"
(* was:
  using word_helper
  by (metis assms intval_abs.simps(1) intval_abs.simps(2) valid32or64_both)
*)
  sorry

lemma abs_neg_is_neg:
  assumes "valid_value x (IntegerStamp b lox hix)"
  shows "intval_abs (intval_negate x) = intval_abs x"
  apply (case_tac[!] "x")
  using word_helper
    (* apply auto+
  done *)
  sorry
end

(*
lemma CanonicalizeAbsAbs:
  assumes vv: "is_IntegerStamp (stamp_expr e)"
  assumes "[m, p] \<turnstile> UnaryExpr UnaryAbs (UnaryExpr UnaryAbs e) \<mapsto> v"
  shows "[m, p] \<turnstile> UnaryExpr UnaryAbs e \<mapsto> v"
  by (metis UnaryExprE abs_abs_is_abs assms(2) stamp_implies_valid_value
      is_IntegerStamp_def unary_eval.simps(1) vv)

lemma CanonicalizeAbsNeg:
  assumes vv: "is_IntegerStamp (stamp_expr e)"
  assumes "[m, p] \<turnstile> UnaryExpr UnaryAbs (UnaryExpr UnaryNeg e) \<mapsto> v"
  shows "[m, p] \<turnstile> UnaryExpr UnaryAbs e \<mapsto> v"
  using UnaryExprE abs_neg_is_neg assms(2) stamp_implies_valid_value
      is_IntegerStamp_def unary_eval.simps(2) vv
  by (smt (verit, ccfv_threshold) evaltree.simps unary_eval.simps(1))

lemma CanonicalizeAbsProof:
  assumes "CanonicalizeAbs before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeAbs.induct)
  case (abs_abs ax x)
  then show ?case
    by (metis UnaryExprE abs_rewrite_helper(2) evalDet stamp_implies_valid_value is_IntegerStamp_def
        unary_eval.simps(1))
next
  case (abs_neg nx x)
  then show ?case
    by (metis UnaryExprE abs_rewrite_helper(1) evalDet stamp_implies_valid_value is_IntegerStamp_def
        unary_eval.simps(1) unary_eval.simps(2))
qed
*)
(* ~(~x) = x *)
lemma not_rewrite_helper:
  assumes "valid_value x (IntegerStamp b lox hix)"
  shows "intval_not (intval_not x) = x"
  using assms valid_int_stamp_gives
  by (metis bit.double_compl intval_not.simps(1) new_int.simps take_bit_not_take_bit)

experiment begin
lemma CanonicalizeNotProof:
  assumes "CanonicalizeNot before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeNot.induct)
  case (not_not nx x)
  then show ?case sorry (*
    by (metis UnaryExprE evalDet is_IntegerStamp_def not_rewrite_helper
        stamp_implies_valid_value unary_eval.simps(3)) *)
qed
end

lemma demorgans_rewrites_helper:
  assumes "valid_value x (IntegerStamp b lox hix)"
  and     "valid_value y (IntegerStamp b loy hiy)"

  shows "intval_and (intval_not x) (intval_not y) = intval_not (intval_or x y)"
  and   "intval_or (intval_not x) (intval_not y) = intval_not (intval_and x y)"
  and   "x = y \<Longrightarrow> intval_and x y = x"
  and   "x = y \<Longrightarrow> intval_or x y = x"
  using assms valid_int_stamp_both
  sorry  (* was: fastforce+ *)

experiment begin
lemma CanonicalizeAndProof:
  assumes "CanonicalizeAnd before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeAnd.induct)
  case (and_same x)
  then show ?case sorry (*
    by (metis BinaryExprE bin_eval.simps(4) demorgans_rewrites_helper(3) evalDet
        stamp_implies_valid_value is_IntegerStamp_def) *)
next
  case (and_demorgans nx x ny y stampx stampy)
  then show ?case sorry (*
    by (smt (z3) BinaryExprE Stamp.sel(1) UnaryExprE bin_eval.simps(4) bin_eval.simps(5)
        demorgans_rewrites_helper(1) evalDet stamp_implies_valid_value is_IntegerStamp_def unary_eval.simps(3)) *)
qed

lemma CanonicalizeOrProof:
  assumes "CanonicalizeOr before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeOr.induct)
  case (or_same x)
  then show ?case sorry (*
    by (metis BinaryExprE bin_eval.simps(5) demorgans_rewrites_helper(4) evalDet
        stamp_implies_valid_value is_IntegerStamp_def) *)
next
  case (or_demorgans nx x ny y stampx stampy)
  then show ?case sorry (*
    by (smt (z3) BinaryExprE Stamp.sel(1) UnaryExprE bin_eval.simps(4) bin_eval.simps(5) demorgans_rewrites_helper(2)
        evalDet stamp_implies_valid_value is_IntegerStamp_def unary_eval.simps(3)) *)
qed
end

experiment begin
lemma stamps_touch_but_not_less_than_implies_equal:
  "\<lbrakk>valid_value x stampx;
    valid_value y stampy;
    is_IntegerStamp stampx \<and> is_IntegerStamp stampy;
    stpi_upper stampx = stpi_lower stampy;
    \<not> val_to_bool (intval_less_than x y)\<rbrakk> \<Longrightarrow> x = y"
  using valid_int_stamp_both intval_equals.simps(1-2) intval_less_than.simps(1-2) val_to_bool.simps(1)
  sorry

lemma disjoint_stamp_implies_less_than:
  "\<lbrakk>valid_value x stampx;
    valid_value y stampy;
    is_IntegerStamp stampx \<and> is_IntegerStamp stampy;
    stpi_upper stampx < stpi_lower stampy\<rbrakk>
  \<Longrightarrow> val_to_bool(intval_less_than x y)"
  sorry

lemma CanonicalizeConditionalProof:
  assumes "CanonicalizeConditional before after"
  assumes "[m, p] \<turnstile> before \<mapsto> res"
  assumes "[m, p] \<turnstile> after \<mapsto> res'"
  shows "res = res'"
  using assms
proof (induct rule: CanonicalizeConditional.induct)
  case (eq_branches t f c)
  then show ?case using evalDet by auto
next
  case (cond_eq c x y stampx stampy)
  obtain xval where xeval: "[m,p] \<turnstile> x \<mapsto> xval"
    using cond_eq.hyps(1) cond_eq.prems(1) by blast
  obtain yval where yeval: "[m,p] \<turnstile> y \<mapsto> yval"
    using cond_eq.prems(2) by auto
  show ?case proof (cases "xval = yval")
    case True
    then show ?thesis
      by (smt (verit, ccfv_threshold) ConditionalExprE cond_eq.prems(1) cond_eq.prems(2) evalDet xeval yeval)
  next
    case False
    then have "\<not>(val_to_bool(intval_equals xval yval))"
      using ConstantExpr Value.distinct(9) valid_value.simps
      apply (cases "intval_equals xval yval")
      using val_to_bool.simps(2) sorry
    then have "res = yval"
      by (smt (verit, ccfv_threshold) BinaryExprE ConditionalExprE bin_eval.simps(11) cond_eq.hyps(1) cond_eq.prems(1) evalDet xeval yeval)
    then show ?thesis
      using cond_eq.prems(1) cond_eq.prems(2) xeval yeval evalDet by auto
  qed
next
  case (condition_bounds_x c x y stampx stampy)
  obtain xval where xeval: "[m,p] \<turnstile> x \<mapsto> xval"
    using condition_bounds_x.prems(2) by auto
  obtain yval where yeval: "[m,p] \<turnstile> y \<mapsto> yval"
    using condition_bounds_x.hyps(1) condition_bounds_x.prems(1) by blast
  then show ?case proof (cases "val_to_bool(intval_less_than xval yval)")
    case True
    then show ?thesis
      by (smt (verit, best) BinaryExprE ConditionalExprE bin_eval.simps(12) condition_bounds_x.hyps(1) condition_bounds_x.prems(1) condition_bounds_x.prems(2) evalDet xeval yeval)
  next
    case False
    then have "stpi_upper stampx = stpi_lower stampy"
      sorry (*
      by (metis False condition_bounds_x.hyps(4) order.not_eq_order_implies_strict
          disjoint_stamp_implies_less_than condition_bounds_x.hyps(2) condition_bounds_x.hyps(3) condition_bounds_x.hyps(6)
          stamp_implies_valid_value xeval yeval) *)
    then have "(xval = yval)"
      sorry (*
      by (metis False condition_bounds_x.hyps(2-3,6) stamp_implies_valid_value
          stamps_touch_but_not_less_than_implies_equal xeval yeval) *)
    then have "res = xval \<and> res' = xval"
      using ConditionalExprE condition_bounds_x.prems(1) \<open>[m,p] \<turnstile> x \<mapsto> res'\<close> evalDet xeval yeval
      by force
    then show ?thesis by simp
  qed
next
  case (condition_bounds_y c x y stampx stampy)
  obtain xval where xeval: "[m,p] \<turnstile> x \<mapsto> xval"
    using condition_bounds_y.hyps(1) condition_bounds_y.prems(1) by auto
  obtain yval where yeval: "[m,p] \<turnstile> y \<mapsto> yval"
    using condition_bounds_y.hyps(1) condition_bounds_y.prems(1) by blast
  then show ?case proof (cases "val_to_bool(intval_less_than xval yval)")
    case True
    then show ?thesis
      by (smt (verit, best) BinaryExprE ConditionalExprE bin_eval.simps(12) condition_bounds_y.hyps(1) condition_bounds_y.prems(1) condition_bounds_y.prems(2) evalDet xeval yeval)
  next
    case False
    have "stpi_upper stampx = stpi_lower stampy"
      sorry (*
      by (metis False condition_bounds_y.hyps(4) order.not_eq_order_implies_strict
          disjoint_stamp_implies_less_than condition_bounds_y.hyps(2) condition_bounds_y.hyps(3)
          condition_bounds_y.hyps(6) stamp_implies_valid_value xeval yeval) *)
    then have "(xval = yval)"
      sorry (*
      by (metis False condition_bounds_y.hyps(2-3,6)
          stamp_implies_valid_value stamps_touch_but_not_less_than_implies_equal xeval yeval)
      *)
    then have "res = yval \<and> res' = yval"
      using ConditionalExprE condition_bounds_y.prems(1) \<open>[m,p] \<turnstile> y \<mapsto> res'\<close> evalDet xeval yeval
      by force
    then show ?thesis by simp
  qed
next
  case (negate_condition nc c stampc lo hi stampx x stampy y)
  obtain cval where ceval: "[m,p] \<turnstile> c \<mapsto> cval"
    using negate_condition.prems(2) by auto
  obtain ncval where nceval: "[m,p] \<turnstile> nc \<mapsto> ncval"
    using negate_condition.prems negate_condition.prems by blast
  then show ?case using assms proof (cases "(val_to_bool ncval)")
    case True
    obtain xval where xeval: "[m,p] \<turnstile> x \<mapsto> xval"
      by (metis (full_types) ConditionalExprE nceval evalDet True negate_condition.prems(1))
    then have "res = xval"
      by (metis (full_types) ConditionalExprE True evalDet nceval negate_condition.prems(1))
    have "c \<noteq> nc"
      by (simp add: negate_condition.hyps(1))
    then have "\<not>(val_to_bool cval)"
      sorry (*
      by (metis True UnaryExprE ceval evalDet intval_logic_negation.simps(1) nceval negate_condition.hyps(1) negate_condition.hyps(2) negate_condition.hyps(3) stamp_implies_valid_value unary_eval.simps(4) val_to_bool.simps(1) valid_int32)
      *)
    then have "res' = xval"
      using nceval ceval True negate_condition(1) negate_condition(9)
      by (metis (full_types) ConditionalExprE evalDet xeval)
    then show ?thesis
      by (simp add: \<open>res = xval\<close>)
  next
    case False
    obtain yval where yeval: "[m,p] \<turnstile> y \<mapsto> yval"
      by (metis (full_types) ConditionalExprE nceval evalDet False negate_condition.prems(1))
    then have "res = yval"
      using False nceval negate_condition.prems(1) evaltree.ConditionalExpr yeval evalDet
      by (metis (full_types) ConditionalExprE)
    moreover have "val_to_bool(cval)"
      sorry (*
      by (metis False UnaryExprE ceval evalDet intval_logic_negation.simps(1) nceval negate_condition.hyps(1) negate_condition.hyps(2) negate_condition.hyps(3) stamp_implies_valid_value unary_eval.simps(4) val_to_bool.simps(1) valid_int32 zero_neq_one)
      *)
    moreover have "res' = yval"
      using calculation(2) ceval negate_condition.prems evaltree.ConditionalExpr yeval evalDet  unary_eval.simps(4)
      by (metis (full_types) ConditionalExprE)
    ultimately show ?thesis by simp
  qed
next
  case (const_true c val t f)
  then show ?case using evalDet by auto
next
  case (const_false c val t f)
  then show ?case using evalDet by auto
qed
end

end


(* Author: Dmitriy Traytel *)

header {* Deciding Equivalence of WS1S Formulas *}

(*<*)
theory WS1S_Equivalence_Checking
imports
  Pi_Equivalence_Checking
  PNormalization
  Init_Normalization
  WS1S_Normalization
  Pi_Regular_Exp_Dual
  "~~/src/Tools/Permanent_Interpretation"
begin
(*>*)

permanent_interpretation embed2 "set o \<sigma> \<Sigma>" "wf_atom \<Sigma>" \<pi> lookup "\<epsilon> \<Sigma>" "split Singleton"
  for \<Sigma> :: "'a :: linorder list"
  defining
      \<DD> = "embed.lderiv lookup (\<epsilon> \<Sigma>)"
  and Co\<DD> = "embed.lderiv_dual lookup (\<epsilon> \<Sigma>)"
  and r\<DD> = "embed.rderiv lookup (\<epsilon> \<Sigma>)"
  and r\<DD>_add = "embed2.rderiv_and_add lookup (\<epsilon> \<Sigma>)"
  and \<QQ> = "embed2.samequot_exec lookup (\<epsilon> \<Sigma>) (split Singleton)"
  by unfold_locales (auto simp: \<sigma>_def \<pi>_def \<epsilon>_def set_n_lists)

lemma enum_not_empty[simp]: "Enum.enum \<noteq> []" (is "?enum \<noteq> []")
proof (rule notI)
  assume "?enum = []"
  hence "set ?enum = {}" by simp
  thus False unfolding UNIV_enum[symmetric] by simp
qed

permanent_interpretation \<Phi>: formula "Enum.enum :: 'a :: {enum, linorder} list"
  defining
      pre_wf_formula = \<Phi>.pre_wf_formula
  and wf_formula = \<Phi>.wf_formula
  and rexp_of = \<Phi>.rexp_of
  and rexp_of_alt = \<Phi>.rexp_of_alt
  and rexp_of_alt' = \<Phi>.rexp_of_alt'
  and rexp_of' = \<Phi>.rexp_of'
  and rexp_of'' = \<Phi>.rexp_of''
  and valid_ENC = \<Phi>.valid_ENC
  and ENC = \<Phi>.ENC
  and dec_interp = \<Phi>.stream_dec
  and any = \<Phi>.any
  where "embed2.samequot_exec lookup (\<epsilon> (Enum.enum :: 'a list)) (split Singleton) = \<QQ> Enum.enum"
  by unfold_locales (auto simp: \<sigma>_def \<pi>_def \<QQ>_def)

lemmas lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of_norm = trans[OF sym[OF \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_norm] \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of]
lemmas lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of'_norm = trans[OF sym[OF \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_norm] \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of']
lemmas lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of''_norm = trans[OF sym[OF \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_norm] \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of'']

setup {* Sign.map_naming (Name_Space.mandatory_path "slow") *}

permanent_interpretation D: rexp_DFA "\<sigma> \<Sigma>" "wf_atom \<Sigma>" \<pi> lookup "\<lambda>x. \<guillemotleft>pnorm (inorm x)\<guillemotright>"
  "\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>" final "alphabet.wf (wf_atom \<Sigma>) n" pnorm "lang \<Sigma> n" n
  for \<Sigma> :: "'a :: linorder list" and n :: nat
  defining
      test = "rexp_DA.test (final :: 'a atom rexp \<Rightarrow> bool)"
  and step = "rexp_DA.step (\<sigma> \<Sigma>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) pnorm n"
  and closure = "rexp_DA.closure (\<sigma> \<Sigma>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) final pnorm n"
  and check_eqvRE = "rexp_DA.check_eqv (\<sigma> \<Sigma>) (\<lambda>x. \<guillemotleft>pnorm (inorm x)\<guillemotright>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) final pnorm n"
  and test_invariant = "rexp_DA.test_invariant (final :: 'a atom rexp \<Rightarrow> bool) ::
    (('a \<times> bool list) list \<times> _) list \<times> _ \<Rightarrow> bool"
  and step_invariant = "rexp_DA.step_invariant (\<sigma> \<Sigma>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) pnorm n"
  and closure_invariant = "rexp_DA.closure_invariant (\<sigma> \<Sigma>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) final pnorm n"
  and counterexampleRE = "rexp_DA.counterexample (\<sigma> \<Sigma>) (\<lambda>x. \<guillemotleft>pnorm (inorm x)\<guillemotright>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) final pnorm n"
  and reachable = "rexp_DA.reachable (\<sigma> \<Sigma>) (\<lambda>x. \<guillemotleft>pnorm (inorm x)\<guillemotright>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) pnorm n"
  and automaton = "rexp_DA.automaton (\<sigma> \<Sigma>) (\<lambda>x. \<guillemotleft>pnorm (inorm x)\<guillemotright>) (\<lambda>a r. \<guillemotleft>\<DD> \<Sigma> a r\<guillemotright>) pnorm n"
  by unfold_locales (auto simp only: comp_apply
    ACI_norm_wf ACI_norm_lang wf_inorm lang_inorm wf_pnorm lang_pnorm wf_lderiv lang_lderiv
    lang_final finite_fold_lderiv dest!: lang_subset_lists)

definition check_eqv where
"check_eqv n \<phi> \<psi> \<longleftrightarrow> wf_formula n (FOr \<phi> \<psi>) \<and>
   slow.check_eqvRE Enum.enum n (rexp_of'' n (norm \<phi>)) (rexp_of'' n (norm \<psi>))"

definition counterexample where
"counterexample n \<phi> \<psi> =
   map_option (\<lambda>w. dec_interp n (FOV (FOr \<phi> \<psi>)) (w @- sconst (any, replicate n False)))
   (slow.counterexampleRE Enum.enum n (rexp_of'' n (norm \<phi>)) (rexp_of'' n (norm \<psi>)))"

lemma completeness:
  assumes "\<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S n \<phi> = \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S n \<psi>" "wf_formula n (FOr \<phi> \<psi>)"
  shows "slow.check_eqv n \<phi> \<psi>"
  using assms(2) unfolding slow.check_eqv_def
  by (intro conjI[OF assms(2) slow.D.check_eqv_complete,
                OF box_equals[OF assms(1) lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of''_norm lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of''_norm]])
   (auto intro!: \<Phi>.wf_rexp_of'')

setup {* Sign.map_naming Name_Space.parent_path *}

setup {* Sign.map_naming (Name_Space.mandatory_path "fast") *}

permanent_interpretation D: rexp_DA_no_post "\<sigma> \<Sigma>" "wf_atom \<Sigma>" \<pi> lookup "\<lambda>x. pnorm (inorm x)"
  "\<lambda>a r. pnorm (\<DD> \<Sigma> a r)" final "alphabet.wf (wf_atom \<Sigma>) n" "lang \<Sigma> n" n
  for \<Sigma> :: "'a :: linorder list" and n :: nat
  defining
      test = "rexp_DA.test (final :: 'a atom rexp \<Rightarrow> bool)"
  and step = "rexp_DA.step (\<sigma> \<Sigma>) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) id n"
  and closure = "rexp_DA.closure (\<sigma> \<Sigma>) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) final id n"
  and check_eqvRE = "rexp_DA.check_eqv (\<sigma> \<Sigma>) (\<lambda>x. pnorm (inorm x)) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) final id n"
  and test_invariant = "rexp_DA.test_invariant (final :: 'a atom rexp \<Rightarrow> bool) ::
    (('a \<times> bool list) list \<times> _) list \<times> _ \<Rightarrow> bool"
  and step_invariant = "rexp_DA.step_invariant (\<sigma> \<Sigma>) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) id n"
  and closure_invariant = "rexp_DA.closure_invariant (\<sigma> \<Sigma>) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) final id n"
  and counterexampleRE = "rexp_DA.counterexample (\<sigma> \<Sigma>) (\<lambda>x. pnorm (inorm x)) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) final id n"
  and reachable = "rexp_DA.reachable (\<sigma> \<Sigma>) (\<lambda>x. pnorm (inorm x)) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) id n"
  and automaton = "rexp_DA.automaton (\<sigma> \<Sigma>) (\<lambda>x. pnorm (inorm x)) (\<lambda>a r. pnorm (\<DD> \<Sigma> a r)) id n"
  by unfold_locales (auto simp only: comp_apply
    ACI_norm_wf ACI_norm_lang wf_inorm lang_inorm wf_pnorm lang_pnorm wf_lderiv lang_lderiv id_apply
    lang_final dest!: lang_subset_lists)

definition check_eqv where
"check_eqv n \<phi> \<psi> \<longleftrightarrow> wf_formula n (FOr \<phi> \<psi>) \<and>
   fast.check_eqvRE Enum.enum n (rexp_of'' n (norm \<phi>)) (rexp_of'' n (norm \<psi>))"

definition counterexample where
"counterexample n \<phi> \<psi> =
   map_option (\<lambda>w. dec_interp n (FOV (FOr \<phi> \<psi>)) (w @- sconst (any, replicate n False)))
   (fast.counterexampleRE Enum.enum n (rexp_of'' n (norm \<phi>)) (rexp_of'' n (norm \<psi>)))"

lemma soundness: "fast.check_eqv n \<phi> \<psi> \<Longrightarrow> \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S n \<phi> = \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S n \<psi>"
  by (rule box_equals[OF fast.D.check_eqv_sound
  sym[OF trans[OF lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of''_norm]] sym[OF trans[OF lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of''_norm]]])
   (auto simp: fast.check_eqv_def intro!: \<Phi>.wf_rexp_of'')

setup {* Sign.map_naming Name_Space.parent_path *}

setup {* Sign.map_naming (Name_Space.mandatory_path "dual") *}

permanent_interpretation D: rexp_DA_no_post "\<sigma> \<Sigma>" "wf_atom \<Sigma>" \<pi> lookup
  "\<lambda>x. pnorm_dual (rexp_dual_of (inorm x))" "\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)" final_dual
  "alphabet.wf_dual (wf_atom \<Sigma>) n" "lang_dual \<Sigma> n" n
  for \<Sigma> :: "'a :: linorder list" and n :: nat
  defining
      test = "rexp_DA.test (final_dual :: 'a atom rexp_dual \<Rightarrow> bool)"
  and step = "rexp_DA.step (\<sigma> \<Sigma>) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) id n"
  and closure = "rexp_DA.closure (\<sigma> \<Sigma>) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) final_dual id n"
  and check_eqvRE = "rexp_DA.check_eqv (\<sigma> \<Sigma>) (\<lambda>x. pnorm_dual (rexp_dual_of (inorm x))) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) final_dual id n"
  and test_invariant = "rexp_DA.test_invariant (final_dual :: 'a atom rexp_dual \<Rightarrow> bool) ::
    (('a \<times> bool list) list \<times> _) list \<times> _ \<Rightarrow> bool"
  and step_invariant = "rexp_DA.step_invariant (\<sigma> \<Sigma>) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) id n"
  and closure_invariant = "rexp_DA.closure_invariant (\<sigma> \<Sigma>) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) final_dual id n"
  and counterexampleRE = "rexp_DA.counterexample (\<sigma> \<Sigma>) (\<lambda>x. pnorm_dual (rexp_dual_of (inorm x))) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) final_dual id n"
  and reachable = "rexp_DA.reachable (\<sigma> \<Sigma>) (\<lambda>x. pnorm_dual (rexp_dual_of (inorm x))) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) id n"
  and automaton = "rexp_DA.automaton (\<sigma> \<Sigma>) (\<lambda>x. pnorm_dual (rexp_dual_of (inorm x))) (\<lambda>a r. pnorm_dual (Co\<DD> \<Sigma> a r)) id n"
  by unfold_locales (auto simp only: comp_apply id_apply
    wf_inorm lang_inorm
    wf_dual_pnorm_dual lang_dual_pnorm_dual
    wf_dual_rexp_dual_of lang_dual_rexp_dual_of
    wf_dual_lderiv_dual lang_dual_lderiv_dual
    lang_dual_final_dual dest!: lang_dual_subset_lists)

definition check_eqv where
"check_eqv n \<phi> \<psi> \<longleftrightarrow> wf_formula n (FOr \<phi> \<psi>) \<and>
   dual.check_eqvRE Enum.enum n (rexp_of'' n (norm \<phi>)) (rexp_of'' n (norm \<psi>))"

definition counterexample where
"counterexample n \<phi> \<psi> =
   map_option (\<lambda>w. dec_interp n (FOV (FOr \<phi> \<psi>)) (w @- sconst (any, replicate n False)))
   (dual.counterexampleRE Enum.enum n (rexp_of'' n (norm \<phi>)) (rexp_of'' n (norm \<psi>)))"

lemma soundness: "dual.check_eqv n \<phi> \<psi> \<Longrightarrow> \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S n \<phi> = \<Phi>.lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S n \<psi>"
  by (rule box_equals[OF dual.D.check_eqv_sound
  sym[OF trans[OF lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of''_norm]] sym[OF trans[OF lang\<^sub>W\<^sub>S\<^sub>1\<^sub>S_rexp_of''_norm]]])
   (auto simp: dual.check_eqv_def intro!: \<Phi>.wf_rexp_of'')

setup {* Sign.map_naming Name_Space.parent_path *}

(*<*)
end
(*>*)