(*
  File:         PAC_Checker_Specification.thy
  Author:       Mathias Fleury, Daniela Kaufmann, JKU
  Maintainer:   Mathias Fleury, JKU
*)
theory PAC_Checker_Specification
  imports PAC_Specification
    Refine_Imperative_HOL.IICF
    Finite_Map_Multiset
begin

section \<open>Checker Algorithm\<close>

text \<open>

In this level of refinement, we define the first level of the
implementation of the checker, both with the specification as
on ideals and the first version of the loop.

\<close>

subsection \<open>Specification\<close>

datatype status =
  is_failed: FAILED |
  is_success: SUCCESS |
  is_found: FOUND

lemma is_success_alt_def:
  \<open>is_success a \<longleftrightarrow> a = SUCCESS\<close>
  by (cases a) auto

datatype ('a, 'b, 'lbls) pac_step =
  Add (pac_src1: 'lbls) (pac_src2: 'lbls) (new_id: 'lbls) (pac_res: 'a) |
  Mult (pac_src1: 'lbls) (pac_mult: 'a) (new_id: 'lbls) (pac_res: 'a) |
  Extension (new_id: 'lbls) (new_var: 'b) (pac_res: 'a) |
  Del (pac_src1: 'lbls)

type_synonym  pac_state = \<open>(nat set \<times> int_poly multiset)\<close>

definition PAC_checker_specification
  :: \<open>int_poly \<Rightarrow> int_poly multiset \<Rightarrow> (status \<times> nat set \<times> int_poly multiset) nres\<close>
where
  \<open>PAC_checker_specification spec A = SPEC(\<lambda>(b, \<V>, B).
      (\<not>is_failed b \<longrightarrow> restricted_ideal_to\<^sub>I (\<Union>(vars ` set_mset A) \<union> vars spec) B \<subseteq> restricted_ideal_to\<^sub>I (\<Union>(vars ` set_mset A) \<union> vars spec) A) \<and>
      (is_found b \<longrightarrow> spec \<in> pac_ideal (set_mset A)))\<close>

definition PAC_checker_specification_spec
  ::  \<open>int_poly \<Rightarrow> pac_state \<Rightarrow> (status \<times> pac_state) \<Rightarrow> bool\<close>
where
  \<open>PAC_checker_specification_spec spec = (\<lambda>(\<V>, A) (b, B). (\<not>is_failed b \<longrightarrow> \<Union>(vars ` set_mset A) \<subseteq> \<V>) \<and>
       (is_success b \<longrightarrow> PAC_Format\<^sup>*\<^sup>* (\<V>, A) B) \<and>
       (is_found b \<longrightarrow> PAC_Format\<^sup>*\<^sup>* (\<V>, A) B \<and> spec \<in> pac_ideal (set_mset A)))\<close>

abbreviation PAC_checker_specification2
  ::  \<open>int_poly \<Rightarrow> (nat set \<times> int_poly multiset) \<Rightarrow> (status \<times> (nat set \<times> int_poly multiset)) nres\<close>
where
  \<open>PAC_checker_specification2 spec A \<equiv> SPEC(PAC_checker_specification_spec spec A)\<close>

definition PAC_checker_specification_step_spec
  ::  \<open>pac_state \<Rightarrow> int_poly \<Rightarrow> pac_state \<Rightarrow> (status \<times> pac_state) \<Rightarrow> bool\<close>
where
  \<open>PAC_checker_specification_step_spec = (\<lambda>(\<V>\<^sub>0, A\<^sub>0) spec (\<V>, A) (b, B).
       (is_success b \<longrightarrow>
         \<Union>(vars ` set_mset A\<^sub>0) \<subseteq> \<V>\<^sub>0 \<and>
          \<Union>(vars ` set_mset A) \<subseteq> \<V> \<and> PAC_Format\<^sup>*\<^sup>* (\<V>\<^sub>0, A\<^sub>0) (\<V>, A) \<and> PAC_Format\<^sup>*\<^sup>* (\<V>, A) B) \<and>
       (is_found b \<longrightarrow>
          \<Union>(vars ` set_mset A\<^sub>0) \<subseteq> \<V>\<^sub>0 \<and>
          \<Union>(vars ` set_mset A) \<subseteq> \<V> \<and> PAC_Format\<^sup>*\<^sup>* (\<V>\<^sub>0, A\<^sub>0) (\<V>, A) \<and> PAC_Format\<^sup>*\<^sup>* (\<V>, A) B \<and>
         spec \<in> pac_ideal (set_mset A\<^sub>0)))\<close>

abbreviation PAC_checker_specification_step2
  ::  \<open>pac_state \<Rightarrow> int_poly \<Rightarrow> pac_state \<Rightarrow> (status \<times> pac_state) nres\<close>
where
  \<open>PAC_checker_specification_step2 A\<^sub>0 spec A \<equiv> SPEC(PAC_checker_specification_step_spec A\<^sub>0  spec A)\<close>

definition normalize_poly_spec :: \<open>_\<close> where
  \<open>normalize_poly_spec p = SPEC (\<lambda>r. p - r \<in> ideal polynomial_bool \<and> vars r \<subseteq> vars p)\<close>

lemma normalize_poly_spec_alt_def:
  \<open>normalize_poly_spec p = SPEC (\<lambda>r. r - p \<in> ideal polynomial_bool \<and> vars r \<subseteq> vars p)\<close>
  unfolding normalize_poly_spec_def
  by (auto dest: ideal.span_neg)

definition mult_poly_spec :: \<open>int mpoly \<Rightarrow> int mpoly \<Rightarrow> int mpoly nres\<close> where
  \<open>mult_poly_spec p q = SPEC (\<lambda>r. p * q - r \<in> ideal polynomial_bool)\<close>

definition check_add :: \<open>(nat, int mpoly) fmap \<Rightarrow> nat set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> int mpoly \<Rightarrow> bool nres\<close> where
  \<open>check_add A \<V> p q i r =
     SPEC(\<lambda>b. b \<longrightarrow> p \<in># dom_m A \<and> q \<in># dom_m A \<and> i \<notin># dom_m A \<and> vars r \<subseteq> \<V> \<and>
            the (fmlookup A p) + the (fmlookup A q) - r \<in>  ideal polynomial_bool)\<close>

definition check_mult :: \<open>(nat, int mpoly) fmap \<Rightarrow> nat set \<Rightarrow> nat \<Rightarrow> int mpoly \<Rightarrow> nat \<Rightarrow> int mpoly \<Rightarrow> bool nres\<close> where
  \<open>check_mult A \<V> p q i r =
     SPEC(\<lambda>b. b \<longrightarrow> p \<in># dom_m A \<and>i \<notin># dom_m A \<and> vars q \<subseteq> \<V> \<and> vars r \<subseteq> \<V> \<and>
            the (fmlookup A p) * q - r \<in>  ideal polynomial_bool)\<close>

definition check_extension :: \<open>(nat, int mpoly) fmap \<Rightarrow> nat set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> int mpoly \<Rightarrow> (bool) nres\<close> where
  \<open>check_extension A \<V> i v p =
     SPEC(\<lambda>b. b \<longrightarrow> (i \<notin># dom_m A \<and>
     (v \<notin> \<V> \<and>
           (p+Var v)\<^sup>2 - (p+Var v) \<in> ideal polynomial_bool \<and>
            vars (p+Var v) \<subseteq> \<V>)))\<close>

fun merge_status where
  \<open>merge_status (FAILED) _ = FAILED\<close> |
  \<open>merge_status _ (FAILED) = FAILED\<close> |
  \<open>merge_status FOUND _ = FOUND\<close> |
  \<open>merge_status _ FOUND = FOUND\<close> |
  \<open>merge_status _ _ = SUCCESS\<close>

type_synonym fpac_step = \<open>nat set \<times> (nat, int_poly) fmap\<close>

definition check_del :: \<open>(nat, int mpoly) fmap \<Rightarrow> nat \<Rightarrow> bool nres\<close> where
  \<open>check_del A p =
     SPEC(\<lambda>b. b \<longrightarrow> True)\<close>

subsection \<open>Algorithm\<close>

definition PAC_checker_step
  ::  \<open>int_poly \<Rightarrow> (status \<times> fpac_step) \<Rightarrow> (int_poly, nat, nat) pac_step \<Rightarrow>
    (status \<times> fpac_step) nres\<close>
where
  \<open>PAC_checker_step = (\<lambda>spec (stat, (\<V>, A)) st. case st of
     Add _ _ _ _ \<Rightarrow>
       do {
         r \<leftarrow> normalize_poly_spec (pac_res st);
        eq \<leftarrow> check_add A \<V> (pac_src1 st) (pac_src2 st) (new_id st) r;
        st' \<leftarrow> SPEC(\<lambda>st'. (\<not>is_failed st' \<and> is_found st' \<longrightarrow> r - spec \<in> ideal polynomial_bool));
        if eq
        then RETURN (merge_status stat st',
          \<V>, fmupd (new_id st) r A)
        else RETURN (FAILED, (\<V>, A))
   }
   | Del _ \<Rightarrow>
       do {
        eq \<leftarrow> check_del A (pac_src1 st);
        if eq
        then RETURN (stat, (\<V>, fmdrop (pac_src1 st) A))
        else RETURN (FAILED, (\<V>, A))
   }
   | Mult _ _ _ _ \<Rightarrow>
       do {
         r \<leftarrow> normalize_poly_spec (pac_res st);
         q \<leftarrow> normalize_poly_spec (pac_mult st);
        eq \<leftarrow> check_mult A \<V> (pac_src1 st) q (new_id st) r;
        st' \<leftarrow> SPEC(\<lambda>st'. (\<not>is_failed st' \<and> is_found st' \<longrightarrow> r - spec \<in> ideal polynomial_bool));
        if eq
        then RETURN (merge_status stat st',
          \<V>, fmupd (new_id st) r A)
        else RETURN (FAILED, (\<V>, A))
   }
   | Extension _ _ _ \<Rightarrow>
       do {
         r \<leftarrow> normalize_poly_spec (pac_res st - Var (new_var st));
        (eq) \<leftarrow> check_extension A \<V> (new_id st) (new_var st) r;
        if eq
        then do {
         RETURN (stat,
          insert (new_var st) \<V>, fmupd (new_id st) (r) A)}
        else RETURN (FAILED, (\<V>, A))
   }
 )\<close>

definition polys_rel :: \<open>((nat, int mpoly)fmap \<times> _) set\<close> where
\<open>polys_rel = {(A, B). B = (ran_m A)}\<close>

definition polys_rel_full :: \<open>((nat set \<times> (nat, int mpoly)fmap) \<times> _) set\<close> where
  \<open>polys_rel_full = {((\<V>, A), (\<V>' , B)). (A, B) \<in> polys_rel \<and> \<V> = \<V>'}\<close>

lemma polys_rel_update_remove:
  \<open>x13 \<notin>#dom_m A \<Longrightarrow> x11 \<in># dom_m A \<Longrightarrow> x12 \<in># dom_m A \<Longrightarrow> x11 \<noteq> x12 \<Longrightarrow> (A,B) \<in> polys_rel \<Longrightarrow>
   (fmupd x13 r (fmdrop x11 (fmdrop x12 A)),
        add_mset r B - {#the (fmlookup A x11), the (fmlookup A x12)#})
       \<in> polys_rel\<close>
  \<open>x13 \<notin>#dom_m A \<Longrightarrow> x11 \<in># dom_m A \<Longrightarrow> (A,B) \<in> polys_rel \<Longrightarrow>
   (fmupd x13 r (fmdrop x11 A),add_mset r B - {#the (fmlookup A x11)#})
       \<in> polys_rel\<close>
  \<open>x13 \<notin>#dom_m A \<Longrightarrow> (A,B) \<in> polys_rel \<Longrightarrow>
   (fmupd x13 r A, add_mset r B) \<in> polys_rel\<close>
  \<open>x13 \<in>#dom_m A \<Longrightarrow> (A,B) \<in> polys_rel \<Longrightarrow>
   (fmdrop x13 A, remove1_mset (the (fmlookup A x13)) B) \<in> polys_rel\<close>
  using distinct_mset_dom[of A]
  apply (auto simp: polys_rel_def ran_m_mapsto_upd ran_m_mapsto_upd_notin
    ran_m_fmdrop)
  apply (subst ran_m_mapsto_upd_notin)
  apply (auto dest: in_diffD dest!: multi_member_split simp: ran_m_fmdrop ran_m_fmdrop_If distinct_mset_remove1_All ran_m_def
      add_mset_eq_add_mset removeAll_notin
    split: if_splits intro!: image_mset_cong)
  done

lemma polys_rel_in_dom_inD:
  \<open>(A, B) \<in> polys_rel \<Longrightarrow>
    x12 \<in># dom_m A \<Longrightarrow>
    the (fmlookup A x12) \<in># B\<close>
  by (auto simp: polys_rel_def)

abbreviation status_rel :: \<open>(status \<times> status) set\<close> where
  \<open>status_rel \<equiv> Id\<close>

lemma is_merge_status[simp]:
  \<open>is_failed (merge_status a st') \<longleftrightarrow> is_failed a \<or> is_failed st'\<close>
  \<open>is_found (merge_status a st') \<longleftrightarrow> \<not>is_failed a \<and> \<not>is_failed st' \<and> (is_found a \<or> is_found st')\<close>
  \<open>is_success (merge_status a st') \<longleftrightarrow> (is_success a \<and> is_success st')\<close>
  by (cases a; cases st'; auto; fail)+

lemma status_rel_merge_status:
  \<open>(merge_status a b, SUCCESS) \<notin> status_rel \<longleftrightarrow>
    (a = FAILED) \<or> (b = FAILED) \<or>
    a = FOUND \<or> (b = FOUND)\<close>
  by (cases a; cases b; auto)

lemma Ex_status_iff:
  \<open>(\<exists>a. P a) \<longleftrightarrow> P SUCCESS \<or> P FOUND \<or> (P (FAILED))\<close>
  apply auto
  apply (case_tac a; auto)
  done

lemma is_failed_alt_def:
  \<open>is_failed st' \<longleftrightarrow> \<not>is_success st' \<and> \<not>is_found st'\<close>
  by (cases st') auto

lemma merge_status_eq_iff[simp]:
  \<open>merge_status a SUCCESS = SUCCESS \<longleftrightarrow> a = SUCCESS\<close>
  \<open>merge_status a SUCCESS = FOUND \<longleftrightarrow> a = FOUND\<close>
  \<open>merge_status SUCCESS a = SUCCESS \<longleftrightarrow> a = SUCCESS\<close>
  \<open>merge_status SUCCESS a = FOUND \<longleftrightarrow> a = FOUND\<close>
  \<open>merge_status SUCCESS a = FAILED \<longleftrightarrow> a = FAILED\<close>
  \<open>merge_status a SUCCESS = FAILED \<longleftrightarrow> a = FAILED\<close>
  \<open>merge_status FOUND a = FAILED \<longleftrightarrow> a = FAILED\<close>
  \<open>merge_status a FOUND = FAILED \<longleftrightarrow> a = FAILED\<close>
  \<open>merge_status a FOUND = SUCCESS \<longleftrightarrow> False\<close>
  \<open>merge_status a b = FOUND \<longleftrightarrow> (a = FOUND \<or> b = FOUND) \<and> (a \<noteq> FAILED \<and> b \<noteq> FAILED)\<close>
  apply (cases a; auto; fail)+
  apply (cases a; cases b; auto; fail)+
  done

lemma fmdrop_irrelevant: \<open>x11 \<notin># dom_m A \<Longrightarrow> fmdrop x11 A = A\<close>
  by (simp add: fmap_ext in_dom_m_lookup_iff)

lemma PAC_checker_step_PAC_checker_specification2:
  fixes a :: \<open>status\<close>
  assumes AB: \<open>((\<V>, A),(\<V>\<^sub>B, B)) \<in> polys_rel_full\<close> and
    \<open>\<not>is_failed a\<close> and
    [simp,intro]: \<open>a = FOUND \<Longrightarrow> spec \<in> pac_ideal (set_mset A\<^sub>0)\<close> and
    A\<^sub>0B: \<open>PAC_Format\<^sup>*\<^sup>* (\<V>\<^sub>0, A\<^sub>0) (\<V>, B)\<close> and
    spec\<^sub>0: \<open>vars spec \<subseteq> \<V>\<^sub>0\<close>  and
    vars_A\<^sub>0: \<open>\<Union> (vars ` set_mset A\<^sub>0) \<subseteq> \<V>\<^sub>0\<close>
  shows \<open>PAC_checker_step spec (a, (\<V>, A)) st \<le> \<Down> (status_rel \<times>\<^sub>r polys_rel_full) (PAC_checker_specification_step2 (\<V>\<^sub>0, A\<^sub>0) spec (\<V>, B))\<close>
proof -
  have
    \<open>\<V>\<^sub>B = \<V>\<close>and
    [simp, intro]:\<open>(A, B) \<in> polys_rel\<close>
    using AB
    by (auto simp: polys_rel_full_def)
  have H0: \<open>2 * the (fmlookup A x12) - r \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
          r \<in> pac_ideal
                (insert (the (fmlookup A x12))
                  ((\<lambda>x. the (fmlookup A x)) ` set_mset Aa))\<close> for x12 r Aa
    by (metis (no_types, lifting) ab_semigroup_mult_class.mult.commute
         diff_in_polynomial_bool_pac_idealI
       ideal.span_base pac_idealI3 set_image_mset set_mset_add_mset_insert union_single_eq_member)+
  then have H0': \<open>\<And>Aa. 2 * the (fmlookup A x12) - r \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
          r - spec \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
          spec \<in> pac_ideal (insert (the (fmlookup A x12)) ((\<lambda>x. the (fmlookup A x)) ` set_mset Aa))\<close>
    for r x12
    by (metis (no_types, lifting) diff_in_polynomial_bool_pac_idealI)

  have H1: \<open> x12 \<in># dom_m A \<Longrightarrow>
       2 * the (fmlookup A x12) - r \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
       r - spec \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
       vars spec \<subseteq> vars r \<Longrightarrow>
       spec \<in> pac_ideal (set_mset B)\<close> for x12 r
     using \<open>(A,B) \<in> polys_rel\<close>
      ideal.span_add[OF ideal.span_add[OF ideal.span_neg ideal.span_neg,
         of \<open>the (fmlookup A x12)\<close> _  \<open>the (fmlookup A x12)\<close>],
      of \<open>set_mset B \<union> polynomial_bool\<close> \<open>2 * the (fmlookup A x12) - r\<close>]
     unfolding polys_rel_def
     by (auto dest!: multi_member_split simp: ran_m_def
         intro: H0')
   have H2': \<open>the (fmlookup A x11) + the (fmlookup A x12) - r \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
       B = add_mset (the (fmlookup A x11)) {#the (fmlookup A x). x \<in># Aa#} \<Longrightarrow>
       (the (fmlookup A x11) + the (fmlookup A x12) - r
        \<in> More_Modules.ideal
            (insert (the (fmlookup A x11))
              ((\<lambda>x. the (fmlookup A x)) ` set_mset Aa \<union> polynomial_bool)) \<Longrightarrow>
        - r
        \<in> More_Modules.ideal
            (insert (the (fmlookup A x11))
              ((\<lambda>x. the (fmlookup A x)) ` set_mset Aa \<union> polynomial_bool))) \<Longrightarrow>
       r \<in> pac_ideal (insert (the (fmlookup A x11)) ((\<lambda>x. the (fmlookup A x)) ` set_mset Aa))\<close>
     for r x12 x11 A Aa
     by (metis (mono_tags, lifting) Un_insert_left diff_diff_eq2 diff_in_polynomial_bool_pac_idealI diff_zero
       ideal.span_diff ideal.span_neg minus_diff_eq pac_idealI1 pac_ideal_def set_image_mset
       set_mset_add_mset_insert union_single_eq_member)
   have H2: \<open>x11 \<in># dom_m A \<Longrightarrow>
       x12 \<in># dom_m A \<Longrightarrow>
       the (fmlookup A x11) + the (fmlookup A x12) - r
       \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
       r - spec \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
       spec \<in> pac_ideal (set_mset B)\<close>  for x12 r x11
     using \<open>(A,B) \<in> polys_rel\<close>
      ideal.span_add[OF ideal.span_add[OF ideal.span_neg ideal.span_neg,
         of \<open>the (fmlookup A x11)\<close> _  \<open>the (fmlookup A x12)\<close>],
      of \<open>set_mset B \<union> polynomial_bool\<close> \<open>the (fmlookup A x11) + the (fmlookup A x12) - r\<close>]
     unfolding polys_rel_def
     by (subgoal_tac \<open>r \<in> pac_ideal (set_mset B)\<close>)
       (auto dest!: multi_member_split simp: ran_m_def ideal.span_base
         intro: diff_in_polynomial_bool_pac_idealI simp: H2')

   have H3': \<open>the (fmlookup A x12) * q - r \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
          r - spec \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
          r \<in> pac_ideal (insert (the (fmlookup A x12)) ((\<lambda>x. the (fmlookup A x)) ` set_mset Aa))\<close>
     for Aa x12 r q
     by (metis (no_types, lifting) ab_semigroup_mult_class.mult.commute diff_in_polynomial_bool_pac_idealI
       ideal.span_base pac_idealI3 set_image_mset set_mset_add_mset_insert union_single_eq_member)

  have H3: \<open>x12 \<in># dom_m A \<Longrightarrow>
       the (fmlookup A x12) * q - r \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
       r - spec \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
       spec \<in> pac_ideal (set_mset B)\<close> for x12 r q
     using \<open>(A,B) \<in> polys_rel\<close>
      ideal.span_add[OF ideal.span_add[OF ideal.span_neg ideal.span_neg,
         of \<open>the (fmlookup A x12)\<close> _  \<open>the (fmlookup A x12)\<close>],
      of \<open>set_mset B \<union> polynomial_bool\<close> \<open>2 * the (fmlookup A x12) - r\<close>]
     unfolding polys_rel_def
     by (subgoal_tac \<open>r \<in> pac_ideal (set_mset B)\<close>)
       (auto dest!: multi_member_split simp: ran_m_def H3'
         intro: diff_in_polynomial_bool_pac_idealI)

  have [intro]: \<open>spec \<in> pac_ideal (set_mset B) \<Longrightarrow> spec \<in> pac_ideal (set_mset A\<^sub>0)\<close> and
    vars_B: \<open>\<Union> (vars ` set_mset B) \<subseteq> \<V>\<close>and
    vars_B: \<open>\<Union> (vars ` set_mset (ran_m A)) \<subseteq> \<V>\<close>
    using rtranclp_PAC_Format_subset_ideal[OF A\<^sub>0B  vars_A\<^sub>0] spec\<^sub>0 \<open>(A, B) \<in> polys_rel\<close>[unfolded polys_rel_def, simplified]
    by (smt (verit) in_mono mem_Collect_eq restricted_ideal_to_def)+

  have eq_successI: \<open>st' \<noteq> FAILED \<Longrightarrow>
       st' \<noteq> FOUND \<Longrightarrow> st' = SUCCESS\<close> for st'
    by (cases st') auto
  have vars_diff_inv: \<open>vars (Var x2 - r) = vars (r - Var x2 :: int mpoly)\<close> for x2 r
    using vars_uminus[of \<open>Var x2 - r\<close>]
    by (auto simp del: vars_uminus)
  have vars_add_inv: \<open>vars (Var x2 + r) = vars (r + Var x2 :: int mpoly)\<close> for x2 r
    unfolding add.commute[of \<open>Var x2\<close> r] ..

  have [iff]: \<open>a \<noteq> FAILED\<close> and
    [intro]: \<open>a \<noteq> SUCCESS \<Longrightarrow> a = FOUND\<close> and
    [simp]: \<open>merge_status a FOUND = FOUND\<close>
    using assms(2) by (cases a; auto)+
  note [[goals_limit=1]]
  show ?thesis
    unfolding PAC_checker_step_def PAC_checker_specification_step_spec_def
      normalize_poly_spec_alt_def check_mult_def check_add_def
      check_extension_def polys_rel_full_def
    apply (cases st)
    apply clarsimp_all
    subgoal for x11 x12 x13 x14
      apply (refine_vcg lhs_step_If)
      subgoal for r eqa st'
        using assms vars_B apply -
        apply (rule RETURN_SPEC_refine)
        apply (rule_tac x = \<open>(merge_status a st',\<V>,add_mset r B)\<close> in exI)
        by (auto simp: polys_rel_update_remove ran_m_mapsto_upd_notin
          intro: PAC_Format_add_and_remove H2 dest: rtranclp_PAC_Format_subset_ideal)
      subgoal
        by (rule RETURN_SPEC_refine)
         (auto simp: Ex_status_iff dest: rtranclp_PAC_Format_subset_ideal)
      done
    subgoal for x11 x12 x13 x14
      apply (refine_vcg lhs_step_If)
      subgoal for r q eqa st'
        using assms vars_B apply -
        apply (rule RETURN_SPEC_refine)
        apply (rule_tac x = \<open>(merge_status a st',\<V>,add_mset r B)\<close> in exI)
        by (auto intro: polys_rel_update_remove intro: PAC_Format_add_and_remove(3-) H3
           dest: rtranclp_PAC_Format_subset_ideal)
      subgoal
        by (rule RETURN_SPEC_refine)
          (auto simp: Ex_status_iff)
      done
    subgoal for x31 x32 x34
      apply (refine_vcg lhs_step_If)
      subgoal for r x
        using assms vars_B apply -
        apply (rule RETURN_SPEC_refine)
        apply (rule_tac x = \<open>(a,insert x32 \<V>, add_mset r B)\<close> in exI)
        apply (auto simp: intro!: polys_rel_update_remove PAC_Format_add_and_remove(5-)
           dest: rtranclp_PAC_Format_subset_ideal)
        done
      subgoal
        by (rule RETURN_SPEC_refine)
          (auto simp: Ex_status_iff)
      done
    subgoal for x11
      unfolding check_del_def
      apply (refine_vcg lhs_step_If)
      subgoal for eq
        using assms vars_B apply -
        apply (rule RETURN_SPEC_refine)
        apply (cases \<open>x11 \<in># dom_m A\<close>)
        subgoal
          apply (rule_tac x = \<open>(a,\<V>, remove1_mset (the (fmlookup A x11)) B)\<close> in exI)
          apply (auto simp: polys_rel_update_remove PAC_Format_add_and_remove
               is_failed_def is_success_def is_found_def
            dest!: eq_successI
            split: if_splits
            dest: rtranclp_PAC_Format_subset_ideal
            intro: PAC_Format_add_and_remove H3)
          done
        subgoal
          apply (rule_tac x = \<open>(a,\<V>, B)\<close> in exI)
          apply (auto simp: fmdrop_irrelevant
               is_failed_def is_success_def is_found_def
            dest!: eq_successI
            split: if_splits
            dest: rtranclp_PAC_Format_subset_ideal
            intro: PAC_Format_add_and_remove)
          done
        done
      subgoal
        by (rule RETURN_SPEC_refine)
          (auto simp: Ex_status_iff)
      done
    done
qed

definition PAC_checker
  :: \<open>int_poly \<Rightarrow> fpac_step \<Rightarrow> status \<Rightarrow> (int_poly, nat, nat) pac_step list \<Rightarrow>
    (status \<times> fpac_step) nres\<close>
where
  \<open>PAC_checker spec A b st = do {
    (S, _) \<leftarrow> WHILE\<^sub>T
       (\<lambda>((b :: status, A :: fpac_step), st). \<not>is_failed b \<and> st \<noteq> [])
       (\<lambda>((bA), st). do {
          ASSERT(st \<noteq> []);
          S \<leftarrow> PAC_checker_step spec (bA) (hd st);
          RETURN (S, tl st)
        })
      ((b, A), st);
    RETURN S
  }\<close>

lemma PAC_checker_specification_spec_trans:
  \<open>PAC_checker_specification_spec spec A (st, x2) \<Longrightarrow>
    PAC_checker_specification_step_spec A spec x2 (st', x1a) \<Longrightarrow>
    PAC_checker_specification_spec spec A (st', x1a)\<close>
 unfolding PAC_checker_specification_spec_def
   PAC_checker_specification_step_spec_def
 apply auto
using is_failed_alt_def apply blast+
done

lemma RES_SPEC_eq:
  \<open>RES \<Phi> = SPEC(\<lambda>P. P \<in> \<Phi>)\<close>
  by auto

lemma is_failed_is_success_completeD:
  \<open>\<not> is_failed x \<Longrightarrow> \<not>is_success x \<Longrightarrow> is_found x\<close>
  by (cases x) auto

lemma PAC_checker_PAC_checker_specification2:
  \<open>(A, B) \<in>  polys_rel_full \<Longrightarrow>
    \<not>is_failed a \<Longrightarrow>
    (a = FOUND \<Longrightarrow> spec \<in> pac_ideal (set_mset (snd B))) \<Longrightarrow>
    \<Union>(vars ` set_mset (ran_m (snd A))) \<subseteq> fst B \<Longrightarrow>
    vars spec \<subseteq> fst B \<Longrightarrow>
  PAC_checker spec A a st \<le> \<Down> (status_rel \<times>\<^sub>r polys_rel_full) (PAC_checker_specification2 spec B)\<close>
  unfolding PAC_checker_def conc_fun_RES
  apply (subst RES_SPEC_eq)
  apply (refine_vcg WHILET_rule[where
      I = \<open>\<lambda>((bB), st). bB \<in> (status_rel \<times>\<^sub>r polys_rel_full)\<inverse> ``
                      Collect (PAC_checker_specification_spec spec B)\<close>
    and R = \<open>measure (\<lambda>(_, st).  Suc (length st))\<close>])
  subgoal by auto
  subgoal apply (auto simp: PAC_checker_specification_spec_def)
    apply (cases B; cases A)
    apply (auto simp:polys_rel_def polys_rel_full_def Image_iff)
    done
  subgoal by auto
  subgoal
    apply auto
    apply (rule
     PAC_checker_step_PAC_checker_specification2[of _ _ _ _ _ _ _ \<open>fst B\<close>, THEN order_trans])
     apply assumption
     apply assumption
     apply (auto intro: PAC_checker_specification_spec_trans simp: conc_fun_RES)
     apply (auto simp: PAC_checker_specification_spec_def polys_rel_full_def polys_rel_def
       dest: PAC_Format_subset_ideal
       dest: is_failed_is_success_completeD; fail)+
    by (auto simp: Image_iff intro: PAC_checker_specification_spec_trans
        simp: polys_rel_def polys_rel_full_def)
  subgoal
    by auto
  done

definition remap_polys_polynomial_bool :: \<open>int mpoly \<Rightarrow> nat set \<Rightarrow> (nat, int_poly) fmap \<Rightarrow> (status \<times> fpac_step) nres\<close> where
\<open>remap_polys_polynomial_bool spec = (\<lambda>\<V> A.
   SPEC(\<lambda>(st, \<V>', A'). (\<not>is_failed st \<longrightarrow>
      dom_m A = dom_m A' \<and>
      (\<forall>i \<in># dom_m A. the (fmlookup A i) - the (fmlookup A' i) \<in> ideal polynomial_bool) \<and>
      \<Union>(vars ` set_mset (ran_m A)) \<subseteq> \<V>' \<and>
      \<Union>(vars ` set_mset (ran_m A')) \<subseteq> \<V>') \<and>
    (st = FOUND \<longrightarrow> spec \<in># ran_m A')))\<close>

definition remap_polys_change_all :: \<open>int mpoly \<Rightarrow> nat set \<Rightarrow> (nat, int_poly) fmap \<Rightarrow> (status \<times> fpac_step) nres\<close> where
\<open>remap_polys_change_all spec = (\<lambda>\<V> A. SPEC (\<lambda>(st, \<V>', A').
    (\<not>is_failed st \<longrightarrow>
      pac_ideal (set_mset (ran_m A)) = pac_ideal (set_mset (ran_m A')) \<and>
      \<Union>(vars ` set_mset (ran_m A)) \<subseteq> \<V>' \<and>
      \<Union>(vars ` set_mset (ran_m A')) \<subseteq> \<V>') \<and>
    (st = FOUND \<longrightarrow> spec \<in># ran_m A')))\<close>

lemma fmap_eq_dom_iff:
  \<open>A = A' \<longleftrightarrow> dom_m A = dom_m A' \<and> (\<forall>i \<in># dom_m A. the (fmlookup A i) = the (fmlookup A' i))\<close>
  by (metis fmap_ext in_dom_m_lookup_iff option.expand)

lemma ideal_remap_incl:
  \<open>finite A' \<Longrightarrow> (\<forall>a'\<in>A'. \<exists>a\<in>A. a-a' \<in> B) \<Longrightarrow> ideal (A' \<union> B) \<subseteq> ideal (A \<union> B)\<close>
  apply (induction A' rule: finite_induct)
  apply (auto intro: ideal.span_mono)
  using ideal.span_mono sup_ge2 apply blast
  proof -
    fix x :: 'a and F :: "'a set" and xa :: 'a and a :: 'a
    assume a1: "a \<in> A"
    assume a2: "a - x \<in> B"
    assume a3: "xa \<in> More_Modules.ideal (insert x (F \<union> B))"
    assume a4: "More_Modules.ideal (F \<union> B) \<subseteq> More_Modules.ideal (A \<union> B)"
    have "x \<in> More_Modules.ideal (A \<union> B)"
      using a2 a1 by (metis (no_types, lifting) Un_upper1 Un_upper2 add_diff_cancel_left' diff_add_cancel
        ideal.module_axioms ideal.span_diff in_mono module.span_superset)
    then show "xa \<in> More_Modules.ideal (A \<union> B)"
      using a4 a3 ideal.span_insert_subset by blast
  qed

lemma pac_ideal_remap_eq:
  \<open>dom_m b = dom_m ba \<Longrightarrow>
       \<forall>i\<in>#dom_m ba.
          the (fmlookup b i) - the (fmlookup ba i)
          \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
     pac_ideal ((\<lambda>x. the (fmlookup b x)) ` set_mset (dom_m ba)) = pac_ideal ((\<lambda>x. the (fmlookup ba x)) ` set_mset (dom_m ba))\<close>
  unfolding pac_ideal_alt_def
  apply standard
  subgoal
    apply (rule ideal_remap_incl)
    apply (auto dest!: multi_member_split
      dest: ideal.span_neg)
    apply (drule ideal.span_neg)
    apply auto
    done
  subgoal
    by (rule ideal_remap_incl)
     (auto dest!: multi_member_split)
  done

lemma remap_polys_polynomial_bool_remap_polys_change_all:
  \<open>remap_polys_polynomial_bool spec \<V> A \<le> remap_polys_change_all spec \<V> A\<close>
  unfolding remap_polys_polynomial_bool_def remap_polys_change_all_def
  apply (simp add: ideal.span_zero fmap_eq_dom_iff ideal.span_eq)
  apply (auto dest: multi_member_split simp: ran_m_def ideal.span_base pac_ideal_remap_eq
    add_mset_eq_add_mset
    eq_commute[of \<open>add_mset _ _\<close> \<open>dom_m (A :: (nat, int mpoly)fmap)\<close> for A])
  done

definition remap_polys :: \<open>int mpoly \<Rightarrow> nat set \<Rightarrow> (nat, int_poly) fmap \<Rightarrow> (status \<times> fpac_step) nres\<close> where
  \<open>remap_polys spec = (\<lambda>\<V> A. do{
   dom \<leftarrow> SPEC(\<lambda>dom. set_mset (dom_m A) \<subseteq> dom \<and> finite dom);

   failed \<leftarrow> SPEC(\<lambda>_::bool. True);
   if failed
   then do {
      RETURN (FAILED, \<V>, fmempty)
   }
   else do {
     (b, N) \<leftarrow> FOREACH dom
       (\<lambda>i (b, \<V>, A').
          if i \<in># dom_m A
          then do {
            p \<leftarrow> SPEC(\<lambda>p. the (fmlookup A i) - p \<in> ideal polynomial_bool \<and> vars p \<subseteq> vars (the (fmlookup A i)));
            eq \<leftarrow> SPEC(\<lambda>eq. eq \<longrightarrow> p = spec);
            \<V> \<leftarrow> SPEC(\<lambda>\<V>'. \<V> \<union> vars (the (fmlookup A i)) \<subseteq> \<V>');
            RETURN(b \<or> eq, \<V>, fmupd i p A')
          } else RETURN (b, \<V>, A'))
       (False, \<V>, fmempty);
       RETURN (if b then FOUND else SUCCESS, N)
     }
   })\<close>

lemma remap_polys_spec:
  \<open>remap_polys spec \<V> A \<le> remap_polys_polynomial_bool spec \<V> A\<close>
  unfolding remap_polys_def remap_polys_polynomial_bool_def
  apply (refine_vcg FOREACH_rule[where
    I = \<open>\<lambda>dom (b, \<V>, A').
      set_mset (dom_m A') =  set_mset (dom_m A) - dom \<and>
      (\<forall>i \<in> set_mset (dom_m A) - dom. the (fmlookup A i) - the (fmlookup A' i) \<in> ideal polynomial_bool) \<and>
     \<Union>(vars ` set_mset (ran_m (fmrestrict_set (set_mset (dom_m A')) A))) \<subseteq> \<V> \<and>
     \<Union>(vars ` set_mset (ran_m A')) \<subseteq> \<V> \<and>
      (b \<longrightarrow> spec \<in># ran_m A')\<close>])
  subgoal by auto
  subgoal by auto
  subgoal by auto
  subgoal by auto
  subgoal by auto
  subgoal by auto
  subgoal by auto
  subgoal
    by auto
  subgoal by auto
  subgoal using ideal.span_add by auto
  subgoal by auto
  subgoal by auto
  subgoal by clarsimp auto
   subgoal
     supply[[goals_limit=1]]
     by (auto simp add: ran_m_mapsto_upd_notin dom_m_fmrestrict_set' subset_eq)
   subgoal
     supply[[goals_limit=1]]
     by (auto simp add: ran_m_mapsto_upd_notin dom_m_fmrestrict_set' subset_eq)
   subgoal
     by (auto simp: ran_m_mapsto_upd_notin)
   subgoal
     by auto
   subgoal
     by auto
   subgoal
     by (auto simp add: ran_m_mapsto_upd_notin dom_m_fmrestrict_set' subset_eq)
   subgoal
     by (auto simp add: ran_m_mapsto_upd_notin dom_m_fmrestrict_set' subset_eq)
   subgoal
     by auto
   subgoal
     by (auto simp: distinct_set_mset_eq_iff[symmetric] distinct_mset_dom)
   subgoal
     by (auto simp: distinct_set_mset_eq_iff[symmetric] distinct_mset_dom)
   subgoal
     by (auto simp add: ran_m_mapsto_upd_notin dom_m_fmrestrict_set' subset_eq
       fmlookup_restrict_set_id')
   subgoal
     by (auto simp add: ran_m_mapsto_upd_notin dom_m_fmrestrict_set' subset_eq)
   subgoal
     by (auto simp add: ran_m_mapsto_upd_notin dom_m_fmrestrict_set' subset_eq
       fmlookup_restrict_set_id')
   done

subsection \<open>Full Checker\<close>

definition full_checker
  :: \<open>int_poly \<Rightarrow> (nat, int_poly) fmap \<Rightarrow> (int_poly, nat,nat) pac_step list \<Rightarrow> (status \<times> _) nres\<close>
 where
  \<open>full_checker spec0 A pac = do {
     spec \<leftarrow> normalize_poly_spec spec0;
     (st, \<V>, A) \<leftarrow> remap_polys_change_all spec {} A;
     if is_failed st then
     RETURN (st, \<V>, A)
     else do {
       \<V> \<leftarrow> SPEC(\<lambda>\<V>'. \<V> \<union> vars spec0 \<subseteq> \<V>');
       PAC_checker spec (\<V>, A) st pac
    }
}\<close>

lemma restricted_ideal_to_mono:
  \<open>restricted_ideal_to\<^sub>I \<V> I \<subseteq> restricted_ideal_to\<^sub>I \<V>' J \<Longrightarrow>
  \<U> \<subseteq> \<V> \<Longrightarrow>
   restricted_ideal_to\<^sub>I \<U> I \<subseteq> restricted_ideal_to\<^sub>I \<U>  J\<close>
  by (auto simp: restricted_ideal_to_def)

lemma pac_ideal_idemp: \<open>pac_ideal (pac_ideal A) = pac_ideal A\<close>
  by (metis dual_order.antisym ideal.span_subset_spanI ideal.span_superset le_sup_iff pac_ideal_def)

lemma full_checker_spec:
  assumes \<open>(A, A') \<in> polys_rel\<close>
  shows
      \<open>full_checker spec A pac \<le> \<Down>{((st, G), (st', G')). (st, st') \<in> status_rel \<and>
           (st \<noteq> FAILED \<longrightarrow> (G, G') \<in> polys_rel_full)}
        (PAC_checker_specification spec (A'))\<close>
proof -
  have H: \<open>set_mset b \<subseteq> pac_ideal (set_mset (ran_m A)) \<Longrightarrow>
       x \<in> pac_ideal (set_mset b) \<Longrightarrow> x \<in> pac_ideal (set_mset A')\<close> for b x
    using assms apply -
    by (drule pac_ideal_mono) (auto simp: polys_rel_def pac_ideal_idemp)
  have 1: \<open>x \<in> {(st, \<V>', A').
          ( \<not> is_failed st \<longrightarrow> pac_ideal (set_mset (ran_m x2)) =
              pac_ideal (set_mset (ran_m A')) \<and>
              \<Union> (vars ` set_mset (ran_m ABC)) \<subseteq> \<V>' \<and>
              \<Union> (vars ` set_mset (ran_m A')) \<subseteq> \<V>') \<and>
            (st = FOUND \<longrightarrow> speca \<in># ran_m A')} \<Longrightarrow>
         x = (st, x') \<Longrightarrow> x' = (\<V>, Aa) \<Longrightarrow>((\<V>', Aa), \<V>', ran_m Aa) \<in> polys_rel_full\<close> for Aa speca x2 st x \<V>' \<V> x' ABC
    by (auto simp: polys_rel_def polys_rel_full_def)
  have H1: \<open>\<And>a aa b xa x x1a x1 x2 speca.
       vars spec \<subseteq> x1b \<Longrightarrow>
       \<Union> (vars ` set_mset (ran_m A)) \<subseteq> x1b \<Longrightarrow>
       \<Union> (vars ` set_mset (ran_m x2a)) \<subseteq> x1b \<Longrightarrow>
       restricted_ideal_to\<^sub>I x1b b \<subseteq> restricted_ideal_to\<^sub>I x1b (ran_m x2a) \<Longrightarrow>
       xa \<in> restricted_ideal_to\<^sub>I (\<Union> (vars ` set_mset (ran_m A)) \<union> vars spec) b \<Longrightarrow>
       xa \<in> restricted_ideal_to\<^sub>I (\<Union> (vars ` set_mset (ran_m A)) \<union> vars spec) (ran_m x2a)\<close>
    for x1b b xa x2a
    by (drule restricted_ideal_to_mono[of _ _ _ _ \<open>\<Union> (vars ` set_mset (ran_m A)) \<union> vars spec\<close>])
      auto
  have H2: \<open>\<And>a aa b speca x2 x1a x1b x2a.
       spec - speca \<in> More_Modules.ideal polynomial_bool \<Longrightarrow>
       vars spec \<subseteq> x1b \<Longrightarrow>
       \<Union> (vars ` set_mset (ran_m A)) \<subseteq> x1b \<Longrightarrow>
       \<Union> (vars ` set_mset (ran_m x2a)) \<subseteq> x1b \<Longrightarrow>
       speca \<in> pac_ideal (set_mset (ran_m x2a)) \<Longrightarrow>
       restricted_ideal_to\<^sub>I x1b b \<subseteq> restricted_ideal_to\<^sub>I x1b (ran_m x2a) \<Longrightarrow>
       spec \<in> pac_ideal (set_mset (ran_m x2a))\<close>
    by (metis (no_types, lifting) group_eq_aux ideal.span_add ideal.span_base in_mono
        pac_ideal_alt_def sup.cobounded2)

  show ?thesis
    supply[[goals_limit=1]]
    unfolding full_checker_def normalize_poly_spec_def
      PAC_checker_specification_def remap_polys_change_all_def
    apply (refine_vcg PAC_checker_PAC_checker_specification2[THEN order_trans, of _ _]
      lhs_step_If)
    subgoal by (auto simp: is_failed_def RETURN_RES_refine_iff)
    apply (rule 1; assumption)
    subgoal
      using fmap_ext assms by (auto simp: polys_rel_def ran_m_def)
    subgoal
      by auto
    subgoal
      by auto
    subgoal for speca x1 x2 x x1a x2a x1b
      apply (rule ref_two_step[OF conc_fun_R_mono])
       apply auto[]
      using assms
      by (auto simp add: PAC_checker_specification_spec_def conc_fun_RES polys_rel_def H1 H2
          polys_rel_full_def
          dest!: rtranclp_PAC_Format_subset_ideal dest: is_failed_is_success_completeD)
    done
qed

lemma full_checker_spec':
  shows
    \<open>(uncurry2 full_checker, uncurry2 (\<lambda>spec A _. PAC_checker_specification spec A)) \<in>
       (Id \<times>\<^sub>r polys_rel) \<times>\<^sub>r Id \<rightarrow>\<^sub>f \<langle>{((st, G), (st', G')). (st, st') \<in> status_rel \<and>
           (st \<noteq> FAILED \<longrightarrow> (G, G') \<in> polys_rel_full)}\<rangle>nres_rel\<close>
  using full_checker_spec
  by (auto intro!: frefI nres_relI)

end


theory Mg_Option
  imports "../Pord" "../Mergeable"
begin

(* Option is used to express a pointed ordering with a least element (None).
 * It can be seen as lifting an ordering on 'a to a pointed ordering on 'a option *)
instantiation option :: (Pord_Weak) Pord_Weak
begin
definition option_pleq : "(x :: 'a option) <[ y =
(case x of
      None \<Rightarrow> True
      | Some x' \<Rightarrow>
        (case y of
          None \<Rightarrow> False
          | Some y' \<Rightarrow> (pleq x' y')))"

instance proof
  show "\<And> (a :: 'a option) . pleq a a"
  proof(-)
    fix a :: "'a option"
    show "pleq a a"
      by(cases a; auto simp add:option_pleq leq_refl)
  qed
next
  fix a b c :: "'a option"
  assume H1 : "pleq a b"
  assume H2 : "pleq b c"
  show "pleq a c" using leq_trans H1 H2
    by(auto simp add:option_pleq split:option.splits)
qed
end

instantiation option :: (Pord) Pord
begin

instance proof
  fix a b :: "'a option"
  assume H1 : "pleq a b"
  assume H2 : "pleq b a"
  show "a = b" using H1 H2 leq_antisym
    by(auto simp add:option_pleq split:option.splits)
qed
end

instantiation option :: (Pordc) Pordc
begin

instance proof
  fix a b :: "'a option"
  assume H : "has_ub {a, b}"
  show "has_sup {a, b}"
  proof(cases a)
    case None
    then show ?thesis
    proof(cases b)
      show "a = None \<Longrightarrow> b = None \<Longrightarrow> has_sup {a, b}"
        by(auto simp add:
              option_pleq
              has_ub_def  is_ub_def
              has_sup_def is_sup_def is_least_def All_def split:option.splits)
      show " \<And>aa::'a. a = None \<Longrightarrow> b = Some aa \<Longrightarrow> has_sup {a, b}" using H leq_refl
        by(auto simp add:
              option_pleq
              has_ub_def  is_ub_def
              has_sup_def is_sup_def is_least_def All_def split:option.splits)
      qed
    next
    case (Some a')
    then show ?thesis
    proof(cases b)
      show "a = Some a' \<Longrightarrow> b = None \<Longrightarrow> has_sup {a, b}" using H leq_refl
      by(auto simp add:
              option_pleq
              has_ub_def  is_ub_def
              has_sup_def is_sup_def is_least_def All_def split:option.splits)

      show "\<And>aa::'a. a = Some a' \<Longrightarrow> b = Some aa \<Longrightarrow> has_sup {a, b}"
        proof(-)
        fix aa
        assume Hi1 : "a = Some a'"
        assume Hi2 : "b = Some aa"

        have OUb : "has_ub {a', aa}"  using H Hi1 Hi2
          by(auto simp add:option_pleq is_ub_def has_ub_def split:option.splits)
        obtain x where OSup : "is_sup {a', aa} x" using complete2[OF OUb]
          by(auto simp add:option_pleq has_sup_def)

        have "is_sup  {a, b} (Some x)"
        proof(rule is_supI)
          fix xa
          assume Hxa : "xa \<in> {a, b}"
          obtain xa' where Hxa' : "xa = Some xa' \<and> (xa' = a' \<or> xa' = aa)" using Hi1 Hi2 Hxa
            by(auto simp add:
                option_pleq is_ub_def is_least_def has_ub_def split:option.splits elim:is_supD1 is_supD2)
          have 0 : "pleq xa' x" using Hxa' OSup
            by(auto simp add:is_sup_def is_least_def is_ub_def)
          show "pleq xa (Some x)" using 0 Hxa'
            by(auto simp add:option_pleq)
        next
          fix x'
          assume Hx' : "is_ub {a, b} x'"
          show "pleq (Some x) x'" using Hx' Hi1 Hi2 OSup
            by(auto simp add:
                option_pleq is_ub_def is_sup_def is_least_def split:option.splits)
        qed
        thus "has_sup {a, b}" by (auto simp add:has_sup_def)
      qed
    qed
  qed
qed
end

lemma is_sup_union_ub :
  assumes Hsup : "is_sup Xs x"
  assumes Hy : "is_ub Ys x"
  shows "is_sup (Xs \<union> Ys) x"
proof(rule is_supI)
  fix z
  assume "z \<in> Xs \<union> Ys"
  then consider (Z1) "z \<in> Xs" | (Z2) "z \<in> Ys"
    by(auto)
  then show "z <[ x"
  proof cases
    case Z1
    then show ?thesis using is_supD1[OF Hsup] by auto
  next
    case Z2
    then show ?thesis using is_ubE[OF Hy] by auto
  qed
next

  fix x'
  assume Ub: "is_ub (Xs \<union> Ys) x'"

  have "is_ub Xs x'"
  proof(rule is_ubI)
    fix w
    assume "w \<in> Xs"
    then have "w \<in> Xs \<union> Ys" by auto
    then show "w <[ x'"
      using is_ubE[OF Ub] by auto
  qed

  then show "x <[ x'"
    using is_supD2[OF Hsup] by auto
qed

lemma is_sup_Some :
  assumes Hnemp : "x \<in> Xs"
  assumes H : "is_sup Xs supr"
  shows "is_sup (Some ` Xs) (Some supr)"
proof(rule is_supI)
  fix z
  assume Z : "z \<in> Some ` Xs"
  then obtain z' where Z' : "z = Some z'" "z' \<in> Xs"
    by auto

  show "z <[ Some supr"
    using is_supD1[OF H Z'(2)] Z'(1)
    by(auto simp add: option_pleq)
next
  fix w
  assume Ub : "is_ub (Some ` Xs) w"

  have "Some x \<in> Some ` Xs"
    using Hnemp by auto

  then have "Some x <[ w"
    using is_ubE[OF Ub]
    by auto

  then obtain w' where W' : "w = Some w'"
    by(cases w; auto simp add: option_pleq)

  have "is_ub Xs w'"
  proof
    fix z'

    assume Z': "z' \<in> Xs"

    then have "Some z' \<in> Some ` Xs"
      by auto

    then have "Some z' <[ w"
      using is_ubE[OF Ub] by auto

    then show "z' <[ w'" using W' by(auto simp add: option_pleq)
  qed

  then have "supr <[ w'"
    using is_supD2[OF H] by auto

  then show "Some supr <[ w"
    using W' by(auto simp add: option_pleq)
qed

lemma is_sup_Some' :
  assumes Hnemp : "x \<in> Xs"
  assumes H: "is_sup (Some ` Xs) (Some supr)"
  shows "is_sup Xs supr"
proof(rule is_supI)
  fix z

  assume Z: "z \<in> Xs"

  then have "Some z <[ Some supr"
    using is_supD1[OF H, of "Some z"] by auto

  then show "z <[ supr"
    by(simp add: option_pleq)
next

  fix w

  assume Ub : "is_ub Xs w"

  have "is_ub (Some ` Xs) (Some w)"
  proof(rule is_ubI)

    fix z'
    assume Z' : "z' \<in> Some ` Xs"

    then obtain z where Z: "z' = Some z" "z \<in> Xs"
      by auto

    have "z <[ w" using is_ubE[OF Ub Z(2)]
      by auto

    then show "z' <[ Some w"
      using Z by(auto simp add: option_pleq)
  qed

  then have "Some supr <[ Some w"
    using is_supD2[OF H] by auto

  then show "supr <[ w"
    by(auto simp add: option_pleq)
qed

lemma is_ub_Some :
  assumes Hnemp : "x \<in> Xs"
  assumes H : "is_ub Xs ub"
  shows "is_ub (Some ` Xs) (Some ub)"
proof(rule is_ubI)
  fix z
  assume Z : "z \<in> Some ` Xs"
  then obtain z' where Z' : "z = Some z'" "z' \<in> Xs"
    by auto

  show "z <[ Some ub"
    using is_ubE[OF H Z'(2)] Z'(1)
    by(auto simp add: option_pleq)
qed

lemma is_ub_Some' :
  assumes Hnemp : "x \<in> Xs"
  assumes H: "is_ub (Some ` Xs) (Some ub)"
  shows "is_ub Xs ub"
proof(rule is_ubI)
  fix z

  assume Z: "z \<in> Xs"

  then have "Some z <[ Some ub"
    using is_ubE[OF H, of "Some z"] by auto

  then show "z <[ ub"
    by(simp add: option_pleq)
qed

instantiation option :: (Pordps) Pordps
begin
instance proof
  fix a b c :: "'a option"

  assume "has_sup {a, b}"
  then obtain sup_ab where Sup_ab : "is_sup {a, b} sup_ab"
    by(auto simp add: has_sup_def)

  assume Sup_bc : "has_sup {b, c}"
  then obtain sup_bc where Sup_bc : "is_sup {b, c} sup_bc"
    by(auto simp add: has_sup_def)

  assume Sup_ac : "has_sup {a, c}"
  then obtain sup_ac where Sup_ac : "is_sup {a, c} sup_ac"
    by(auto simp add: has_sup_def)

  show "has_sup {a, b, c}"
  proof(cases a)
    case ANone : None

    then have "is_ub {a} sup_bc"
      by(auto simp add: is_ub_def option_pleq)

    then have "is_sup {a, b, c} sup_bc"
      using is_sup_union_ub[OF Sup_bc, of "{a}"] by auto

    then show ?thesis
      by(auto simp add: has_sup_def)
  next
    case ASome : (Some a')

    show ?thesis
    proof(cases b)

      case BNone : None

      have Comm : "{b, a, c} = {a, b, c}"
        by auto

      have "is_ub {b} sup_ac" using BNone
        by(auto simp add: is_ub_def option_pleq)

      then have "is_sup {a, b, c} sup_ac"
        using is_sup_union_ub[OF Sup_ac, of "{b}"] Comm
        by(auto)

      then show ?thesis
        by(auto simp add: has_sup_def)
    next

      case BSome : (Some b')

      show ?thesis
      proof(cases c)

        case CNone : None

        have Comm : "{c, a, b} = {a, b, c}"
          by auto

        have "is_ub {c} sup_ab" using CNone
          by(auto simp add: is_ub_def option_pleq)

        then have "is_sup {a, b, c} sup_ab"
          using is_sup_union_ub[OF Sup_ab, of "{c}"] Comm
          by(auto)

        then show ?thesis
          by(auto simp add: has_sup_def)
      next

        case CSome : (Some c')

        obtain sup_ab' where Sup_ab' :
          "sup_ab = Some sup_ab'"
          using Sup_ab ASome
          by(cases sup_ab; auto simp add: is_sup_def is_least_def is_ub_def option_pleq)

        obtain sup_bc' where Sup_bc' :
          "sup_bc = Some sup_bc'"
          using Sup_bc BSome
          by(cases sup_bc; auto simp add: is_sup_def is_least_def is_ub_def option_pleq)

        obtain sup_ac' where Sup_ac' :
          "sup_ac = Some sup_ac'"
          using Sup_ac ASome
          by(cases sup_ac; auto simp add: is_sup_def is_least_def is_ub_def option_pleq)

        have Has_ab':
          "has_sup {a', b'}"
          using Sup_ab Sup_ab' ASome BSome is_sup_Some'[of a' "{a', b'}" sup_ab']
          by(auto simp add: has_sup_def)

        have Has_bc':
          "has_sup {b', c'}"
          using Sup_bc Sup_bc' BSome CSome is_sup_Some'[of b' "{b', c'}" sup_bc']
          by(auto simp add: has_sup_def)

        have Has_ac':
          "has_sup {a', c'}"
          using Sup_ac Sup_ac' ASome CSome is_sup_Some'[of a' "{a', c'}" sup_ac']
          by(auto simp add: has_sup_def)

        obtain sup' where Sup' : "is_sup {a', b', c'} sup'"
          using pairwise_sup[OF Has_ab' Has_bc' Has_ac']
          by(auto simp add: has_sup_def)

        have "is_sup {a, b, c} (Some sup')"
          using is_sup_Some[OF _ Sup'] ASome BSome CSome
          by auto

        then show ?thesis
          by(auto simp add: has_sup_def)
      qed
    qed
  qed
qed
end

instantiation option :: (Pordpsok) Pordpsok
begin
instance proof
  fix a b supr :: "'a option"
  assume Aok : "a \<in> ok_S"
  assume Bok : "b \<in> ok_S"
  assume Sup : "is_sup {a, b} supr"

  obtain a' where A' : "a = Some a'" "a' \<in> ok_S" using Aok
    by(cases a; auto simp add: option_ok_S)

  obtain b' where B' : "b = Some b'" "b' \<in> ok_S" using Bok
    by(cases b; auto simp add: option_ok_S)

  show "supr \<in> ok_S"
  proof(cases supr)
    case None

    then have "a <[ None"
      using is_supD1[OF Sup, of a]
      by auto

    then have False using A'
      by(auto simp add: option_pleq)

    then show ?thesis by auto
  next
    case (Some supr')

    have Supr' : "is_sup {a', b'} (supr')"
      using is_sup_Some'[of "a'" "{a', b'}" supr'] using Sup
      unfolding A' B' Some
      by auto

    then have "supr' \<in> ok_S"
      using pairwise_sup_ok[OF A'(2) B'(2) Supr'] by auto

    then show ?thesis using Some
      by(auto simp add: option_ok_S)
  qed
qed
end

instantiation option :: (Pord_Weak) Pord_Weakb
begin

definition option_bot : "bot = (None :: 'a option)"

instance proof
next
  fix a :: "'a option"
  show "\<bottom> <[ a"
    by(auto simp add:option_pleq option_bot)
qed
end

instantiation option :: (Pord) Pordb
begin
instance proof qed
end

instantiation option :: (Pordc) Pordbc
begin
instance proof qed
end

instantiation option :: (Mergeable) Mergeableb
begin
definition option_bsup: "[^(x :: 'a option), y^] =
  (case x of
    None \<Rightarrow> y
    | Some x' \<Rightarrow> (case y of
                       None \<Rightarrow> Some x'
                       | Some y' \<Rightarrow> Some (bsup x' y')))"
instance proof
  fix a b :: "'a option"
  show "is_bsup a b (bsup a b)"
  proof(cases a)
    case None
    then show ?thesis
    proof(cases b)
      show "a = None \<Longrightarrow> b = None \<Longrightarrow> is_bsup a b (bsup a b)"
        by(auto simp add: option_pleq option_bsup is_bsup_def is_least_def is_bub_def is_sup_def is_ub_def)

      fix b'
      assume Hi1 : "a = None"
      assume Hi2 : "b = Some b'"
      show "is_bsup a b (bsup a b)"
      proof(rule is_bsupI)
        show "pleq a (bsup a b)" using Hi1 Hi2
          by(simp add: option_pleq option_bsup is_bsup_def is_least_def is_bub_def is_sup_def is_ub_def split:option.splits)
      next

        fix bd sd
        assume Hii1 : "pleq bd b"
        assume Hii2 : "is_sup {a, bd} sd"

        show "pleq sd (bsup a b)"
        proof(cases bd)
          assume Hiii1 : "bd = None"
          have "is_sup {None} None" by (auto simp add:is_sup_def is_least_def is_ub_def option_pleq)
          hence "sd = None" using Hi1 Hii2 Hiii1 is_sup_unique by(cases sd; auto)
          thus "pleq sd (bsup a b)"
            by(auto simp add:option_pleq split:option.splits)
        next
          fix bd'
          assume Hiii1 : "bd = Some bd'"
          have "is_sup {None, Some bd'} (Some bd')" by(auto simp add:is_sup_def is_least_def is_ub_def option_pleq leq_refl)
          hence "sd = Some bd'" using Hi1 Hii2 Hiii1 is_sup_unique
            by(cases sd; auto)
          thus "pleq sd (bsup a b)" using Hi1 Hi2 Hii1 Hiii1
            by(auto simp add:option_pleq option_bsup split:option.splits)
        qed
      next
        fix x'
        assume H : "is_bub a b x'"
        show "pleq (bsup a b) x'" using is_bubD2[OF H]
        proof(-)
          assume Hleast : "(\<And>(bd::'a option) sd::'a option. pleq bd b \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow> pleq sd x')"

          have 0 : "pleq (Some b') (b)" using Hi2 by(simp add: leq_refl)

          have 1 : "is_sup {a, (Some b')} (Some b')" using Hi1
            by(auto simp add:option_pleq is_sup_def is_least_def is_ub_def leq_refl)

          show "pleq (bsup a b) x'" using Hleast[OF 0 1]
            by(simp add: Hi1 Hi2 option_bsup)
        qed
      qed
    qed
  next
    case (Some a')
    then show ?thesis
    proof(cases b)
      assume Hi1 : "a = Some a'"
      assume Hi2 : "b = None"
      show "is_bsup a b (bsup a b)"
      proof(rule is_bsupI)
        show "pleq a (bsup a b)" using Hi1 Hi2
          by(simp add: option_pleq option_bsup is_bsup_def is_least_def is_bub_def is_sup_def is_ub_def leq_refl split:option.splits)
      next
        fix bd sd
        assume Hii1 : "pleq bd b"
        assume Hii2 : "is_sup {a, bd} sd"

        show "pleq sd (bsup a b)"
        proof(cases bd)
          assume Hiii1 : "bd = None"
          have "is_sup {Some a', None} (Some a')" by(auto simp add:is_sup_def is_least_def is_ub_def option_pleq leq_refl)
          hence "sd = Some a'" using Hi1 Hi2 Hii1 Hii2 Hiii1 is_sup_unique by(cases sd; auto)
          thus "pleq sd (bsup a b)" using Hi1 Hi2 leq_refl
            by(auto simp add:option_pleq option_bsup)
        next
          fix bd'
          assume Hiii1 : "bd = Some bd'"
          (* contradiction *)
          thus "pleq sd (bsup a b)" using Hi2 Hii1 Hiii1
            by(auto simp add:option_pleq option_bsup)
        qed

      next
          fix x'
          assume H : "is_bub a b x'"
          show "pleq (bsup a b) x'" using is_bubD2[OF H]
          proof(-)
            assume Hleast : "(\<And>(bd::'a option) sd::'a option. pleq bd b \<Longrightarrow> is_sup {a, bd} sd \<Longrightarrow> pleq sd x')"

            have 0 : "pleq (None) (b)" using Hi2 by(simp add: leq_refl)

            have 1 : "is_sup {a, None} (a)" using Hi1
              by(auto simp add:option_pleq is_sup_def is_least_def is_ub_def leq_refl)

            show "pleq (bsup a b) x'" using Hleast[OF 0 1]
              by(simp add: Hi1 Hi2 option_bsup)
          qed
        qed

      next

        fix b'
        assume Hi1 : "a = Some a'"
        assume Hi2 : "b = Some b'"
        show "is_bsup a b (bsup a b)"
        proof(rule is_bsupI)
          show "pleq a (bsup a b)" using Hi1 Hi2 bsup_leq bsup_spec[of a' b']
            by(auto simp add: option_pleq option_bsup is_bsup_def is_least_def is_bub_def is_sup_def is_ub_def leq_refl split:option.splits)
        next

          fix bd sd
          assume Hii1 : "pleq bd b"
          assume Hii2 : "is_sup {a, bd} sd"
          show "pleq sd (bsup a b)"
          proof(cases bd)
            assume Hiii1 : "bd = None"
            have "is_sup {Some a', None} (Some a')" by(auto simp add:is_sup_def is_least_def is_ub_def option_pleq leq_refl)
            hence "sd = Some a'" using Hi1 Hi2 Hii1 Hii2 Hiii1 is_sup_unique by(cases sd; auto)
            thus "pleq sd (bsup a b)" using Hi1 Hi2 bsup_leq bsup_spec[of a' b']
              by(auto simp add:option_pleq option_bsup)
          next
            fix bd'
            assume Hiii1 : "bd = Some bd'"
            obtain sd' where Hsd' : "sd = Some sd'"
              using Hii2 Hi1
              by(auto simp add:is_sup_def is_least_def is_ub_def option_pleq split:option.splits)

            have OSup :  "is_sup {a', bd'} sd'"
            proof(rule is_supI)
              fix x'
              assume H : "x' \<in> {a', bd'}"
              have 0 : "pleq a' sd'"  using Hii2 Hi1 Hsd'
                by(auto simp add:is_sup_def is_least_def is_ub_def option_pleq split:option.splits)

              have 1 : "pleq bd' sd'" using Hii2 Hiii1 Hsd'
                by(auto simp add:is_sup_def is_least_def is_ub_def option_pleq split:option.splits)

              show "pleq x' sd'" using H 0 1 by auto
            next
              fix x'
              assume H : "is_ub {a', bd'} x'"

              show "pleq sd' x'" using H Hi1 Hii2 Hiii1 Hsd'
                by(auto simp add:is_sup_def is_least_def is_ub_def option_pleq split:option.splits)
            qed

            have OBsup : "is_bsup a' b' (bsup a' b')" by (auto simp add:bsup_spec)

            have Hbbd' : "pleq bd' b'" using Hi2 Hii1 Hiii1
              by(auto simp add:option_pleq)

            show "pleq sd (bsup a b)" using is_bsupD2[OF OBsup Hbbd' OSup] Hsd' Hi1 Hi2 Hiii1
              by(auto simp add:option_pleq option_bsup)
          qed

        next
          fix x
          assume H: "is_bub a b x"

          obtain x' where Hx' : "x = Some x'" using Hi1 Hi2 H
            by(auto simp add:is_bub_def option_pleq split:option.splits)

          have Bub' : "is_bub a' b' x'"
          proof(rule is_bubI)
            show "pleq a' x'" using Hi1 Hx' is_bubD1[OF H]
              by(auto simp add:option_pleq)

          next

            fix bd' sd'
            assume Hpleq' : "pleq bd' b'"
            assume HOsup : "is_sup {a', bd'} sd'"

            have Hpleq : "pleq (Some bd') (b)" using Hi2 Hpleq' by (auto simp add:option_pleq)

            have HSup : "is_sup {a, Some bd'} (Some sd')"
              using Hi1 HOsup
              by(auto simp add:option_pleq is_sup_def is_least_def is_ub_def split:option.splits)

            show "pleq sd' x'" using Hi1 Hx' is_bubD2[OF H Hpleq HSup]
              by(auto simp add:option_pleq is_sup_def)
          qed

          show "pleq (bsup a b) x" using Hx' Hi1 Hi2 Bub' bsup_spec[of a' b']
            by(auto simp add:option_pleq option_bsup is_bsup_def is_least_def)
        qed
      qed
    qed
  qed
end

instantiation option :: (Pordc_all) Pordc_all
begin
instance proof
  fix a b :: "('a option)"

  show "has_ub {a, b}"
  proof(cases a)
    case None
    then have "is_ub {a, b} b"
      by(cases b; auto simp add: is_ub_def option_pleq leq_refl)
    then show ?thesis
      by(auto simp add: has_ub_def)
  next
    case (Some a')
    show ?thesis
    proof(cases b)
      case None' : None
      then have "is_ub {a, b} a" using Some
        by(auto simp add: is_ub_def option_pleq leq_refl)
      then show ?thesis
        by(auto simp add: has_ub_def)
    next
      case Some' : (Some b')

      obtain ub where Ub: "is_ub {a', b'} ub"
        using ub2_all
        by(auto simp add: has_ub_def)

      then have "is_ub {a, b} (Some ub)"
        unfolding Some Some'
        using is_ub_Some[OF _ Ub]
        by auto

      then show ?thesis
        by(auto simp add: has_ub_def)
    qed
  qed
qed

end

end


(* Author: Dmitriy Traytel *)

section \<open>$\Pi$-Extended Dual Regular Expressions\<close>

(*<*)
theory Pi_Regular_Exp_Dual
imports Pi_Derivatives "HOL-Library.List_Lexorder" "HOL-Library.Code_Target_Nat"
begin
(*>*)
subsection \<open>Syntax of regular expressions\<close>

datatype 'a rexp_dual =
  CoZero (co: bool) |
  CoOne (co: bool) |
  CoAtom (co: bool) 'a |
  CoPlus (co: bool) "'a rexp_dual" "'a rexp_dual" |
  CoTimes (co: bool) "'a rexp_dual" "'a rexp_dual" |
  CoStar (co: bool) "'a rexp_dual" |
  CoPr (co: bool) "'a rexp_dual"
derive linorder rexp_dual

abbreviation "CoPLUS_dual b \<equiv> rexp_of_list (CoPlus b) (CoZero b)"
abbreviation "bool_unop_dual b \<equiv> (if b then id else HOL.Not)"
abbreviation "bool_binop_dual b \<equiv> (if b then (\<or>) else (\<and>))"
abbreviation "set_binop_dual b \<equiv> (if b then (\<union>) else (\<inter>))"

primrec final_dual :: "'a rexp_dual \<Rightarrow> bool"
where
  "final_dual (CoZero b) = (\<not> b)"
| "final_dual (CoOne b) = b"
| "final_dual (CoAtom b _) = (\<not> b)"
| "final_dual (CoPlus b r s) = bool_binop_dual b (final_dual r) (final_dual s)"
| "final_dual (CoTimes b r s) = bool_binop_dual (\<not> b) (final_dual r) (final_dual s)"
| "final_dual (CoStar b _) = b"
| "final_dual (CoPr _ r) = final_dual r"

context alphabet
begin

primrec wf_dual :: "nat \<Rightarrow> 'b rexp_dual \<Rightarrow> bool"
where
"wf_dual n (CoZero _) = True" |
"wf_dual n (CoOne _) = True" |
"wf_dual n (CoAtom _ a) = (wf_atom n a)" |
"wf_dual n (CoPlus _ r s) = (wf_dual n r \<and> wf_dual n s)" |
"wf_dual n (CoTimes _ r s) = (wf_dual n r \<and> wf_dual n s)" |
"wf_dual n (CoStar _ r) = wf_dual n r" |
"wf_dual n (CoPr _ r) = wf_dual (n + 1) r"

lemma wf_dual_PLUS_dual[simp]:
  "wf_dual n (CoPLUS_dual b xs) = (\<forall>r \<in> set xs. wf_dual n r)"
  by (induct xs rule: list_singleton_induct) auto

abbreviation "set_unop_dual n b A \<equiv> if b then A else lists (\<Sigma> n) - A"

end

context project
begin

primrec lang_dual :: "nat \<Rightarrow> 'b rexp_dual => 'a lang" where
"lang_dual n (CoZero b) = set_unop_dual n b {}" |
"lang_dual n (CoOne b) = set_unop_dual n b {[]}" |
"lang_dual n (CoAtom b a) = set_unop_dual n b {[x] | x. lookup a x \<and> x \<in> \<Sigma> n}" |
"lang_dual n (CoPlus b r s) = set_binop_dual b (lang_dual n r) (lang_dual n s)" |
"lang_dual n (CoTimes b r s) = set_unop_dual n b
   (set_unop_dual n b (lang_dual n r) @@ set_unop_dual n b (lang_dual n s))" |
"lang_dual n (CoStar b r) = set_unop_dual n b (star (set_unop_dual n b (lang_dual n r)))" |
"lang_dual n (CoPr b r) = set_unop_dual n b (map project ` (set_unop_dual (n + 1) b (lang_dual (n + 1) r)))"

lemma wf_dual_lang_dual_wf_word: "wf_dual n r \<Longrightarrow> \<forall>w \<in> lang_dual n r. wf_word n w"
  by (induct r arbitrary: n) (auto elim: rev_subsetD[OF _ conc_mono] star_induct
    intro: iffD2[OF wf_word] wf_word_map_project)

lemma lang_dual_subset_lists: "wf_dual n r \<Longrightarrow> lang_dual n r \<subseteq> lists (\<Sigma> n)"
proof (induct r arbitrary: n)
  case (CoPr b r) thus ?case by (cases b) (fastforce intro!: project)+
qed (auto simp: conc_subset_lists star_subset_lists)

lemma lang_dual_final_dual: "final_dual r = ([] \<in> lang_dual n r)"
  by (induct r arbitrary: n) (auto intro: concI[of "[]" _ "[]", simplified])

lemma lang_dual_PLUS_dual[simp]:
  "lang_dual n (CoPLUS_dual True xs) = (\<Union>r \<in> set xs. lang_dual n r)"
  by (induct xs rule: list_singleton_induct) auto

lemma lang_dual_CoPLUS_dual[simp]:
  "lang_dual n (CoPLUS_dual False xs) = (if xs = [] then lists (\<Sigma> n) else \<Inter>r \<in> set xs. lang_dual n r)"
  by (induct xs rule: list_singleton_induct) auto

end

context embed
begin

primrec lderiv_dual :: "'a \<Rightarrow> 'b rexp_dual \<Rightarrow> 'b rexp_dual" where
  "lderiv_dual _ (CoZero b) = (CoZero b)"
| "lderiv_dual _ (CoOne b) = (CoZero b)"
| "lderiv_dual a (CoAtom b c) = (if lookup c a then CoOne b else CoZero b)"
| "lderiv_dual a (CoPlus b r s) = CoPlus b (lderiv_dual a r) (lderiv_dual a s)"
| "lderiv_dual a (CoTimes b r s) =
    (let r's = CoTimes b (lderiv_dual a r) s
     in if bool_unop_dual b (final_dual r) then CoPlus b r's (lderiv_dual a s) else r's)"
| "lderiv_dual a (CoStar b r) = CoTimes b (lderiv_dual a r) (CoStar b r)"
| "lderiv_dual a (CoPr b r) = CoPr b (CoPLUS_dual b (map (\<lambda>a'. lderiv_dual a' r) (embed a)))"

primrec lderivs_dual where
  "lderivs_dual [] r = r"
| "lderivs_dual (w#ws) r = lderivs_dual ws (lderiv_dual w r)"

lemma wf_dual_lderiv_dual[simp]: "wf_dual n r \<Longrightarrow> wf_dual n (lderiv_dual w r)"
  by (induct r arbitrary: n w) (auto simp add: Let_def)

lemma wf_dual_lderivs_dual[simp]: "wf_dual n r \<Longrightarrow> wf_dual n (lderivs_dual ws r)"
  by (induct ws arbitrary: r) (auto intro: wf_dual_lderiv_dual)

lemma lang_dual_lderiv_dual: "\<lbrakk>wf_dual n r; w \<in> \<Sigma> n\<rbrakk> \<Longrightarrow>
  lang_dual n (lderiv_dual w r) = lQuot w (lang_dual n r)"
proof (induct r arbitrary: n w)
  case (CoPr b r)
  hence *: "wf_dual (Suc n) r" "\<And>w'. w' \<in> set (embed w) \<Longrightarrow>  w' \<in> \<Sigma> (Suc n)" by (auto simp: embed)
  then show ?case using lQuot_map_project[OF CoPr(3) lang_dual_subset_lists[OF *(1)]]
    lQuot_map_project[OF CoPr(3) Diff_subset, of "lang_dual (n + 1) r"]
    by (simp_all add: CoPr(1,3))
qed (auto 0 3 simp: Let_def lang_dual_final_dual[symmetric])

lemma lang_dual_lderivs_dual: "\<lbrakk>wf_dual n r; wf_word n ws\<rbrakk> \<Longrightarrow>
  lang_dual n (lderivs_dual ws r) = lQuots ws (lang_dual n r)"
  by (induct ws arbitrary: r) (auto simp: lang_dual_lderiv_dual)

corollary lderivs_dual_final_dual:
  assumes "wf_dual n r" "wf_word n ws"
  shows "final_dual (lderivs_dual ws r) \<longleftrightarrow> ws \<in> lang_dual n r"
  using lang_dual_lderivs_dual[OF assms] lang_dual_final_dual[of "lderivs_dual ws r" n] by auto

end

fun pnCoPlus :: "bool \<Rightarrow> 'a::linorder rexp_dual \<Rightarrow> 'a rexp_dual \<Rightarrow> 'a rexp_dual" where
  "pnCoPlus b1 (CoZero b2) r = (if b1 = b2 then r else CoZero b2)"
| "pnCoPlus b1 r (CoZero b2) = (if b1 = b2 then r else CoZero b2)"
| "pnCoPlus b1 (CoPlus b2 r s) t =
    (if b1 = b2 then pnCoPlus b2 r (pnCoPlus b2 s t) else CoPlus b1 (CoPlus b2 r s) t)"
| "pnCoPlus b1 r (CoPlus b2 s t) =
     (if b1 = b2 then
       (if r = s then (CoPlus b2 s t)
       else if r \<le> s then CoPlus b2 r (CoPlus b2 s t)
       else CoPlus b2 s (pnCoPlus b2 r t))
     else CoPlus b1 r (CoPlus b2 s t))"
| "pnCoPlus b r s =
     (if r = s then r
      else if r \<le> s then CoPlus b r s
      else CoPlus b s r)"

lemma (in alphabet) wf_dual_pnCoPlus[simp]: "\<lbrakk>wf_dual n r; wf_dual n s\<rbrakk> \<Longrightarrow> wf_dual n (pnCoPlus b r s)"
  by (induct b r s rule: pnCoPlus.induct) auto

lemma (in project) lang_dual_pnCoPlus[simp]: "\<lbrakk>wf_dual n r; wf_dual n s\<rbrakk> \<Longrightarrow>
  lang_dual n (pnCoPlus b r s) = lang_dual n (CoPlus b r s)"
proof (induct b r s rule: pnCoPlus.induct)
  case 1 thus ?case by (auto dest: lang_dual_subset_lists)
next
  case "2_1" thus ?case by auto
next
  case "2_2" thus ?case by auto
next
  case "2_3" thus ?case by (auto dest: lang_dual_subset_lists)
next
  case "2_4" thus ?case by (auto dest!: lang_dual_subset_lists dest:
    subsetD[OF conc_subset_lists, unfolded in_lists_conv_set, rotated -1])
next
  case "2_5" thus ?case by (auto dest!: lang_dual_subset_lists dest:
    subsetD[OF star_subset_lists, unfolded in_lists_conv_set, rotated -1])
next
  case "2_6" thus ?case by (auto 4 4 dest!: lang_dual_subset_lists intro: project)
next
  case "3_1" thus ?case by auto
next
  case "3_2" thus ?case by auto
next
  case "3_3" thus ?case by auto
next
  case "3_4" thus ?case by auto
next
  case "3_5" thus ?case by auto
next
  case "3_6" thus ?case by auto
next
  case "4_1" thus ?case by auto
next
  case "4_2" thus ?case by auto
next
  case "4_3" thus ?case by auto
next
  case "4_4" thus ?case by auto
next
  case "4_5" thus ?case by auto
next
  case "5_1" thus ?case by auto
next
  case "5_2" thus ?case by auto
next
  case "5_3" thus ?case by auto
next
  case "5_4" thus ?case by auto
next
  case "5_5" thus ?case by auto
next
  case "5_6" thus ?case by auto
next
  case "5_7" thus ?case by auto
next
  case "5_8" thus ?case by auto
next
  case "5_9" thus ?case by auto
next
  case "5_10" thus ?case
    by auto (metis (no_types, hide_lams) Cons_in_lists_iff Diff_iff imageI list.simps(8) list.simps(9) lists.Nil)+
next
  case "5_11" thus ?case by auto
next
  case "5_12" thus ?case by auto
next
  case "5_13" thus ?case by auto
next
  case "5_14" thus ?case by auto
next
  case "5_15" thus ?case by auto
next
  case "5_16" thus ?case by auto
next
  case "5_17" thus ?case by auto
next
  case "5_18" thus ?case by auto
next
  case "5_19" thus ?case by (auto dest!: lang_dual_subset_lists dest:
    subsetD[OF star_subset_lists, unfolded in_lists_conv_set, rotated -1])
next
  case "5_20" thus ?case by auto
next
  case "5_21" thus ?case by auto
next
  case "5_22" thus ?case
    by auto (metis (no_types, hide_lams) Cons_in_lists_iff Diff_iff imageI list.simps(8) list.simps(9) lists.Nil)+
next
  case "5_23" thus ?case by auto
next
  case "5_24" thus ?case by auto
next
  case "5_25" thus ?case by auto
qed

fun pnCoTimes :: "bool \<Rightarrow> 'a::linorder rexp_dual \<Rightarrow> 'a rexp_dual \<Rightarrow> 'a rexp_dual" where
  "pnCoTimes b1 (CoZero b2) r = (if b1 = b2 then CoZero b1 else CoTimes b1 (CoZero b2) r)"
| "pnCoTimes b1 (CoOne b2) r = (if b1 = b2 then r else CoTimes b1 (CoOne b2) r)"
| "pnCoTimes b1 (CoPlus b2 r s) t = (if b1 = b2 then pnCoPlus b2 (pnCoTimes b2 r t) (pnCoTimes b2 s t)
   else CoTimes b1 (CoPlus b2 r s) t)"
| "pnCoTimes b r s = CoTimes b r s"

lemma (in alphabet) wf_dual_pnCoTimes[simp]: "\<lbrakk>wf_dual n r; wf_dual n s\<rbrakk> \<Longrightarrow> wf_dual n (pnCoTimes b r s)"
  by (induct b r s rule: pnCoTimes.induct) auto

lemma (in project) lang_dual_pnCoTimes[simp]: "\<lbrakk>wf_dual n r; wf_dual n s\<rbrakk> \<Longrightarrow> lang_dual n (pnCoTimes b r s) = lang_dual n (CoTimes b r s)"
  apply (induct b r s rule: pnCoTimes.induct)
  apply (auto, auto dest!: lang_dual_subset_lists dest: project
      subsetD[OF star_subset_lists, unfolded in_lists_conv_set, rotated -1]
      subsetD[OF conc_subset_lists, unfolded in_lists_conv_set, rotated -1])
  by (metis (full_types) Diff_iff conc_epsilon(1) double_diff empty_subsetI in_listsI insert_subset lists.Nil subset_refl)

fun pnCoPr :: "bool \<Rightarrow> 'a::linorder rexp_dual \<Rightarrow> 'a rexp_dual" where
  "pnCoPr b1 (CoZero b2) = (if b1 = b2 then CoZero b2 else CoPr b1 (CoZero b2))"
| "pnCoPr b1 (CoOne b2) = (if b1 = b2 then CoOne b2 else CoPr b1 (CoOne b2))"
| "pnCoPr b1 (CoPlus b2 r s) = (if b1 = b2 then pnCoPlus b2 (pnCoPr b2 r) (pnCoPr b2 s)
    else CoPr b1 (CoPlus b2 r s))"
| "pnCoPr b r = CoPr b r"

lemma (in alphabet) wf_dual_pnCoPr[simp]: "wf_dual (Suc n) r \<Longrightarrow> wf_dual n (pnCoPr b r)"
  by (induct b r rule: pnCoPr.induct) auto

lemma (in project) lang_dual_pnCoPr[simp]: "wf_dual (Suc n) r \<Longrightarrow> lang_dual n (pnCoPr b r) = lang_dual n (CoPr b r)"
  by (induct b r rule: pnCoPr.induct) auto

primrec pnorm_dual :: "'a::linorder rexp_dual \<Rightarrow> 'a rexp_dual" where
  "pnorm_dual (CoZero b) = (CoZero b)"
| "pnorm_dual (CoOne b) = (CoOne b)"
| "pnorm_dual (CoAtom b a) = (CoAtom b a)"
| "pnorm_dual (CoPlus b r s) = pnCoPlus b (pnorm_dual r) (pnorm_dual s)"
| "pnorm_dual (CoTimes b r s) = pnCoTimes b (pnorm_dual r) s"
| "pnorm_dual (CoStar b r) = CoStar b r"
| "pnorm_dual (CoPr b r) = pnCoPr b (pnorm_dual r)"

lemma (in alphabet) wf_dual_pnorm_dual[simp]: "wf_dual n r \<Longrightarrow> wf_dual n (pnorm_dual r)"
  by (induct r arbitrary: n) auto

lemma (in project) lang_dual_pnorm_dual[simp]: "wf_dual n r \<Longrightarrow> lang_dual n (pnorm_dual r) = lang_dual n r"
  by (induct r arbitrary: n) auto

primrec CoNot where
  "CoNot (CoZero b) = CoZero (\<not> b)"
| "CoNot (CoOne b) = CoOne (\<not> b)"
| "CoNot (CoAtom b a) = CoAtom (\<not> b) a"
| "CoNot (CoPlus b r s) = CoPlus (\<not> b) (CoNot r) (CoNot s)"
| "CoNot (CoTimes b r s) = CoTimes (\<not> b) (CoNot r) (CoNot s)"
| "CoNot (CoStar b r) = CoStar (\<not> b) (CoNot r)"
| "CoNot (CoPr b r) = CoPr (\<not> b) (CoNot r)"

primrec rexp_dual_of where
  "rexp_dual_of Zero = CoZero True"
| "rexp_dual_of Full = CoZero False"
| "rexp_dual_of One = CoOne True"
| "rexp_dual_of (Atom a) = CoAtom True a"
| "rexp_dual_of (Plus r s) = CoPlus True (rexp_dual_of r) (rexp_dual_of s)"
| "rexp_dual_of (Times r s) = CoTimes True (rexp_dual_of r) (rexp_dual_of s)"
| "rexp_dual_of (Star r) = CoStar True (rexp_dual_of r)"
| "rexp_dual_of (Not r) = CoNot (rexp_dual_of r)"
| "rexp_dual_of (Inter r s) = CoPlus False (rexp_dual_of r) (rexp_dual_of s)"
| "rexp_dual_of (Pr r) = CoPr True (rexp_dual_of r)"

lemma (in alphabet) wf_dual_CoNot[simp]: "wf_dual n r \<Longrightarrow> wf_dual n (CoNot r)"
  by (induct r arbitrary: n) auto

lemma (in project) lang_dual_CoNot[simp]: "wf_dual n r \<Longrightarrow> lang_dual n (CoNot r) = lists (\<Sigma> n) - lang_dual n r"
  apply (induct r arbitrary: n)
  apply (auto dest!: lang_dual_subset_lists simp: double_diff intro!: project)
  apply force
  apply (metis (full_types) Diff_subset contra_subsetD in_listsD star_subset_lists)
  done

lemma (in alphabet) wf_dual_rexp_dual_of[simp]: "wf n r \<Longrightarrow> wf_dual n (rexp_dual_of r)"
  by (induct r arbitrary: n) auto

lemma (in project) lang_dual_rexp_dual_of[simp]: "wf n r \<Longrightarrow> lang_dual n (rexp_dual_of r) = lang n r"
  by (induct r arbitrary: n) auto

end


theory prop_73
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  fun filter2 :: "('a => bool) => 'a list => 'a list" where
  "filter2 x (Nil2) = Nil2"
  | "filter2 x (Cons2 z xs) =
       (if x z then Cons2 z (filter2 x xs) else filter2 x xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun rev :: "'a list => 'a list" where
  "rev (Nil2) = Nil2"
  | "rev (Cons2 y xs) = append (rev xs) (Cons2 y (Nil2))"
  (*hipster filter append rev *)

(*hipster filter2 rev*)
lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes filter2.simps rev.simps)

lemma lemma_aa []: "filter2 x13 (filter2 y13 z13) = filter2 y13 (filter2 x13 z13)"
by (hipster_induct_schemes filter2.simps rev.simps)

lemma lemma_ab [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes filter2.simps rev.simps)

lemma lemma_ac []: "filter2 x9 (filter2 x9 y9) = filter2 x9 y9"
by (hipster_induct_schemes filter2.simps rev.simps)

lemma lemma_ad [thy_expl]: "append (filter2 x6 y6) (filter2 x6 z6) = filter2 x6 (append y6 z6)"
by (hipster_induct_schemes filter2.simps rev.simps)

(*hipster rev append filter2*)
lemma lemma_ae [thy_expl]: "append (rev x4) (rev y4) = rev (append y4 x4)"
by (hipster_induct_schemes rev.simps append.simps filter2.simps)

lemma lemma_af [thy_expl]: "rev (rev x3) = x3"
by (hipster_induct_schemes rev.simps append.simps filter2.simps)

lemma ss: "f x \<Longrightarrow> filter2 f (Cons2 x y) = Cons2 x (filter2 f y)"
by simp

lemma sst: "\<not> f x \<Longrightarrow> filter2 f (Cons2 x y) = (filter2 f y)"
by simp
setup \<open>Hip_Tac_Ops.set_metis_to @{context} 2000\<close>

lemma unknown []: "rev (filter2 x y) = filter2 x (rev y)"
    by (hipster_induct_schemes rev.simps append.simps filter2.simps)

apply(induction y)
apply(simp_all)
by (metis rev.simps append.simps filter2.simps thy_expl) (*lemma_ad lemma_a lemma_ab lemma_ac lemma_ae lemma_af)*)

setup \<open>Hip_Tac_Ops.set_metis_to @{context} 2000\<close>
  theorem x0 :
    "(rev (filter2 p xs)) = (filter2 p (rev xs))"
    by (hipster_induct_schemes rev.simps append.simps filter2.simps)

end