section \<open>Matrices by Array (Row-Major)\<close>
theory IICF_Array_Matrix
imports "../Intf/IICF_Matrix" Separation_Logic_Imperative_HOL.Array_Blit
begin

  definition "is_amtx N M c mtx \<equiv> \<exists>\<^sub>Al. mtx \<mapsto>\<^sub>a l * \<up>(
      length l = N*M
    \<and> (\<forall>i<N. \<forall>j<M. l!(i*M+j) = c (i,j))
    \<and> (\<forall>i j. (i\<ge>N \<or> j\<ge>M) \<longrightarrow> c (i,j) = 0))"

  lemma is_amtx_precise[safe_constraint_rules]: "precise (is_amtx N M)"
    apply rule
    unfolding is_amtx_def
    apply clarsimp
    apply prec_extract_eqs
    apply (rule ext)
    apply (rename_tac x)
    apply (case_tac x; simp)
    apply (rename_tac i j)
    apply (case_tac "i<N"; case_tac "j<M"; simp)
    done

  lemma is_amtx_bounded:
    shows "rdomp (is_amtx N M) m \<Longrightarrow> mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M}"
    unfolding rdomp_def
    apply (clarsimp simp: mtx_nonzero_def is_amtx_def)
    by (meson not_less)

  (*definition "mtx_new N M c \<equiv> do {
    Array.make (N*M) (\<lambda>i. c (i div M, i mod M))
  }"*)

  definition "mtx_tabulate N M c \<equiv> do {
    m \<leftarrow> Array.new (N*M) 0;
    (_,_,m) \<leftarrow> imp_for' 0 (N*M) (\<lambda>k (i,j,m). do {
      Array.upd k (c (i,j)) m;
      let j=j+1;
      if j<M then return (i,j,m)
      else return (i+1,0,m)
    }) (0,0,m);
    return m
  }"

  definition "amtx_copy \<equiv> array_copy"

  definition "amtx_dflt N M v \<equiv> Array.make (N*M) (\<lambda>i. v)"

  definition "mtx_get M mtx e \<equiv> Array.nth mtx (fst e * M + snd e)"
  definition "mtx_set M mtx e v \<equiv> Array.upd (fst e * M + snd e) v mtx"

  lemma mtx_idx_valid[simp]: "\<lbrakk>i < (N::nat); j < M\<rbrakk> \<Longrightarrow> i * M + j < N * M"
    by (rule mlex_bound)

  lemma mtx_idx_unique_conv[simp]:
    fixes M :: nat
    assumes "j<M" "j'<M"
    shows "(i * M + j = i' * M + j') \<longleftrightarrow> (i=i' \<and> j=j')"
    using assms
    apply auto
    subgoal
      by (metis add_right_cancel div_if div_mult_self3 linorder_neqE_nat not_less0)
    subgoal
      using \<open>\<lbrakk>j < M; j' < M; i * M + j = i' * M + j'\<rbrakk> \<Longrightarrow> i = i'\<close> by auto
    done

  (*lemma mtx_index_unique[simp]: "\<lbrakk>i<(N::nat); j<M; i'<N; j'<M\<rbrakk> \<Longrightarrow> i*M+j = i'*M+j' \<longleftrightarrow> i=i' \<and> j=j'"
    by (metis ab_semigroup_add_class.add.commute add_diff_cancel_right' div_if div_mult_self3 gr0I not_less0)*)

  lemma mtx_copy_rl[sep_heap_rules]:
    "<is_amtx N M c mtx> amtx_copy mtx <\<lambda>r. is_amtx N M c mtx * is_amtx N M c r>"
    by (sep_auto simp: amtx_copy_def is_amtx_def)

  definition "PRES_ZERO_UNIQUE A \<equiv> (A``{0}={0} \<and> A\<inverse>``{0} = {0})"
  lemma IS_ID_imp_PRES_ZERO_UNIQUE[constraint_rules]: "IS_ID A \<Longrightarrow> PRES_ZERO_UNIQUE A"
    unfolding IS_ID_def PRES_ZERO_UNIQUE_def by auto

  definition op_amtx_dfltNxM :: "nat \<Rightarrow> nat \<Rightarrow> 'a::zero \<Rightarrow> nat\<times>nat\<Rightarrow>'a" where
    [simp]: "op_amtx_dfltNxM N M v \<equiv> \<lambda>(i,j). if i<N \<and> j<M then v else 0"
  context fixes N M::nat begin
  sepref_decl_op (no_def) op_amtx_dfltNxM: "op_amtx_dfltNxM N M" :: "A \<rightarrow> \<langle>A\<rangle>mtx_rel"
    where "CONSTRAINT PRES_ZERO_UNIQUE A"
    apply (rule fref_ncI) unfolding op_amtx_dfltNxM_def[abs_def] mtx_rel_def
    apply parametricity
    by (auto simp add: PRES_ZERO_UNIQUE_def)
  end

  lemma mtx_dflt_rl[sep_heap_rules]: "<emp> amtx_dflt N M k <is_amtx N M (op_amtx_dfltNxM N M k)>"
    by (sep_auto simp: amtx_dflt_def is_amtx_def)

  lemma mtx_get_rl[sep_heap_rules]: "\<lbrakk>i<N; j<M \<rbrakk> \<Longrightarrow> <is_amtx N M c mtx> mtx_get M mtx (i,j) <\<lambda>r. is_amtx N M c mtx * \<up>(r = c (i,j))>"
    by (sep_auto simp: mtx_get_def is_amtx_def)

  lemma mtx_set_rl[sep_heap_rules]: "\<lbrakk>i<N; j<M \<rbrakk>
    \<Longrightarrow> <is_amtx N M c mtx> mtx_set M mtx (i,j) v <\<lambda>r. is_amtx N M (c((i,j) := v)) r>"
    by (sep_auto simp: mtx_set_def is_amtx_def nth_list_update)

  definition "amtx_assn N M A \<equiv> hr_comp (is_amtx N M) (\<langle>the_pure A\<rangle>mtx_rel)"
  lemmas [fcomp_norm_unfold] = amtx_assn_def[symmetric]
  lemmas [safe_constraint_rules] = CN_FALSEI[of is_pure "amtx_assn N M A" for N M A]

  lemma [intf_of_assn]: "intf_of_assn A TYPE('a) \<Longrightarrow> intf_of_assn (amtx_assn N M A) TYPE('a i_mtx)"
    by simp

  abbreviation "asmtx_assn N A \<equiv> amtx_assn N N A"

  lemma mtx_rel_pres_zero:
    assumes "PRES_ZERO_UNIQUE A"
    assumes "(m,m')\<in>\<langle>A\<rangle>mtx_rel"
    shows "m ij = 0 \<longleftrightarrow> m' ij = 0"
    using assms
    apply1 (clarsimp simp: IS_PURE_def PRES_ZERO_UNIQUE_def is_pure_conv mtx_rel_def)
    apply (drule fun_relD) applyS (rule IdI[of ij]) applyS auto
    done

  lemma amtx_assn_bounded:
    assumes "CONSTRAINT (IS_PURE PRES_ZERO_UNIQUE) A"
    shows "rdomp (amtx_assn N M A) m \<Longrightarrow> mtx_nonzero m \<subseteq> {0..<N}\<times>{0..<M}"
    apply (clarsimp simp: mtx_nonzero_def amtx_assn_def rdomp_hrcomp_conv)
    apply (drule is_amtx_bounded)
    using assms
    by (fastforce simp: IS_PURE_def is_pure_conv mtx_rel_pres_zero[symmetric] mtx_nonzero_def)

  lemma mtx_tabulate_aref:
    "(mtx_tabulate N M, RETURN o op_mtx_new)
      \<in> [\<lambda>c. mtx_nonzero c \<subseteq> {0..<N}\<times>{0..<M}]\<^sub>a id_assn\<^sup>k \<rightarrow> IICF_Array_Matrix.is_amtx N M"
    by sepref_to_hoare sep_auto

  lemma mtx_copy_aref:
    "(amtx_copy, RETURN o op_mtx_copy) \<in> (is_amtx N M)\<^sup>k \<rightarrow>\<^sub>a is_amtx N M"
    apply rule apply rule
    apply (sep_auto simp: pure_def)
    done

  lemma mtx_nonzero_bid_eq:
    assumes "R\<subseteq>Id"
    assumes "(a, a') \<in> Id \<rightarrow> R"
    shows "mtx_nonzero a = mtx_nonzero a'"
    using assms
    apply (clarsimp simp: mtx_nonzero_def)
    apply (metis fun_relE2 pair_in_Id_conv subsetCE)
    done

  lemma mtx_nonzero_zu_eq:
    assumes "PRES_ZERO_UNIQUE R"
    assumes "(a, a') \<in> Id \<rightarrow> R"
    shows "mtx_nonzero a = mtx_nonzero a'"
    using assms
    apply (clarsimp simp: mtx_nonzero_def PRES_ZERO_UNIQUE_def)
    by (metis (no_types, hide_lams) IdI Image_singleton_iff converse_iff singletonD tagged_fun_relD_none)

  lemma op_mtx_new_fref':
    "CONSTRAINT PRES_ZERO_UNIQUE A \<Longrightarrow> (RETURN \<circ> op_mtx_new, RETURN \<circ> op_mtx_new) \<in> (nat_rel \<times>\<^sub>r nat_rel \<rightarrow> A) \<rightarrow>\<^sub>f \<langle>\<langle>A\<rangle>mtx_rel\<rangle>nres_rel"
    by (rule op_mtx_new.fref)

  sepref_decl_impl (no_register) amtx_new_by_tab: mtx_tabulate_aref uses op_mtx_new_fref'
    by (auto simp: mtx_nonzero_zu_eq)

  sepref_decl_impl amtx_copy: mtx_copy_aref .

  definition [simp]: "op_amtx_new (N::nat) (M::nat) \<equiv> op_mtx_new"
  lemma amtx_fold_custom_new:
    "op_mtx_new \<equiv> op_amtx_new N M"
    "mop_mtx_new \<equiv> \<lambda>c. RETURN (op_amtx_new N M c)"
    by (auto simp: mop_mtx_new_alt[abs_def])

  context fixes N M :: nat begin
    sepref_register "PR_CONST (op_amtx_new N M)" :: "(nat \<times> nat \<Rightarrow> 'a) \<Rightarrow> 'a i_mtx"
  end

  context fixes N M :: nat notes [param] = IdI[of N] IdI[of M] begin

    lemma mtx_dflt_aref:
      "(amtx_dflt N M, RETURN o PR_CONST (op_amtx_dfltNxM N M)) \<in> id_assn\<^sup>k \<rightarrow>\<^sub>a is_amtx N M"
      apply rule apply rule
      apply (sep_auto simp: pure_def)
      done
    sepref_decl_impl amtx_dflt: mtx_dflt_aref .

    lemma amtx_get_aref:
      "(uncurry (mtx_get M), uncurry (RETURN oo op_mtx_get)) \<in> [\<lambda>(_,(i,j)). i<N \<and> j<M]\<^sub>a (is_amtx N M)\<^sup>k *\<^sub>a (prod_assn nat_assn nat_assn)\<^sup>k \<rightarrow> id_assn"
      apply rule apply rule
      apply (sep_auto simp: pure_def)
      done
    sepref_decl_impl amtx_get: amtx_get_aref .

    lemma amtx_set_aref: "(uncurry2 (mtx_set M), uncurry2 (RETURN ooo op_mtx_set))
      \<in> [\<lambda>((_,(i,j)),_). i<N \<and> j<M]\<^sub>a (is_amtx N M)\<^sup>d *\<^sub>a (prod_assn nat_assn nat_assn)\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow> is_amtx N M"
      apply rule apply (rule hn_refine_preI) apply rule
      apply (sep_auto simp: pure_def hn_ctxt_def invalid_assn_def)
      done

    sepref_decl_impl amtx_set: amtx_set_aref .

    lemma amtx_get_aref':
      "(uncurry (mtx_get M), uncurry (RETURN oo op_mtx_get)) \<in> (is_amtx N M)\<^sup>k *\<^sub>a (prod_assn (pure (nbn_rel N)) (pure (nbn_rel M)))\<^sup>k \<rightarrow>\<^sub>a id_assn"
      apply rule apply rule
      apply (sep_auto simp: pure_def IS_PURE_def IS_ID_def)
      done

    sepref_decl_impl amtx_get': amtx_get_aref' .

    lemma amtx_set_aref': "(uncurry2 (mtx_set M), uncurry2 (RETURN ooo op_mtx_set))
      \<in> (is_amtx N M)\<^sup>d *\<^sub>a (prod_assn (pure (nbn_rel N)) (pure (nbn_rel M)))\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a is_amtx N M"
      apply rule apply (rule hn_refine_preI) apply rule
      apply (sep_auto simp: pure_def hn_ctxt_def invalid_assn_def IS_PURE_def IS_ID_def)
      done

    sepref_decl_impl amtx_set': amtx_set_aref' .

  end

  subsection \<open>Pointwise Operations\<close>
  context
    fixes M N :: nat
  begin
    sepref_decl_op amtx_lin_get: "\<lambda>f i. op_mtx_get f (i div M, i mod M)" :: "\<langle>A\<rangle>mtx_rel \<rightarrow> nat_rel \<rightarrow> A"
      unfolding op_mtx_get_def mtx_rel_def
      by (rule frefI) (parametricity; simp)

    sepref_decl_op amtx_lin_set: "\<lambda>f i x. op_mtx_set f (i div M, i mod M) x" :: "\<langle>A\<rangle>mtx_rel \<rightarrow> nat_rel \<rightarrow> A \<rightarrow> \<langle>A\<rangle>mtx_rel"
      unfolding op_mtx_set_def mtx_rel_def
      apply (rule frefI) apply parametricity by simp_all

    lemma op_amtx_lin_get_aref: "(uncurry Array.nth, uncurry (RETURN oo PR_CONST op_amtx_lin_get)) \<in> [\<lambda>(_,i). i<N*M]\<^sub>a (is_amtx N M)\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow> id_assn"
      apply sepref_to_hoare
      unfolding is_amtx_def
      apply sep_auto
      apply (metis mult.commute div_eq_0_iff div_mult2_eq div_mult_mod_eq mod_less_divisor mult_is_0 not_less0)
      done

    sepref_decl_impl amtx_lin_get: op_amtx_lin_get_aref by auto

    lemma op_amtx_lin_set_aref: "(uncurry2 (\<lambda>m i x. Array.upd i x m), uncurry2 (RETURN ooo PR_CONST op_amtx_lin_set)) \<in> [\<lambda>((_,i),_). i<N*M]\<^sub>a (is_amtx N M)\<^sup>d *\<^sub>a nat_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow> is_amtx N M"
    proof -
      have [simp]: "i < N * M \<Longrightarrow> \<not>(M \<le> i mod M)" for i
        by (cases "N = 0 \<or> M = 0") (auto simp add: not_le)
      have [simp]: "i < N * M \<Longrightarrow> \<not>(N \<le> i div M)" for i
        apply (cases "N = 0 \<or> M = 0")
         apply (auto simp add: not_le)
        apply (metis mult.commute div_eq_0_iff div_mult2_eq neq0_conv)
        done
      show ?thesis
        apply sepref_to_hoare
        unfolding is_amtx_def
        by (sep_auto simp: nth_list_update)
    qed

    sepref_decl_impl amtx_lin_set: op_amtx_lin_set_aref by auto
  end

  lemma amtx_fold_lin_get: "m (i div M, i mod M) = op_amtx_lin_get M m i" by simp
  lemma amtx_fold_lin_set: "m ((i div M, i mod M) := x) = op_amtx_lin_set M m i x" by simp

  locale amtx_pointwise_unop_impl = mtx_pointwise_unop_loc +
    fixes A :: "'a \<Rightarrow> 'ai::{zero,heap} \<Rightarrow> assn"
    fixes fi :: "nat\<times>nat \<Rightarrow> 'ai \<Rightarrow> 'ai Heap"
    assumes fi_hnr:
      "(uncurry fi,uncurry (RETURN oo f)) \<in> (prod_assn nat_assn nat_assn)\<^sup>k *\<^sub>a A\<^sup>k \<rightarrow>\<^sub>a A"
  begin

    lemma this_loc: "amtx_pointwise_unop_impl N M f A fi" by unfold_locales

    context
      assumes PURE: "CONSTRAINT (IS_PURE PRES_ZERO_UNIQUE) A"
    begin
      context
        notes [[sepref_register_adhoc f N M]]
        notes [sepref_import_param] = IdI[of N] IdI[of M]
        notes [sepref_fr_rules] = fi_hnr
        notes [safe_constraint_rules] = PURE
        notes [simp] = algebra_simps
      begin
        sepref_thm opr_fold_impl1 is "RETURN o opr_fold_impl" :: "(amtx_assn N M A)\<^sup>d \<rightarrow>\<^sub>a amtx_assn N M A"
          unfolding opr_fold_impl_def fold_prod_divmod_conv'
          apply (rewrite amtx_fold_lin_set)
          apply (rewrite in "f _ \<hole>" amtx_fold_lin_get)
          by sepref
      end
    end
    concrete_definition (in -) amtx_pointwise_unnop_fold_impl1 uses amtx_pointwise_unop_impl.opr_fold_impl1.refine_raw
    prepare_code_thms (in -) amtx_pointwise_unnop_fold_impl1_def

  locale amtx_pointwise_binop_impl = mtx_pointwise_binop_loc +
    fixes A :: "'a \<Rightarrow> 'ai::{zero,heap} \<Rightarrow> assn"
    fixes fi :: "'ai \<Rightarrow> 'ai \<Rightarrow> 'ai Heap"
    assumes fi_hnr: "(uncurry fi,uncurry (RETURN oo f)) \<in> A\<^sup>k *\<^sub>a A\<^sup>k \<rightarrow>\<^sub>a A"
  begin

    lemma this_loc: "amtx_pointwise_binop_impl f A fi"
      by unfold_locales

    context
      notes [[sepref_register_adhoc f N M]]
      notes [sepref_import_param] = IdI[of N] IdI[of M]
      notes [sepref_fr_rules] = fi_hnr
      assumes PURE[safe_constraint_rules]: "CONSTRAINT (IS_PURE PRES_ZERO_UNIQUE) A"
      notes [simp] = algebra_simps
    begin
      sepref_thm opr_fold_impl1 is "uncurry (RETURN oo opr_fold_impl)" :: "(amtx_assn N M A)\<^sup>d*\<^sub>a(amtx_assn N M A)\<^sup>k \<rightarrow>\<^sub>a amtx_assn N M A"
        unfolding opr_fold_impl_def[abs_def] fold_prod_divmod_conv'
        apply (rewrite amtx_fold_lin_set)
        apply (rewrite in "f \<hole> _" amtx_fold_lin_get)
        apply (rewrite in "f _ \<hole>" amtx_fold_lin_get)
        by sepref

    end

    concrete_definition (in -) amtx_pointwise_binop_fold_impl1 for fi N M
      uses amtx_pointwise_binop_impl.opr_fold_impl1.refine_raw is "(uncurry ?f,_)\<in>_"
    prepare_code_thms (in -) amtx_pointwise_binop_fold_impl1_def

    lemma op_hnr[sepref_fr_rules]:
      assumes PURE: "CONSTRAINT (IS_PURE PRES_ZERO_UNIQUE) A"
      shows "(uncurry (amtx_pointwise_binop_fold_impl1 fi N M), uncurry (RETURN oo PR_CONST (mtx_pointwise_binop f))) \<in> (amtx_assn N M A)\<^sup>d *\<^sub>a (amtx_assn N M A)\<^sup>k \<rightarrow>\<^sub>a amtx_assn N M A"
      unfolding PR_CONST_def
      apply (rule hfref_weaken_pre'[OF _ amtx_pointwise_binop_fold_impl1.refine[OF this_loc PURE,FCOMP opr_fold_impl_refine]])
      apply (auto dest: amtx_assn_bounded[OF PURE])
      done

  end

  locale amtx_pointwise_cmpop_impl = mtx_pointwise_cmpop_loc +
    fixes A :: "'a \<Rightarrow> 'ai::{zero,heap} \<Rightarrow> assn"
    fixes fi :: "'ai \<Rightarrow> 'ai \<Rightarrow> bool Heap"
    fixes gi :: "'ai \<Rightarrow> 'ai \<Rightarrow> bool Heap"
    assumes fi_hnr:
      "(uncurry fi,uncurry (RETURN oo f)) \<in> A\<^sup>k *\<^sub>a A\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    assumes gi_hnr:
      "(uncurry gi,uncurry (RETURN oo g)) \<in> A\<^sup>k *\<^sub>a A\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  begin

    lemma this_loc: "amtx_pointwise_cmpop_impl f g A fi gi"
      by unfold_locales

    context
      notes [[sepref_register_adhoc f g N M]]
      notes [sepref_import_param] = IdI[of N] IdI[of M]
      notes [sepref_fr_rules] = fi_hnr gi_hnr
      assumes PURE[safe_constraint_rules]: "CONSTRAINT (IS_PURE PRES_ZERO_UNIQUE) A"
    begin
      sepref_thm opr_fold_impl1 is "uncurry opr_fold_impl" :: "(amtx_assn N M A)\<^sup>d*\<^sub>a(amtx_assn N M A)\<^sup>k \<rightarrow>\<^sub>a bool_assn"
        unfolding opr_fold_impl_def[abs_def] nfoldli_prod_divmod_conv
        apply (rewrite in "f \<hole> _" amtx_fold_lin_get)
        apply (rewrite in "f _ \<hole>" amtx_fold_lin_get)
        apply (rewrite in "g \<hole> _" amtx_fold_lin_get)
        apply (rewrite in "g _ \<hole>" amtx_fold_lin_get)
        by sepref
    end

    concrete_definition (in -) amtx_pointwise_cmpop_fold_impl1 for N M fi gi
      uses amtx_pointwise_cmpop_impl.opr_fold_impl1.refine_raw is "(uncurry ?f,_)\<in>_"
    prepare_code_thms (in -) amtx_pointwise_cmpop_fold_impl1_def

    lemma op_hnr[sepref_fr_rules]:
      assumes PURE: "CONSTRAINT (IS_PURE PRES_ZERO_UNIQUE) A"
      shows "(uncurry (amtx_pointwise_cmpop_fold_impl1 N M fi gi), uncurry (RETURN oo PR_CONST (mtx_pointwise_cmpop f g))) \<in> (amtx_assn N M A)\<^sup>d *\<^sub>a (amtx_assn N M A)\<^sup>k \<rightarrow>\<^sub>a bool_assn"
      unfolding PR_CONST_def
      apply (rule hfref_weaken_pre'[OF _ amtx_pointwise_cmpop_fold_impl1.refine[OF this_loc PURE,FCOMP opr_fold_impl_refine]])
      apply (auto dest: amtx_assn_bounded[OF PURE])
      done

  end

  subsection \<open>Regression Test and Usage Example\<close>

  context begin
    text \<open>To work with a matrix, the dimension should be fixed in a context\<close>
    context
      fixes N M :: nat
      \<comment> \<open>We also register the dimension as an operation, such that we can
        use it like a constant\<close>
      notes [[sepref_register_adhoc N M]]
      notes [sepref_import_param] = IdI[of N] IdI[of M]
      \<comment> \<open>Finally, we fix a type variable with the required type classes for matrix entries\<close>
      fixes dummy:: "'a::{times,zero,heap}"
    begin

      text \<open>First, we implement scalar multiplication with destructive update
        of the matrix:\<close>
      private definition scmul :: "'a \<Rightarrow> 'a mtx \<Rightarrow> 'a mtx nres" where
        "scmul x m \<equiv> nfoldli [0..<N] (\<lambda>_. True) (\<lambda>i m.
          nfoldli [0..<M] (\<lambda>_. True) (\<lambda>j m. do {
              let mij = m(i,j);
              RETURN (m((i,j) := x * mij))
            }
          ) m
        ) m"

      text \<open>After declaration of an implementation for multiplication,
        refinement is straightforward. Note that we use the fixed @{term N} in
        the refinement assertions.\<close>
      private lemma times_param: "((*),(*)::'a\<Rightarrow>_) \<in> Id \<rightarrow> Id \<rightarrow> Id" by simp

      context
        notes [sepref_import_param] = times_param
      begin
        sepref_definition scmul_impl
          is "uncurry scmul" :: "(id_assn\<^sup>k *\<^sub>a (amtx_assn N M id_assn)\<^sup>d \<rightarrow>\<^sub>a amtx_assn N M id_assn)"
          unfolding scmul_def[abs_def]
          by sepref
      end

      text \<open>Initialization with default value\<close>
      private definition "init_test \<equiv> do {
        let m = op_amtx_dfltNxM 10 5 (0::nat);
        RETURN (m(1,2))
      }"
      private sepref_definition init_test_impl is "uncurry0 init_test" :: "unit_assn\<^sup>k\<rightarrow>\<^sub>anat_assn"
        unfolding init_test_def
        by sepref

      text \<open>Initialization from function diagonal is more complicated:
        First, we have to define the function as a new constant\<close>
      (* TODO: PR_CONST option for sepref-register! *)
      qualified definition "diagonalN k \<equiv> \<lambda>(i,j). if i=j \<and> j<N then k else 0"
      text \<open>If it carries implicit parameters, we have to wrap it into a @{term PR_CONST} tag:\<close>
      private sepref_register "PR_CONST diagonalN"
      private lemma [def_pat_rules]: "IICF_Array_Matrix.diagonalN$N \<equiv> UNPROTECT diagonalN" by simp

      text \<open>Then, we have to implement the constant, where the result assertion must be for a
        pure function. Note that, due to technical reasons, we need the \<open>the_pure\<close> in the function type,
        and the refinement rule to be parameterized over an assertion variable (here \<open>A\<close>).
        Of course, you can constrain \<open>A\<close> further, e.g., @{term "CONSTRAINT (IS_PURE IS_ID) (A::int \<Rightarrow> int \<Rightarrow> assn)"}
        \<close>
      private lemma diagonalN_hnr[sepref_fr_rules]:
        assumes "CONSTRAINT (IS_PURE PRES_ZERO_UNIQUE) A"
        (*assumes "CONSTRAINT (IS_PURE IS_ID) (A::int \<Rightarrow> int \<Rightarrow> assn)"*)
        shows "(return o diagonalN, RETURN o (PR_CONST diagonalN)) \<in> A\<^sup>k \<rightarrow>\<^sub>a pure (nat_rel \<times>\<^sub>r nat_rel \<rightarrow> the_pure A)"
        using assms
        apply sepref_to_hoare
        apply (sep_auto simp: diagonalN_def is_pure_conv IS_PURE_def PRES_ZERO_UNIQUE_def (*IS_ID_def*))
        done

      text \<open>In order to discharge preconditions, we need to prove some auxiliary lemma
        that non-zero indexes are within range\<close>
      lemma diagonal_nonzero_ltN[simp]: "(a,b)\<in>mtx_nonzero (diagonalN k) \<Longrightarrow> a<N \<and> b<N"
        by (auto simp: mtx_nonzero_def diagonalN_def split: if_split_asm)

      private definition "init_test2 \<equiv> do {
        ASSERT (N>2); \<comment> \<open>Ensure that the coordinate \<open>(1,2)\<close> is valid\<close>
        let m = op_mtx_new (diagonalN (1::int));
        RETURN (m(1,2))
      }"
      private sepref_definition init_test2_impl is "uncurry0 init_test2" :: "unit_assn\<^sup>k\<rightarrow>\<^sub>aint_assn"
        unfolding init_test2_def amtx_fold_custom_new[of N N]
        by sepref

    end

    export_code scmul_impl in SML_imp
  end
  hide_const scmul_impl

  hide_const(open) is_amtx

end


section \<open>Implementation of Maps by Red Black Trees\<close>
theory IICF_RbtMap_Map
  imports  "Imperative_HOL_Time.IHT_Red_Black_Tree" "../Intf/IICF_Map"
begin

  hide_const(open) R B

(* inspired by Separation_Logic_Imperative_HOL/Examples/Array_Map_Impl *)

definition rbt_map_map_assn where [rewrite_ent]:
  "rbt_map_map_assn MM p = (\<exists>\<^sub>AM. rbt_map_assn M p * \<up>(MM = meval M))"

subsubsection "empty map init via rbtree"

definition "map_empty = tree_empty"

declare [[print_trace]]
setup \<open>fold del_prfstep_thm @{thms rbt_map_assn_def}\<close>

lemma meval_empty_map[rewrite]: "meval empty_map = Map.empty" unfolding empty_map_def by auto

setup \<open>add_rewrite_rule @{thm meval.simps}\<close>
theorem map_empty_rule [hoare_triple]:
  "<$1> map_empty <rbt_map_map_assn (Map.empty)>"
  unfolding map_empty_def by auto2

lemma mop_map_empty_rule[sepref_fr_rules]:
  "1 \<le> n () \<Longrightarrow> (uncurry0 map_empty, uncurry0 (PR_CONST (mop_map_empty n))) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a rbt_map_map_assn"
  apply sepref_to_hoare
  unfolding mop_map_empty_def autoref_tag_defs
  apply (rule extract_cost_otherway'[OF _ map_empty_rule  ])
  by (sep_auto simp: emb'_def)+

subsubsection "update map via rbtree insert"

definition "map_update p k x = rbt_insert k x p"

lemma keys_of_dom_meval: "keys_of M = dom (meval M)"
  unfolding keys_of_def by auto

abbreviation "sizeM1' m \<equiv> 1 + card (dom m)"

lemma sizeM1'_sizeM1[rewrite]: "sizeM1' (meval M) = sizeM1 M"
  by(simp add: keys_of_dom_meval   sizeM1_def)

lemma meval_update[rewrite]: "meval ( M { k \<rightarrow> v }) = (meval M)(k \<mapsto> v)"
   by (auto simp: update_map_def)

theorem map_update_rule [hoare_triple]:
  "<rbt_map_map_assn M m * $ (rbt_insert_logN (sizeM1' M))>
           map_update m k v
   <rbt_map_map_assn ( M( k \<mapsto> v ))>\<^sub>t"
  unfolding map_update_def
  by auto2

lemma mop_set_insert_rule[sepref_fr_rules]: "(uncurry2 map_update, uncurry2 (PR_CONST (mop_map_update t)))
  \<in> [\<lambda>((a, b), x). rbt_insert_logN (sizeM1' a) \<le> t ((a, b), x)]\<^sub>a rbt_map_map_assn\<^sup>d *\<^sub>a id_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow> rbt_map_map_assn"
  apply sepref_to_hoare
  unfolding mop_map_update_def autoref_tag_defs
  apply (rule extract_cost_otherway'[OF _ map_update_rule  ])
    by (auto simp: emb'_def | solve_entails; auto)+

subsubsection "dom_member map via rbtree search"

definition "map_dom_member m k = do {
                  v \<leftarrow> rbt_search k m;
                  return (v\<noteq>None) }"

lemma M[rewrite]: "M\<langle>x\<rangle>\<noteq>None \<longleftrightarrow> x:dom (meval M)"
  unfolding keys_of_iff[symmetric] keys_of_dom_meval by simp

theorem map_dom_member_rule [hoare_triple]:
  "<rbt_map_map_assn M m * $ (rbt_search_time_logN (sizeM1' M)+1)>
           map_dom_member m x
   <\<lambda>r. rbt_map_map_assn M m * \<up>(r\<longleftrightarrow>x\<in>dom M)>\<^sub>t"
  unfolding map_dom_member_def
  by auto2

lemma mop_mem_set_rule[sepref_fr_rules]:
  "(uncurry map_dom_member, uncurry (PR_CONST (mop_map_dom_member t)))
   \<in> [\<lambda>(a, b). rbt_search_time_logN (sizeM1' a) + 1 \<le> t (a, b)]\<^sub>a rbt_map_map_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow> bool_assn"
  apply sepref_to_hoare
  unfolding mop_map_dom_member_def autoref_tag_defs
  apply (rule extract_cost_otherway'[OF _ map_dom_member_rule  ])
  by (auto simp: emb'_def | solve_entails; auto)+

subsubsection "lookup map via rbtree search"

definition "map_lookup m k = do {
                  v \<leftarrow> rbt_search k m;
                  return (the v) }"

theorem map_lookup_rule [hoare_triple]:
  "x\<in>dom M \<Longrightarrow> <rbt_map_map_assn M m * $ (rbt_search_time_logN (sizeM1' M)+1)>
           map_lookup m x
   <\<lambda>r. rbt_map_map_assn M m * \<up>(r=the (M x))>\<^sub>t"
  unfolding map_lookup_def  rbt_map_map_assn_def
  by (sep_auto simp del: One_nat_def heap: rbt_search simp: sizeM1'_sizeM1 zero_time)

lemma mop_map_lookup_rule[sepref_fr_rules]:
  "(uncurry map_lookup, uncurry (PR_CONST (mop_map_lookup t)))
     \<in> [\<lambda>(a, b). rbt_search_time_logN (sizeM1' a) + 1 \<le> t (a, b)]\<^sub>a rbt_map_map_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow> id_assn"
  apply sepref_to_hoare
  unfolding mop_map_lookup_def autoref_tag_defs
  apply(rule hnr_ASSERT)
  apply(rule extract_cost_otherway'[OF _ map_lookup_rule   ])
  by sep_auto+

end


section\<open>Tag-Based Encodings\<close>
theory T
imports T_G_Prelim
begin

subsection\<open>The tag translation\<close>

text\<open>The extension of the function symbols with type tags and type witnesses:\<close>

datatype ('fsym,'tp) efsym = Oldf 'fsym | Tag 'tp | Wit 'tp

context ProblemIkTpart
begin

text\<open>``TE'' stands for ``tag encoding''\<close>

fun TE_wtFsym where
 "TE_wtFsym (Oldf f) \<longleftrightarrow> wtFsym f"
|"TE_wtFsym (Tag \<sigma>) \<longleftrightarrow> True"
|"TE_wtFsym (Wit \<sigma>) \<longleftrightarrow> \<not> isRes \<sigma>"

fun TE_arOf where
 "TE_arOf (Oldf f) = arOf f"
|"TE_arOf (Tag \<sigma>) = [\<sigma>]"
|"TE_arOf (Wit \<sigma>) = []"

fun TE_resOf where
 "TE_resOf (Oldf f) = resOf f"
|"TE_resOf (Tag \<sigma>) = \<sigma>"
|"TE_resOf (Wit \<sigma>) = \<sigma>"

lemma countable_TE_wtFsym: "countable (Collect TE_wtFsym)" (is "countable ?K")
proof-
  let ?F = "\<lambda> ef. case ef of Oldf f \<Rightarrow> Inl f | Tag \<sigma> \<Rightarrow> Inr (Inl \<sigma>) | Wit \<sigma> \<Rightarrow> Inr (Inr \<sigma>)"
  let ?U = "(UNIV::'tp set) <+> (UNIV::'tp set)"
  let ?L = "(Collect wtFsym) <+> ?U"
  have "inj_on ?F ?K" unfolding inj_on_def apply clarify
  apply(case_tac x, simp_all) by (case_tac y, simp_all)+
  moreover have "?F ` ?K \<subseteq> ?L" apply clarify by (case_tac ef, auto)
  ultimately have "|?K| \<le>o |?L|" unfolding card_of_ordLeq[symmetric] by auto
  moreover have "countable ?L" using countable_wtFsym countable_tp
  by (metis countable_Plus)
  ultimately show ?thesis by(rule countable_ordLeq)
qed

end (* context ProblemIkTpart *)

sublocale ProblemIkTpart < TE? : Signature
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf
apply standard
using countable_tp countable_TE_wtFsym countable_wtPsym by auto

context ProblemIkTpart
begin

(* encoding of non-naked terms *)
fun tNN where
"tNN (Var x) =
 (if unprot (tpOfV x) \<or> protFw (tpOfV x) then Var x else Fn (Tag (tpOfV x)) [Var x])"
|
"tNN (Fn f Tl) = (if unprot (resOf f) \<or> protFw (resOf f)
                    then Fn (Oldf f) (map tNN Tl)
                    else Fn (Tag (resOf f)) [Fn (Oldf f) (map tNN Tl)])"

fun tT where
"tT (Var x) = (if unprot (tpOfV x) then Var x else Fn (Tag (tpOfV x)) [Var x])"
|
"tT t = tNN t"

fun tL where
"tL (Pos (Eq T1 T2)) = Pos (Eq (tT T1) (tT T2))"
|
"tL (Neg (Eq T1 T2)) = Neg (Eq (tNN T1) (tNN T2))"
|
"tL (Pos (Pr p Tl)) = Pos (Pr p (map tNN Tl))"
|
"tL (Neg (Pr p Tl)) = Neg (Pr p (map tNN Tl))"

definition "tC \<equiv> map tL"

(* The extra axioms: *)

(* The function axioms: *)
(* Lefthand side: *)
definition "rOfFax f = Fn (Oldf f) (getTvars (arOf f))"
(* Righthand side: *)
definition "lOfFax f = Fn (Tag (resOf f)) [rOfFax f]"
definition "Fax \<equiv> {[Pos (Eq (lOfFax f) (rOfFax f))] | f. wtFsym f}"

(* The witness axioms: *)
(* Lefthand side: *)
definition "rOfWax \<sigma> = Fn (Wit \<sigma>) []"
(* Righthand side: *)
definition "lOfWax \<sigma> = Fn (Tag \<sigma>) [rOfWax \<sigma>]"
definition "Wax \<equiv> {[Pos (Eq (lOfWax \<sigma>) (rOfWax \<sigma>))] | \<sigma>. \<not> isRes \<sigma> \<and> protFw \<sigma>}"

definition "tPB = tC ` \<Phi> \<union> Fax \<union> Wax"

(* Well-typedness of the translation: *)
lemma tpOf_tNN[simp]: "TE.tpOf (tNN T) = Ik.tpOf T"
by (induct T) auto

lemma tpOf_t[simp]: "TE.tpOf (tT T) = Ik.tpOf T"
by (cases T) auto

lemma wt_tNN[simp]: "Ik.wt T \<Longrightarrow> TE.wt (tNN T)"
by (induct T, auto simp add: list_all_iff)

lemma wt_t[simp]: "Ik.wt T \<Longrightarrow> TE.wt (tT T)"
by (cases T, auto simp add: list_all_iff)

lemma wtL_tL[simp]: "Ik.wtL l \<Longrightarrow> TE.wtL (tL l)"
apply(cases l) apply (rename_tac [!] atm) apply(case_tac [!] atm)
by (auto simp add: list_all_iff)

lemma wtC_tC[simp]: "Ik.wtC c \<Longrightarrow> TE.wtC (tC c)"
unfolding tC_def Ik.wtC_def TE.wtC_def by (induct c, auto)

lemma tpOf_rOfFax[simp]: "TE.tpOf (rOfFax f) = resOf f"
unfolding rOfFax_def by simp

lemma tpOf_lOfFax[simp]: "TE.tpOf (lOfFax f) = resOf f"
unfolding lOfFax_def by simp

lemma tpOf_rOfWax[simp]: "TE.tpOf (rOfWax \<sigma>) = \<sigma>"
unfolding rOfWax_def by simp

lemma tpOf_lOfWax[simp]: "TE.tpOf (lOfWax \<sigma>) = \<sigma>"
unfolding lOfWax_def by simp

lemma wt_rOfFax[simp]: "wtFsym f \<Longrightarrow> TE.wt (rOfFax f)"
unfolding rOfFax_def by simp

lemma wt_lOfFax[simp]: "wtFsym f \<Longrightarrow> TE.wt (lOfFax f)"
unfolding lOfFax_def by simp

lemma wt_rOfWax[simp]: "\<not> isRes \<sigma> \<Longrightarrow> TE.wt (rOfWax \<sigma>)"
unfolding rOfWax_def by simp

lemma wt_lOfWax[simp]: "\<not> isRes \<sigma> \<Longrightarrow> TE.wt (lOfWax \<sigma>)"
unfolding lOfWax_def by simp

lemma wtPB_Fax[simp]: "TE.wtPB Fax" unfolding Fax_def TE.wtPB_def TE.wtC_def by auto

lemma wtPB_Wax[simp]: "TE.wtPB Wax" unfolding Wax_def TE.wtPB_def TE.wtC_def by auto

lemma wtPB_tC_\<Phi>[simp]: "TE.wtPB (tC ` \<Phi>)"
using Ik.wt_\<Phi> unfolding Ik.wtPB_def TE.wtPB_def by auto

lemma wt_Tag:
assumes "TE.wt (Fn (Tag \<sigma>) Tl)"
shows "\<exists> T. Tl = [T] \<and> TE.wt T \<and> tpOf T = \<sigma>"
using assms
by simp (metis (hide_lams, no_types) list.inject list_all_simps(1) map_eq_Cons_conv neq_Nil_conv)

lemma tpOf_Tag: "TE.tpOf (Fn (Tag \<sigma>) Tl) = \<sigma>" by simp

lemma tpOf_Wit: "TE.tpOf (Fn (Wit \<sigma>) Tl) = \<sigma>" by simp

end (* context ProblemIkTpart *)

subsection\<open>Soundness\<close>

context ModelIkTpart begin

(* The identity-tag extension of a given structure of the original signature *)
fun TE_intF where
 "TE_intF (Oldf f) al = intF f al"
|"TE_intF (Tag \<sigma>) al = hd al"
|"TE_intF (Wit \<sigma>) al = pickT \<sigma>"
(* note: for tags, we only care about al being the singleton list [a],
   and hence the interpretation returns a; for witnesses, we only care
   about al being [] *)

end (* context ModelIkTpart *)

sublocale ModelIkTpart < TE? : Struct
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf and intF = TE_intF
proof
  fix ef al assume "TE_wtFsym ef" and "list_all2 intT (TE_arOf ef) al"
  thus "intT (TE_resOf ef) (TE_intF ef al)"
  using intF by (cases ef, auto)
qed auto

context ModelIkTpart begin

lemma tNN_int[simp]: "TE.int \<xi> (tNN T) = Ik.int \<xi> T"
proof(induct T)
  case (Fn f Tl)
  hence 0: "map (TE.int \<xi> \<circ> tNN) Tl = map (Ik.int \<xi>) Tl"
  unfolding list_eq_iff list_all_iff by auto
  show ?case by (simp add: 0)
qed auto

lemma map_tNN_int[simp]: "map (TE.int \<xi> \<circ> tNN) Tl = map (Ik.int \<xi>) Tl"
unfolding list_eq_iff list_all_iff by auto

lemma t_int[simp]: "TE.int \<xi> (tT T) = Ik.int \<xi> T"
by (cases T, auto)

lemma map_t_int[simp]: "map (TE.int \<xi> \<circ> tT) Tl = map (Ik.int \<xi>) Tl"
unfolding list_eq_iff list_all_iff by auto

lemma tL_satL[simp]: "TE.satL \<xi> (tL l) \<longleftrightarrow> Ik.satL \<xi> l"
apply(cases l) apply (rename_tac [!] atm) apply(case_tac [!] atm) by auto

lemma tC_satC[simp]: "TE.satC \<xi> (tC c) \<longleftrightarrow> Ik.satC \<xi> c"
unfolding TE.satC_def Ik.satC_def tC_def by (induct c, auto)

lemma tC_\<Phi>_satPB[simp]: "TE.satPB \<xi> (tC ` \<Phi>) \<longleftrightarrow> Ik.satPB \<xi> \<Phi>"
unfolding TE.satPB_def Ik.satPB_def by auto

lemma Fax_Wax_satPB:
"TE.satPB \<xi> (Fax) \<and> TE.satPB \<xi> (Wax)"
unfolding TE.satPB_def TE.satC_def Fax_def Wax_def
by (auto simp add: lOfFax_def rOfFax_def lOfWax_def rOfWax_def)

lemmas Fax_satPB[simp] = Fax_Wax_satPB[THEN conjunct1]
lemmas Wax_satPB[simp] = Fax_Wax_satPB[THEN conjunct2]

theorem T_soundness:
"Model TE_wtFsym wtPsym TE_arOf TE_resOf parOf tPB intT TE_intF intP"
apply standard using wtPB_tPB soundness by auto

end (* context ModelIkTpart *)

(* Soundness theorem in sublocale form: Given a problem (with indicated
type partition) and a model for it, we obtain a model of the tag-extended (TE)
problem: *)
sublocale ModelIkTpart < TE? : Model
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf
and \<Phi> = tPB and intF = TE_intF
apply standard using wtPB_tPB soundness by auto

subsection\<open>Completeness\<close>

(* iimg B f transforms f into a function f' having the same B-range as f
and such that it is the identity on its B-image, namely, \<forall> b \<in> B. f' (f' a) = f' a;
also, it holds that \<forall> b \<in> B. f' (f b) = f b *)
definition "iimg B f a \<equiv> if a \<in> f ` B then a else f a"

lemma inImage_iimg[simp]: "a \<in> f ` B \<Longrightarrow> iimg B f a = a"
unfolding iimg_def by auto

lemma not_inImage_iimg[simp]: "a \<notin> f ` B \<Longrightarrow> iimg B f a = f a"
unfolding iimg_def by auto

lemma iimg[simp]: "a \<in> B \<Longrightarrow> iimg B f (f a) = f a"
by (cases "a \<in> f ` B", auto)

(* Problem with type partition and model of its tag-encoding translation: *)

locale ProblemIkTpart_TEModel =
Ik? : ProblemIkTpart wtFsym wtPsym arOf resOf parOf \<Phi> infTp prot protFw +
TE? : Model "ProblemIkTpart.TE_wtFsym wtFsym resOf" wtPsym
           "ProblemIkTpart.TE_arOf arOf" "ProblemIkTpart.TE_resOf resOf" parOf
           tPB eintT eintF eintP
for wtFsym :: "'fsym \<Rightarrow> bool"
and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and prot and protFw
and eintT and eintF and eintP

context ProblemIkTpart_TEModel begin

(* new tag semantics (taking as input elements, instead of singleton lists): *)
definition
"ntsem \<sigma> \<equiv>
 if unprot \<sigma> \<or> protFw \<sigma> then id
                   else iimg {b. eintT \<sigma> b} (eintF (Tag \<sigma>) o singl)"

lemma unprot_ntsem[simp]: "unprot \<sigma> \<or> protFw \<sigma> \<Longrightarrow> ntsem \<sigma> a = a"
unfolding ntsem_def by simp

lemma protFw_ntsem[simp]: "protFw \<sigma> \<Longrightarrow> ntsem \<sigma> a = a"
unfolding ntsem_def by simp

lemma inImage_ntsem[simp]:
"a \<in> (eintF (Tag \<sigma>) o singl) ` {b. eintT \<sigma> b} \<Longrightarrow> ntsem \<sigma> a = a"
unfolding ntsem_def by simp

lemma not_unprot_inImage_ntsem[simp]:
assumes "\<not> unprot \<sigma>" and "\<not> protFw \<sigma>" and "a \<notin> (eintF (Tag \<sigma>) o singl) ` {b. eintT \<sigma> b}"
shows "ntsem \<sigma> a = eintF (Tag \<sigma>) [a]"
using assms unfolding ntsem_def by (simp add: singl_def)

(* crucial: *)
lemma ntsem[simp]:
"eintT \<sigma> b \<Longrightarrow> ntsem \<sigma> (eintF (Tag \<sigma>) [b]) = eintF (Tag \<sigma>) [b]"
unfolding singl_def[symmetric] by simp

lemma eintT_ntsem:
assumes a: "eintT \<sigma> a"  shows "eintT \<sigma> (ntsem \<sigma> a)"
proof(cases "unprot \<sigma> \<or> protFw \<sigma>")
  case False note unprot = False show ?thesis
  proof(cases "a \<in> (eintF (Tag \<sigma>) o singl) ` {b. eintT \<sigma> b}")
    case False hence 1: "ntsem \<sigma> a = eintF (Tag \<sigma>) [a]" using unprot by simp
    show ?thesis unfolding 1 using a TE.intF
    by (metis TE_arOf.simps TE_resOf.simps TE_wtFsym.simps list_all2_Cons list_all2_Nil)
  qed(insert a, auto)
qed(insert a, simp)

(* The reduct structure of a given structure in the tag-extended signature: *)
definition
"intT \<sigma> a \<equiv>
 if unprot \<sigma> then eintT \<sigma> a
 else if protFw \<sigma> then eintT \<sigma> a \<and> eintF (Tag \<sigma>) [a] = a
 else eintT \<sigma> a \<and> a \<in> (eintF (Tag \<sigma>) o singl) ` {b. eintT \<sigma> b}"
definition
"intF f al \<equiv>
 if unprot (resOf f) \<or> protFw (resOf f)
   then eintF (Oldf f) (map2 ntsem (arOf f) al)
   else eintF (Tag (resOf f)) [eintF (Oldf f) (map2 ntsem (arOf f) al)]"
definition
"intP p al \<equiv> eintP p (map2 ntsem (parOf p) al)"

(* Semantic rephrasings of the fact that the (tagged problem) model satisfies
   Fax and Wax *)
lemma TE_Tag: (* fixme: messy proof *)
assumes f: "wtFsym f" and al: "list_all2 eintT (arOf f) al"
shows "eintF (Tag (resOf f)) [eintF (Oldf f) al] = eintF (Oldf f) al"
proof-
  define xl where "xl = getVars (arOf f)"
  have l[simp]: "length xl = length al" "length al = length (arOf f)"
  unfolding xl_def using al unfolding list_all2_iff by auto
  have 1[simp]: "\<And> i. i < length (arOf f) \<Longrightarrow> tpOfV (xl!i) = (arOf f)!i"
  unfolding xl_def by auto
  have xl[simp]: "distinct xl" unfolding xl_def using distinct_getVars by auto
  define \<xi> where "\<xi> = pickE xl al"
  have \<xi>: "TE.wtE \<xi>" unfolding \<xi>_def apply(rule wtE_pickE)
  using al  list_all2_nthD by auto
  have [simp]: "\<And> i. i < length (arOf f) \<Longrightarrow> \<xi> (xl ! i) = al ! i"
  using al unfolding \<xi>_def by (auto simp: list_all2_length intro: pickE)
  have 0: "map (TE.int \<xi>) (getTvars (arOf f)) = al"
  apply(rule nth_equalityI)
  using al by (auto simp: list_all2_length getTvars_def xl_def[symmetric])
  have "TE.satPB \<xi> Fax" using TE.sat_\<Phi>[OF \<xi>] unfolding tPB_def by simp
  hence "TE.satC \<xi> [Pos (Eq (lOfFax f) (rOfFax f))]"
  unfolding TE.satPB_def Fax_def using f by auto
  hence "TE.satA \<xi> (Eq (lOfFax f) (rOfFax f))" unfolding TE.satC_def by simp
  thus ?thesis using al by (simp add: lOfFax_def rOfFax_def 0)
qed

lemma TE_Wit:
assumes \<sigma>: "\<not> isRes \<sigma>" "protFw \<sigma>"
shows "eintF (Tag \<sigma>) [eintF (Wit \<sigma>) []] = eintF (Wit \<sigma>) []"
proof-
  define \<xi> where "\<xi> = pickE [] []"
  have \<xi>: "TE.wtE \<xi>" unfolding \<xi>_def apply(rule wtE_pickE) by auto
  have "TE.satPB \<xi> Wax" using TE.sat_\<Phi>[OF \<xi>] unfolding tPB_def by simp
  hence "TE.satC \<xi> [Pos (Eq (lOfWax \<sigma>) (rOfWax \<sigma>))]"
  unfolding TE.satPB_def Wax_def using \<sigma> by auto
  hence "TE.satA \<xi> (Eq (lOfWax \<sigma>) (rOfWax \<sigma>))" unfolding TE.satC_def by auto
  thus ?thesis unfolding TE.satA.simps lOfWax_def rOfWax_def by simp
qed

lemma NE_intT_forget: "NE (intT \<sigma>)"
proof-
  obtain b where b: "eintT \<sigma> b" using TE.NE_intT by blast
  show ?thesis proof(cases "unprot \<sigma>")
    case True thus ?thesis using b unfolding intT_def by auto
  next
    case False note unprot = False show ?thesis
    proof(cases "protFw \<sigma>")
      case True note protFw = True show ?thesis proof(cases "isRes \<sigma>")
        case True then obtain f where f: "wtFsym f" and \<sigma>: "\<sigma> = resOf f"
        unfolding isRes_def by auto
        define al where "al = map pickT (arOf f)"
        have al: "list_all2 eintT (arOf f) al"
        unfolding al_def list_all2_map2 unfolding list_all2_length by auto
        define a where "a = eintF (Oldf f) al"
        have "eintT \<sigma> a" unfolding a_def \<sigma> using f al
        by (metis TE_arOf.simps TE_resOf.simps TE_wtFsym.simps TE.intF)
        moreover have "eintF (Tag \<sigma>) [a] = a" unfolding \<sigma> a_def using TE_Tag[OF f al] .
        ultimately show ?thesis using unprot protFw unfolding intT_def by auto
      next
        case False
        define a where "a = eintF (Wit \<sigma>) []"
        have "eintT \<sigma> a" unfolding a_def
        by (metis False TE_arOf.simps TE_resOf.simps TE_wtFsym.simps TE.intF list_all2_NilR)
        moreover have "eintF (Tag \<sigma>) [a] = a" unfolding a_def using TE_Wit[OF False protFw] .
        ultimately show ?thesis using unprot protFw unfolding intT_def by auto
      qed
    next
      case False  hence "eintT \<sigma> (eintF (Tag \<sigma>) [b])"
      using b list_all2_Cons list_all2_NilL
      by (metis TE.intF TE_arOf.simps TE_resOf.simps TE_wtFsym.simps)
      hence "intT \<sigma> (eintF (Tag \<sigma>) [b])"
      unfolding intT_def singl_def[abs_def] using b False by auto
      thus ?thesis by blast
    qed
  qed
qed

lemma wt_intF:
assumes f: "wtFsym f" and al: "list_all2 intT (arOf f) al"
shows "intT (resOf f) (intF f al)"
proof-
  let ?t = "eintF (Tag (resOf f))"
  let ?t'al = "map2 ntsem (arOf f) al"
  have al: "list_all2 eintT (arOf f) al"
  using al unfolding list_all2_length intT_def by metis
  have 0: "list_all2 eintT (arOf f) ?t'al"
  proof(rule listAll2_map2I)
    show l: "length (arOf f) = length al"
    using al unfolding list_all2_length by simp
    fix i assume "i < length (arOf f)"
    hence 1: "eintT (arOf f ! i) (al ! i)"
    using al unfolding list_all2_length by simp
    show "eintT (arOf f ! i) (ntsem (arOf f ! i) (al ! i))"
    using eintT_ntsem[OF 1] .
  qed
  hence 1: "eintT (resOf f) (eintF (Oldf f) ?t'al)"
  by (metis TE_arOf.simps TE_resOf.simps TE_wtFsym.simps f TE.intF)
  show ?thesis  proof(cases "unprot (resOf f)")
    case True thus ?thesis unfolding intF_def intT_def by (simp add: 1)
  next
    case False note unprot = False show ?thesis proof(cases "protFw (resOf f)")
      case True thus ?thesis using unprot TE_Tag[OF f 0] 1
      unfolding intF_def intT_def by simp
    next
      case False
      have "eintT (resOf f) (intF f al)" using intF_def 0 1 TE_Tag f by auto
      moreover have
      "intF f al \<in> (eintF (Tag (resOf f)) o singl) ` {b. eintT (resOf f) b}"
      unfolding intF_def using 1 unprot False by (auto simp add: singl_def)
      ultimately show ?thesis using False unfolding intT_def by simp
    qed
  qed
qed

lemma Struct: "Struct wtFsym wtPsym arOf resOf intT intF intP"
apply standard using NE_intT_forget wt_intF by auto

end (* context ProblemIkTpart_TEModel *)

sublocale ProblemIkTpart_TEModel < Ik? : Struct
where intT = intT and intF = intF and intP = intP
using Struct .

context ProblemIkTpart_TEModel begin

(* The inverse of the tag function (required for translating environments backwards)*)
definition
"invt \<sigma> a \<equiv> if unprot \<sigma> \<or> protFw \<sigma> then a else (SOME b. eintT \<sigma> b \<and> eintF (Tag \<sigma>) [b] = a)"

lemma unprot_invt[simp]: "unprot \<sigma> \<or> protFw \<sigma> \<Longrightarrow> invt \<sigma> a = a"
unfolding invt_def by auto

lemma invt_invt_inImage:
assumes \<sigma>: "\<not> unprot \<sigma>" "\<not> protFw \<sigma>"
and a: "a \<in> (eintF (Tag \<sigma>) o singl) ` {b. eintT \<sigma> b}"
shows "eintT \<sigma> (invt \<sigma> a) \<and> eintF (Tag \<sigma>) [invt \<sigma> a] = a"
proof-
  obtain b where "eintT \<sigma> b" and "eintF (Tag \<sigma>) [b] = a"
  using a unfolding image_def singl_def[symmetric] by auto
  thus ?thesis using \<sigma> unfolding invt_def apply simp apply(rule someI_ex) by auto
qed

lemmas invt[simp] = invt_invt_inImage[THEN conjunct1]
lemmas invt_inImage[simp] = invt_invt_inImage[THEN conjunct2]

(* We translate the environments of the tag-extended-problem model
to environments of its original-signature reduct: *)  term invt
definition "eenv \<xi> x \<equiv> invt (tpOfV x) (\<xi> x)"

lemma wt_eenv:
assumes \<xi>: "Ik.wtE \<xi>"  shows "TE.wtE (eenv \<xi>)"
unfolding TE.wtE_def proof safe
  fix x let ?\<sigma> = "TE.tpOfV x"
  show "eintT ?\<sigma> (eenv \<xi> x)" proof(cases "unprot ?\<sigma>")
    case True note unprot = True
    thus ?thesis unfolding eenv_def by (metis \<xi> Ik.wtTE_intT intT_def unprot_invt)
  next
    case False note unprot = False show ?thesis proof(cases "protFw ?\<sigma>")
      case True thus ?thesis unfolding eenv_def using unprot \<xi>
      by (metis Ik.wtTE_intT intT_def unprot_invt)
    next
      case False thus ?thesis unfolding eenv_def using unprot \<xi>
      by (metis (no_types) \<xi> Ik.wtE_def intT_def invt)
    qed
  qed
qed

lemma int_tNN[simp]:
assumes T: "Ik.Ik.wt T" and \<xi>: "Ik.wtE \<xi>"
shows "TE.int (eenv \<xi>) (tNN T) = Ik.int \<xi> T"
using T proof(induct T)
  case (Var x) let ?\<sigma> = "TE.tpOfV x"  show ?case
  proof(cases "unprot ?\<sigma>")
    case False note unprot = False
    show ?thesis proof(cases "protFw ?\<sigma>")
      case True thus ?thesis using unprot \<xi>
      unfolding eenv_def Ik.wtE_def intT_def by simp
    next
      case False  hence "\<xi> x \<in> (eintF (Tag ?\<sigma>) \<circ> singl) ` {b. eintT ?\<sigma> b}"
        using \<xi> unprot unfolding wtE_def intT_def singl_def[abs_def] by (simp cong del: image_cong_simp)
      thus ?thesis using unprot unfolding eenv_def using False by simp
    qed
  qed(unfold eenv_def, simp)
next
  case (Fn f Tl)
  let ?e\<xi> = "eenv \<xi>" let ?ar = "arOf f" let ?r = "resOf f"
  have l: "length ?ar = length Tl" using Fn by simp
  have 0: "map2 ntsem ?ar (map (Ik.int \<xi>) Tl) =
           map (TE.int ?e\<xi> \<circ> tNN) Tl"  (is "?L = ?R")
  proof(rule nth_equalityI)
    fix i assume "i < length ?L"
    hence i: "i < length ?ar" using l by simp
    hence 1: "TE.int (eenv \<xi>) (tNN (Tl!i)) = Ik.int \<xi> (Tl!i)"
      using Fn by (auto simp: list_all_length)
    have 2: "?ar ! i = Ik.Ik.tpOf (Tl!i)" using Fn i by simp
    have 3: "intT (?ar ! i) (Ik.int \<xi> (Tl ! i))"
      unfolding 2 apply(rule wt_int)
      using Fn \<xi> i by (auto simp: list_all_length)
    show "?L!i = ?R!i" apply (cases "unprot (?ar ! i) \<or> protFw (?ar ! i)")
      using i 1 l 3 unfolding intT_def by auto
  qed(insert l, auto)
  show ?case apply(cases "unprot ?r \<or> protFw ?r")
    using [[unfold_abs_def = false]]
    unfolding Ik.int.simps TE.int.simps tT.simps unfolding intF_def using Fn 0 by auto
qed

lemma map_int_tNN[simp]:
assumes Tl: "list_all Ik.Ik.wt Tl" and \<xi>: "Ik.wtE \<xi>"
shows
"map2 ntsem (map Ik.Ik.tpOf Tl) (map (Ik.int \<xi>) Tl) =
 map (TE.int (eenv \<xi>) \<circ> tNN) Tl"
proof-
  {fix i assume i: "i < length Tl"
   hence wt: "Ik.Ik.wt (Tl!i)" using Tl unfolding list_all_length by simp
   have "intT (Ik.Ik.tpOf (Tl!i)) (Ik.int \<xi> (Tl!i))" using Ik.wt_int[OF \<xi> wt] .
  }
  thus ?thesis
  using [[unfold_abs_def = false]]
  using assms unfolding intT_def list_all_length
  unfolding list_eq_iff apply clarsimp by (metis inImage_ntsem unprot_ntsem)
qed

lemma int_t[simp]:
assumes T: "Ik.Ik.wt T" and \<xi>: "Ik.wtE \<xi>"
shows "TE.int (eenv \<xi>) (tT T) = Ik.int \<xi> T"
using T proof(induct T)
  case (Var x) let ?\<sigma> = "tpOfV x"  show ?case
  proof(cases "unprot ?\<sigma>")
    case False note unprot = False
    show ?thesis proof(cases "protFw ?\<sigma>")
      case True thus ?thesis using unprot \<xi>
      unfolding eenv_def Ik.wtE_def intT_def by simp
    next
      case False  hence "\<xi> x \<in> (eintF (Tag ?\<sigma>) \<circ> singl) ` {b. eintT ?\<sigma> b}"
      using \<xi> unprot unfolding wtE_def intT_def singl_def[abs_def] by (simp cong del: image_cong_simp)
      thus ?thesis using unprot unfolding eenv_def using False by simp
    qed
  qed(unfold eenv_def, simp)
next
  case (Fn f Tl)
  let ?e\<xi> = "eenv \<xi>"  let ?ar = "arOf f"  let ?r = "resOf f"
  have l: "length ?ar = length Tl" using Fn by simp
  have ar: "?ar = map Ik.Ik.tpOf Tl" using Fn by simp
  have 0: "map2 ntsem ?ar (map (Ik.int \<xi>) Tl) = map (TE.int ?e\<xi> \<circ> tNN) Tl"
  unfolding ar apply(rule map_int_tNN[OF _ \<xi>]) using Fn by simp
  show ?case apply(cases "unprot ?r \<or> protFw ?r")
  using [[unfold_abs_def = false]]
  unfolding  Ik.int.simps TE.int.simps tT.simps unfolding intF_def using Fn 0 by auto
qed

lemma map_int_t[simp]:
assumes Tl: "list_all Ik.Ik.wt Tl" and \<xi>: "Ik.wtE \<xi>"
shows
"map2 ntsem (map Ik.Ik.tpOf Tl) (map (Ik.int \<xi>) Tl) =
 map (TE.int (eenv \<xi>) \<circ> tT) Tl"
proof-
  {fix i assume i: "i < length Tl"
   hence wt: "Ik.Ik.wt (Tl!i)" using Tl unfolding list_all_length by simp
   have "intT (Ik.Ik.tpOf (Tl!i)) (Ik.int \<xi> (Tl!i))" using wt_int[OF \<xi> wt] .
  }
  thus ?thesis
  using [[unfold_abs_def = false]]
  using assms unfolding intT_def list_all_length
  unfolding list_eq_iff apply clarsimp by (metis inImage_ntsem unprot_ntsem)
qed

lemma satL_tL[simp]:
assumes l: "Ik.Ik.wtL l" and \<xi>: "Ik.wtE \<xi>"
shows "TE.satL (eenv \<xi>) (tL l) \<longleftrightarrow> Ik.satL \<xi> l"
using assms apply(cases l) apply (rename_tac [!] atm) by (case_tac [!] atm) (auto simp add: intP_def)

lemma satC_tC[simp]:
assumes l: "Ik.Ik.wtC c" and \<xi>: "Ik.wtE \<xi>"
shows "TE.satC (eenv \<xi>) (tC c) \<longleftrightarrow> Ik.satC \<xi> c"
unfolding TE.satC_def Ik.satC_def
using assms by (induct c, auto simp add: Ik.Ik.wtC_def tC_def)

lemma satPB_tPB[simp]:
assumes \<xi>: "Ik.wtE \<xi>"
shows "TE.satPB (eenv \<xi>) (tC ` \<Phi>) \<longleftrightarrow> Ik.satPB \<xi> \<Phi>"
using Ik.wt_\<Phi> assms unfolding TE.satPB_def Ik.satPB_def by (auto simp add: Ik.Ik.wtPB_def)

lemma completeness: "Ik.SAT \<Phi>"
unfolding Ik.SAT_def proof safe
  fix \<xi> assume \<xi>: "Ik.wtE \<xi>" hence "TE.wtE (eenv \<xi>)" by(rule wt_eenv)
  hence "TE.satPB (eenv \<xi>) tPB" by (rule TE.sat_\<Phi>)
  hence "TE.satPB (eenv \<xi>) (tC ` \<Phi>)" unfolding tPB_def by simp
  thus "Ik.satPB \<xi> \<Phi>" using \<xi> by simp
qed

lemma T_completeness: "Model wtFsym wtPsym arOf resOf parOf \<Phi> intT intF intP"
by standard (rule completeness)

end (* context ProblemIkTpart_TEModel *)

(* Completeness theorem in sublocale form: Given a problem (with indicated
type partition) and a model for its tag-translated problem,
we obtain a model of the original problem: *)

sublocale ProblemIkTpart_TEModel < O? : Model
where intT = intT and intF = intF and intP = intP
using T_completeness .

subsection\<open>The result of the tag translation is an infiniteness-augmented problem\<close>

(* Note that basic fact, merely stating that
the translation is well-defined between infiniteness-augmented problems,
is only proved at this late stage since it requires completeness.
This is an interesting dependency, not spotted in the paper. *)

sublocale ProblemIkTpart < TE? : Problem
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf
and \<Phi> = tPB
apply standard by auto

sublocale ProblemIkTpart < TE? : ProblemIk
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf
and \<Phi> = tPB
proof
  fix \<sigma> eintT eintF eintP a  assume \<sigma>: "infTp \<sigma>"
  assume M: "Model TE_wtFsym wtPsym TE_arOf TE_resOf parOf tPB eintT eintF eintP"
  let ?TE_intT = "ProblemIkTpart_TEModel.intT prot protFw eintT eintF"
  let ?TE_intF = "ProblemIkTpart_TEModel.intF arOf resOf prot protFw eintT eintF"
  let ?TE_intP = "ProblemIkTpart_TEModel.intP parOf prot protFw eintT eintF eintP"
  have 0: "ProblemIkTpart_TEModel wtFsym wtPsym arOf resOf parOf
                                   \<Phi> infTp prot protFw eintT eintF eintP"
  using M unfolding ProblemIkTpart_TEModel_def apply safe apply standard done
  hence MM: "Ik.MModel ?TE_intT ?TE_intF ?TE_intP"
  by (rule ProblemIkTpart_TEModel.T_completeness)
  have "infinite {a. ?TE_intT \<sigma> a}" using infTp[OF \<sigma> MM] .
  moreover have "{a. ?TE_intT \<sigma> a} \<subseteq> {a. eintT \<sigma> a}"
  using ProblemIkTpart_TEModel.intT_def[OF 0] by auto
  ultimately show "infinite {a. eintT \<sigma> a}" using infinite_super by blast
qed

subsection\<open>The verification of the first monotonicity calculus criterion
for the tagged problem\<close>

context ProblemIkTpart begin

lemma nvT_t[simp]: "\<not> unprot \<sigma> \<Longrightarrow> (\<forall> x \<in> TE.nvT (tT T). tpOfV x \<noteq> \<sigma>)"
apply(induct T) by auto

lemma nvL_tL[simp]: "\<not> unprot \<sigma> \<Longrightarrow> (\<forall> x \<in> TE.nvL (tL l). tpOfV x \<noteq> \<sigma>)"
apply(cases l) apply(rename_tac [!] atm) apply(case_tac [!] atm) by auto (metis nvT_t)+

lemma nvC_tC[simp]: "\<not> unprot \<sigma> \<Longrightarrow> (\<forall> x \<in> TE.nvC (tC c). tpOfV x \<noteq> \<sigma>)"
unfolding tC_def TE.nvC_def apply (induct c)
by auto (metis (full_types) nvL_tL)+

lemma unprot_nvT_t[simp]:
"unprot (tpOfV x) \<Longrightarrow> x \<in> TE.nvT (tT T) \<longleftrightarrow> x \<in>  TE.nvT T"
by (induct T, auto)

lemma tpL_nvT_tL[simp]:
"unprot (tpOfV x) \<Longrightarrow> x \<in> TE.nvL (tL l) \<longleftrightarrow> x \<in> TE.nvL l"
by (cases l, rename_tac [!] atm, case_tac [!] atm, auto)

lemma unprot_nvC_tC[simp]:
"unprot (tpOfV x) \<Longrightarrow> x \<in> TE.nvC (tC c) \<longleftrightarrow> x \<in> TE.nvC c"
unfolding tC_def TE.nvC_def apply (induct c) by auto

(* The added axioms are monotonic *)
lemma nv_OfFax[simp]:
"x \<notin> TE.nvT (lOfFax f)"  "x \<notin> TE.nvT (rOfFax f)"
unfolding lOfFax_def rOfFax_def lOfWax_def rOfWax_def by auto

lemma nv_OfWax[simp]:
"x \<notin> TE.nvT (lOfWax \<sigma>')"  "x \<notin> TE.nvT (rOfWax \<sigma>')"
unfolding lOfFax_def rOfFax_def lOfWax_def rOfWax_def by auto

lemma nvC_Fax: "c \<in> Fax \<Longrightarrow> TE.nvC c = {}" unfolding Fax_def TE.nvC_def by auto
lemma mcalc_Fax: "c \<in> Fax \<Longrightarrow> TE.mcalc \<sigma> c" using nvC_Fax unfolding TE.mcalc_iff by auto
lemma nvC_Wax: "c \<in> Wax \<Longrightarrow> TE.nvC c = {}" unfolding Wax_def TE.nvC_def by auto
lemma mcalc_Wax: "c \<in> Wax \<Longrightarrow> TE.mcalc \<sigma> c" using nvC_Wax[of c] by simp

end (* context ProblemIkTpart *)

sublocale ProblemIkTpart < TE?: ProblemIkMcalc
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf
and \<Phi> = tPB
proof
  fix \<sigma> c assume "c \<in> tPB"
  thus "TE.mcalc \<sigma> c" unfolding tPB_def proof safe
    fix d assume d: "d \<in> \<Phi>" thus "TE.mcalc \<sigma> (tC d)"
    using unprot_mcalc[OF _ d] unfolding TE.mcalc_iff by (cases "unprot \<sigma>", auto, force)
  qed(insert mcalc_Fax mcalc_Wax, blast+)
qed

(* We already know that ProblemIkMcalc < MonotProblem, so by transitivity we obtain
the following main theorem, stating that the tag translation yields a monotonic
problem *)
context ProblemIkTpart begin

theorem T_monotonic:
"MonotProblem TE_wtFsym wtPsym TE_arOf TE_resOf parOf tPB" ..

end (* context ProblemIkTpart *)

sublocale ProblemIkTpart < TE?: MonotProblem
where wtFsym = TE_wtFsym and arOf = TE_arOf and resOf = TE_resOf and \<Phi> = tPB
using T_monotonic .

end


theory Kyber_Values
  imports
    Crypto_Scheme
    (* Check_Prime *)
    (* NTT_Scheme *)
begin

section \<open>Specification for Kyber\<close>

typedef fin7681 = "{0..<7681::int}"
  morphisms fin7681_rep fin7681_abs
  by (rule_tac x = 0 in exI, simp)

setup_lifting type_definition_fin7681

lemma CARD_fin7681 [simp]: "CARD (fin7681) = 7681"
  unfolding type_definition.card [OF type_definition_fin7681]
  by simp

lemma fin7681_nontriv [simp]: "1 < CARD(fin7681)"
  unfolding CARD_fin7681 by auto

lemma prime_7681: "prime (7681::nat)" by eval

instantiation fin7681 :: comm_ring_1
begin

lift_definition zero_fin7681 :: "fin7681" is "0" by simp

lift_definition one_fin7681 :: "fin7681" is "1" by simp

lift_definition plus_fin7681 :: "fin7681 \<Rightarrow> fin7681 \<Rightarrow> fin7681"
  is "(\<lambda>x y. (x+y) mod 7681)"
  by auto

lift_definition uminus_fin7681 :: "fin7681 \<Rightarrow> fin7681"
  is "(\<lambda>x. (uminus x) mod 7681)"
  by auto

lift_definition minus_fin7681 :: "fin7681 \<Rightarrow> fin7681 \<Rightarrow> fin7681"
  is "(\<lambda>x y. (x-y) mod 7681)"
  by auto

lift_definition times_fin7681 :: "fin7681 \<Rightarrow> fin7681 \<Rightarrow> fin7681"
  is "(\<lambda>x y. (x*y) mod 7681)"
  by auto

instance
proof
  fix a b c ::fin7681
  show "a * b * c = a * (b * c)"
    by (transfer, simp add: algebra_simps mod_mult_left_eq mod_mult_right_eq)
  show "a + b + c = a + (b + c)"
    by (transfer, simp add: algebra_simps mod_add_left_eq mod_add_right_eq)
  show "(a + b) * c = a * c + b * c"
    by (transfer, simp add: algebra_simps mod_add_right_eq  mod_mult_right_eq)
qed (transfer; simp add: algebra_simps mod_add_right_eq; fail)+

end

instantiation fin7681 :: finite
begin
instance
proof
  show "finite (UNIV :: fin7681 set)" unfolding type_definition.univ [OF type_definition_fin7681]
    by auto
qed
end

instantiation fin7681 :: equal
begin
lift_definition equal_fin7681 :: "fin7681 \<Rightarrow> fin7681 \<Rightarrow> bool" is "(=)" .
instance by (intro_classes, transfer, auto)
end

instantiation fin7681 :: nontriv
begin
instance
proof
  show "1 < CARD(fin7681)" unfolding CARD_fin7681 by auto
qed
end

instantiation fin7681 :: prime_card
begin
instance
proof
  show "prime CARD(fin7681)" unfolding CARD_fin7681 using prime_7681
    by blast
qed
end

instantiation fin7681 :: qr_spec
begin

definition qr_poly'_fin7681:: "fin7681 itself \<Rightarrow> int poly" where
  "qr_poly'_fin7681 \<equiv> (\<lambda>_. Polynomial.monom (1::int) 256 + 1)"

instance proof
  have "lead_coeff (qr_poly' TYPE(fin7681)) = 1" unfolding qr_poly'_fin7681_def
    by (simp add: degree_add_eq_left degree_monom_eq)
  then show "\<not> int CARD(fin7681) dvd
       lead_coeff (qr_poly' TYPE(fin7681))"
    unfolding CARD_fin7681 by auto
next
  have "degree (qr_poly' TYPE(fin7681)) = 256" unfolding qr_poly'_fin7681_def
    by (simp add: degree_add_eq_left degree_monom_eq)
  then show "0 < degree (qr_poly' TYPE(fin7681))"  by auto
qed
end

lift_definition to_int_fin7681 :: "fin7681 \<Rightarrow> int" is "\<lambda>x. x" .

lift_definition of_int_fin7681 :: "int \<Rightarrow> fin7681" is "\<lambda>x. (x mod 7681)"
  by simp

interpretation to_int_fin7681_hom: inj_zero_hom to_int_fin7681
  by (unfold_locales; transfer, auto)

interpretation of_int_fin7681_hom: zero_hom of_int_fin7681
  by (unfold_locales, transfer, auto)

lemma to_int_fin7681_of_int_fin7681 [simp]:
  "to_int_fin7681 (of_int_fin7681 x) = x mod 7681"
  using of_int_fin7681.rep_eq to_int_fin7681.rep_eq by presburger

lemma of_int_fin7681_to_int_fin7681 [simp]:
  "of_int_fin7681 (to_int_fin7681 x) = x"
  using fin7681_rep to_int_fin7681.rep_eq to_int_fin7681_hom.injectivity
    to_int_fin7681_of_int_fin7681 by force

lemma of_int_mod_ring_eq_iff [simp]:
  "(of_int_fin7681 a = of_int_fin7681 b) \<longleftrightarrow>
   ((a mod 7681) = (b mod 7681))"
  by (metis of_int_fin7681.abs_eq of_int_fin7681.rep_eq)

interpretation kyber7681: kyber_spec 256 7681 3 8 "TYPE(fin7681)" "TYPE(3)"
proof (unfold_locales, goal_cases)
  case 4
  then show ?case using prime_7681 prime_int_numeral_eq by blast
next
  case 5
  then show ?case using CARD_fin7681 by auto
next
  case 7
  then show ?case unfolding qr_poly'_fin7681_def by auto
qed auto

end


header {* Determinants\label{sec.det.ext} *}

theory Determinants_extension
imports
  Main
  "~~/src/HOL/Library/Polynomial"
  "~~/src/HOL/Multivariate_Analysis/Determinants"
begin

text{* This theory generalises a number of lemmas from HOL/Multivariate\_Analysis/Determinants to
   the case of commutative rings, i.e.~to the type class comm\_ring\_1. To that aim, some auxiliary
   results, in particular on the decomposition of the symmetric group,
   are established in advance. *}

(* ------------------------------------------------------------------------- *)
subsection {* Decomposition of the symmetric group *}
(* ------------------------------------------------------------------------- *)

abbreviation fscomp :: "(('b \<Rightarrow> 'c) set) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> (('a \<Rightarrow> 'c) set)" (infixl "oS" 55) where
  "S oS g \<equiv> (\<lambda>f. f \<circ> g) ` S"

lemma fscomp_singleton: "{ f } oS g = { f o g }"
  by auto

lemma permlem:
  assumes "finite S" "a \<in> S" "b \<in> S" "a \<noteq> b"
  shows "{ p. p permutes S \<and> sign p = -1 } =
         { q. q permutes S \<and> sign q = 1 } oS Fun.swap a b id" (is "?lhs = ?rhs")
proof-
  let ?s = "Fun.swap a b id"
  from permutation_swap_id[of a b] have perms: "permutation ?s"
    by auto
  from assms have spermS: "?s permutes S"
    by (simp add: permutes_swap_id)
  from assms sign_swap_id[of a b] have signs: "sign ?s = -1"
    by auto

  have "?lhs \<subseteq> ?rhs"
  proof(rule subsetI)
    fix p assume "p \<in> ?lhs"
    hence caseass: "p permutes S" "sign p = -1"
      by auto
    let ?q = "p o ?s"
    have qpS: "?q permutes S"
      by (simp add: caseass permutes_compose spermS)
    have sq1: "sign (?q) = 1"
    proof-
      have "permutation p"
        using caseass assms permutation_permutes  by auto
      hence "sign (?q) = sign p * sign ?s"
        using perms sign_compose[of p ?s] by auto
      with signs caseass show ?thesis
        by simp
    qed
    from qpS sq1 have qinset: "?q \<in> { q. q permutes S \<and> sign q = 1 }"
      by auto
    have qsp: "?q o ?s = p"
      by (metis comp_swap o_id swap_nilpotent)
    from qsp qinset show "p \<in> ?rhs"
      by (auto simp: image_iff)
  qed

  also have "?rhs \<subseteq> ?lhs"
  proof(rule subsetI)
    fix p assume "p \<in> ?rhs"
    then obtain q where "q \<in> { q. q permutes S \<and> sign q = 1 }" and psq: "p = q o ?s"
      by auto
    then have qpermS: "q permutes S" and sq1: "sign q = 1"
      by auto
    have ppermS: "p permutes S" using spermS qpermS permutes_compose[of ?s S q] psq
      by auto
    have spm1: "sign p = -1"
    proof-
      have "permutation q"
        using qpermS assms permutation_permutes by auto
      moreover have "sign p = sign (q o ?s)"
        using psq by auto
      ultimately have "sign p = sign(q) * sign(?s)"
        using perms sign_compose[of q ?s] by auto
      with signs sq1 show ?thesis
        by auto
    qed
    show "p \<in> ?lhs" using ppermS spm1
      by auto
  qed

  finally show ?thesis
    by auto
qed

theorem dec_symgroup:
  assumes "finite S" "a \<in> S" "b \<in> S" "a \<noteq> b"
  shows "{ p. p permutes S } = { q. q permutes S \<and> sign q = 1 } \<union>
                               ( { q. q permutes S \<and> sign q = 1 } oS Fun.swap a b id )"
proof-
  have "\<And> p. sign p = 1 \<or> sign p = -1"
    by (simp add: sign_def)
  with set_eq_iff have "{ p. p permutes S } =
                        { p. p permutes S \<and> sign p = 1 } \<union> { p. p permutes S \<and> sign p = -1 }"
    by auto
  with permlem[of S a b] assms show ?thesis
    by simp
qed

theorem dec_symgroup_disjoint:
  assumes "finite S" "a \<in> S" "b \<in> S" "a \<noteq> b"
  shows "{ q. q permutes S \<and> sign q = 1 } \<inter>
         ( { p. p permutes S \<and> sign p = 1 } oS Fun.swap a b id ) = {}"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain q p where eq: "q permutes S" "sign q = 1"
  "p permutes S" "sign p = 1" "q = p o Fun.swap a b id"
    by auto
  hence "sign q = -1"
    by (metis assms(1) assms(4) evenperm_comp evenperm_swap
        permutation_permutes permutation_swap_id sign_def)
  hence "sign q \<noteq> 1"
    by auto
  thus "False"
    using eq by auto
qed

(* ------------------------------------------------------------------------- *)
subsection {* Auxiliary lemma concerning big operators *}
(* ------------------------------------------------------------------------- *)

lemma setprod_remove2:
  assumes "finite A" "a \<in> A" "b \<in> A" "a \<noteq> b"
  shows "setprod f A = f a * f b * setprod f (A - {a,b})"
  using setprod.remove[of "A - {a}" b f] setprod.remove[of "A" a f] assms
  by (simp add: ac_simps Diff_insert2[symmetric])

(* ------------------------------------------------------------------------- *)
subsection {* Generalisations of / additions to properties of determinants *}
(* ------------------------------------------------------------------------- *)

text {* This subsection collects generalisations and additions to the library on determinants. A
   generalization of a lemma XYZ in the library is indicated by giving it the name my\_XYZ here. *}

lemma my_det_identical_rows:
  fixes A :: "'a::comm_ring_1^'n^'n" and i j :: "'n"
  assumes ij: "i \<noteq> j" and r: "row i A = row j A"
  shows "det A = 0"
proof-
  let ?S = "(UNIV::'n set)"
  let ?Sn = "{ p. p permutes ?S }"
  let ?An = "{ q. q permutes ?S \<and> sign q = 1 }"
  let ?\<tau> = "Fun.swap i j id"
  have dec: "?Sn = ?An \<union> (?An oS ?\<tau>)"
    using assms dec_symgroup[of ?S i j] by auto
  have disj: "?An \<inter> (?An oS ?\<tau>) = {}"
    using assms dec_symgroup_disjoint[of ?S i j] by auto

  have aux_even2: "\<And> p. (\<Prod>k\<in>UNIV. A $ k $ p k) =
    A $ i $ p i * A $ j $ p j * (\<Prod>k\<in>UNIV-{i,j}. A $ k $ p k)"
    by (rule setprod_remove2)
       (simp_all add: ij)

  have aux_ij: "\<And> k. A $ i $ k = A $ j $ k"
    using r row_def[of i A] row_def[of j A] by (metis vec_lambda_beta)

  txt{* main calculation *}
  have "det A = (\<Sum>p\<in> ?Sn. of_int (sign p) * (\<Prod>i\<in>UNIV. A $ i $ p i) )"
    by (simp add: det_def)
  also have "\<dots> = (\<Sum>p\<in> ?An. of_int (sign p) * (\<Prod>i\<in>UNIV. A $ i $ p i) )
                + (\<Sum>p\<in>( ?An oS ?\<tau>). of_int (sign p) * (\<Prod>i\<in>UNIV. A $ i $ p i) )"
    using dec disj setsum.union_disjoint[of "?An" "?An oS ?\<tau>" "\<lambda> p. of_int (sign p) * (\<Prod>i\<in>UNIV. A $ i $ p i)"]
    by auto
  also have "(\<Sum>p\<in> ?An. of_int (sign p) * (\<Prod>i\<in>UNIV. A $ i $ p i) )
           = (\<Sum>p\<in> ?An. \<Prod>i\<in>UNIV. A $ i $ p i )"
    by simp
  also have "(\<Sum>p\<in>( ?An oS ?\<tau> ). of_int (sign p) * (\<Prod>i\<in>UNIV. A $ i $ p i) )
         = - (\<Sum> q \<in> ?An. \<Prod>i\<in>UNIV. A $ i $ (q o ?\<tau>) i)"
  proof-
    let ?f = "(\<lambda> p. p o ?\<tau>)"
    have f_inj_on_An: "inj_on ?f ?An"
    by(rule inj_onI)
      (metis comp_id comp_swap swap_nilpotent)
    have sign: "\<And> q. q \<in> ?An \<Longrightarrow> sign (q o ?\<tau>) = - 1"
    proof-
      fix q assume ass: "q \<in> ?An"
      hence "permutation q"
        using permutation_permutes[of q] by auto
      then have "sign (q o ?\<tau>) = sign q * sign ?\<tau>"
        using sign_compose[of q ?\<tau>] by (simp add: permutation_swap_id)
      thus "sign (q o ?\<tau>) = - 1"
        using ass sign_swap_id[of i j] ij by auto
    qed

    have "(\<Sum>p\<in>( ?An oS ?\<tau> ). of_int (sign p) * (\<Prod>i\<in>UNIV. A $ i $ p i) )
      = (\<Sum> q \<in> ?An. of_int(sign (q o ?\<tau>)) * (\<Prod>i\<in>UNIV. A $ i $ (q o ?\<tau>) i) ) "
      using f_inj_on_An setsum.reindex[of "?f" "?An"
        "\<lambda> p. of_int (sign p) * (\<Prod>i\<in>UNIV. A $ i $ p i)"] by simp
    also have "\<dots> = (\<Sum> q \<in> ?An. (- 1) * (\<Prod>i\<in>UNIV. A $ i $ (q o ?\<tau>) i) )"
      using sign setsum.cong by auto
    finally show ?thesis
      by (metis (no_types) comm_ring_1_class.normalizing_ring_rules(1)  setsum_right_distrib)
  qed
  also have "(\<Sum>p\<in>{q. q permutes UNIV \<and> sign q = 1}. \<Prod>i\<in>UNIV. A $ i $ p i) +
  - (\<Sum>q | q permutes UNIV \<and> sign q = 1. \<Prod>ia\<in>UNIV. A $ ia $ (q \<circ> Fun.swap i j id) ia) = (\<Sum>p\<in>?An. \<Prod>i\<in>UNIV. A $ i $ p i) - (\<Sum>p\<in>?An. \<Prod>i\<in>UNIV. A $ i $ (p o ?\<tau>) i)"
    by simp
  also have "\<dots> = (\<Sum>p\<in>?An. (\<Prod>k\<in>UNIV. A $ k $ p k) - (\<Prod>k\<in>UNIV. A $ k $ (p o ?\<tau>) k))"
    using setsum_subtractf[of "\<lambda> p. \<Prod>i\<in>UNIV. A $ i $ p i" "\<lambda> p. \<Prod>i\<in>UNIV. A $ i $ (p o ?\<tau>) i" "?An"]
    by presburger
  also have "\<dots> = (\<Sum>p\<in>?An. (A $ i $ p i) * (A $ j $ p j) * (\<Prod> k \<in> UNIV - {i,j}. A $ k $ p k) -
    (A $ j $ p j) * (A $ i $ p i) * (\<Prod> k \<in> UNIV - {i,j}. A $ k $ p k))"
    using aux_ij aux_even2
    by simp

  finally show ?thesis by auto
qed

lemma my_det_row_operation:
  fixes A :: "'a::comm_ring_1^'n^'n"
  assumes ij: "i \<noteq> j"
  shows "det (\<chi> k. if k = i then row i A + c *s row j A else row k A) = det A"
  (is "?lhs = ?rhs")
proof-
  let ?Z = "(\<chi> k. if k = i then row j A else row k A)"
  have aux1: "row i ?Z = row j ?Z"
    by (vector row_def)
  have "(\<chi> k. if k = i then row i A else row k A) = A"
    by (vector row_def)
  hence "?lhs = det A + det (\<chi> k. if k = i then c *s row j A else row k A)"
    by (simp add: det_row_add)
  also have "\<dots> = det A + c * det ?Z"
    by (simp add: det_row_mul)
  finally show ?thesis
    by (simp add: my_det_identical_rows[OF ij aux1])
qed

lemma my_det_identical_columns:
  fixes A :: "'a::comm_ring_1^'n^'n" and i j :: "'n"
  assumes a: "i \<noteq> j" "column i A = column j A"
  shows "det A = 0"
  by(subst det_transpose[symmetric])
    (metis row_transpose a(2) my_det_identical_rows[OF a(1)])

lemma det_col_mul:
  shows "det (\<chi> i j. if j = k then c * (A $ i $ j) else A $ i $ j) = c * det A"
  (is "det ?lm = c * det ?rm")
proof-
  { fix A :: "'a::comm_ring_1^'n^'n" and l c
    have "det (\<chi> i j. if i = l then c * (A $ j $ i) else A $ j $ i) = c * det A"
    (is "det ?lm = ?rm" )
    proof-
    { fix A :: "'a::comm_ring_1^'n^'n" and c
      have "det (\<chi> i j. if i = l then c * (A $ i $ j) else A $ i $ j) = c * det A"
      proof-
        have "(\<chi> i j. if i = l then (c *s (A $ i)) $ j else (A $ i $ j))
        = (\<chi> i. if i = l then (c *s (A $ i)) else (A $ i))"
          by (simp add: vec_eq_iff)
        moreover have "det (\<chi> i. if i = l then (c *s (A $ i)) else (A $ i)) = c * det( A )"
          by(simp_all add: Determinants.det_row_mul[of l c] vec_lambda_eta[of A])
        ultimately show ?thesis
          by(simp only: vector_smult_component[of c, symmetric])
      qed }
    moreover have "det (\<chi> i j. if i = l then c * (transpose A $ i $ j) else transpose A $ i $ j) =
    det (\<chi> i j. if i = l then c * (A $ j $ i) else A $ j $ i)"
      by(simp add: transpose_def cong del: if_weak_cong)
    ultimately show ?thesis
      by (metis det_transpose)
  qed }
  thus ?thesis
  by (subst det_transpose[symmetric]) (simp add: transpose_def)
qed

lemma det_linear_column_setsum:
  assumes "finite S"
  fixes A :: "'a::comm_ring_1^'n^'n" and b :: "'n \<Rightarrow> 'a^'n" and k :: "'n"
  shows "det ( \<chi> r c . if c = k then (\<Sum> j \<in> S. b j $ r) else A $ r $ c ) =
  (\<Sum>j\<in>S. det( \<chi> r c . if c = k then b j $ r else A $ r $ c ))"
proof-
  { fix A k
    have "det( \<chi> i c . if i = k then ( \<Sum> j \<in> S . b j $ c ) else A $ i $ c )
    = (\<Sum>j\<in>S. det(\<chi> i c. if i = k then b j $ c else A $ i $ c) )" (is "?left = ?r")
    proof-
      have "\<And>j. (\<chi> i . if i = k then ( b j) else A $ i )
      = (\<chi> i c . if i = k then ( b j $ c ) else A $ i $ c)"
        by (simp add: vec_eq_iff)
      moreover have "det( \<chi> i . if i = k then setsum b S else A $ i) = ?left"
        by(subst Cart_lambda_cong)
          (auto simp add: setsum_eq vec_lambda_eta)
      ultimately show ?thesis
        using det_linear_row_setsum[of "S" "k" "\<lambda> i. b" "\<lambda> s. A $ s"]
        by auto
    qed
  } note 1 = this

  have "det (transpose ( \<chi> r c . if c = k then (\<Sum> j \<in> S. b j $ r) else A $ r $ c )) =
  (\<Sum> j \<in> S. det(transpose ( \<chi> r c . if c = k then b j $ r else A $ r $ c )))"
    using 1[of _ "transpose A"]
    by(simp only: assms transpose_def vec_lambda_inverse[OF UNIV_I])

  thus ?thesis
    by (simp add: det_transpose)
qed

lemma det_one_element_matrix:
  fixes A :: "'a::comm_ring_1 poly^'n\<Colon>finite^'n"
  assumes *: "card(UNIV :: 'n set) = 1"
  shows "det A = A $ x $ x"
proof -
  have 1: "{x} = UNIV"
    using * card_eq_UNIV_imp_eq_UNIV finite_code
    by (metis Nat.add_0_right Suc_eq_plus1 card_0_eq card_insert_disjoint empty_iff add.commute)
  show ?thesis
    unfolding det_def 1[symmetric]
    by (simp add: sign_id)
qed

end


(*  Title:      HOL/Induct/Sexp.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge

S-expressions, general binary trees for defining recursive data
structures by hand.
*)

theory Sexp
imports "~~/src/HOL/Library/Old_Datatype"
begin

type_synonym 'a item = "'a Old_Datatype.item"
abbreviation "Leaf == Old_Datatype.Leaf"
abbreviation "Numb == Old_Datatype.Numb"

inductive_set
  sexp      :: "'a item set"
  where
    LeafI:  "Leaf(a) \<in> sexp"
  | NumbI:  "Numb(i) \<in> sexp"
  | SconsI: "[| M \<in> sexp;  N \<in> sexp |] ==> Scons M N \<in> sexp"

definition
  sexp_case :: "['a=>'b, nat=>'b, ['a item, 'a item]=>'b,
                'a item] => 'b" where
  "sexp_case c d e M = (THE z. (EX x.   M=Leaf(x) & z=c(x))
                             | (EX k.   M=Numb(k) & z=d(k))
                             | (EX N1 N2. M = Scons N1 N2  & z=e N1 N2))"

definition
  pred_sexp :: "('a item * 'a item)set" where
     "pred_sexp = (\<Union>M \<in> sexp. \<Union>N \<in> sexp. {(M, Scons M N), (N, Scons M N)})"

definition
  sexp_rec  :: "['a item, 'a=>'b, nat=>'b,
                ['a item, 'a item, 'b, 'b]=>'b] => 'b" where
   "sexp_rec M c d e = wfrec pred_sexp
             (%g. sexp_case c d (%N1 N2. e N1 N2 (g N1) (g N2))) M"

(** sexp_case **)

lemma sexp_case_Leaf [simp]: "sexp_case c d e (Leaf a) = c(a)"
by (simp add: sexp_case_def, blast)

lemma sexp_case_Numb [simp]: "sexp_case c d e (Numb k) = d(k)"
by (simp add: sexp_case_def, blast)

lemma sexp_case_Scons [simp]: "sexp_case c d e (Scons M N) = e M N"
by (simp add: sexp_case_def)

(** Introduction rules for sexp constructors **)

lemma sexp_In0I: "M \<in> sexp ==> In0(M) \<in> sexp"
apply (simp add: In0_def)
apply (erule sexp.NumbI [THEN sexp.SconsI])
done

lemma sexp_In1I: "M \<in> sexp ==> In1(M) \<in> sexp"
apply (simp add: In1_def)
apply (erule sexp.NumbI [THEN sexp.SconsI])
done

declare sexp.intros [intro,simp]

lemma range_Leaf_subset_sexp: "range(Leaf) <= sexp"
by blast

lemma Scons_D: "Scons M N \<in> sexp ==> M \<in> sexp & N \<in> sexp"
  by (induct S == "Scons M N" set: sexp) auto

(** Introduction rules for 'pred_sexp' **)

lemma pred_sexp_subset_Sigma: "pred_sexp <= sexp \<times> sexp"
  by (simp add: pred_sexp_def) blast

(* (a,b) \<in> pred_sexp^+ ==> a \<in> sexp *)
lemmas trancl_pred_sexpD1 =
    pred_sexp_subset_Sigma
         [THEN trancl_subset_Sigma, THEN subsetD, THEN SigmaD1]
and trancl_pred_sexpD2 =
    pred_sexp_subset_Sigma
         [THEN trancl_subset_Sigma, THEN subsetD, THEN SigmaD2]

lemma pred_sexpI1:
    "[| M \<in> sexp;  N \<in> sexp |] ==> (M, Scons M N) \<in> pred_sexp"
by (simp add: pred_sexp_def, blast)

lemma pred_sexpI2:
    "[| M \<in> sexp;  N \<in> sexp |] ==> (N, Scons M N) \<in> pred_sexp"
by (simp add: pred_sexp_def, blast)

(*Combinations involving transitivity and the rules above*)
lemmas pred_sexp_t1 [simp] = pred_sexpI1 [THEN r_into_trancl]
and    pred_sexp_t2 [simp] = pred_sexpI2 [THEN r_into_trancl]

lemmas pred_sexp_trans1 [simp] = trans_trancl [THEN transD, OF _ pred_sexp_t1]
and    pred_sexp_trans2 [simp] = trans_trancl [THEN transD, OF _ pred_sexp_t2]

(*Proves goals of the form (M,N):pred_sexp^+ provided M,N:sexp*)
declare cut_apply [simp]

lemma pred_sexpE:
    "[| p \<in> pred_sexp;
        !!M N. [| p = (M, Scons M N);  M \<in> sexp;  N \<in> sexp |] ==> R;
        !!M N. [| p = (N, Scons M N);  M \<in> sexp;  N \<in> sexp |] ==> R
     |] ==> R"
by (simp add: pred_sexp_def, blast)

lemma wf_pred_sexp: "wf(pred_sexp)"
apply (rule pred_sexp_subset_Sigma [THEN wfI])
apply (erule sexp.induct)
apply (blast elim!: pred_sexpE)+
done

(*** sexp_rec -- by wf recursion on pred_sexp ***)

lemma sexp_rec_unfold_lemma:
     "(%M. sexp_rec M c d e) ==
      wfrec pred_sexp (%g. sexp_case c d (%N1 N2. e N1 N2 (g N1) (g N2)))"
by (simp add: sexp_rec_def)

lemmas sexp_rec_unfold = def_wfrec [OF sexp_rec_unfold_lemma wf_pred_sexp]

(* sexp_rec a c d e =
   sexp_case c d
    (%N1 N2.
        e N1 N2 (cut (%M. sexp_rec M c d e) pred_sexp a N1)
         (cut (%M. sexp_rec M c d e) pred_sexp a N2)) a
*)

(** conversion rules **)

lemma sexp_rec_Leaf: "sexp_rec (Leaf a) c d h = c(a)"
apply (subst sexp_rec_unfold)
apply (rule sexp_case_Leaf)
done

lemma sexp_rec_Numb: "sexp_rec (Numb k) c d h = d(k)"
apply (subst sexp_rec_unfold)
apply (rule sexp_case_Numb)
done

lemma sexp_rec_Scons: "[| M \<in> sexp;  N \<in> sexp |] ==>
     sexp_rec (Scons M N) c d h = h M N (sexp_rec M c d h) (sexp_rec N c d h)"
apply (rule sexp_rec_unfold [THEN trans])
apply (simp add: pred_sexpI1 pred_sexpI2)
done

end


theory WPDS
  imports "LTS" "Saturation" "ReverseWellQuasiOrder" "FinFunWellQuasiOrder" "ProdDioid" "Kleene_Algebra.Dioid_Models"
begin

\<comment> \<open>Preliminary definition of reflexive and transitive closure over a relation labelled with a monoid,
    (and transitive closure over a semigroup-labelled relation)\<close>
inductive_set monoid_rtrancl :: "('a \<times> 'b::monoid_mult \<times> 'a) set \<Rightarrow> ('a \<times> 'b \<times> 'a) set"
 for r :: "('a \<times> 'b \<times> 'a) set" where
    monoid_rtrancl_refl [intro!, Pure.intro!, simp]: "(a, 1, a) \<in> monoid_rtrancl r"
  | monoid_rtrancl_into_rtrancl [Pure.intro]: "(a, w, b) \<in> monoid_rtrancl r \<Longrightarrow> (b, l, c) \<in> r \<Longrightarrow> (a, w*l,c) \<in> monoid_rtrancl r"
inductive_cases monoid_rtrancl_empty [elim]: "(p, 1, q) \<in> monoid_rtrancl r"
inductive_cases monoid_rtrancl_extend: "(p, w*l, q) \<in> monoid_rtrancl r"

inductive_set semigroup_trancl :: "('a \<times> 'b::semigroup_mult \<times> 'a) set \<Rightarrow> ('a \<times> 'b \<times> 'a) set"
 for r :: "('a \<times> 'b \<times> 'a) set" where
    semigroup_trancl_refl [intro!, Pure.intro!, simp]: "(a, l, b) \<in> r \<Longrightarrow> (a, l, b) \<in> semigroup_trancl r"
  | semigroup_trancl_into_rtrancl [Pure.intro]: "(a, w, b) \<in> semigroup_trancl r \<Longrightarrow> (b, l, c) \<in> r \<Longrightarrow> (a, w*l,c) \<in> semigroup_trancl r"

\<comment> \<open>If the @{typ 'label} of a LTS is a monoid, we can express the monoid product of labels over a path.\<close>
locale monoidLTS = LTS transition_relation
  for transition_relation :: "('state, 'label::monoid_mult) transition set"
begin
definition l_step_relp  :: "'state \<Rightarrow> 'label \<Rightarrow> 'state \<Rightarrow> bool" ("(_)/ \<Midarrow> (_)/ \<Rightarrow> (_)/" [70,70,80] 80) where
  "c \<Midarrow>l\<Rightarrow> c' \<longleftrightarrow> (c, l, c') \<in> transition_relation"
abbreviation monoid_star_relp :: "'state \<Rightarrow> 'label \<Rightarrow> 'state \<Rightarrow> bool" ("(_)/ \<Midarrow> (_)/ \<Rightarrow>\<^sup>* (_)/" [90,90,100] 100) where
  "c \<Midarrow>l\<Rightarrow>\<^sup>* c' \<equiv> (monoid_rtranclp l_step_relp) c l c'"
definition monoid_star :: "('state \<times> 'label \<times> 'state) set" where
  "monoid_star = {(c,l,c'). c \<Midarrow>l\<Rightarrow>\<^sup>* c'}"
end

\<comment> \<open>If the @{typ 'label} of a LTS is a dioid with additive and multiplicative identities,
    we can express the meet-over-all-paths value as a generalization of pre-star and post-star.\<close>
locale dioidLTS = monoidLTS transition_relation
  for transition_relation :: "('state, 'label::dioid_one_zero) transition set"
begin

definition weight_pre_star :: "('state \<Rightarrow> 'label) \<Rightarrow> ('state \<Rightarrow> 'label)" where
  "weight_pre_star C c = \<Sum>{l*(C c') | l c'. c \<Midarrow>l\<Rightarrow>\<^sup>* c'}"
definition weight_post_star :: "('state \<Rightarrow> 'label) \<Rightarrow> ('state \<Rightarrow> 'label)" where
  "weight_post_star C c = \<Sum>{(C c')*l | c' l. c' \<Midarrow>l\<Rightarrow>\<^sup>* c}"
end

datatype 'label operation = pop | swap 'label | push 'label 'label
\<comment> \<open>WPDS has a @{typ "'weight::dioid_one_zero"} on the rule.\<close>
type_synonym ('ctr_loc, 'label, 'weight) rule = "('ctr_loc \<times> 'label) \<times> 'weight \<times> ('ctr_loc \<times> 'label operation)"
type_synonym ('ctr_loc, 'label) conf = "'ctr_loc \<times> 'label list"

locale WPDS =
  fixes \<Delta> :: "('ctr_loc, 'label::finite, 'weight::dioid_one_zero) rule set"
begin

primrec lbl :: "'label operation \<Rightarrow> 'label list" where
  "lbl pop = []"
| "lbl (swap \<gamma>) = [\<gamma>]"
| "lbl (push \<gamma>  \<gamma>') = [\<gamma>, \<gamma>']"

definition is_rule :: "'ctr_loc \<times> 'label \<Rightarrow> 'weight \<Rightarrow> 'ctr_loc \<times> 'label operation \<Rightarrow> bool" ("((_)/ \<midarrow> (_)/ \<hookrightarrow> (_)/ )" [70,70,80] 80) where
  "p\<gamma> \<midarrow>d\<hookrightarrow> p'w \<equiv> (p\<gamma>,d,p'w) \<in> \<Delta>"

inductive_set transition_rel :: "(('ctr_loc, 'label) conf \<times> 'weight \<times> ('ctr_loc, 'label) conf) set" where
  "(p, \<gamma>) \<midarrow>d\<hookrightarrow> (p', w) \<Longrightarrow> ((p, \<gamma>#w'), d, (p', (lbl w)@w')) \<in> transition_rel"

(*
definition lang :: "('state, 'label) transition set \<Rightarrow> (('ctr_loc, 'label) conf \<Rightarrow> 'weight)"
*)

interpretation dioidLTS transition_rel .

notation step_relp (infix "\<Rightarrow>" 80)
notation step_starp (infix "\<Rightarrow>\<^sup>*" 80)
notation l_step_relp ("(_)/ \<Midarrow> (_)/ \<Rightarrow> (_)/" [70,70,80] 80)
notation monoid_star_relp ("(_)/ \<Midarrow> (_)/ \<Rightarrow>\<^sup>* (_)/" [90,90,100] 100)

lemma step_relp_def2:
  "(p, \<gamma>w') \<Midarrow>d\<Rightarrow> (p',ww') \<longleftrightarrow> (\<exists>\<gamma> w' w. \<gamma>w' = \<gamma>#w' \<and> ww' = (lbl w)@w' \<and> (p, \<gamma>) \<midarrow>d\<hookrightarrow> (p', w))"
  by (meson monoidLTS.l_step_relp_def transition_rel.simps)
end

datatype ('ctr_loc, 'noninit, 'label) state =
  is_Init: Init (the_Ctr_Loc: 'ctr_loc) (* p \<in> P *)
  | is_Noninit: Noninit (the_St: 'noninit) (* q \<in> Q \<and> q \<notin> P *)
  | is_Isolated: Isolated (the_Ctr_Loc: 'ctr_loc) (the_Label: 'label) (* q\<^sub>p\<^sub>\<gamma> *)

lemma finitely_many_states:
  assumes "finite (UNIV :: 'ctr_loc set)"
  assumes "finite (UNIV :: 'noninit set)"
  assumes "finite (UNIV :: 'label set)"
  shows "finite (UNIV :: ('ctr_loc, 'noninit, 'label) state set)"
proof -
  define Isolated' :: "('ctr_loc * 'label) \<Rightarrow> ('ctr_loc, 'noninit, 'label) state" where
    "Isolated' == \<lambda>(c :: 'ctr_loc, l:: 'label). Isolated c l"
  define Init' :: "'ctr_loc \<Rightarrow> ('ctr_loc, 'noninit, 'label) state" where
    "Init' = Init"
  define Noninit' :: "'noninit \<Rightarrow> ('ctr_loc, 'noninit, 'label) state" where
    "Noninit' = Noninit"

  have split: "UNIV = (Init' ` UNIV) \<union> (Noninit' ` UNIV) \<union> (Isolated' ` (UNIV :: (('ctr_loc * 'label) set)))"
    unfolding Init'_def Noninit'_def
  proof (rule; rule; rule; rule)
    fix x :: "('ctr_loc, 'noninit, 'label) state"
    assume "x \<in> UNIV"
    moreover
    assume "x \<notin> range Isolated'"
    moreover
    assume "x \<notin> range Noninit"
    ultimately
    show "x \<in> range Init"
      by (metis Isolated'_def prod.simps(2) range_eqI state.exhaust)
  qed

  have "finite (Init' ` (UNIV:: 'ctr_loc set))"
    using assms by auto
  moreover
  have "finite (Noninit' ` (UNIV:: 'noninit set))"
    using assms by auto
  moreover
  have "finite (UNIV :: (('ctr_loc * 'label) set))"
    using assms by (simp add: finite_Prod_UNIV)
  then have "finite (Isolated' ` (UNIV :: (('ctr_loc * 'label) set)))"
    by auto
  ultimately
  show "finite (UNIV :: ('ctr_loc, 'noninit, 'label) state set)"
    unfolding split by auto
qed

instantiation state :: (finite, finite, finite) finite begin
  instance by standard (simp add: finitely_many_states)
end

\<comment> \<open>For the semantics of a weighted automaton, labels are lifted to the list-monoid and paired with a weight\<close>
type_synonym ('label, 'weight) wautomaton_label = "('label list \<times> 'weight)"
\<comment> \<open>Weighted automata transitions are modelled as a @{term finfun} from transitions to their weight,
    where @{term "0::('weight::dioid_one_zero)"} is the default value, indicating no transition.\<close>
type_synonym ('state, 'label, 'weight) w_transitions = "('state, 'label) transition \<Rightarrow>f 'weight"

type_synonym ('state, 'label, 'weight) w_transition_set = "('state, ('label list \<times> 'weight)) transition set"

\<comment> \<open>Embed a weighted automata into a monoidLTS. All non-zero transitions are added. The label is lifted to the list-monoid.\<close>
definition wts_to_monoidLTS :: "(('state, 'label, 'weight::{dioid_one_zero,reverse_wqo}) w_transitions) \<Rightarrow> ('state, ('label list \<times> 'weight)) transition set" where
  "wts_to_monoidLTS ts = {(p, ([l],d), q) | p l d q. ts $ (p,l,q) = d \<and> d \<noteq> 0}"

locale W_automata = monoidLTS "wts_to_monoidLTS transition_relation"
  for transition_relation :: "('state::finite, 'label, 'weight::{dioid_one_zero,reverse_wqo}) w_transitions" +
  fixes initials :: "'state set" and finals :: "'state set"
begin
interpretation monoidLTS "wts_to_monoidLTS transition_relation" .

end

\<comment> \<open>The weighted version of the @{term LTS.reach} function.
    Computes a set of pairs of a state and the weight to reach the state.
    Note that the @{term wts_to_monoidLTS} embedding ensures that all labels @{term \<gamma>'} of
    transitions in @{term ts} are of lists length 1.\<close>
context fixes ts :: "('state, 'label list \<times> 'weight::monoid_mult) transition set" begin
fun monoidLTS_reach where
  "monoidLTS_reach p [] = {(p,1)}"
| "monoidLTS_reach p (\<gamma>#w) = (\<Union>(q',d) \<in> (\<Union>(p',(\<gamma>',d),q') \<in> ts. if p' = p \<and> \<gamma>' = [\<gamma>] then {(q',d)} else {}).
      {(q,d*d') | q d'. (q,d') \<in> monoidLTS_reach q' w})"
end

locale WPDS_with_W_automata = WPDS \<Delta>
  for \<Delta> :: "('ctr_loc::enum, 'label::finite, 'weight::{dioid_one_zero,reverse_wqo}) rule set"
    +
  fixes final_inits :: "('ctr_loc::enum) set"
  fixes final_noninits :: "('noninit::finite) set"
begin

(* Corresponds to Schwoon's F *)
definition finals :: "('ctr_loc, 'noninit::finite, 'label) state set" where
  "finals = Init ` final_inits \<union> Noninit ` final_noninits"

lemma F_not_Ext: "\<not>(\<exists>f\<in>finals. is_Isolated f)"
  using finals_def by fastforce

(* Corresponds to Schwoon's P *)
definition inits :: "('ctr_loc, 'noninit, 'label) state set" where
  "inits = {q. is_Init q}"

lemma inits_code[code]: "inits = set (map Init Enum.enum)"
  by (auto simp: inits_def is_Init_def simp flip: UNIV_enum)

definition noninits :: "('ctr_loc, 'noninit, 'label) state set" where
  "noninits = {q. is_Noninit q}"

definition isols :: "('ctr_loc, 'noninit, 'label) state set" where
  "isols = {q. is_Isolated q}"

interpretation dioidLTS transition_rel .
notation step_relp (infix "\<Rightarrow>" 80)
notation step_starp (infix "\<Rightarrow>\<^sup>*" 80)
notation l_step_relp ("(_)/ \<Midarrow> (_)/ \<Rightarrow> (_)/" [70,70,80] 80)
notation monoid_star_relp ("(_)/ \<Midarrow> (_)/ \<Rightarrow>\<^sup>* (_)/" [90,90,100] 100)

\<comment> \<open>Generalization of @{term PDS_with_P_automata.accepts} that computes the meet-over-all-paths in the W-automaton.\<close>
definition accepts :: "(('ctr_loc, 'noninit, 'label) state, 'label, 'weight) w_transitions \<Rightarrow> ('ctr_loc, 'label) conf \<Rightarrow> 'weight" where
  "accepts ts \<equiv> \<lambda>(p,w). (\<Sum>{d | d q. q \<in> finals \<and> (Init p,(w,d),q) \<in> monoidLTS.monoid_star (wts_to_monoidLTS ts)})"

\<comment> \<open>Weighted pre-star rule updates the finfun of transition weights.\<close>
inductive pre_star_rule :: "(('ctr_loc, 'noninit, 'label) state, 'label, 'weight) w_transitions saturation_rule" where
  add_trans: "((p, \<gamma>) \<midarrow>d\<hookrightarrow> (p', w))
      \<Longrightarrow> (Init p', (lbl w, d'), q) \<in> monoidLTS.monoid_star (wts_to_monoidLTS ts)
      \<Longrightarrow> (ts $ (Init p, \<gamma>, q)) = d''
      \<Longrightarrow> (d'' + (d * d')) \<noteq> d''
      \<Longrightarrow> pre_star_rule ts ts((Init p, \<gamma>, q) $:= d'' + (d * d'))"

(* from: https://stackoverflow.com/questions/28633353/converting-a-set-to-a-list-in-isabelle *)
definition set_to_list :: "'a set \<Rightarrow> 'a list"
  where "set_to_list s = (SOME l. set l = s)"
lemma  set_set_to_list:
   "finite s \<Longrightarrow> set (set_to_list s) = s"
  unfolding set_to_list_def by (metis (mono_tags) finite_list some_eq_ex)
(* end from *)

\<comment> \<open>For the executable pre-star, the saturation rule computes a set of new transition weights,
    that are updated using the dioid's plus operator to combine with the existing value.\<close>
fun update_wts :: "('a \<Rightarrow>f 'b::semigroup_add) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<Rightarrow>f 'b)" where
  "update_wts f [] = f" |
  "update_wts f ((a,b)#xs) = update_wts f(a $:= (f$a) + b) xs"

definition update_wts_set :: "('a \<Rightarrow>f 'b::ab_semigroup_add) \<Rightarrow> ('a \<times> 'b) set \<Rightarrow> ('a \<Rightarrow>f 'b)" where
  "update_wts_set f s = update_wts f (set_to_list s)"

definition pre_star1 :: "(('ctr_loc, 'noninit, 'label) state, 'label, 'weight) w_transitions \<Rightarrow> ((('ctr_loc, 'noninit, 'label) state, 'label) transition \<times> 'weight) set" where
  "pre_star1 wts =
    (\<Union>((p, \<gamma>), d, (p', w)) \<in> \<Delta>.
        \<Union>(q,d') \<in> monoidLTS_reach (wts_to_monoidLTS wts) (Init p') (lbl w).
            {((Init p, \<gamma>, q), d * d')})"

\<comment> \<open>A weighted automaton is initialized with weights 1 (neutral element along paths) on existing transitions,
    and a default weight of 0 (neutral element for combining paths) for non-existing transitions.\<close>
definition ts_to_wts :: "('state, 'label) transition set \<Rightarrow> ('state, 'label, 'weight::{dioid_one_zero,reverse_wqo}) w_transitions" where
  "ts_to_wts ts = update_wts_set (K$ 0) {(t,1) | t. t \<in> ts}"
definition wts_to_ts :: "('state, 'label, 'weight::{dioid_one_zero,reverse_wqo}) w_transitions \<Rightarrow> ('state, 'label) transition set" where
  "wts_to_ts wts = {t | t. wts $ t \<noteq> 0}"

definition "pre_star_loop = while_option (\<lambda>s. update_wts_set s (pre_star1 s) \<noteq> s) (\<lambda>s. update_wts_set s (pre_star1 s))"
definition "pre_star_exec = the o pre_star_loop"
definition "pre_star_exec_check A = (if inits \<subseteq> LTS.srcs A then pre_star_loop (ts_to_wts A) else None)"

definition "accept_pre_star_exec_check A c = (if inits \<subseteq> LTS.srcs A then Some (accepts (pre_star_exec (ts_to_wts A)) c) else None)"

theorem pre_star_rule_correct:
  assumes "inits \<subseteq> LTS.srcs (wts_to_monoidLTS A)"
  assumes "saturation pre_star_rule A A'"
  shows "accepts A' = weight_pre_star (accepts A)"

  oops

lemma finfun_update_less:
  assumes "ts $ a < ts' $ a"
  assumes "ts(a $:= d) = ts'"
  shows "ts < ts'"
  using assms unfolding less_finfun_def less_eq_finfun_def
  apply (simp, safe)
  subgoal for a'
    apply (cases "a = a'")
    using order_less_imp_le by (blast, simp)
  using dual_order.strict_iff_not by blast

lemma pre_star_saturation_less:
  fixes ts::"((('ctr_loc, 'noninit::finite, 'label::finite) state, 'label, 'weight::{dioid_one_zero,reverse_wqo}) w_transitions)"
  assumes "ts $ (Init p, \<gamma>, q) + d \<cdot> d' \<noteq> ts $ (Init p, \<gamma>, q)"
  assumes "ts' = ts((Init p, \<gamma>, q) $:= ts $ (Init p, \<gamma>, q) + d \<cdot> d')"
  shows "ts < ts'"
proof -
  from assms(1) have "ts $ (Init p, \<gamma>, q) < ts $ (Init p, \<gamma>, q) + d \<cdot> d'"
    by (simp add: join.sup.strict_order_iff join.sup_commute join.sup_left_commute)
  then have "ts $ (Init p, \<gamma>, q) < ts' $ (Init p, \<gamma>, q)" using assms(2) by simp
  then show ?thesis using assms(2) finfun_update_less[of ts "(Init p, \<gamma>, q)" ts'] by blast
qed

lemma pre_star_saturation_exi:
  fixes ts ::"(('ctr_loc, 'noninit::finite, 'label::finite) state, 'label, 'weight::{dioid_one_zero,reverse_wqo}) w_transitions"
  shows "\<exists>ts'. saturation pre_star_rule ts ts'"
  by (rule reverse_wqo_class_saturation_exi[of pre_star_rule ts])
     (auto simp add:pre_star_rule.simps pre_star_saturation_less)

lemma lemma_3_1_w:
  assumes "p'w \<Midarrow>d\<Rightarrow>\<^sup>* pv"
  assumes "accepts A pv = d'"
  assumes "saturation pre_star_rule A A'"
  shows "accepts A' p'w \<le> d * d'"
  using assms
  sorry

lemma lemma_3_2_a'_w:
(* assumes "inits \<subseteq> LTS.srcs A"*)
  assumes "pre_star_rule\<^sup>*\<^sup>* A A'"
  assumes "(Init p, (w,d), q) \<in> monoidLTS.monoid_star (wts_to_monoidLTS A')"
  shows "\<exists>p' w'. (Init p', (w',d'), q) \<in> monoidLTS.monoid_star (wts_to_monoidLTS A) \<and> (p, w) \<Midarrow>d''\<Rightarrow>\<^sup>* (p', w') \<and> d'' * d' \<le> d"
(* Maybe assume d'=1 *)
  sorry

lemma lemma_3_2_a_w:
(* assumes "inits \<subseteq> LTS.srcs A" *)
  assumes "saturation pre_star_rule A A'"
  assumes "(Init p, (w,d), q) \<in> monoidLTS.monoid_star (wts_to_monoidLTS A')"
  shows "\<exists>p' w'. (Init p', (w',d'), q) \<in> monoidLTS.monoid_star (wts_to_monoidLTS A) \<and> (p, w) \<Midarrow>d''\<Rightarrow>\<^sup>* (p', w') \<and> d'' * d' \<le> d"
  using assms lemma_3_2_a'_w saturation_def by metis

\<comment> \<open>Corresponds to one direction of Schwoon's theorem 3.2\<close>
theorem pre_star_rule_subset_pre_star_lang:
(*  assumes "inits \<subseteq> LTS.srcs A"*)
  assumes "pre_star_rule\<^sup>*\<^sup>* A A'"
  shows "\<forall>c. weight_pre_star (accepts A) c \<le> accepts A' c"
proof
  fix c :: "'ctr_loc \<times> 'label list"
  define d where "d = accepts A' c"
  define p where "p = fst c"
  define w where "w = snd c"
  from p_def w_def d_def have "d = accepts A' (p,w)"
    by auto
  then have "\<exists>q \<in> finals. (Init p, (w,d), q) \<in> monoidLTS.monoid_star (wts_to_monoidLTS A')"
    unfolding accepts_def sorry
  (*by auto
  then obtain q where q_p: "q \<in> finals" "(Init p, w, q) \<in> LTS.trans_star A'"
    by auto
  then have "\<exists>p' w'. (p,w) \<Rightarrow>\<^sup>* (p',w') \<and> (Init p', w', q) \<in> LTS.trans_star A"
    using lemma_3_2_a'_w assms(1) assms(2) by metis
  then obtain p' w' where p'_w'_p: "(p,w) \<Rightarrow>\<^sup>* (p',w')" "(Init p', w', q) \<in> LTS.trans_star A"
    by auto
  then have "(p', w') \<in> lang A"
    unfolding lang_def unfolding accepts_def using q_p(1) by auto
  then have "(p,w) \<in> pre_star (lang A)"
    unfolding pre_star_def using p'_w'_p(1) by auto*)
  then show "weight_pre_star (accepts A) c \<le> d"
    unfolding p_def w_def sorry (* by auto*)
qed

\<comment> \<open>Corresponds to Schwoon's theorem 3.2\<close>
theorem pre_star_rule_accepts_correct:
(*  assumes "inits \<subseteq> LTS.srcs A" *)
  assumes "saturation pre_star_rule A A'"
  shows "\<forall>c. weight_pre_star (accepts A) c = accepts A' c"
  unfolding order_eq_iff
proof (rule; rule)
  fix c :: "'ctr_loc \<times> 'label list"
  define p where "p = fst c"
  define w where "w = snd c"
  define d where "d = weight_pre_star (accepts A) c"
  then have "d = weight_pre_star (accepts A) (p,w)"
    unfolding p_def w_def d_def by auto
  then have "\<exists>d' p' w'. d \<le> d' * accepts A (p',w') \<and> (p,w) \<Midarrow>d'\<Rightarrow>\<^sup>* (p',w')" (* \<Sum>{l*(C (p',w')) | l  (p',w'). (p,w) \<Midarrow>l\<Rightarrow>\<^sup>*  (p',w')} *)
    unfolding weight_pre_star_def by force
  then obtain p' w' d' where "d \<le> d' * accepts A (p',w') \<and> (p,w) \<Midarrow>d'\<Rightarrow>\<^sup>* (p',w')"
    by auto
thm lemma_3_1_w[of "(p,w)" d' "(p',w')"]
  have "accepts A' (p, w) \<le> d' \<cdot> d'" sorry
  then have "\<exists>q \<in> finals. (Init p, w, q) \<in> monoidLTS.monoid_star (wts_to_monoidLTS A')"
    using lemma_3_1 assms(2) unfolding accepts_def by force
  then have "accepts A' (p,w) \<le> d"
    unfolding accepts_def by auto
  then show "(accepts A') c \<le> d"
    using p_def w_def sorry (* by auto*)
next
  fix c :: "'ctr_loc \<times> 'label list"
  show "weight_pre_star (accepts A) c \<le> accepts A' c"
    using pre_star_rule_subset_pre_star_lang assms unfolding saturation_def by blast
qed

\<comment> \<open>Example of a theorem that should hold...
    We still need to define intersection of weighted automata to state the final correctness theorem.\<close>
theorem "accept_pre_star_exec_check A c = Some (weight_pre_star (accepts (ts_to_wts A)) c)"

  oops

end

end