(*  Title:       Isabelle Collections Library
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
header {* \isaheader{Set Implementation by sorted Lists} *}
theory ListSetImpl_Sorted
imports
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  "../../Lib/Sorted_List_Operations"
begin
text_raw {*\label{thy:ListSetImpl_Sorted}*}

(*@impl Set
  @type 'a::linorder lss
  @abbrv lss
  Sets implemented by sorted lists.
*)

type_synonym
  'a lss = "'a list"

subsection "Definitions"
definition lss_\<alpha> :: "'a lss \<Rightarrow> 'a set" where "lss_\<alpha> == set"
definition lss_invar :: "'a::{linorder} lss \<Rightarrow> bool" where "lss_invar l == distinct l \<and> sorted l"
definition lss_empty :: "unit \<Rightarrow> 'a lss" where "lss_empty == (\<lambda>_::unit. [])"
definition lss_memb :: "'a::{linorder} \<Rightarrow> 'a lss \<Rightarrow> bool" where "lss_memb x l == Sorted_List_Operations.memb_sorted l x"
definition lss_ins :: "'a::{linorder} \<Rightarrow> 'a lss \<Rightarrow> 'a lss" where "lss_ins x l == insertion_sort x l"
definition lss_ins_dj :: "'a::{linorder} \<Rightarrow> 'a lss \<Rightarrow> 'a lss" where "lss_ins_dj == lss_ins"

definition lss_delete :: "'a::{linorder} \<Rightarrow> 'a lss \<Rightarrow> 'a lss" where "lss_delete x l == delete_sorted x l"

definition lss_iterateoi :: "'a lss \<Rightarrow> ('a,'\<sigma>) set_iterator"
where "lss_iterateoi l = foldli l"

definition lss_reverse_iterateoi :: "'a lss \<Rightarrow> ('a,'\<sigma>) set_iterator"
where "lss_reverse_iterateoi l = foldli (rev l)"

definition lss_iteratei :: "'a lss \<Rightarrow> ('a,'\<sigma>) set_iterator"
where "lss_iteratei l = foldli l"

definition lss_isEmpty :: "'a lss \<Rightarrow> bool" where "lss_isEmpty s == s=[]"

definition lss_union :: "'a::{linorder} lss \<Rightarrow> 'a lss \<Rightarrow> 'a lss"
  where "lss_union s1 s2 == merge s1 s2"
definition lss_union_list :: "'a::{linorder} lss list \<Rightarrow> 'a lss"
  where "lss_union_list l == merge_list [] l"
definition lss_inter :: "'a::{linorder} lss \<Rightarrow> 'a lss \<Rightarrow> 'a lss"
  where "lss_inter == inter_sorted"
definition lss_union_dj :: "'a::{linorder} lss \<Rightarrow> 'a lss \<Rightarrow> 'a lss"
  where "lss_union_dj == lss_union" -- "Union of disjoint sets"

definition lss_image_filter
  where "lss_image_filter f l =
         mergesort_remdups (List.map_filter f l)"

definition lss_filter where [code_unfold]: "lss_filter = List.filter"

definition lss_inj_image_filter
  where "lss_inj_image_filter == lss_image_filter"

definition "lss_image == iflt_image lss_image_filter"
definition "lss_inj_image == iflt_inj_image lss_inj_image_filter"

definition lss_to_list :: "'a lss \<Rightarrow> 'a list" where "lss_to_list == id"
definition list_to_lss :: "'a::{linorder} list \<Rightarrow> 'a lss" where "list_to_lss == mergesort_remdups"

subsection "Correctness"
lemmas lss_defs =
  lss_\<alpha>_def
  lss_invar_def
  lss_empty_def
  lss_memb_def
  lss_ins_def
  lss_ins_dj_def
  lss_delete_def
  lss_iteratei_def
  lss_isEmpty_def
  lss_union_def
  lss_union_list_def
  lss_inter_def
  lss_union_dj_def
  lss_image_filter_def
  lss_inj_image_filter_def
  lss_image_def
  lss_inj_image_def
  lss_to_list_def
  list_to_lss_def

lemma lss_empty_impl: "set_empty lss_\<alpha> lss_invar lss_empty"
by (unfold_locales) (auto simp add: lss_defs)

lemma lss_memb_impl: "set_memb lss_\<alpha> lss_invar lss_memb"
by (unfold_locales) (auto simp add: lss_defs memb_sorted_correct)

lemma lss_ins_impl: "set_ins lss_\<alpha> lss_invar lss_ins"
by (unfold_locales) (auto simp add: lss_defs insertion_sort_correct)

lemma lss_ins_dj_impl: "set_ins_dj lss_\<alpha> lss_invar lss_ins_dj"
by (unfold_locales) (auto simp add: lss_defs insertion_sort_correct)

lemma lss_\<alpha>_finite[simp, intro!]: "finite (lss_\<alpha> l)"
  by (auto simp add: lss_defs)

lemma lss_is_finite_set: "finite_set lss_\<alpha> lss_invar"
by (unfold_locales) (auto simp add: lss_defs)

lemma lss_iterateoi_impl: "poly_set_iterateoi lss_\<alpha> lss_invar lss_iterateoi"
proof
  fix l :: "'a::{linorder} list"
  assume invar_l: "lss_invar l"
  show "finite (lss_\<alpha> l)"
    unfolding lss_\<alpha>_def by simp

  from invar_l
  show "set_iterator_linord (lss_iterateoi l) (lss_\<alpha> l)"
    apply (rule_tac set_iterator_linord_I [of "l"])
    apply (simp_all add: lss_\<alpha>_def lss_invar_def lss_iterateoi_def)
  done
qed

lemma lss_reverse_iterateoi_impl: "poly_set_rev_iterateoi lss_\<alpha> lss_invar lss_reverse_iterateoi"
proof
  fix l :: "'a list"
  assume invar_l: "lss_invar l"
  show "finite (lss_\<alpha> l)"
    unfolding lss_\<alpha>_def by simp

  from invar_l
  show "set_iterator_rev_linord (lss_reverse_iterateoi l) (lss_\<alpha> l)"
    apply (rule_tac set_iterator_rev_linord_I [of "rev l"])
    apply (simp_all add: lss_\<alpha>_def lss_invar_def lss_reverse_iterateoi_def)
  done
qed

lemma lss_iteratei_impl: "poly_set_iteratei lss_\<alpha> lss_invar lss_iteratei"
proof
  fix l :: "'a list"
  assume invar_l: "lss_invar l"
  show "finite (lss_\<alpha> l)"
    unfolding lss_\<alpha>_def by simp

  from invar_l
  show "set_iterator (lss_iteratei l) (lss_\<alpha> l)"
    apply (rule_tac set_iterator_I [of "l"])
    apply (simp_all add: lss_\<alpha>_def lss_invar_def lss_iteratei_def)
  done
qed

lemma lss_isEmpty_impl: "set_isEmpty lss_\<alpha> lss_invar lss_isEmpty"
by(unfold_locales)(auto simp add: lss_defs)

lemma lss_inter_impl: "set_inter lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_inter"
by (unfold_locales) (auto simp add: lss_defs inter_sorted_correct)

lemma lss_union_impl: "set_union lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_union"
by (unfold_locales) (auto simp add: lss_defs merge_correct)

lemma lss_union_list_impl: "set_union_list lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_union_list"
proof
  fix l :: "'a::{linorder} lss list"
  assume "\<forall>s1\<in>set l. lss_invar s1"

  with merge_list_correct [of l "[]"]
  show "lss_\<alpha> (lss_union_list l) = \<Union>{lss_\<alpha> s1 |s1. s1 \<in> set l}"
       "lss_invar (lss_union_list l)"
    by (auto simp add: lss_defs)
qed

lemma lss_union_dj_impl: "set_union_dj lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_union_dj"
by (unfold_locales) (auto simp add: lss_defs merge_correct)

lemma lss_image_filter_impl : "set_image_filter lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_image_filter"
apply (unfold_locales)
apply (simp_all add:
  lss_invar_def lss_image_filter_def lss_\<alpha>_def mergesort_remdups_correct
  set_map_filter Bex_def)
done

lemma lss_inj_image_filter_impl : "set_inj_image_filter lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_inj_image_filter"
apply (unfold_locales)
apply (simp_all add: lss_invar_def lss_inj_image_filter_def lss_image_filter_def
                     mergesort_remdups_correct lss_\<alpha>_def
                     set_map_filter Bex_def)
done

lemma lss_filter_impl : "set_filter lss_\<alpha> lss_invar lss_\<alpha> lss_invar lss_filter"
apply (unfold_locales)
apply (simp_all add: lss_invar_def lss_filter_def sorted_filter lss_\<alpha>_def
                     set_map_filter Bex_def sorted_filter')
done

lemmas lss_image_impl = iflt_image_correct[OF lss_image_filter_impl, folded lss_image_def]
lemmas lss_inj_image_impl = iflt_inj_image_correct[OF lss_inj_image_filter_impl, folded lss_inj_image_def]

lemma lss_to_list_impl: "set_to_list lss_\<alpha> lss_invar lss_to_list"
by(unfold_locales)(auto simp add: lss_defs)

lemma list_to_lss_impl: "list_to_set lss_\<alpha> lss_invar list_to_lss"
  by (unfold_locales) (auto simp add: lss_defs mergesort_remdups_correct)

definition lss_basic_ops :: "('x::linorder,'x lss) oset_basic_ops"
  where [icf_rec_def]: "lss_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = lss_\<alpha>,
    bset_op_invar = lss_invar,
    bset_op_empty = lss_empty,
    bset_op_memb = lss_memb,
    bset_op_ins = lss_ins,
    bset_op_ins_dj = lss_ins_dj,
    bset_op_delete = lss_delete,
    bset_op_list_it = lss_iteratei,
    bset_op_ordered_list_it = lss_iterateoi,
    bset_op_rev_list_it = lss_reverse_iterateoi
  \<rparr>"

setup Locale_Code.open_block
interpretation lss_basic!: StdBasicOSet lss_basic_ops
  apply (rule StdBasicOSet.intro)
  apply (rule StdBasicSet.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule lss_empty_impl lss_memb_impl lss_ins_impl lss_ins_dj_impl
    lss_delete_impl lss_iteratei_impl lss_iterateoi_impl
    lss_reverse_iterateoi_impl)+
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lss_ops \<equiv> lss_basic.dflt_oops \<lparr>
  set_op_isEmpty := lss_isEmpty,
  set_op_union := lss_union,
  set_op_union_dj := lss_union_dj,
  set_op_filter := lss_filter,
  set_op_to_list := lss_to_list,
  set_op_from_list := list_to_lss
  \<rparr>"

setup Locale_Code.open_block
interpretation lss!: StdOSetDefs lss_ops .
interpretation lss!: StdOSet lss_ops
proof -
  interpret aux: StdOSet lss_basic.dflt_oops
    by (rule lss_basic.dflt_oops_impl)

  show "StdOSet lss_ops"
    unfolding lss_ops_def
    apply (rule StdOSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf
      lss_isEmpty_impl lss_union_impl lss_union_dj_impl lss_to_list_impl
      lss_filter_impl
      list_to_lss_impl
    )
    done
qed
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "lss"*}

lemma pi_lss[proper_it]:
  "proper_it' lss_iteratei lss_iteratei"
  apply (rule proper_it'I)
  unfolding lss_iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_lss: proper_it_loc lss_iteratei lss_iteratei
  apply unfold_locales by (rule pi_lss)

definition test_codegen where "test_codegen \<equiv> (
  lss.empty,
  lss.memb,
  lss.ins,
  lss.delete,
  lss.list_it,
  lss.sng,
  lss.isEmpty,
  lss.isSng,
  lss.ball,
  lss.bex,
  lss.size,
  lss.size_abort,
  lss.union,
  lss.union_dj,
  lss.diff,
  lss.filter,
  lss.inter,
  lss.subset,
  lss.equal,
  lss.disjoint,
  lss.disjoint_witness,
  lss.sel,
  lss.to_list,
  lss.from_list
)"

export_code test_codegen in SML

end


(*
  File:     More_Multivariate_Polynomial_HLW.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>Additional facts about multivariate polynomials\<close>
theory More_Multivariate_Polynomial_HLW
  imports "Power_Sum_Polynomials.Power_Sum_Polynomials_Library"
begin

subsection \<open>Miscellaneous\<close>

lemma Var_altdef: "Var i = monom (Poly_Mapping.single i 1) 1"
  by transfer' (simp add: Var\<^sub>0_def)

lemma Const_conv_monom: "Const c = monom 0 c"
  by transfer' (auto simp: Const\<^sub>0_def)

lemma smult_conv_mult_Const: "smult c p = Const c * p"
  by (simp add: smult_conv_mult Const_conv_monom)

lemma mpoly_map_vars_Var [simp]: "bij f \<Longrightarrow> mpoly_map_vars f (Var i) = Var (f i)"
  unfolding Var_altdef
  by (subst mpoly_map_vars_monom) (auto simp: permutep_single bij_imp_bij_inv inv_inv_eq)

lemma symmetric_mpoly_symmetric_prod':
  assumes "\<And>\<pi>. \<pi> permutes A \<Longrightarrow> g \<pi> permutes X"
  assumes "\<And>x \<pi>. x \<in> X \<Longrightarrow> \<pi> permutes A \<Longrightarrow> mpoly_map_vars \<pi> (f x) = f (g \<pi> x)"
  shows "symmetric_mpoly A (\<Prod>x\<in>X. f x)"
  unfolding symmetric_mpoly_def
proof safe
  fix \<pi> assume \<pi>: "\<pi> permutes A"
  have "mpoly_map_vars \<pi> (prod f X) = (\<Prod>x\<in>X. mpoly_map_vars \<pi> (f x))"
    by simp
  also have "\<dots> = (\<Prod>x\<in>X. f (g \<pi> x))"
    by (intro prod.cong assms \<pi> refl)
  also have "\<dots> = (\<Prod>x\<in>g \<pi>`X. f x)"
    using assms(1)[OF \<pi>] by (subst prod.reindex) (auto simp: permutes_inj_on)
  also have "g \<pi> ` X = X"
    using assms(1)[OF \<pi>] by (simp add: permutes_image)
  finally show "mpoly_map_vars \<pi> (prod f X) = prod f X" .
qed

subsection \<open>Converting a univariate polynomial into a multivariate one\<close>

lift_definition mpoly_of_poly_aux :: "nat \<Rightarrow> 'a :: zero poly \<Rightarrow> (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a" is
  "\<lambda>i c m. if Poly_Mapping.keys m \<subseteq> {i} then c (Poly_Mapping.lookup m i) else 0"
proof goal_cases
  case (1 i c)
  hence fin: "finite {n. c n \<noteq> 0}"
    by (metis eventually_cofinite)
  show "finite {x. (if keys x \<subseteq> {i} then c (lookup x i) else 0) \<noteq> 0}"
  proof (rule finite_subset)
    show "finite (Poly_Mapping.single i ` {n. c n \<noteq> 0})"
      by (intro finite_imageI fin)
  next
    show "{x. (if keys x \<subseteq> {i} then c (lookup x i) else 0) \<noteq> 0} \<subseteq>
            Poly_Mapping.single i ` {n. c n \<noteq> 0}"
    proof (safe, split if_splits)
      fix x :: "(nat \<Rightarrow>\<^sub>0 nat)"
      assume x: "keys x \<subseteq> {i}" "c (lookup x i) \<noteq> 0"
      hence "x = Poly_Mapping.single i (lookup x i)"
        by (metis Diff_eq_empty_iff keys_empty_iff lookup_single_eq
                  remove_key_keys remove_key_single remove_key_sum)
      thus "x \<in> Poly_Mapping.single i ` {n. c n \<noteq> 0}"
        using x by blast
    qed auto
  qed
qed

lift_definition mpoly_of_poly :: "nat \<Rightarrow> 'a :: zero poly \<Rightarrow> 'a mpoly" is
  "mpoly_of_poly_aux" .

lemma mpoly_of_poly_0 [simp]: "mpoly_of_poly i 0 = 0"
  by (transfer', transfer) auto

lemma coeff_mpoly_of_poly1 [simp]:
  "coeff (mpoly_of_poly i p) (Poly_Mapping.single i n) = poly.coeff p n"
  by (transfer', transfer') auto

lemma coeff_mpoly_of_poly2 [simp]:
  assumes "\<not>keys x \<subseteq> {i}"
  shows "coeff (mpoly_of_poly i p) x = 0"
  using assms by (transfer', transfer') auto

lemma coeff_mpoly_of_poly:
  "coeff (mpoly_of_poly i p) m =
     (poly.coeff p (Poly_Mapping.lookup m i) when keys m \<subseteq> {i})"
  by (transfer', transfer') auto

lemma poly_mapping_single_eq_0_iff [simp]: "Poly_Mapping.single i n = 0 \<longleftrightarrow> n = 0"
  by (metis lookup_single_eq single_zero)

lemma mpoly_of_poly_pCons [simp]:
  fixes p :: "'a :: semiring_1 poly"
  shows "mpoly_of_poly i (pCons c p) = Const c + Var i * mpoly_of_poly i p"
proof (rule mpoly_eqI)
  fix mon :: "nat \<Rightarrow>\<^sub>0 nat"
  define moni :: "nat \<Rightarrow>\<^sub>0 nat" where "moni = Poly_Mapping.single i 1"
  have "coeff (Var i * mpoly_of_poly i p) mon =
          (\<Sum>l. (1 when l = moni) * (\<Sum>q. coeff (mpoly_of_poly i p) q when mon = moni + q))"
    unfolding coeff_mpoly_times prod_fun_def coeff_Var moni_def
    by (rule Sum_any.cong) (auto simp: when_def)
  also have "\<dots> = (\<Sum>a. coeff (mpoly_of_poly i p) a when mon = moni + a)"
    by (subst Sum_any_left_distrib [symmetric]) simp_all
  finally have eq: "coeff (Var i * mpoly_of_poly i p) mon = \<dots>" .

  show "coeff (mpoly_of_poly i (pCons c p)) mon = coeff (Const c + Var i * mpoly_of_poly i p) mon"
  proof (cases "keys mon \<subseteq> {i}")
    case False
    hence [simp]: "mon \<noteq> 0"
      by auto
    obtain j where j: "j \<in> keys mon" "j \<noteq> i"
      using False by auto
    have "coeff (mpoly_of_poly i p) mon' = 0" if mon_eq: "mon = moni + mon'" for mon'
    proof -
      have "Poly_Mapping.lookup mon j \<noteq> 0"
        using j by (meson lookup_eq_zero_in_keys_contradict)
      also have "Poly_Mapping.lookup mon j = Poly_Mapping.lookup mon' j"
        unfolding mon_eq moni_def using j by (simp add: lookup_add lookup_single)
      finally have "j \<in> keys mon'"
        by (meson lookup_not_eq_zero_eq_in_keys)
      with j have "\<not>keys mon' \<subseteq> {i}"
        by blast
      thus ?thesis by simp
    qed
    hence "coeff (Var i * mpoly_of_poly i p) mon = 0"
      unfolding eq by (intro Sum_any_zeroI) (auto simp: when_def)
    thus ?thesis using False
      by (simp add: mpoly_coeff_Const)
  next
    case True
    define n where "n = Poly_Mapping.lookup mon i"
    have mon_eq: "mon = Poly_Mapping.single i n"
      using True unfolding n_def
      by (metis Diff_eq_empty_iff add_cancel_right_left keys_empty_iff remove_key_keys remove_key_sum)
    have eq': "mon = moni + mon' \<longleftrightarrow> n > 0 \<and> mon' = Poly_Mapping.single i (n - 1)" for mon'
    proof safe
      assume eq: "mon = moni + mon'"
      thus "n > 0" "mon' = Poly_Mapping.single i (n - 1)"
        unfolding moni_def mon_eq using gr0I by (force simp: single_diff)+
    next
      assume "n > 0" "mon' = Poly_Mapping.single i (n - 1)"
      thus "mon = moni + Poly_Mapping.single i (n - 1)"
        unfolding mon_eq moni_def by (subst single_add [symmetric]) auto
    qed
    have "coeff (Var i * mpoly_of_poly i p) mon = (poly.coeff p (n - 1) when (n > 0))"
      unfolding eq eq' by (auto simp: when_def)
    thus ?thesis
      by (auto simp: mon_eq when_def mpoly_coeff_Const coeff_pCons split: nat.splits)
  qed
qed

lemma mpoly_of_poly_1 [simp]: "mpoly_of_poly i 1 = 1"
  unfolding one_pCons mpoly_of_poly_pCons mpoly_of_poly_0 by simp

lemma mpoly_of_poly_uminus [simp]: "mpoly_of_poly i (-p) = -mpoly_of_poly i p"
  by (rule mpoly_eqI) (auto simp: coeff_mpoly_of_poly when_def)

lemma mpoly_of_poly_add [simp]: "mpoly_of_poly i (p + q) = mpoly_of_poly i p + mpoly_of_poly i q"
  by (rule mpoly_eqI) (auto simp: coeff_mpoly_of_poly when_def)

lemma mpoly_of_poly_diff [simp]: "mpoly_of_poly i (p - q) = mpoly_of_poly i p - mpoly_of_poly i q"
  by (rule mpoly_eqI) (auto simp: coeff_mpoly_of_poly when_def)

lemma mpoly_of_poly_smult [simp]:
  "mpoly_of_poly i (Polynomial.smult c p) = smult c (mpoly_of_poly i p)"
  by (rule mpoly_eqI) (auto simp: coeff_mpoly_of_poly when_def)

lemma mpoly_of_poly_mult [simp]:
  fixes p q :: "'a :: comm_semiring_1 poly"
  shows "mpoly_of_poly i (p * q) = mpoly_of_poly i p * mpoly_of_poly i q"
  by (induction p) (auto simp: algebra_simps smult_conv_mult_Const)

lemma insertion_mpoly_of_poly [simp]: "insertion f (mpoly_of_poly i p) = poly p (f i)"
  by (induction p) (auto simp: insertion_add insertion_mult)

lemma mapping_of_mpoly_of_poly [simp]: "mapping_of (mpoly_of_poly i p) = mpoly_of_poly_aux i p"
  by transfer' simp

lemma vars_mpoly_of_poly: "vars (mpoly_of_poly i p) \<subseteq> {i}"
proof -
  have "x = i" if "xa \<in> keys (mpoly_of_poly_aux i p)" "x \<in> keys xa" for x xa
    using that
    by (meson in_mono lookup_eq_zero_in_keys_contradict mpoly_of_poly_aux.rep_eq singletonD)
  thus ?thesis
    by (auto simp: vars_def)
qed

lemma mpoly_map_vars_mpoly_of_poly [simp]:
  assumes "bij f"
  shows   "mpoly_map_vars f (mpoly_of_poly i p) = mpoly_of_poly (f i) p"
proof (rule mpoly_eqI, goal_cases)
  case (1 mon)
  have "f -` keys mon \<subseteq> {i} \<longleftrightarrow> keys mon \<subseteq> {f i}"
    using assms by (simp add: vimage_subset_eq)
  thus ?case using assms
    by (simp add: coeff_mpoly_map_vars coeff_mpoly_of_poly lookup_permutep keys_permutep when_def)
qed

end


theory Encodings
  imports ProcessCalculi
begin

section \<open>Encodings\<close>

text \<open>In the simplest case an encoding from a source into a target language is a mapping from
        source into target terms. Encodability criteria describe properties on such mappings. To
        analyse encodability criteria we map them on conditions on relations between source and
        target terms. More precisely, we consider relations on pairs of the disjoint union of
        source and target terms. We denote this disjoint union of source and target terms by Proc.
\<close>

datatype ('procS, 'procT) Proc =
  SourceTerm 'procS |
  TargetTerm 'procT

definition STCal
    :: "'procS processCalculus \<Rightarrow> 'procT processCalculus
        \<Rightarrow> (('procS, 'procT) Proc) processCalculus"
  where
  "STCal Source Target \<equiv>
   \<lparr>Reductions = \<lambda>P P'.
   (\<exists>SP SP'. P = SourceTerm SP \<and> P' = SourceTerm SP' \<and> Reductions Source SP SP') \<or>
   (\<exists>TP TP'. P = TargetTerm TP \<and> P' = TargetTerm TP' \<and> Reductions Target TP TP')\<rparr>"

definition STCalWB
    :: "('procS, 'barbs) calculusWithBarbs \<Rightarrow> ('procT, 'barbs) calculusWithBarbs
        \<Rightarrow> (('procS, 'procT) Proc, 'barbs) calculusWithBarbs"
  where
  "STCalWB Source Target \<equiv>
   \<lparr>Calculus = STCal (calculusWithBarbs.Calculus Source) (calculusWithBarbs.Calculus Target),
   HasBarb   = \<lambda>P a. (\<exists>SP. P = SourceTerm SP \<and> (calculusWithBarbs.HasBarb Source) SP a) \<or>
                     (\<exists>TP. P = TargetTerm TP \<and> (calculusWithBarbs.HasBarb Target) TP a)\<rparr>"

text \<open>An encoding consists of a source language, a target language, and a mapping from source
        into target terms.\<close>

locale encoding =
  fixes Source :: "'procS processCalculus"
    and Target :: "'procT processCalculus"
    and Enc    :: "'procS \<Rightarrow> 'procT"
begin

abbreviation enc :: "'procS \<Rightarrow> 'procT" ("\<lbrakk>_\<rbrakk>" [65] 70) where
  "\<lbrakk>S\<rbrakk> \<equiv> Enc S"

abbreviation isSource :: "('procS, 'procT) Proc \<Rightarrow> bool" ("_ \<in> ProcS" [70] 80) where
  "P \<in> ProcS \<equiv> (\<exists>S. P = SourceTerm S)"

abbreviation isTarget :: "('procS, 'procT) Proc \<Rightarrow> bool" ("_ \<in> ProcT" [70] 80) where
  "P \<in> ProcT \<equiv> (\<exists>T. P = TargetTerm T)"

abbreviation getSource
    :: "'procS \<Rightarrow> ('procS, 'procT) Proc \<Rightarrow> bool" ("_ \<in>S _" [70, 70] 80)
  where
  "S \<in>S P \<equiv> (P = SourceTerm S)"

abbreviation getTarget
    :: "'procT \<Rightarrow> ('procS, 'procT) Proc \<Rightarrow> bool" ("_ \<in>T _" [70, 70] 80)
  where
  "T \<in>T P \<equiv> (P = TargetTerm T)"

text \<open>A step of a term in Proc is either a source term step or a target term step.\<close>

abbreviation stepST
    :: "('procS, 'procT) Proc \<Rightarrow> ('procS, 'procT) Proc \<Rightarrow> bool" ("_ \<longmapsto>ST _" [70, 70] 80)
  where
  "P \<longmapsto>ST P' \<equiv>
   (\<exists>S S'. S \<in>S P \<and> S' \<in>S P' \<and> S \<longmapsto>Source S') \<or> (\<exists>T T'. T \<in>T P \<and> T' \<in>T P' \<and> T \<longmapsto>Target T')"

lemma stepST_STCal_step:
  fixes P P' :: "('procS, 'procT) Proc"
  shows "P \<longmapsto>(STCal Source Target) P' = P \<longmapsto>ST P'"
    by (simp add: STCal_def)

lemma STStep_step:
  fixes S  :: "'procS"
    and T  :: "'procT"
    and P' :: "('procS, 'procT) Proc"
  shows "SourceTerm S \<longmapsto>ST P' = (\<exists>S'. S' \<in>S P' \<and> S \<longmapsto>Source S')"
    and "TargetTerm T \<longmapsto>ST P' = (\<exists>T'. T' \<in>T P' \<and> T \<longmapsto>Target T')"
    by blast+

lemma STCal_step:
  fixes S  :: "'procS"
    and T  :: "'procT"
    and P' :: "('procS, 'procT) Proc"
  shows "SourceTerm S \<longmapsto>(STCal Source Target) P' = (\<exists>S'. S' \<in>S P' \<and> S \<longmapsto>Source S')"
    and "TargetTerm T \<longmapsto>(STCal Source Target) P' = (\<exists>T'. T' \<in>T P' \<and> T \<longmapsto>Target T')"
    by (simp add: STCal_def)+

text \<open>A sequence of steps of a term in Proc is either a sequence of source term steps or a
        sequence of target term steps.\<close>

abbreviation stepsST
    :: "('procS, 'procT) Proc \<Rightarrow> ('procS, 'procT) Proc \<Rightarrow> bool" ("_ \<longmapsto>ST* _" [70, 70] 80)
  where
  "P \<longmapsto>ST* P' \<equiv>
   (\<exists>S S'. S \<in>S P \<and> S' \<in>S P' \<and> S \<longmapsto>Source* S') \<or> (\<exists>T T'. T \<in>T P \<and> T' \<in>T P' \<and> T \<longmapsto>Target* T')"

lemma STSteps_steps:
  fixes S  :: "'procS"
    and T  :: "'procT"
    and P' :: "('procS, 'procT) Proc"
  shows "SourceTerm S \<longmapsto>ST* P' = (\<exists>S'. S' \<in>S P' \<and> S \<longmapsto>Source* S')"
    and "TargetTerm T \<longmapsto>ST* P' = (\<exists>T'. T' \<in>T P' \<and> T \<longmapsto>Target* T')"
    by blast+

lemma STCal_steps:
  fixes S  :: "'procS"
    and T  :: "'procT"
    and P' :: "('procS, 'procT) Proc"
  shows "SourceTerm S \<longmapsto>(STCal Source Target)* P' = (\<exists>S'. S' \<in>S P' \<and> S \<longmapsto>Source* S')"
    and "TargetTerm T \<longmapsto>(STCal Source Target)* P' = (\<exists>T'. T' \<in>T P' \<and> T \<longmapsto>Target* T')"
proof auto
  assume "SourceTerm S \<longmapsto>(STCal Source Target)* P'"
  from this obtain n where "SourceTerm S \<longmapsto>(STCal Source Target)\<^bsup>n\<^esup> P'"
    by (auto simp add: steps_def)
  thus "\<exists>S'. S' \<in>S P' \<and> S \<longmapsto>Source* S'"
  proof (induct n arbitrary: P')
    case 0
    assume "SourceTerm S \<longmapsto>(STCal Source Target)\<^bsup>0\<^esup> P'"
    hence "S \<in>S P'"
      by simp
    moreover have "S \<longmapsto>Source* S"
      by (rule steps_refl)
    ultimately show "\<exists>S'. S' \<in>S P' \<and> S \<longmapsto>Source* S'"
      by blast
  next
    case (Suc n P'')
    assume "SourceTerm S \<longmapsto>(STCal Source Target)\<^bsup>Suc n\<^esup> P''"
    from this obtain P' where A1: "SourceTerm S \<longmapsto>(STCal Source Target)\<^bsup>n\<^esup> P'"
                          and A2: "P' \<longmapsto>(STCal Source Target) P''"
      by auto
    assume "\<And>P'. SourceTerm S \<longmapsto>(STCal Source Target)\<^bsup>n\<^esup> P' \<Longrightarrow> \<exists>S'. S' \<in>S P' \<and> S \<longmapsto>Source* S'"
    with A1 obtain S' where A3: "S' \<in>S P'" and A4: "S \<longmapsto>Source* S'"
      by blast
    from A2 A3 obtain S'' where A5: "S'' \<in>S P''" and A6: "S' \<longmapsto>Source S''"
        using STCal_step(1)[where S="S'" and P'="P''"]
      by blast
    from A4 A6 have "S \<longmapsto>Source* S''"
        using step_to_steps[where Cal="Source" and P="S'" and P'="S''"]
      by (simp add: steps_add[where Cal="Source" and P="S" and Q="S'" and R="S''"])
    with A5 show "\<exists>S''. S'' \<in>S P'' \<and> S \<longmapsto>Source* S''"
      by blast
  qed
next
  fix S'
  assume "S \<longmapsto>Source* S'"
  from this obtain n where "S \<longmapsto>Source\<^bsup>n\<^esup> S'"
    by (auto simp add: steps_def)
  thus "SourceTerm S \<longmapsto>(STCal Source Target)* (SourceTerm S')"
  proof (induct n arbitrary: S')
    case 0
    assume "S \<longmapsto>Source\<^bsup>0\<^esup> S'"
    hence "S = S'"
      by auto
    thus "SourceTerm S \<longmapsto>(STCal Source Target)* (SourceTerm S')"
      by (simp add: steps_refl)
  next
    case (Suc n S'')
    assume "S \<longmapsto>Source\<^bsup>Suc n\<^esup> S''"
    from this obtain S' where B1: "S \<longmapsto>Source\<^bsup>n\<^esup> S'" and B2: "S' \<longmapsto>Source S''"
      by auto
    assume "\<And>S'. S \<longmapsto>Source\<^bsup>n\<^esup> S' \<Longrightarrow> SourceTerm S \<longmapsto>(STCal Source Target)* (SourceTerm S')"
    with B1 have "SourceTerm S \<longmapsto>(STCal Source Target)* (SourceTerm S')"
      by blast
    moreover from B2 have "SourceTerm S' \<longmapsto>(STCal Source Target)* (SourceTerm S'')"
        using step_to_steps[where Cal="STCal Source Target" and P="SourceTerm S'"]
      by (simp add: STCal_def)
    ultimately show "SourceTerm S \<longmapsto>(STCal Source Target)* (SourceTerm S'')"
      by (rule steps_add)
  qed
next
  assume "TargetTerm T \<longmapsto>(STCal Source Target)* P'"
  from this obtain n where "TargetTerm T \<longmapsto>(STCal Source Target)\<^bsup>n\<^esup> P'"
    by (auto simp add: steps_def)
  thus "\<exists>T'. T' \<in>T P' \<and> T \<longmapsto>Target* T'"
  proof (induct n arbitrary: P')
    case 0
    assume "TargetTerm T \<longmapsto>(STCal Source Target)\<^bsup>0\<^esup> P'"
    hence "T \<in>T P'"
      by simp
    moreover have "T \<longmapsto>Target* T"
      by (rule steps_refl)
    ultimately show "\<exists>T'. T' \<in>T P' \<and> T \<longmapsto>Target* T'"
      by blast
  next
    case (Suc n P'')
    assume "TargetTerm T \<longmapsto>(STCal Source Target)\<^bsup>Suc n\<^esup> P''"
    from this obtain P' where A1: "TargetTerm T \<longmapsto>(STCal Source Target)\<^bsup>n\<^esup> P'"
                          and A2: "P' \<longmapsto>(STCal Source Target) P''"
      by auto
    assume "\<And>P'. TargetTerm T \<longmapsto>(STCal Source Target)\<^bsup>n\<^esup> P' \<Longrightarrow> \<exists>T'. T' \<in>T P' \<and> T \<longmapsto>Target* T'"
    with A1 obtain T' where A3: "T' \<in>T P'" and A4: "T \<longmapsto>Target* T'"
      by blast
    from A2 A3 obtain T'' where A5: "T'' \<in>T P''" and A6: "T' \<longmapsto>Target T''"
        using STCal_step(2)[where T="T'" and P'="P''"]
      by blast
    from A4 A6 have "T \<longmapsto>Target* T''"
        using step_to_steps[where Cal="Target" and P="T'" and P'="T''"]
      by (simp add: steps_add[where Cal="Target" and P="T" and Q="T'" and R="T''"])
    with A5 show "\<exists>T''. T'' \<in>T P'' \<and> T \<longmapsto>Target* T''"
      by blast
  qed
next
  fix T'
  assume "T \<longmapsto>Target* T'"
  from this obtain n where "T \<longmapsto>Target\<^bsup>n\<^esup> T'"
    by (auto simp add: steps_def)
  thus "TargetTerm T \<longmapsto>(STCal Source Target)* (TargetTerm T')"
  proof (induct n arbitrary: T')
    case 0
    assume "T \<longmapsto>Target\<^bsup>0\<^esup> T'"
    hence "T = T'"
      by auto
    thus "TargetTerm T \<longmapsto>(STCal Source Target)* (TargetTerm T')"
      by (simp add: steps_refl)
  next
    case (Suc n T'')
    assume "T \<longmapsto>Target\<^bsup>Suc n\<^esup> T''"
    from this obtain T' where B1: "T \<longmapsto>Target\<^bsup>n\<^esup> T'" and B2: "T' \<longmapsto>Target T''"
      by auto
    assume "\<And>T'. T \<longmapsto>Target\<^bsup>n\<^esup> T' \<Longrightarrow> TargetTerm T \<longmapsto>(STCal Source Target)* (TargetTerm T')"
    with B1 have "TargetTerm T \<longmapsto>(STCal Source Target)* (TargetTerm T')"
      by blast
    moreover from B2 have "TargetTerm T' \<longmapsto>(STCal Source Target)* (TargetTerm T'')"
        using step_to_steps[where Cal="STCal Source Target" and P="TargetTerm T'"]
      by (simp add: STCal_def)
    ultimately show "TargetTerm T \<longmapsto>(STCal Source Target)* (TargetTerm T'')"
      by (rule steps_add)
  qed
qed

lemma stepsST_STCal_steps:
  fixes P P' :: "('procS, 'procT) Proc"
  shows "P \<longmapsto>(STCal Source Target)* P' = P \<longmapsto>ST* P'"
proof (cases P)
  case (SourceTerm SP)
  assume "SP \<in>S P"
  thus "P \<longmapsto>(STCal Source Target)* P' = P \<longmapsto>ST* P'"
      using STCal_steps(1)[where S="SP" and P'="P'"] STSteps_steps(1)[where S="SP" and P'="P'"]
    by blast
next
  case (TargetTerm TP)
  assume "TP \<in>T P"
  thus "P \<longmapsto>(STCal Source Target)* P' = P \<longmapsto>ST* P'"
      using STCal_steps(2)[where T="TP" and P'="P'"] STSteps_steps(2)[where T="TP" and P'="P'"]
    by blast
qed

lemma stepsST_refl:
  fixes P :: "('procS, 'procT) Proc"
  shows "P \<longmapsto>ST* P"
    by (cases P, simp_all add: steps_refl)

lemma stepsST_add:
  fixes P Q R :: "('procS, 'procT) Proc"
  assumes A1: "P \<longmapsto>ST* Q"
      and A2: "Q \<longmapsto>ST* R"
  shows "P \<longmapsto>ST* R"
proof -
  from A1 have "P \<longmapsto>(STCal Source Target)* Q"
    by (simp add: stepsST_STCal_steps)
  moreover from A2 have "Q \<longmapsto>(STCal Source Target)* R"
    by (simp add: stepsST_STCal_steps)
  ultimately have "P \<longmapsto>(STCal Source Target)* R"
    by (rule steps_add)
  thus "P \<longmapsto>ST* R"
    by (simp add: stepsST_STCal_steps)
qed

text \<open>A divergent term of Proc is either a divergent source term or a divergent target term.\<close>

abbreviation divergentST
    :: "('procS, 'procT) Proc \<Rightarrow> bool" ("_ \<longmapsto>ST\<omega>" [70] 80)
  where
  "P \<longmapsto>ST\<omega> \<equiv> (\<exists>S. S \<in>S P \<and> S \<longmapsto>(Source)\<omega>) \<or> (\<exists>T. T \<in>T P \<and> T \<longmapsto>(Target)\<omega>)"

lemma STCal_divergent:
  fixes S  :: "'procS"
    and T  :: "'procT"
  shows "SourceTerm S \<longmapsto>(STCal Source Target)\<omega> = S \<longmapsto>(Source)\<omega>"
    and "TargetTerm T \<longmapsto>(STCal Source Target)\<omega> = T \<longmapsto>(Target)\<omega>"
      using STCal_steps
    by (auto simp add: STCal_def divergent_def)

lemma divergentST_STCal_divergent:
  fixes P :: "('procS, 'procT) Proc"
  shows "P \<longmapsto>(STCal Source Target)\<omega> = P \<longmapsto>ST\<omega>"
proof (cases P)
  case (SourceTerm SP)
  assume "SP \<in>S P"
  thus "P \<longmapsto>(STCal Source Target)\<omega> = P \<longmapsto>ST\<omega>"
      using STCal_divergent(1)
    by simp
next
  case (TargetTerm TP)
  assume "TP \<in>T P"
  thus "P \<longmapsto>(STCal Source Target)\<omega> = P \<longmapsto>ST\<omega>"
      using STCal_divergent(2)
    by simp
qed

text \<open>Similar to relations we define what it means for an encoding to preserve, reflect, or
        respect a predicate. An encoding preserves some predicate P if P(S) implies P(enc S) for
        all source terms S.\<close>

abbreviation enc_preserves_pred :: "(('procS, 'procT) Proc \<Rightarrow> bool) \<Rightarrow> bool" where
  "enc_preserves_pred Pred \<equiv> \<forall>S. Pred (SourceTerm S) \<longrightarrow> Pred (TargetTerm (\<lbrakk>S\<rbrakk>))"

abbreviation enc_preserves_binary_pred
    :: "(('procS, 'procT) Proc \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
  where
  "enc_preserves_binary_pred Pred \<equiv> \<forall>S x. Pred (SourceTerm S) x \<longrightarrow> Pred (TargetTerm (\<lbrakk>S\<rbrakk>)) x"

text \<open>An encoding reflects some predicate P if P(S) implies P(enc S) for all source terms S.\<close>

abbreviation enc_reflects_pred :: "(('procS, 'procT) Proc \<Rightarrow> bool) \<Rightarrow> bool" where
  "enc_reflects_pred Pred \<equiv> \<forall>S. Pred (TargetTerm (\<lbrakk>S\<rbrakk>)) \<longrightarrow> Pred (SourceTerm S)"

abbreviation enc_reflects_binary_pred
    :: "(('procS, 'procT) Proc \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
  where
  "enc_reflects_binary_pred Pred \<equiv> \<forall>S x. Pred (TargetTerm (\<lbrakk>S\<rbrakk>)) x \<longrightarrow> Pred (SourceTerm S) x"

text \<open>An encoding respects a predicate if it preserves and reflects it.\<close>

abbreviation enc_respects_pred :: "(('procS, 'procT) Proc \<Rightarrow> bool) \<Rightarrow> bool" where
  "enc_respects_pred Pred \<equiv> enc_preserves_pred Pred \<and> enc_reflects_pred Pred"

abbreviation enc_respects_binary_pred
    :: "(('procS, 'procT) Proc \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
  where
  "enc_respects_binary_pred Pred \<equiv>
   enc_preserves_binary_pred Pred \<and> enc_reflects_binary_pred Pred"

end

text \<open>To compare source terms and target terms w.r.t. their barbs or observables we assume that
        each languages defines its own predicate for the existence of barbs.\<close>

locale encoding_wrt_barbs =
  encoding Source Target Enc
  for Source :: "'procS processCalculus"
  and Target :: "'procT processCalculus"
  and Enc    :: "'procS \<Rightarrow> 'procT" +
  fixes SWB :: "('procS, 'barbs) calculusWithBarbs"
    and TWB :: "('procT, 'barbs) calculusWithBarbs"
  assumes calS: "calculusWithBarbs.Calculus SWB = Source"
      and calT: "calculusWithBarbs.Calculus TWB = Target"
begin

lemma STCalWB_STCal:
  shows "Calculus (STCalWB SWB TWB) = STCal Source Target"
      unfolding STCalWB_def using calS calT
    by auto

text \<open>We say a term P of Proc has some barbs a if either P is a source term that has barb a or P
        is a target term that has the barb b. For simplicity we assume that the sets of barbs is
        large enough to contain all barbs of the source terms, the target terms, and all barbs they
        might have in common.\<close>

abbreviation hasBarbST
    :: "('procS, 'procT) Proc \<Rightarrow> 'barbs \<Rightarrow> bool" ("_\<down>._" [70, 70] 80)
  where
  "P\<down>.a \<equiv> (\<exists>S. S \<in>S P \<and> S\<down><SWB>a) \<or> (\<exists>T. T \<in>T P \<and> T\<down><TWB>a)"

lemma STCalWB_hasBarbST:
  fixes P :: "('procS, 'procT) Proc"
    and a :: "'barbs"
  shows "P\<down><STCalWB SWB TWB>a = P\<down>.a"
    by (simp add: STCalWB_def)

lemma reflection_of_barbs_in_barbed_encoding:
  fixes Rel :: "(('procS, 'procT) Proc \<times> ('procS, 'procT) Proc) set"
    and P Q :: "('procS, 'procT) Proc"
    and a   :: "'barbs"
  assumes reflection: "rel_reflects_barbs Rel (STCalWB SWB TWB)"
      and rel:        "(P, Q) \<in> Rel"
      and barb:       "Q\<down>.a"
  shows "P\<down>.a"
      using reflection rel barb
    by (simp add: STCalWB_def)

lemma respection_of_barbs_in_barbed_encoding:
  fixes Rel :: "(('procS, 'procT) Proc \<times> ('procS, 'procT) Proc) set"
    and P Q :: "('procS, 'procT) Proc"
    and a   :: "'barbs"
  assumes respection: "rel_respects_barbs Rel (STCalWB SWB TWB)"
      and rel:        "(P, Q) \<in> Rel"
  shows "P\<down>.a = Q\<down>.a"
      using preservation_of_barbs_in_barbed_encoding[where Rel="Rel" and P="P" and Q="Q" and a="a"]
            reflection_of_barbs_in_barbed_encoding[where Rel="Rel" and P="P" and Q="Q" and a="a"]
            respection rel
    by blast

text \<open>A term P of Proc reaches a barb a if either P is a source term that reaches a or P is a
        target term that reaches a.\<close>

abbreviation reachesBarbST
    :: "('procS, 'procT) Proc \<Rightarrow> 'barbs \<Rightarrow> bool" ("_\<Down>._" [70, 70] 80)
  where
  "P\<Down>.a \<equiv> (\<exists>S. S \<in>S P \<and> S\<Down><SWB>a) \<or> (\<exists>T. T \<in>T P \<and> T\<Down><TWB>a)"

lemma STCalWB_reachesBarbST:
  fixes P :: "('procS, 'procT) Proc"
    and a :: "'barbs"
  shows "P\<Down><STCalWB SWB TWB>a = P\<Down>.a"
proof -
  have "\<forall>S. SourceTerm S\<Down><STCalWB SWB TWB>a = SourceTerm S\<Down>.a"
      using STCal_steps(1)
    by (auto simp add: STCalWB_def calS calT)
  moreover have "\<forall>T. TargetTerm T\<Down><STCalWB SWB TWB>a = TargetTerm T\<Down>.a"
      using STCal_steps(2)
    by (auto simp add: STCalWB_def calS calT)
  ultimately show "P\<Down><STCalWB SWB TWB>a = P\<Down>.a"
    by (cases P, simp+)
qed

lemma weak_preservation_of_barbs_in_barbed_encoding:
  fixes Rel :: "(('procS, 'procT) Proc \<times> ('procS, 'procT) Proc) set"
    and P Q :: "('procS, 'procT) Proc"
    and a   :: "'barbs"
  assumes preservation: "rel_weakly_preserves_barbs Rel (STCalWB SWB TWB)"
      and rel:          "(P, Q) \<in> Rel"
      and barb:         "P\<Down>.a"
  shows "Q\<Down>.a"
proof -
  from barb have "P\<Down><STCalWB SWB TWB>a"
    by (simp add: STCalWB_reachesBarbST)
  with preservation rel have "Q\<Down><STCalWB SWB TWB>a"
    by blast
  thus "Q\<Down>.a"
    by (simp add: STCalWB_reachesBarbST)
qed

lemma weak_reflection_of_barbs_in_barbed_encoding:
  fixes Rel :: "(('procS, 'procT) Proc \<times> ('procS, 'procT) Proc) set"
    and P Q :: "('procS, 'procT) Proc"
    and a   :: "'barbs"
  assumes reflection: "rel_weakly_reflects_barbs Rel (STCalWB SWB TWB)"
      and rel:        "(P, Q) \<in> Rel"
      and barb:       "Q\<Down>.a"
  shows "P\<Down>.a"
proof -
  from barb have "Q\<Down><STCalWB SWB TWB>a"
    by (simp add: STCalWB_reachesBarbST)
  with reflection rel have "P\<Down><STCalWB SWB TWB>a"
    by blast
  thus "P\<Down>.a"
    by (simp add: STCalWB_reachesBarbST)
qed

lemma weak_respection_of_barbs_in_barbed_encoding:
  fixes Rel :: "(('procS, 'procT) Proc \<times> ('procS, 'procT) Proc) set"
    and P Q :: "('procS, 'procT) Proc"
    and a   :: "'barbs"
  assumes respection: "rel_weakly_respects_barbs Rel (STCalWB SWB TWB)"
      and rel:        "(P, Q) \<in> Rel"
  shows "P\<Down>.a = Q\<Down>.a"
proof (rule iffI)
  assume "P\<Down>.a"
  with respection rel show "Q\<Down>.a"
      using weak_preservation_of_barbs_in_barbed_encoding[where Rel="Rel"]
    by blast
next
  assume "Q\<Down>.a"
  with respection rel show "P\<Down>.a"
      using weak_reflection_of_barbs_in_barbed_encoding[where Rel="Rel"]
    by blast
qed

end

end


(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory List_local
imports Extra "HOL-Library.While_Combinator"
begin

text\<open>Partition a list with respect to an equivalence relation.\<close>

text\<open>First up: split a list according to a relation.\<close>

abbreviation "rel_ext r \<equiv> { x . r x }"

definition
  partition_split_body :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list \<times> 'a list \<Rightarrow> 'a list \<times> 'a list"
where
  [code]: "partition_split_body r x \<equiv> \<lambda>y (X', xc).
            if r (x, y) then (X', List.insert y xc) else (List.insert y X', xc)"

definition
  partition_split :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list"
where
  [code]: "partition_split r x xs \<equiv> foldr (partition_split_body r x) xs ([], [])"

lemma partition_split:
  shows "set (fst (partition_split r x xs)) = set xs - (rel_ext r `` {x})"
    and "set (snd (partition_split r x xs)) = set xs \<inter> (rel_ext r `` {x})"
proof(induct xs)
  case Nil
  { case 1 with Nil show ?case
      unfolding partition_split_def by simp }
  { case 2 with Nil show ?case
      unfolding partition_split_def by simp }
next
  case (Cons x xs)
  { case 1 with Cons show ?case
      unfolding partition_split_def
      apply simp
      apply (subst partition_split_body_def)
      apply (split prod.split)
      apply clarsimp
      apply rule
       apply clarsimp
      apply clarsimp
      unfolding Image_def
      apply auto
      done }
  { case 2 with Cons show ?case
      unfolding partition_split_def
      apply simp
      apply (subst partition_split_body_def)
      apply (split prod.split)
      apply clarsimp
      apply rule
       apply clarsimp
      apply clarsimp
      done }
qed

lemma partition_split':
  assumes "partition_split r x xs = (xxs', xec)"
  shows "set xxs' = set xs - (rel_ext r `` {x})"
    and "set xec = set xs \<inter> (rel_ext r `` {x})"
  using assms partition_split[where r=r and x=x and xs=xs]
  by simp_all

text\<open>Next, split an list on each of its members. For this to be
unambiguous @{term "r"} must be an equivalence relation.\<close>

definition
  partition_aux_body :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<times> 'a list list \<Rightarrow> 'a list \<times> 'a list list"
where
  "partition_aux_body \<equiv> \<lambda>r (xxs, ecs). case xxs of [] \<Rightarrow> ([], []) | x # xs \<Rightarrow>
                           let (xxs', xec) = partition_split r x xs
                            in (xxs', (x # xec) # ecs)"

definition
  partition_aux :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list list"
where
  [code]: "partition_aux r xs \<equiv>
             while (Not \<circ> List.null \<circ> fst) (partition_aux_body r) (xs, [])"

(* FIXME move these. *)

lemma equiv_subseteq_in_sym:
  "\<lbrakk> r `` X \<subseteq> X;  (x, y) \<in> r; y \<in> X; equiv Y r; X \<subseteq> Y \<rbrakk> \<Longrightarrow> x \<in> X"
  unfolding equiv_def by (auto dest: symD)

lemma FIXME_refl_on_insert_absorb[simp]:
  "\<lbrakk> refl_on A r; x \<in> A \<rbrakk> \<Longrightarrow> insert x (r `` {x}) = r `` {x}"
  by (auto dest: refl_onD)

lemma equiv_subset[intro]:
  "\<lbrakk> equiv A r; B \<subseteq> A \<rbrakk> \<Longrightarrow> equiv B (r \<inter> B \<times> B)"
  unfolding equiv_def by (auto intro: refl_onI symI transI dest: refl_onD symD transD)

lemma FIXME_fiddle1: "\<lbrakk> x \<in> Y; X \<subseteq> Y; refl_on Y r \<rbrakk> \<Longrightarrow> insert x (X \<inter> r `` {x}) = (insert x X) \<inter> r `` {x}"
  by (auto dest: refl_onD)

lemma FIXME_second_fiddle:
  "\<lbrakk> (r \<inter> Y \<times> Y) `` X \<subseteq> X; refl_on Z r; x \<in> X; X \<subseteq> Y; Y \<subseteq> Z \<rbrakk>
     \<Longrightarrow> (r \<inter> (Y - (X - r `` {x})) \<times> (Y - (X - r `` {x}))) `` {x}
       = (r \<inter> X \<times> X) `` {x}"
  by (blast dest: refl_onD)

lemma FIXME_third_fiddle:
  "\<lbrakk> (r \<inter> Y \<times> Y) `` X \<subseteq> X; X \<subseteq> Y; x \<in> X; y \<in> Y - X    ;    r `` {y} \<inter> X = {} \<rbrakk>
     \<Longrightarrow> (r \<inter> (Y - (X - r `` {x})) \<times> (Y - (X - r `` {x}))) `` {y}
       = (r \<inter> (Y - X) \<times> (Y - X)) `` {y}"
  by auto

lemma partition_aux:
  assumes equiv: "equiv X (rel_ext r)"
      and XZ: "set xs \<subseteq> X"
  shows "fst (partition_aux r xs) = []
       \<and> set ` set (snd (partition_aux r xs))
       = (set xs // (rel_ext r \<inter> set xs \<times> set xs))"
proof -
  let ?b = "Not \<circ> List.null \<circ> fst"
  let ?c = "partition_aux_body r"
  let ?r' = "\<lambda>A. rel_ext r \<inter> A \<times> A"
  let ?P1 = "\<lambda>(A, B). set A \<subseteq> set xs"
  let ?P2 = "\<lambda>(A, B). ?r' (set xs) `` set A \<subseteq> set A"
  let ?P3 = "\<lambda>(A, B). set ` set B = ((set xs - set A) // ?r' (set xs - set A))"
  let ?P = "\<lambda>AB. ?P1 AB \<and> ?P2 AB \<and> ?P3 AB"
  let ?wfr = "inv_image finite_psubset (set \<circ> fst)"
  show ?thesis
  unfolding partition_aux_def
  proof(rule while_rule[where P="?P" and r="?wfr"])
    from equiv XZ show "?P (xs, [])" by auto
  next
    fix s assume P: "?P s" and b: "?b s"

    obtain A B where s: "s = (A, B)" by (cases s) blast

    moreover
    from XZ P s have "?P1 (?c (A, B))"
      unfolding partition_aux_body_def
      by (auto simp add: partition_split' split: list.split prod.split)

    moreover
    from equiv XZ P s have "?P2 (?c s)"
      apply (cases A)
      unfolding partition_aux_body_def
      apply simp_all
      subgoal for a as
        apply (cases "partition_split r a as")
        apply (simp add: partition_split')
        unfolding equiv_def
        apply (auto dest: symD transD elim: quotientE)
        done
      done

    moreover
    have "?P3 (?c s)"
    proof -
      from b s obtain x where x: "x \<in> set A" by (cases A) (auto iff: null_def)
      with XZ equiv P b s x
      show ?thesis

        unfolding partition_aux_body_def
        apply clarsimp
        apply (erule equivE)
        apply (cases A)
         apply simp
        apply simp
        apply (case_tac "partition_split r a list")
        apply clarsimp
        apply (simp add: partition_split')

        apply (subst FIXME_fiddle1[where Y=X])
           apply blast
          apply auto[1]
         apply blast

        apply rule
         apply clarsimp
         apply rule
          apply (rule_tac x=a in quotientI2)
           apply (blast dest: refl_onD)
          using XZ
          apply (auto dest: refl_onD)[1]
         apply clarsimp
         apply (erule quotientE)
         apply clarsimp
         apply (rule_tac x=xa in quotientI2)
          apply (blast dest: refl_onD)
         apply rule
          apply clarsimp
         apply clarsimp
         apply rule
          apply rule
          apply clarsimp
          apply (cut_tac X="insert a (set list)" and Y="set xs" and x=xa and y=a and r="rel_ext r \<inter> set xs \<times> set xs" in equiv_subseteq_in_sym)
          apply simp_all
          using equiv
          apply blast
         apply clarsimp
         apply (cut_tac X="insert a (set list)" and Y="set xs" and x=xa and y=xb and r="rel_ext r \<inter> set xs \<times> set xs" in equiv_subseteq_in_sym)
         apply simp_all
         using equiv
         apply blast

        apply (rule subsetI)
        apply (erule quotientE)
        apply (case_tac "xaa = a")
         apply auto[1]
        apply clarsimp

        apply (case_tac "xa \<in> set list")
         apply clarsimp
         apply rule
          apply (auto dest: transD)[1]
         apply (auto dest: symD transD)[1]

        unfolding quotient_def
        apply clarsimp
        apply (erule_tac x=xa in ballE)
         unfolding Image_def
         apply clarsimp
        apply (auto dest: symD transD)  (* SLOW *)
        done
    qed

    ultimately show "?P (?c s)" by auto
  next
    fix s assume P: "?P s" and b: "\<not> (?b s)"
    from b have F: "fst s = []"
      apply (cases s)
      apply simp
      apply (case_tac a)
      apply (simp_all add: List.null_def)
      done
    from equiv P F have S: "set ` set (snd s) = (set xs // ?r' (set xs))"
      apply (cases s)
      unfolding Image_def
      apply simp
      done
    from F S show "fst s = [] \<and> set ` set (snd s) = (set xs // ?r' (set xs))"
      by (simp add: prod_eqI)
  next
    show "wf ?wfr" by (blast intro: wf_finite_psubset Int_lower2 [THEN [2] wf_subset])
  next
    fix s assume P: "?P s" and b: "?b s"
    from equiv XZ P b have "set (fst (?c s)) \<subset> set (fst s)"
      apply -
      apply (cases s)
      apply (simp add: Let_def)
      unfolding partition_aux_body_def
      apply clarsimp
      apply (case_tac a)
       apply (simp add: List.null_def)
      apply simp
      apply (case_tac "partition_split r aa list")
      apply (simp add: partition_split')

      unfolding equiv_def
      apply (auto dest: refl_onD)
      done
    thus "(?c s, s) \<in> ?wfr" by auto
  qed
qed

definition
  partition :: "('a \<times> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list list"
where
  [code]: "partition r xs \<equiv> snd (partition_aux r xs)"

lemma partition:
  assumes equiv: "equiv X (rel_ext r)"
      and xs: "set xs \<subseteq> X"
  shows "set ` set (partition r xs) = set xs // ((rel_ext r) \<inter> set xs \<times> set xs)"
  unfolding partition_def
  using partition_aux[OF equiv xs] by simp

(* **************************************** *)

fun
  odlist_equal :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "odlist_equal [] [] = True"
| "odlist_equal [] ys = False"
| "odlist_equal xs [] = False"
| "odlist_equal (x # xs) (y # ys) = (x = y \<and> odlist_equal xs ys)"

declare odlist_equal.simps [code]

lemma equal_odlist_equal[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> odlist_equal xs ys \<longleftrightarrow> (xs = ys)"
  by (induct xs ys rule: odlist_equal.induct) (auto)

fun
  difference :: "('a :: linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "difference [] ys = []"
| "difference xs [] = xs"
| "difference (x # xs) (y # ys) =
     (if x = y then difference xs ys
               else if x < y then x # difference xs (y # ys)
                             else difference (x # xs) ys)"

declare difference.simps [code]

lemma set_difference[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> set (difference xs ys) = set xs - set ys"
  by (induct xs ys rule: difference.induct) (auto)

lemma distinct_sorted_difference[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> distinct (difference xs ys) \<and> sorted (difference xs ys)"
  by (induct xs ys rule: difference.induct) (auto)

fun
  intersection :: "('a :: linorder) list \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "intersection [] ys = []"
| "intersection xs [] = []"
| "intersection (x # xs) (y # ys) =
     (if x = y then x # intersection xs ys
               else if x < y then intersection xs (y # ys)
                             else intersection (x # xs) ys)"

declare intersection.simps [code]

lemma set_intersection[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> set (intersection xs ys) = set xs \<inter> set ys"
  by (induct xs ys rule: intersection.induct) (auto)

lemma distinct_sorted_intersection[simp]:
  "\<lbrakk> distinct xs; distinct ys; sorted xs; sorted ys \<rbrakk>
     \<Longrightarrow> distinct (intersection xs ys) \<and> sorted (intersection xs ys)"
  by (induct xs ys rule: intersection.induct) (auto)

(* This is a variant of zipWith *)
fun
  image :: "('a :: linorder \<times> 'b :: linorder) list \<Rightarrow> 'a list \<Rightarrow> 'b list"
where
  "image [] xs = []"
| "image R []  = []"
| "image ((x, y) # rs) (z # zs) =
     (if x = z then y # image rs (z # zs)
               else if x < z then image rs (z # zs)
                             else image ((x, y) # rs) zs)"

declare image.simps [code]

lemma set_image[simp]:
  "\<lbrakk> distinct R; distinct xs; sorted R; sorted xs \<rbrakk>
     \<Longrightarrow> set (image R xs) = set R `` set xs"
  by (induct R xs rule: image.induct) (auto iff: less_eq_prod_def)

(* Extra lemmas that really belong in List.thy *)

lemma sorted_filter[simp]:
  "sorted xs \<Longrightarrow> sorted (filter P xs)"
  by (induct xs) (auto)

lemma map_prod_eq:
  assumes f: "map fst xs = map fst ys"
      and s: "map snd xs = map snd ys"
  shows "xs = ys"
  using assms by (fact pair_list_eqI)

lemma list_choose_hd:
  assumes "\<forall>x \<in> set xs. P x"
      and "x \<in> set xs"
  shows "P (List.hd xs)"
  using assms by (induct xs arbitrary: x) auto

end


(*  Author:     Tobias Nipkow, 2007  *)

theory QElin
imports LinArith
begin

subsection\<open>Fourier\<close>

definition qe_FM\<^sub>1 :: "atom list \<Rightarrow> atom fm" where
"qe_FM\<^sub>1 as = list_conj [Atom(combine p q). p\<leftarrow>lbounds as, q\<leftarrow>ubounds as]"

theorem I_qe_FM\<^sub>1:
assumes less: "\<forall>a \<in> set as. is_Less a" and dep: "\<forall>a \<in> set as. depends\<^sub>R a"
shows "R.I (qe_FM\<^sub>1 as) xs = (\<exists>x. \<forall>a \<in> set as. I\<^sub>R a (x#xs))"  (is "?L = ?R")
proof
  let ?Ls = "set(lbounds as)" let ?Us = "set(ubounds as)"
  let ?lbs = "UN (r,cs):?Ls. {r + \<langle>cs,xs\<rangle>}"
  let ?ubs = "UN (r,cs):?Us. {r + \<langle>cs,xs\<rangle>}"
  have fins: "finite ?lbs \<and> finite ?ubs" by auto
  have 2: "\<forall>f\<in> set as. \<exists>r c cs. f = Less r (c#cs) \<and>
          (c>0 \<and> (r/c,(-1/c)*\<^sub>s cs) \<in> ?Ls \<or> c<0 \<and> (r/c,(-1/c)*\<^sub>s cs) \<in> ?Us)"
    using dep less
    by(fastforce simp:set_lbounds set_ubounds is_Less_iff depends\<^sub>R_def
                split:list.splits)
  assume ?L
  have 1: "\<forall>x\<in>?lbs. \<forall>y\<in>?ubs. x < y"
  proof (rule ballI)+
    fix x y assume "x\<in>?lbs" "y\<in>?ubs"
    then obtain r cs
      where "(r,cs) \<in> ?Ls \<and> x = r + \<langle>cs,xs\<rangle>" by fastforce
    moreover from \<open>y\<in>?ubs\<close> obtain s ds
      where "(s,ds) \<in> ?Us \<and> y = s + \<langle>ds,xs\<rangle>" by fastforce
    ultimately show "x<y" using \<open>?L\<close>
      by(fastforce simp:qe_FM\<^sub>1_def algebra_simps iprod_left_diff_distrib)
  qed
  { assume nonempty: "?lbs \<noteq> {} \<and> ?ubs \<noteq> {}"
    hence "Max ?lbs < Min ?ubs" using fins 1
      by(blast intro: Max_less_iff[THEN iffD2] Min_gr_iff[THEN iffD2])
    then obtain m where "Max ?lbs < m \<and> m < Min ?ubs"
      using dense[where 'a = real] by blast
    hence "\<forall>a \<in> set as. I\<^sub>R a (m#xs)" using 2 nonempty
      apply (auto simp: Ball_def)
      apply (auto simp: Bex_def)
      apply (fastforce simp: field_simps)
      done
    hence ?R .. }
  moreover
  { assume asm: "?lbs \<noteq> {} \<and> ?ubs = {}"
    have "\<forall>a \<in> set as. I\<^sub>R a ((Max ?lbs + 1) # xs)"
    proof
      fix a assume "a \<in> set as"
      then obtain r c cs
        where "a = Less r (c#cs)" "c>0" "(r/c,(-1/c)*\<^sub>s cs) \<in> ?Ls"
        using asm 2
          by (fastforce simp: field_simps)
      moreover hence "(r - \<langle>cs,xs\<rangle>)/c \<le> Max ?lbs"
        using asm fins
        by(auto intro!: Max_ge_iff[THEN iffD2])
          (force simp add:field_simps)
      ultimately show "I\<^sub>R a ((Max ?lbs + 1) # xs)" by (simp add: field_simps)
    qed
    hence ?R .. }
  moreover
  { assume asm: "?lbs = {} \<and> ?ubs \<noteq> {}"
    have "\<forall>a \<in> set as. I\<^sub>R a ((Min ?ubs - 1) # xs)"
    proof
      fix a assume "a \<in> set as"
      then obtain r c cs
        where "a = Less r (c#cs)" "c<0" "(r/c,(-1/c)*\<^sub>s cs) \<in> ?Us"
        using asm 2 by fastforce
      moreover hence "Min ?ubs \<le> (r - \<langle>cs,xs\<rangle>)/c"
        using asm fins
        by(auto intro!: Min_le_iff[THEN iffD2])
          (force simp add:field_simps)
      ultimately show "I\<^sub>R a ((Min ?ubs - 1) # xs)" by (simp add: field_simps)
    qed
    hence ?R .. }
  moreover
  { assume "?lbs = {} \<and> ?ubs = {}"
    hence ?R using 2 less by auto (rule, fast)
  }
  ultimately show ?R by blast
next
  let ?Ls = "set(lbounds as)" let ?Us = "set(ubounds as)"
  assume ?R
  then obtain x where 1: "\<forall>a\<in> set as. I\<^sub>R a (x#xs)" ..
  { fix r c cs s d ds
    assume "Less r (c#cs) \<in> set as" "0 < c" "Less s (d#ds) \<in> set as" "d < 0"
    hence "r < c*x + \<langle>cs,xs\<rangle>" "s < d*x + \<langle>ds,xs\<rangle>" "c > 0" "d < 0"
      using 1 by auto
    hence "(r - \<langle>cs,xs\<rangle>)/c < x" "x < (s - \<langle>ds,xs\<rangle>)/d" by(simp add:field_simps)+
    hence "(r - \<langle>cs,xs\<rangle>)/c < (s - \<langle>ds,xs\<rangle>)/d" by arith
  }
  thus ?L by (auto simp: qe_FM\<^sub>1_def iprod_left_diff_distrib less field_simps set_lbounds set_ubounds)
qed

corollary I_qe_FM\<^sub>1_pretty:
  "\<forall>a \<in> set as. is_Less a \<and> depends\<^sub>R a \<Longrightarrow> R.is_dnf_qe qe_FM\<^sub>1 as"
by(metis I_qe_FM\<^sub>1)

fun subst\<^sub>0 :: "atom \<Rightarrow> atom \<Rightarrow> atom" where
"subst\<^sub>0 (Eq r (c#cs)) a = (case a of
   Less s (d#ds) \<Rightarrow> Less (s - (r*d)/c) (ds - (d/c) *\<^sub>s cs)
 | Eq s (d#ds) \<Rightarrow> Eq (s - (r*d)/c) (ds - (d/c) *\<^sub>s cs))"

lemma subst\<^sub>0_pretty:
 "subst\<^sub>0 (Eq r (c#cs)) (Less s (d#ds)) = Less (s - (r*d)/c) (ds - (d/c) *\<^sub>s cs)"
 "subst\<^sub>0 (Eq r (c#cs)) (Eq s (d#ds)) = Eq (s - (r*d)/c) (ds - (d/c) *\<^sub>s cs)"
by auto

lemma I_subst\<^sub>0: "depends\<^sub>R a \<Longrightarrow> c \<noteq> 0 \<Longrightarrow>
       I\<^sub>R (subst\<^sub>0 (Eq r (c#cs)) a) xs = I\<^sub>R a ((r - \<langle>cs,xs\<rangle>)/c # xs)"
apply(cases a)
by (auto simp add: depends\<^sub>R_def iprod_left_diff_distrib algebra_simps diff_divide_distrib split:list.splits)

interpretation R\<^sub>e:
  ATOM_EQ neg\<^sub>R "(\<lambda>a. True)" I\<^sub>R depends\<^sub>R decr\<^sub>R
          "(\<lambda>Eq _ (c#_) \<Rightarrow> c \<noteq> 0 | _ \<Rightarrow> False)"
          "(\<lambda>Eq r cs \<Rightarrow> r=0 \<and> (\<forall>c\<in> set cs. c=0) | _ \<Rightarrow> False)" subst\<^sub>0
apply(unfold_locales)
   apply(simp del:subst\<^sub>0.simps add:I_subst\<^sub>0 split:atom.splits list.splits)
  apply(simp add: iprod0_if_coeffs0 split:atom.splits)
 apply(simp split:atom.splits list.splits)
 apply(rename_tac r ds c cs)
 apply(rule_tac x= "(r - \<langle>cs,xs\<rangle>)/c" in exI)
 apply (simp add: algebra_simps diff_divide_distrib)
apply(simp add: self_list_diff set_replicate_conv_if
        split:atom.splits list.splits)
done

(* FIXME does not help
setup {* Sign.revert_abbrev "" @{const_name R\<^sub>e.lift_dnfeq_qe} *}
*)

definition "qe_FM = R\<^sub>e.lift_dnfeq_qe qe_FM\<^sub>1"

lemma qfree_qe_FM\<^sub>1: "qfree (qe_FM\<^sub>1 as)"
by(auto simp:qe_FM\<^sub>1_def intro!:qfree_list_conj)

corollary I_qe_FM: "R.I (qe_FM \<phi>) xs = R.I \<phi> xs"
unfolding qe_FM_def
apply(rule R\<^sub>e.I_lift_dnfeq_qe)
 apply(rule qfree_qe_FM\<^sub>1)
apply(rule allI)
apply(rule I_qe_FM\<^sub>1)
 prefer 2 apply blast
apply(clarify)
apply(drule_tac x=a in bspec) apply simp
apply(simp add: depends\<^sub>R_def split:atom.splits list.splits)
done

theorem qfree_qe_FM: "qfree (qe_FM f)"
by(simp add:qe_FM_def R\<^sub>e.qfree_lift_dnfeq_qe qfree_qe_FM\<^sub>1)

subsubsection\<open>Tests\<close>

lemmas qesimps = qe_FM_def R\<^sub>e.lift_dnfeq_qe_def R\<^sub>e.lift_eq_qe_def R.qelim_def qe_FM\<^sub>1_def lbounds_def ubounds_def list_conj_def list_disj_def and_def or_def depends\<^sub>R_def

lemma "qe_FM(TrueF) = TrueF"
by(simp add:qesimps)

lemma
  "qe_FM(ExQ (And (Atom(Less 0 [1])) (Atom(Less 0 [-1])))) = Atom(Less 0 [])"
by(simp add:qesimps)

lemma
 "qe_FM(ExQ (And (Atom(Less 0 [1])) (Atom(Less (- 1) [-1])))) = Atom(Less (- 1) [])"
by(simp add:qesimps)

end


theory Scratch0
  imports Refine_Imperative_HOL.IICF
begin

fun fib :: "nat \<Rightarrow> int" where
  "fib 0 = 1"
| "fib (Suc 0) = 1"
| "fib (Suc (Suc n)) = fib (Suc n) + fib n"

definition fib_imp :: "nat \<Rightarrow> int nres" where
  "fib_imp n \<equiv> SPEC (op = (fib n))"

term WHILEIT
term WHILET
definition fib_imp0 :: "nat \<Rightarrow> int nres" where
  "fib_imp0 n \<equiv> do {
    (_, x, _) \<leftarrow> WHILEIT
      (\<lambda>(i, f0, f1). i\<le>n \<and> f0 = fib i \<and> f1 = fib (Suc i))
      (\<lambda>(i, f0, f1). i < n)
      (\<lambda>(i, f0, f1). RETURN (Suc i, f1, f0+f1))
      (0, 1, 1);
    RETURN x
  }"

term nat_assn
term Id

lemma "(fib_imp0, fib_imp) \<in> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
proof -
  have "fib_imp0 n \<le> fib_imp n" for n
  proof -
    have fib_measure: "wf (measure (\<lambda>(i, f0, f1). n-i))"
      by simp
    show ?thesis
      unfolding fib_imp_def fib_imp0_def
      by (refine_vcg fib_measure) auto
  qed
  thus ?thesis
    by (clarsimp intro!: nres_relI)
qed

term while
term last

definition fib_imp' :: "nat \<Rightarrow> int list nres" where
  "fib_imp' n \<equiv> SPEC (op = [fib i. i \<leftarrow> [0..<n]])"

definition fib_imp0' :: "nat \<Rightarrow> int list nres" where
  "fib_imp0' n = RETURN (take n (fold (\<lambda>i l. (list_update l (i+2) (l!i+l!(i+1)))) [0..<n] (replicate (n+2) 1)))"
term list_update
term Ref.update

lemma "(fib_imp0', fib_imp') \<in> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
proof -
  have "fib_imp0' n \<le> fib_imp' n" for n
  proof -
    have fib_fold: "take m (fold (\<lambda>i l. (list_update l (i+2) (l!i+l!(i+1)))) [0..<m] (replicate (m+2) 1)) = map fib [0..<m]" for m
      apply (induction m)
       apply auto[]
      find_theorems imp_for
      term while
      oops
      term replicate

sepref_definition fib_imp1' is fib_imp0' :: "nat_assn\<^sup>k \<rightarrow>\<^sub>a (list_assn int_assn)"
  unfolding fib_imp0'_def
unfolding "HOL_list.fold_custom_empty"
      apply sepref_dbg_keep
        apply sepref_dbg_trans_step

          apply sepref_dbg_trans_step
            apply sepref_dbg_trans_step
           apply sepref_dbg_trans_step
          apply sepref_dbg_trans_step

         apply sepref_dbg_trans_step
           apply sepref_dbg_trans_step
             apply sepref_dbg_trans_step
            apply sepref_dbg_trans_step
              apply sepref_dbg_trans_step
                apply sepref_dbg_trans_step
             apply sepref_dbg_trans_step
               apply sepref_dbg_trans_step
              apply sepref_dbg_trans_step
             apply sepref_dbg_trans_step
            apply sepref_dbg_trans_step
           apply sepref_dbg_trans_step
          apply sepref_dbg_trans_step
         apply sepref_dbg_trans_step
        apply sepref_dbg_trans_step
               apply sepref_dbg_trans_step
              apply sepref_dbg_trans_step
             apply sepref_dbg_trans_step
            apply sepref_dbg_trans_step
           apply sepref_dbg_trans_step
          apply sepref_dbg_trans_step
            apply sepref_dbg_trans_step
              apply sepref_dbg_trans_step
             apply sepref_dbg_trans_step
               apply sepref_dbg_trans_step_keep
               apply sepref_dbg_trans_step_keep
               apply sepref_dbg_trans_step_keep

  term 0(*
  find_theorems op_list_get hn_refine
  term list_custom_empty
  thm HOL_list.fold_custom_empty
  thm op_list_prepend_def[symmetric]
  thm op_list_get_def
end