(* Author: Fabian Immler, TU Muenchen *)
(* Author: Florian Haftmann, TU Muenchen *)
(* Author: Andreas Lochbihler, ETH Zurich *)
(* Author: Alexander Maletzky, RISC Linz *)

section \<open>Executable Representation of Polynomial Mappings as Association Lists\<close>

theory MPoly_Type_Class_OAlist
  imports Term_Order
begin

instantiation pp :: (type, "{equal, zero}") equal
begin

definition equal_pp :: "('a, 'b) pp \<Rightarrow> ('a, 'b) pp \<Rightarrow> bool" where
  "equal_pp p q \<equiv> (\<forall>t. lookup_pp p t = lookup_pp q t)"

instance by standard (auto simp: equal_pp_def intro: pp_eqI)

end

instantiation poly_mapping :: (type, "{equal, zero}") equal
begin

definition equal_poly_mapping :: "('a, 'b) poly_mapping \<Rightarrow> ('a, 'b) poly_mapping \<Rightarrow> bool" where
  equal_poly_mapping_def [code del]: "equal_poly_mapping p q \<equiv> (\<forall>t. lookup p t = lookup q t)"

instance by standard (auto simp: equal_poly_mapping_def intro: poly_mapping_eqI)

end

subsection \<open>Power-Products Represented by @{type oalist_tc}\<close>

definition PP_oalist :: "('a::linorder, 'b::zero) oalist_tc \<Rightarrow> ('a, 'b) pp"
  where "PP_oalist xs = pp_of_fun (OAlist_tc_lookup xs)"

code_datatype PP_oalist

lemma lookup_PP_oalist [simp, code]: "lookup_pp (PP_oalist xs) = OAlist_tc_lookup xs"
  unfolding PP_oalist_def
proof (rule lookup_pp_of_fun)
  have "{x. OAlist_tc_lookup xs x \<noteq> 0} \<subseteq> fst ` set (list_of_oalist_tc xs)"
  proof (rule, simp)
    fix x
    assume "OAlist_tc_lookup xs x \<noteq> 0"
    thus "x \<in> fst ` set (list_of_oalist_tc xs)"
      using in_OAlist_tc_sorted_domain_iff_lookup set_OAlist_tc_sorted_domain by blast
  qed
  also have "finite ..." by simp
  finally (finite_subset) show "finite {x. OAlist_tc_lookup xs x \<noteq> 0}" .
qed

lemma keys_PP_oalist [code]: "keys_pp (PP_oalist xs) = set (OAlist_tc_sorted_domain xs)"
  by (rule set_eqI, simp add: keys_pp_iff in_OAlist_tc_sorted_domain_iff_lookup)

lemma lex_comp_PP_oalist [code]:
  "lex_comp' (PP_oalist xs) (PP_oalist ys) =
         the (OAlist_tc_lex_ord (\<lambda>_ x y. Some (comparator_of x y)) xs ys)"
  for xs ys::"('a::nat, 'b::nat) oalist_tc"
proof (cases "lex_comp' (PP_oalist xs) (PP_oalist ys) = Eq")
  case True
  hence "PP_oalist xs = PP_oalist ys" by (rule lex_comp'_EqD)
  hence eq: "OAlist_tc_lookup xs = OAlist_tc_lookup ys" by (simp add: pp_eq_iff)
  have "OAlist_tc_lex_ord (\<lambda>_ x y. Some (comparator_of x y)) xs ys = Some Eq"
    by (rule OAlist_tc_lex_ord_EqI, simp add: eq)
  thus ?thesis by (simp add: True)
next
  case False
  then obtain x where 1: "x \<in> keys_pp (rep_nat_pp (PP_oalist xs)) \<union> keys_pp (rep_nat_pp (PP_oalist ys))"
    and 2: "comparator_of (lookup_pp (rep_nat_pp (PP_oalist xs)) x) (lookup_pp (rep_nat_pp (PP_oalist ys)) x) =
          lex_comp' (PP_oalist xs) (PP_oalist ys)"
    and 3: "\<And>y. y < x \<Longrightarrow> lookup_pp (rep_nat_pp (PP_oalist xs)) y = lookup_pp (rep_nat_pp (PP_oalist ys)) y"
    by (rule lex_comp'_valE, blast)
  have "OAlist_tc_lex_ord (\<lambda>_ x y. Some (comparator_of x y)) xs ys = Some (lex_comp' (PP_oalist xs) (PP_oalist ys))"
  proof (rule OAlist_tc_lex_ord_valI)
    from False show "Some (lex_comp' (PP_oalist xs) (PP_oalist ys)) \<noteq> Some Eq" by simp
  next
    from 1 have "abs_nat x \<in> abs_nat ` (keys_pp (rep_nat_pp (PP_oalist xs)) \<union> keys_pp (rep_nat_pp (PP_oalist ys)))"
      by (rule imageI)
    also have "... = fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys)"
      by (simp add: keys_rep_nat_pp_pp keys_PP_oalist OAlist_tc_sorted_domain_def image_Un image_image)
    finally show "abs_nat x \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys)" .
  next
    show "Some (lex_comp' (PP_oalist xs) (PP_oalist ys)) =
          Some (comparator_of (OAlist_tc_lookup xs (abs_nat x)) (OAlist_tc_lookup ys (abs_nat x)))"
      by (simp add: 2[symmetric] lookup_rep_nat_pp_pp)
  next
    fix y::'a
    assume "y < abs_nat x"
    hence "rep_nat y < x" by (metis abs_inverse ord_iff(2))
    hence "lookup_pp (rep_nat_pp (PP_oalist xs)) (rep_nat y) = lookup_pp (rep_nat_pp (PP_oalist ys)) (rep_nat y)"
      by (rule 3)
    hence "OAlist_tc_lookup xs y = OAlist_tc_lookup ys y" by (auto simp: lookup_rep_nat_pp_pp elim: rep_inj)
    thus "Some (comparator_of (OAlist_tc_lookup xs y) (OAlist_tc_lookup ys y)) = Some Eq" by simp
  qed
  thus ?thesis by simp
qed

lemma zero_PP_oalist [code]: "(0::('a::linorder, 'b::zero) pp) = PP_oalist OAlist_tc_empty"
  by (rule pp_eqI, simp add: lookup_OAlist_tc_empty)

lemma plus_PP_oalist [code]:
  "PP_oalist xs + PP_oalist ys = PP_oalist (OAlist_tc_map2_val_neutr (\<lambda>_. (+)) xs ys)"
  by (rule pp_eqI, simp add: lookup_plus_pp, rule lookup_OAlist_tc_map2_val_neutr[symmetric], simp_all)

lemma minus_PP_oalist [code]:
  "PP_oalist xs - PP_oalist ys = PP_oalist (OAlist_tc_map2_val_rneutr (\<lambda>_. (-)) xs ys)"
  by (rule pp_eqI, simp add: lookup_minus_pp, rule lookup_OAlist_tc_map2_val_rneutr[symmetric], simp)

lemma equal_PP_oalist [code]: "equal_class.equal (PP_oalist xs) (PP_oalist ys) = (xs = ys)"
  by (simp add: equal_eq pp_eq_iff, auto elim: OAlist_tc_lookup_inj)

lemma lcs_PP_oalist [code]:
  "lcs (PP_oalist xs) (PP_oalist ys) = PP_oalist (OAlist_tc_map2_val_neutr (\<lambda>_. max) xs ys)"
  for xs ys :: "('a::linorder, 'b::add_linorder_min) oalist_tc"
  by (rule pp_eqI, simp add: lookup_lcs_pp, rule lookup_OAlist_tc_map2_val_neutr[symmetric], simp_all add: max_def)

lemma deg_pp_PP_oalist [code]: "deg_pp (PP_oalist xs) = sum_list (map snd (list_of_oalist_tc xs))"
proof -
  have "irreflp ((<)::_::linorder \<Rightarrow> _)" by (rule irreflpI, simp)
  have "deg_pp (PP_oalist xs) = sum (OAlist_tc_lookup xs) (set (OAlist_tc_sorted_domain xs))"
    by (simp add: deg_pp_alt keys_PP_oalist)
  also have "... = sum_list (map (OAlist_tc_lookup xs) (OAlist_tc_sorted_domain xs))"
    by (rule sum.distinct_set_conv_list, rule distinct_sorted_wrt_irrefl,
        fact, fact transp_less, fact sorted_OAlist_tc_sorted_domain)
  also have "... = sum_list (map snd (list_of_oalist_tc xs))"
    by (rule arg_cong[where f=sum_list], simp add: OAlist_tc_sorted_domain_def OAlist_tc_lookup_eq_valueI)
  finally show ?thesis .
qed

lemma single_PP_oalist [code]: "single_pp x e = PP_oalist (oalist_tc_of_list [(x, e)])"
  by (rule pp_eqI, simp add: lookup_single_pp OAlist_tc_lookup_single)

definition adds_pp_add_linorder :: "('b, 'a::add_linorder) pp \<Rightarrow> _ \<Rightarrow> bool"
  where [code_abbrev]: "adds_pp_add_linorder = (adds)"

lemma adds_pp_PP_oalist [code]:
  "adds_pp_add_linorder (PP_oalist xs) (PP_oalist ys) = OAlist_tc_prod_ord (\<lambda>_. less_eq) xs ys"
  for xs ys::"('a::linorder, 'b::add_linorder_min) oalist_tc"
proof (simp add: adds_pp_add_linorder_def adds_pp_iff adds_poly_mapping lookup_pp.rep_eq[symmetric] OAlist_tc_prod_ord_alt le_fun_def,
      intro iffI allI ballI)
  fix k
  assume "\<forall>x. OAlist_tc_lookup xs x \<le> OAlist_tc_lookup ys x"
  thus "OAlist_tc_lookup xs k \<le> OAlist_tc_lookup ys k" by blast
next
  fix x
  assume *: "\<forall>k\<in>fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys).
              OAlist_tc_lookup xs k \<le> OAlist_tc_lookup ys k"
  show "OAlist_tc_lookup xs x \<le> OAlist_tc_lookup ys x"
  proof (cases "x \<in> fst ` set (list_of_oalist_tc xs) \<union> fst ` set (list_of_oalist_tc ys)")
    case True
    with * show ?thesis ..
  next
    case False
    hence "x \<notin> set (OAlist_tc_sorted_domain xs)" and "x \<notin> set (OAlist_tc_sorted_domain ys)"
      by (simp_all add: set_OAlist_tc_sorted_domain)
    thus ?thesis by (simp add: in_OAlist_tc_sorted_domain_iff_lookup)
  qed
qed

subsubsection \<open>Constructor\<close>

definition "sparse\<^sub>0 xs = PP_oalist (oalist_tc_of_list xs)" \<comment>\<open>sparse representation\<close>

subsubsection \<open>Computations\<close>

experiment begin

abbreviation "X \<equiv> 0::nat"
abbreviation "Y \<equiv> 1::nat"
abbreviation "Z \<equiv> 2::nat"

value [code] "sparse\<^sub>0 [(X, 2::nat), (Z, 7)]"

lemma
  "sparse\<^sub>0 [(X, 2::nat), (Z, 7)] - sparse\<^sub>0 [(X, 2), (Z, 2)] = sparse\<^sub>0 [(Z, 5)]"
  by eval

lemma
  "lcs (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 7)]) (sparse\<^sub>0 [(Y, 3), (Z, 2)]) = sparse\<^sub>0 [(X, 2), (Y, 3), (Z, 7)]"
  by eval

lemma
  "(sparse\<^sub>0 [(X, 2::nat), (Z, 1)]) adds (sparse\<^sub>0 [(X, 3), (Y, 2), (Z, 1)])"
  by eval

lemma
  "lookup_pp (sparse\<^sub>0 [(X, 2::nat), (Z, 3)]) X = 2"
  by eval

lemma
  "deg_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3), (X, 1)]) = 6"
  by eval

lemma
  "lex_comp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)]) = Lt"
  by eval

lemma
  "lex_comp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)], 3::nat) (sparse\<^sub>0 [(X, 4)], 2) = Lt"
  by eval

lemma
  "lex_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)])"
  by eval

lemma
  "lex_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)])"
  by eval

lemma
  "\<not> dlex_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 3)]) (sparse\<^sub>0 [(X, 4)])"
  by eval

lemma
  "dlex_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse\<^sub>0 [(X, 5)])"
  by eval

lemma
  "\<not> drlex_pp (sparse\<^sub>0 [(X, 2::nat), (Y, 1), (Z, 2)]) (sparse\<^sub>0 [(X, 5)])"
  by eval

end

subsection \<open>\<open>MP_oalist\<close>\<close>

lift_definition MP_oalist :: "('a::nat_term, 'b::zero) oalist_ntm \<Rightarrow> 'a \<Rightarrow>\<^sub>0 'b"
  is OAlist_lookup_ntm
proof -
  fix xs :: "('a, 'b) oalist_ntm"
  have "{x. OAlist_lookup_ntm xs x \<noteq> 0} \<subseteq> fst ` set (fst (list_of_oalist_ntm xs))"
  proof (rule, simp)
    fix x
    assume "OAlist_lookup_ntm xs x \<noteq> 0"
    thus "x \<in> fst ` set (fst (list_of_oalist_ntm xs))"
      using oa_ntm.in_sorted_domain_iff_lookup oa_ntm.set_sorted_domain by blast
  qed
  also have "finite ..." by simp
  finally (finite_subset) show "finite {x. OAlist_lookup_ntm xs x \<noteq> 0}" .
qed

lemmas [simp, code] = MP_oalist.rep_eq

code_datatype MP_oalist

lemma MP_oalist_empty [simp]: "MP_oalist (OAlist_empty_ntm ko) = 0"
  by (rule poly_mapping_eqI, simp add: oa_ntm.lookup_empty)

lemma zero_MP_oalist [code]: "(0::('a::{linorder,nat_term} \<Rightarrow>\<^sub>0 'b::zero)) = MP_oalist (OAlist_empty_ntm nat_term_order_of_le)"
  by simp

definition is_zero :: "('a \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> bool"
  where [code_abbrev]: "is_zero p \<longleftrightarrow> (p = 0)"

lemma is_zero_MP_oalist [code]: "is_zero (MP_oalist xs) = List.null (fst (list_of_oalist_ntm xs))"
  unfolding is_zero_def List.null_def
proof
  assume "MP_oalist xs = 0"
  hence "OAlist_lookup_ntm xs k = 0" for k by (simp add: poly_mapping_eq_iff)
  thus "fst (list_of_oalist_ntm xs) = []"
    by (metis image_eqI ko_ntm.min_key_val_raw_in oa_ntm.in_sorted_domain_iff_lookup oa_ntm.set_sorted_domain)
next
  assume "fst (list_of_oalist_ntm xs) = []"
  hence "OAlist_lookup_ntm xs k = 0" for k
    by (metis oa_ntm.list_of_oalist_empty oa_ntm.lookup_empty oalist_ntm_eqI surjective_pairing)
  thus "MP_oalist xs = 0" by (simp add: poly_mapping_eq_iff ext)
qed

lemma plus_MP_oalist [code]: "MP_oalist xs + MP_oalist ys = MP_oalist (OAlist_map2_val_neutr_ntm (\<lambda>_. (+)) xs ys)"
  by (rule poly_mapping_eqI, simp add: lookup_plus_fun, rule oa_ntm.lookup_map2_val_neutr[symmetric], simp_all)

lemma minus_MP_oalist [code]: "MP_oalist xs - MP_oalist ys = MP_oalist (OAlist_map2_val_rneutr_ntm (\<lambda>_. (-)) xs ys)"
  by (rule poly_mapping_eqI, simp add: lookup_minus_fun, rule oa_ntm.lookup_map2_val_rneutr[symmetric], simp)

lemma uminus_MP_oalist [code]: "- MP_oalist xs = MP_oalist (OAlist_map_val_ntm (\<lambda>_. uminus) xs)"
  by (rule poly_mapping_eqI, simp, rule oa_ntm.lookup_map_val[symmetric], simp)

lemma equal_MP_oalist [code]: "equal_class.equal (MP_oalist xs) (MP_oalist ys) = (OAlist_eq_ntm xs ys)"
  by (simp add: oa_ntm.oalist_eq_alt equal_eq poly_mapping_eq_iff)

lemma map_MP_oalist [code]: "Poly_Mapping.map f (MP_oalist xs) = MP_oalist (OAlist_map_val_ntm (\<lambda>_. f) xs)"
proof -
  have eq: "OAlist_map_val_ntm (\<lambda>_. f) xs = OAlist_map_val_ntm (\<lambda>_ c. f c when c \<noteq> 0) xs"
  proof (rule oa_ntm.map_val_cong)
    fix t c
    assume *: "(t, c) \<in> set (fst (list_of_oalist_ntm xs))"
    hence "fst (t, c) \<in> fst ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
    hence "OAlist_lookup_ntm xs t \<noteq> 0"
      by (simp add: oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])
    moreover from * have "OAlist_lookup_ntm xs t = c" by (rule oa_ntm.lookup_eq_valueI)
    ultimately have "c \<noteq> 0" by simp
    thus "f c = (f c when c \<noteq> 0)" by simp
  qed
  show ?thesis
    by (rule poly_mapping_eqI, simp add: Poly_Mapping.map.rep_eq eq, rule oa_ntm.lookup_map_val[symmetric], simp)
qed

lemma range_MP_oalist [code]: "Poly_Mapping.range (MP_oalist xs) = set (map snd (fst (list_of_oalist_ntm xs)))"
proof (simp add: Poly_Mapping.range.rep_eq, intro set_eqI iffI)
  fix c
  assume "c \<in> range (OAlist_lookup_ntm xs) - {0}"
  hence "c \<in> range (OAlist_lookup_ntm xs)" and "c \<noteq> 0" by simp_all
  from this(1) obtain t where "OAlist_lookup_ntm xs t = c" by fastforce
  with \<open>c \<noteq> 0\<close> have "(t, c) \<in> set (fst (list_of_oalist_ntm xs))" by (simp add: oa_ntm.lookup_eq_value)
  hence "snd (t, c) \<in> snd ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
  thus "c \<in> snd ` set (fst (list_of_oalist_ntm xs))" by simp
next
  fix c
  assume "c \<in> snd ` set (fst (list_of_oalist_ntm xs))"
  then obtain t where *: "(t, c) \<in> set (fst (list_of_oalist_ntm xs))" by fastforce
  hence "fst (t, c) \<in> fst ` set (fst (list_of_oalist_ntm xs))" by (rule imageI)
  hence "OAlist_lookup_ntm xs t \<noteq> 0"
    by (simp add: oa_ntm.in_sorted_domain_iff_lookup[simplified oa_ntm.set_sorted_domain])
  moreover from * have "OAlist_lookup_ntm xs t = c" by (rule oa_ntm.lookup_eq_valueI)
  ultimately show "c \<in> range (OAlist_lookup_ntm xs) - {0}" by fastforce
qed

lemma if_poly_mapping_eq_iff:
  "(if x = y then a else b) = (if (\<forall>i\<in>keys x \<union> keys y. lookup x i = lookup y i) then a else b)"
  by simp (metis UnI1 UnI2 in_keys_iff poly_mapping_eqI)

lemma keys_add_eq: "keys (a + b) = keys a \<union> keys b - {x \<in> keys a \<inter> keys b. lookup a x + lookup b x = 0}"
  by (auto simp: in_keys_iff lookup_add add_eq_0_iff
      simp del: lookup_not_eq_zero_eq_in_keys)

locale gd_nat_term =
    gd_term pair_of_term term_of_pair
        "\<lambda>s t. le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
        "\<lambda>s t. lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
        "le_of_nat_term_order cmp_term"
        "lt_of_nat_term_order cmp_term"
      for pair_of_term::"'t::nat_term \<Rightarrow> ('a::{nat_term,graded_dickson_powerprod} \<times> 'k::{countable,the_min,wellorder})"
      and term_of_pair::"('a \<times> 'k) \<Rightarrow> 't"
      and cmp_term +
    assumes splus_eq_splus: "t \<oplus> u = nat_term_class.splus (term_of_pair (t, the_min)) u"
begin

definition shift_map_keys :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('t, 'b) oalist_ntm \<Rightarrow> ('t, 'b::semiring_0) oalist_ntm"
  where "shift_map_keys t f xs = OAlist_ntm (map_raw (\<lambda>kv. (t \<oplus> fst kv, f (snd kv))) (list_of_oalist_ntm xs))"

lemma list_of_oalist_shift_keys:
  "list_of_oalist_ntm (shift_map_keys t f xs) = (map_raw (\<lambda>kv. (t \<oplus> fst kv, f (snd kv))) (list_of_oalist_ntm xs))"
  unfolding shift_map_keys_def
  by (rule oa_ntm.list_of_oalist_of_list_id, rule ko_ntm.oalist_inv_map_raw, fact oalist_inv_list_of_oalist_ntm,
      simp add: nat_term_compare_inv_conv[symmetric] nat_term_compare_inv_def splus_eq_splus nat_term_compare_splus)

lemma lookup_shift_map_keys_plus:
  "lookup (MP_oalist (shift_map_keys t ((*) c) xs)) (t \<oplus> u) = c * lookup (MP_oalist xs) u" (is "?l = ?r")
proof -
  let ?f = "\<lambda>kv. (t \<oplus> fst kv, c * snd kv)"
  have "?l = lookup_ko_ntm (map_raw ?f (list_of_oalist_ntm xs)) (fst (?f (u, c)))"
    by (simp add: oa_ntm.lookup_def list_of_oalist_shift_keys)
  also have "... = snd (?f (u, lookup_ko_ntm (list_of_oalist_ntm xs) u))"
    by (rule ko_ntm.lookup_raw_map_raw, fact oalist_inv_list_of_oalist_ntm, simp,
        simp add: nat_term_compare_inv_conv[symmetric] nat_term_compare_inv_def splus_eq_splus nat_term_compare_splus)
  also have "... = ?r" by (simp add: oa_ntm.lookup_def)
  finally show ?thesis .
qed

lemma monom_mult_MP_oalist [code]:
  "monom_mult c t (MP_oalist xs) =
    MP_oalist (if c = 0 then OAlist_empty_ntm (snd (list_of_oalist_ntm xs)) else shift_map_keys t ((*) c) xs)"
proof (cases "c = 0")
  case True
  hence "monom_mult c t (MP_oalist xs) = 0" using monom_mult_zero_left by simp
  thus ?thesis using True by simp
next
  case False
  have "monom_mult c t (MP_oalist xs) = MP_oalist (shift_map_keys t ((*) c) xs)"
  proof (rule poly_mapping_eqI, simp add: lookup_monom_mult del: MP_oalist.rep_eq, intro conjI impI)
    fix u
    assume "t adds\<^sub>p u"
    then obtain v where "u = t \<oplus> v" by (rule adds_ppE)
    thus "c * lookup (MP_oalist xs) (u \<ominus> t) = lookup (MP_oalist (shift_map_keys t ((*) c) xs)) u"
      by (simp add: splus_sminus lookup_shift_map_keys_plus del: MP_oalist.rep_eq)
  next
    fix u
    assume "\<not> t adds\<^sub>p u"
    have "u \<notin> keys (MP_oalist (shift_map_keys t ((*) c) xs))"
    proof
      assume "u \<in> keys (MP_oalist (shift_map_keys t ((*) c) xs))"
      also have "... \<subseteq> ((\<oplus>) t) ` keys (MP_oalist xs)" by (fact keys_shift_map_keys_subset)
      finally obtain v where "u = t \<oplus> v" ..
      hence "t adds\<^sub>p u" by (rule adds_ppI)
      with \<open>\<not> t adds\<^sub>p u\<close> show False ..
    qed
    thus "lookup (MP_oalist (shift_map_keys t ((*) c) xs)) u = 0" by (simp add: in_keys_iff)
  qed
  thus ?thesis by (simp add: False)
qed

lemma mult_scalar_MP_oalist [code]:
  "(MP_oalist xs) \<odot> (MP_oalist ys) =
      (if is_zero (MP_oalist xs) then
        MP_oalist (OAlist_empty_ntm (snd (list_of_oalist_ntm ys)))
      else
        let ct = OAlist_hd_ntm xs in
        monom_mult (snd ct) (fst ct) (MP_oalist ys) + (MP_oalist (OAlist_tl_ntm xs)) \<odot> (MP_oalist ys))"
proof (split if_split, intro conjI impI)
  assume "is_zero (MP_oalist xs)"
  thus "MP_oalist xs \<odot> MP_oalist ys = MP_oalist (OAlist_empty_ntm (snd (list_of_oalist_ntm ys)))"
    by (simp add: is_zero_def)
next
  assume "\<not> is_zero (MP_oalist xs)"
  hence *: "fst (list_of_oalist_ntm xs) \<noteq> []" by (simp add: is_zero_MP_oalist List.null_def)
  define ct where "ct = OAlist_hd_ntm xs"
  have eq: "except (MP_oalist xs) {fst ct} = MP_oalist (OAlist_tl_ntm xs)"
    by (rule poly_mapping_eqI, simp add: lookup_except ct_def oa_ntm.lookup_tl')
  have "MP_oalist xs \<odot> MP_oalist ys =
          monom_mult (lookup (MP_oalist xs) (fst ct)) (fst ct) (MP_oalist ys) +
          except (MP_oalist xs) {fst ct} \<odot> MP_oalist ys" by (fact mult_scalar_rec_left)
  also have "... = monom_mult (snd ct) (fst ct) (MP_oalist ys) + except (MP_oalist xs) {fst ct} \<odot> MP_oalist ys"
    using * by (simp add: ct_def oa_ntm.snd_hd)
  also have "... = monom_mult (snd ct) (fst ct) (MP_oalist ys) + MP_oalist (OAlist_tl_ntm xs) \<odot> MP_oalist ys"
    by (simp only: eq)
  finally show "MP_oalist xs \<odot> MP_oalist ys =
                (let ct = OAlist_hd_ntm xs in
                  monom_mult (snd ct) (fst ct) (MP_oalist ys) + MP_oalist (OAlist_tl_ntm xs) \<odot> MP_oalist ys)"
    by (simp add: ct_def Let_def)
qed

end (* ordered_nat_term *)

subsubsection \<open>Special case of addition: adding monomials\<close>

definition plus_monomial_less :: "('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::monoid_add)"
  where "plus_monomial_less p c u = p + monomial c u"

text \<open>@{const plus_monomial_less} is useful when adding a monomial to a polynomial, where the term
  of the monomial is known to be smaller than all terms in the polynomial, because it can be
  implemented more efficiently than general addition.\<close>

lemma plus_monomial_less_MP_oalist [code]:
  "plus_monomial_less (MP_oalist xs) c u = MP_oalist (OAlist_update_by_fun_gr_ntm u (\<lambda>c0. c0 + c) xs)"
  unfolding plus_monomial_less_def oa_ntm.update_by_fun_gr_eq_update_by_fun
  by (rule poly_mapping_eqI, simp add: lookup_plus_fun oa_ntm.lookup_update_by_fun lookup_single)

text \<open>@{const plus_monomial_less} is computed by @{const OAlist_update_by_fun_gr_ntm}, because greater
  terms come @{emph \<open>before\<close>} smaller ones in @{type oalist_ntm}.\<close>

subsubsection \<open>Constructors\<close>

definition "distr\<^sub>0 ko xs = MP_oalist (oalist_of_list_ntm (xs, ko))" \<comment>\<open>sparse representation\<close>

definition V\<^sub>0 :: "'a \<Rightarrow> ('a, nat) pp \<Rightarrow>\<^sub>0 'b::{one,zero}" where
  "V\<^sub>0 n \<equiv> monomial 1 (single_pp n 1)"

definition C\<^sub>0 :: "'b \<Rightarrow> ('a, nat) pp \<Rightarrow>\<^sub>0 'b::zero" where "C\<^sub>0 c \<equiv> monomial c 0"

lemma C\<^sub>0_one: "C\<^sub>0 1 = 1"
  by (simp add: C\<^sub>0_def)

lemma C\<^sub>0_numeral: "C\<^sub>0 (numeral x) = numeral x"
  by (auto intro!: poly_mapping_eqI simp: C\<^sub>0_def lookup_numeral)

lemma C\<^sub>0_minus: "C\<^sub>0 (- x) = - C\<^sub>0 x"
  by (simp add: C\<^sub>0_def single_uminus)

lemma C\<^sub>0_zero: "C\<^sub>0 0 = 0"
  by (auto intro!: poly_mapping_eqI simp: C\<^sub>0_def)

lemma V\<^sub>0_power: "V\<^sub>0 v ^ n = monomial 1 (single_pp v n)"
  by (induction n) (auto simp: V\<^sub>0_def mult_single single_pp_plus)

lemma single_MP_oalist [code]: "Poly_Mapping.single k v = distr\<^sub>0 nat_term_order_of_le [(k, v)]"
  unfolding distr\<^sub>0_def by (rule poly_mapping_eqI, simp add: lookup_single OAlist_lookup_ntm_single)

lemma one_MP_oalist [code]: "1 = distr\<^sub>0 nat_term_order_of_le [(0, 1)]"
  by (metis single_MP_oalist single_one)

lemma except_MP_oalist [code]: "except (MP_oalist xs) S = MP_oalist (OAlist_filter_ntm (\<lambda>kv. fst kv \<notin> S) xs)"
  by (rule poly_mapping_eqI, simp add: lookup_except oa_ntm.lookup_filter)

subsubsection \<open>Changing the Internal Order\<close>

definition change_ord :: "'a::nat_term_compare nat_term_order \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b)"
  where "change_ord to = (\<lambda>x. x)"

lemma change_ord_MP_oalist [code]: "change_ord to (MP_oalist xs) = MP_oalist (OAlist_reorder_ntm to xs)"
  by (rule poly_mapping_eqI, simp add: change_ord_def oa_ntm.lookup_reorder)

subsubsection \<open>Ordered Power-Products\<close>

lemma foldl_assoc:
  assumes "\<And>x y z. f (f x y) z = f x (f y z)"
  shows "foldl f (f a b) xs = f a (foldl f b xs)"
proof (induct xs arbitrary: a b)
  fix a b
  show "foldl f (f a b) [] = f a (foldl f b [])" by simp
next
  fix a b x xs
  assume "\<And>a b. foldl f (f a b) xs = f a (foldl f b xs)"
  from assms[of a b x] this[of a "f b x"]
    show "foldl f (f a b) (x # xs) = f a (foldl f b (x # xs))" unfolding foldl_Cons by simp
  qed

context gd_nat_term
begin

definition ord_pp :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "ord_pp s t = le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"

definition ord_pp_strict :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  where "ord_pp_strict s t = lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"

lemma lt_MP_oalist [code]:
  "lt (MP_oalist xs) = (if is_zero (MP_oalist xs) then min_term else fst (OAlist_min_key_val_ntm cmp_term xs))"
proof (split if_split, intro conjI impI)
  assume "is_zero (MP_oalist xs)"
  thus "lt (MP_oalist xs) = min_term" by (simp add: is_zero_def)
next
  assume "\<not> is_zero (MP_oalist xs)"
  hence "fst (list_of_oalist_ntm xs) \<noteq> []" by (simp add: is_zero_MP_oalist List.null_def)
  show "lt (MP_oalist xs) = fst (OAlist_min_key_val_ntm cmp_term xs)"
  proof (rule lt_eqI_keys)
    show "fst (OAlist_min_key_val_ntm cmp_term xs) \<in> keys (MP_oalist xs)"
      by (simp add: keys_MP_oalist, rule imageI, rule oa_ntm.min_key_val_in, fact)
  next
    fix u
    assume "u \<in> keys (MP_oalist xs)"
    also have "... = fst ` set (fst (list_of_oalist_ntm xs))" by (simp add: keys_MP_oalist)
    finally obtain z where "z \<in> set (fst (list_of_oalist_ntm xs))" and "u = fst z" ..
    from this(1) have "ko.le (key_order_of_nat_term_order_inv cmp_term) (fst (OAlist_min_key_val_ntm cmp_term xs)) u"
      unfolding \<open>u = fst z\<close> by (rule oa_ntm.min_key_val_minimal)
    thus "le_of_nat_term_order cmp_term u (fst (OAlist_min_key_val_ntm cmp_term xs))"
      by (simp add: le_of_nat_term_order_alt)
  qed
qed

lemma lc_MP_oalist [code]:
  "lc (MP_oalist xs) = (if is_zero (MP_oalist xs) then 0 else snd (OAlist_min_key_val_ntm cmp_term xs))"
proof (split if_split, intro conjI impI)
  assume "is_zero (MP_oalist xs)"
  thus "lc (MP_oalist xs) = 0" by (simp add: is_zero_def)
next
  assume "\<not> is_zero (MP_oalist xs)"
  moreover from this have "fst (list_of_oalist_ntm xs) \<noteq> []" by (simp add: is_zero_MP_oalist List.null_def)
  ultimately show "lc (MP_oalist xs) = snd (OAlist_min_key_val_ntm cmp_term xs)"
    by (simp add: lc_def lt_MP_oalist oa_ntm.snd_min_key_val)
qed

lemma tail_MP_oalist [code]: "tail (MP_oalist xs) = MP_oalist (OAlist_except_min_ntm cmp_term xs)"
proof (cases "is_zero (MP_oalist xs)")
  case True
  hence "fst (list_of_oalist_ntm xs) = []" by (simp add: is_zero_MP_oalist List.null_def)
  hence "fst (list_of_oalist_ntm (OAlist_except_min_ntm cmp_term xs)) = []"
    by (rule oa_ntm.except_min_Nil)
  hence "is_zero (MP_oalist (OAlist_except_min_ntm cmp_term xs))"
    by (simp add: is_zero_MP_oalist List.null_def)
  with True show ?thesis by (simp add: is_zero_def)
next
  case False
  show ?thesis by (rule poly_mapping_eqI, simp add: lookup_tail_2 oa_ntm.lookup_except_min' lt_MP_oalist False)
qed

definition comp_opt_p :: "('t \<Rightarrow>\<^sub>0 'c::zero, 't \<Rightarrow>\<^sub>0 'c) comp_opt"
  where "comp_opt_p p q =
              (if p = q then Some Eq else if ord_strict_p p q then Some Lt else if ord_strict_p q p then Some Gt else None)"

lemma comp_opt_p_MP_oalist [code]:
  "comp_opt_p (MP_oalist xs) (MP_oalist ys) =
    OAlist_lex_ord_ntm cmp_term (\<lambda>_ x y. if x = y then Some Eq else if x = 0 then Some Lt else if y = 0 then Some Gt else None) xs ys"
proof -
  let ?f = "\<lambda>_ x y. if x = y then Some Eq else if x = 0 then Some Lt else if y = 0 then Some Gt else None"
  show ?thesis
  proof (cases "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Eq")
    case True
    hence "MP_oalist xs = MP_oalist ys" by (simp add: comp_opt_p_def split: if_splits)
    hence "lookup (MP_oalist xs) = lookup (MP_oalist ys)" by (rule arg_cong)
    hence eq: "OAlist_lookup_ntm xs = OAlist_lookup_ntm ys" by simp
    have "OAlist_lex_ord_ntm cmp_term ?f xs ys = Some Eq"
      by (rule oa_ntm.lex_ord_EqI, simp add: eq)
    with True show ?thesis by simp
  next
    case False
    hence neq: "MP_oalist xs \<noteq> MP_oalist ys" by (simp add: comp_opt_p_def split: if_splits)
    then obtain v where 1: "v \<in> keys (MP_oalist xs) \<union> keys (MP_oalist ys)"
      and 2: "lookup (MP_oalist xs) v \<noteq> lookup (MP_oalist ys) v"
      and 3: "\<And>u. lt_of_nat_term_order cmp_term v u \<Longrightarrow> lookup (MP_oalist xs) u = lookup (MP_oalist ys) u"
      by (rule poly_mapping_neqE, blast)
    show ?thesis
    proof (rule HOL.sym, rule oa_ntm.lex_ord_valI)
      from 1 show "v \<in> fst ` set (fst (list_of_oalist_ntm xs)) \<union> fst ` set (fst (list_of_oalist_ntm ys))"
        by (simp add: keys_MP_oalist)
    next
      from 2 have 4: "OAlist_lookup_ntm xs v \<noteq> OAlist_lookup_ntm ys v" by simp
      show "comp_opt_p (MP_oalist xs) (MP_oalist ys) =
            (if OAlist_lookup_ntm xs v = OAlist_lookup_ntm ys v then Some Eq
             else if OAlist_lookup_ntm xs v = 0 then Some Lt
             else if OAlist_lookup_ntm ys v = 0 then Some Gt else None)"
      proof (simp add: 4, intro conjI impI)
        assume "OAlist_lookup_ntm ys v = 0" and "OAlist_lookup_ntm xs v = 0"
        with 4 show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Lt" by simp
      next
        assume "OAlist_lookup_ntm xs v \<noteq> 0" and "OAlist_lookup_ntm ys v = 0"
        hence "lookup (MP_oalist ys) v = 0" and "lookup (MP_oalist xs) v \<noteq> 0" by simp_all
        hence "ord_strict_p (MP_oalist ys) (MP_oalist xs)" using 3[symmetric]
          by (rule ord_strict_pI)
        with neq show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Gt" by (auto simp: comp_opt_p_def)
      next
        assume "OAlist_lookup_ntm ys v \<noteq> 0" and "OAlist_lookup_ntm xs v = 0"
        hence "lookup (MP_oalist xs) v = 0" and "lookup (MP_oalist ys) v \<noteq> 0" by simp_all
        hence "ord_strict_p (MP_oalist xs) (MP_oalist ys)" using 3 by (rule ord_strict_pI)
        with neq show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = Some Lt" by (auto simp: comp_opt_p_def)
      next
        assume "OAlist_lookup_ntm xs v \<noteq> 0"
        hence "lookup (MP_oalist xs) v \<noteq> 0" by simp
        with 2 have a: "\<not> ord_strict_p (MP_oalist xs) (MP_oalist ys)" using 3 by (rule not_ord_strict_pI)
        assume "OAlist_lookup_ntm ys v \<noteq> 0"
        hence "lookup (MP_oalist ys) v \<noteq> 0" by simp
        with 2[symmetric] have "\<not> ord_strict_p (MP_oalist ys) (MP_oalist xs)"
          using 3[symmetric] by (rule not_ord_strict_pI)
        with neq a show "comp_opt_p (MP_oalist xs) (MP_oalist ys) = None" by (auto simp: comp_opt_p_def)
      qed
    next
      fix u
      assume "ko.lt (key_order_of_nat_term_order_inv cmp_term) u v"
      hence "lt_of_nat_term_order cmp_term v u" by (simp only: lt_of_nat_term_order_alt)
      hence "lookup (MP_oalist xs) u = lookup (MP_oalist ys) u" by (rule 3)
      thus "(if OAlist_lookup_ntm xs u = OAlist_lookup_ntm ys u then Some Eq
            else if OAlist_lookup_ntm xs u = 0 then Some Lt
            else if OAlist_lookup_ntm ys u = 0 then Some Gt else None) = Some Eq" by simp
    qed fact
  qed
qed

lemma compute_ord_p [code]: "ord_p p q = (let aux = comp_opt_p p q in aux = Some Lt \<or> aux = Some Eq)"
  by (auto simp: ord_p_def comp_opt_p_def)

lemma compute_ord_p_strict [code]: "ord_strict_p p q = (comp_opt_p p q = Some Lt)"
  by (auto simp: comp_opt_p_def)

lemma keys_to_list_MP_oalist [code]: "keys_to_list (MP_oalist xs) = OAlist_sorted_domain_ntm cmp_term xs"
proof -
  have eq: "ko.lt (key_order_of_nat_term_order_inv cmp_term) = ord_term_strict_conv"
    by (intro ext, simp add: lt_of_nat_term_order_alt)
  have 1: "irreflp ord_term_strict_conv" by (rule irreflpI, simp)
  have 2: "transp ord_term_strict_conv" by (rule transpI, simp)
  have "antisymp ord_term_strict_conv" by (rule antisympI, simp)
  moreover have 3: "sorted_wrt ord_term_strict_conv (keys_to_list (MP_oalist xs))"
    unfolding keys_to_list_def by (fact pps_to_list_sorted_wrt)
  moreover note _
  moreover have 4: "sorted_wrt ord_term_strict_conv (OAlist_sorted_domain_ntm cmp_term xs)"
    unfolding eq[symmetric] by (fact oa_ntm.sorted_sorted_domain)
  ultimately show ?thesis
  proof (rule sorted_wrt_distinct_set_unique)
    from 1 2 3 show "distinct (keys_to_list (MP_oalist xs))" by (rule distinct_sorted_wrt_irrefl)
  next
    from 1 2 4 show "distinct (OAlist_sorted_domain_ntm cmp_term xs)" by (rule distinct_sorted_wrt_irrefl)
  next
    show "set (keys_to_list (MP_oalist xs)) = set (OAlist_sorted_domain_ntm cmp_term xs)"
      by (simp add: set_keys_to_list keys_MP_oalist oa_ntm.set_sorted_domain)
  qed
qed

end (* ordered_nat_term *)

lifting_update poly_mapping.lifting
lifting_forget poly_mapping.lifting

subsection \<open>Interpretations\<close>

lemma term_powerprod_gd_term:
  fixes pair_of_term :: "'t::nat_term \<Rightarrow> ('a::{graded_dickson_powerprod,nat_pp_compare} \<times> 'k::{the_min,wellorder})"
  assumes "term_powerprod pair_of_term term_of_pair"
    and "\<And>v. fst (rep_nat_term v) = rep_nat_pp (fst (pair_of_term v))"
    and "\<And>t. snd (rep_nat_term (term_of_pair (t, the_min))) = 0"
    and "\<And>v w. snd (pair_of_term v) \<le> snd (pair_of_term w) \<Longrightarrow> snd (rep_nat_term v) \<le> snd (rep_nat_term w)"
    and "\<And>s t k. term_of_pair (s + t, k) = splus (term_of_pair (s, k)) (term_of_pair (t, k))"
    and "\<And>t v. term_powerprod.splus pair_of_term term_of_pair t v = splus (term_of_pair (t, the_min)) v"
  shows "gd_term pair_of_term term_of_pair
        (\<lambda>s t. le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min)))
        (\<lambda>s t. lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min)))
        (le_of_nat_term_order cmp_term)
        (lt_of_nat_term_order cmp_term)"
proof -
  from assms(1) interpret tp: term_powerprod pair_of_term term_of_pair .
  let ?f = "\<lambda>x. term_of_pair (x, the_min)"
  show ?thesis
  proof (intro gd_term.intro ordered_term.intro)
    from assms(1) show "term_powerprod pair_of_term term_of_pair" .
  next
    show "ordered_powerprod (\<lambda>s t. le_of_nat_term_order cmp_term (?f s) (?f t))
                        (\<lambda>s t. lt_of_nat_term_order cmp_term (?f s) (?f t))"
    proof (intro ordered_powerprod.intro ordered_powerprod_axioms.intro)
      show "class.linorder (\<lambda>s t. le_of_nat_term_order cmp_term (?f s) (?f t))
                        (\<lambda>s t. lt_of_nat_term_order cmp_term (?f s) (?f t))"
      proof (unfold_locales, simp_all add: lt_of_nat_term_order_alt le_of_nat_term_order_alt ko.linear ko.less_le_not_le)
        fix x y
        assume "ko.le (key_order_of_nat_term_order_inv cmp_term) (term_of_pair (x, the_min)) (term_of_pair (y, the_min))"
          and "ko.le (key_order_of_nat_term_order_inv cmp_term) (term_of_pair (y, the_min)) (term_of_pair (x, the_min))"
        hence "term_of_pair (x, the_min) = term_of_pair (y, the_min)" by (rule ko.antisym)
        hence "(x, the_min) = (y, the_min::'k)" by (rule tp.term_of_pair_injective)
        thus "x = y" by simp
      qed
    next
      fix t
      show "le_of_nat_term_order cmp_term (?f 0) (?f t)"
        unfolding le_of_nat_term_order
        by (rule nat_term_compD1', fact comparator_nat_term_compare, fact nat_term_comp_nat_term_compare,
            simp add: assms(3), simp add: assms(2) zero_pp tp.pair_term)
    next
      fix s t u
      assume "le_of_nat_term_order cmp_term (?f s) (?f t)"
      hence "le_of_nat_term_order cmp_term (?f (u + s)) (?f (u + t))"
        by (simp add: le_of_nat_term_order assms(5) nat_term_compare_splus)
      thus "le_of_nat_term_order cmp_term (?f (s + u)) (?f (t + u))" by (simp only: ac_simps)
    qed
  next
    show "class.linorder (le_of_nat_term_order cmp_term) (lt_of_nat_term_order cmp_term)"
      by (fact linorder_le_of_nat_term_order)
  next
    show "ordered_term_axioms pair_of_term term_of_pair (\<lambda>s t. le_of_nat_term_order cmp_term (?f s) (?f t))
       (le_of_nat_term_order cmp_term)"
    proof
      fix v w t
      assume "le_of_nat_term_order cmp_term v w"
      thus "le_of_nat_term_order cmp_term (t \<oplus> v) (t \<oplus> w)"
        by (simp add: le_of_nat_term_order assms(6) nat_term_compare_splus)
    next
      fix v w
      assume "le_of_nat_term_order cmp_term (?f (tp.pp_of_term v)) (?f (tp.pp_of_term w))"
      hence 3: "nat_term_compare cmp_term (?f (tp.pp_of_term v)) (?f (tp.pp_of_term w)) \<noteq> Gt"
        by (simp add: le_of_nat_term_order)
      assume "tp.component_of_term v \<le> tp.component_of_term w"
      hence 4: "snd (rep_nat_term v) \<le> snd (rep_nat_term w)"
        by (simp add: tp.component_of_term_def assms(4))
      note comparator_nat_term_compare nat_term_comp_nat_term_compare
      moreover have "fst (rep_nat_term v) = fst (rep_nat_term (?f (tp.pp_of_term v)))"
        by (simp add: assms(2) tp.pp_of_term_def tp.pair_term)
      moreover have "fst (rep_nat_term w) = fst (rep_nat_term (?f (tp.pp_of_term w)))"
        by (simp add: assms(2) tp.pp_of_term_def tp.pair_term)
      moreover note 4
      moreover have "snd (rep_nat_term (?f (tp.pp_of_term v))) = snd (rep_nat_term (?f (tp.pp_of_term w)))"
        by (simp add: assms(3))
      ultimately show "le_of_nat_term_order cmp_term v w" unfolding le_of_nat_term_order using 3
        by (rule nat_term_compD4'')
    qed
  qed
qed

lemma gd_term_to_pair_unit:
  "gd_term (to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod} \<Rightarrow> _) fst
        (\<lambda>s t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
        (\<lambda>s t. lt_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
        (le_of_nat_term_order cmp_term)
        (lt_of_nat_term_order cmp_term)"
proof (intro gd_term.intro ordered_term.intro)
  show "term_powerprod to_pair_unit fst" by unfold_locales
next
  show "ordered_powerprod (\<lambda>s t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
                      (\<lambda>s t. lt_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))"
    unfolding fst_conv using linorder_le_of_nat_term_order
  proof (intro ordered_powerprod.intro)
    from le_of_nat_term_order_zero_min show "ordered_powerprod_axioms (le_of_nat_term_order cmp_term)"
    proof (unfold_locales)
      fix s t u
      assume "le_of_nat_term_order cmp_term s t"
      hence "le_of_nat_term_order cmp_term (u + s) (u + t)" by (rule le_of_nat_term_order_plus_monotone)
      thus "le_of_nat_term_order cmp_term (s + u) (t + u)" by (simp only: ac_simps)
    qed
  qed
next
  show "class.linorder (le_of_nat_term_order cmp_term) (lt_of_nat_term_order cmp_term)"
    by (fact linorder_le_of_nat_term_order)
next
  show "ordered_term_axioms to_pair_unit fst (\<lambda>s t. le_of_nat_term_order cmp_term (fst (s, the_min)) (fst (t, the_min)))
     (le_of_nat_term_order cmp_term)" by (unfold_locales, auto intro: le_of_nat_term_order_plus_monotone)
qed

corollary gd_nat_term_to_pair_unit:
  "gd_nat_term (to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod} \<Rightarrow> _) fst cmp_term"
  by (rule gd_nat_term.intro, fact gd_term_to_pair_unit, rule gd_nat_term_axioms.intro, simp add: splus_pp_term)

lemma gd_term_id:
  "gd_term (\<lambda>x::('a::{nat_term_compare,nat_pp_compare,nat_pp_term,graded_dickson_powerprod} \<times> 'b::{nat,the_min}). x) (\<lambda>x. x)
        (\<lambda>s t. le_of_nat_term_order cmp_term (s, the_min) (t, the_min))
        (\<lambda>s t. lt_of_nat_term_order cmp_term (s, the_min) (t, the_min))
        (le_of_nat_term_order cmp_term)
        (lt_of_nat_term_order cmp_term)"
  apply (rule term_powerprod_gd_term)
  subgoal by unfold_locales
  subgoal by (simp add: rep_nat_term_prod_def)
  subgoal by (simp add: rep_nat_term_prod_def the_min_eq_zero)
  subgoal by (simp add: rep_nat_term_prod_def ord_iff[symmetric])
  subgoal by (simp add: splus_prod_def pprod.splus_def)
  subgoal by (simp add: splus_prod_def)
  done

corollary gd_nat_term_id: "gd_nat_term (\<lambda>x. x) (\<lambda>x. x) cmp_term"
  for cmp_term :: "('a::{nat_term_compare,nat_pp_compare,nat_pp_term,graded_dickson_powerprod} \<times> 'c::{nat,the_min}) nat_term_order"
  by (rule gd_nat_term.intro, fact gd_term_id, rule gd_nat_term_axioms.intro, simp add: splus_prod_def)

subsection \<open>Computations\<close>

type_synonym 'a mpoly_tc = "(nat, nat) pp \<Rightarrow>\<^sub>0 'a"

global_interpretation punit0: gd_nat_term "to_pair_unit::'a::{nat_term_compare,nat_pp_term,graded_dickson_powerprod} \<Rightarrow> _" fst cmp_term
  rewrites "punit.adds_term = (adds)"
  and "punit.pp_of_term = (\<lambda>x. x)"
  and "punit.component_of_term = (\<lambda>_. ())"
  for cmp_term
  defines monom_mult_punit = punit.monom_mult
  and mult_scalar_punit = punit.mult_scalar
  and shift_map_keys_punit = punit0.shift_map_keys
  and ord_pp_punit = punit0.ord_pp
  and ord_pp_strict_punit = punit0.ord_pp_strict
  and min_term_punit = punit0.min_term
  and lt_punit = punit0.lt
  and lc_punit = punit0.lc
  and tail_punit = punit0.tail
  and comp_opt_p_punit = punit0.comp_opt_p
  and ord_p_punit = punit0.ord_p
  and ord_strict_p_punit = punit0.ord_strict_p
  and keys_to_list_punit = punit0.keys_to_list
  subgoal by (fact gd_nat_term_to_pair_unit)
  subgoal by (fact punit_adds_term)
  subgoal by (fact punit_pp_of_term)
  subgoal by (fact punit_component_of_term)
  done

lemma shift_map_keys_punit_MP_oalist [code abstract]:
  "list_of_oalist_ntm (shift_map_keys_punit t f xs) = map_raw (\<lambda>(k, v). (t + k, f v)) (list_of_oalist_ntm xs)"
  by (simp add: punit0.list_of_oalist_shift_keys case_prod_beta')

lemmas [code] = punit0.mult_scalar_MP_oalist[unfolded mult_scalar_punit_def punit_mult_scalar]
                punit0.punit_min_term

lemma ord_pp_punit_alt [code_unfold]: "ord_pp_punit = le_of_nat_term_order"
  by (intro ext, simp add: punit0.ord_pp_def)

lemma ord_pp_strict_punit_alt [code_unfold]: "ord_pp_strict_punit = lt_of_nat_term_order"
  by (intro ext, simp add: punit0.ord_pp_strict_def)

lemma gd_powerprod_ord_pp_punit: "gd_powerprod (ord_pp_punit cmp_term) (ord_pp_strict_punit cmp_term)"
  unfolding punit0.ord_pp_def punit0.ord_pp_strict_def ..

locale trivariate\<^sub>0_rat
begin

abbreviation X::"rat mpoly_tc" where "X \<equiv> V\<^sub>0 (0::nat)"
abbreviation Y::"rat mpoly_tc" where "Y \<equiv> V\<^sub>0 (1::nat)"
abbreviation Z::"rat mpoly_tc" where "Z \<equiv> V\<^sub>0 (2::nat)"

end

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

value [code] "X ^ 2"

value [code] "X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2"

value [code] "distr\<^sub>0 DRLEX [(sparse\<^sub>0 [(0::nat, 3::nat)], 1::rat)] = distr\<^sub>0 DRLEX [(sparse\<^sub>0 [(0, 3)], 1)]"

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

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

value [code] "min_term_punit::(nat, nat) pp"

value [code] "is_zero (distr\<^sub>0 DRLEX [(sparse\<^sub>0 [(0::nat, 3::nat)], 1::rat)])"

value [code] "lt_punit DRLEX (distr\<^sub>0 DRLEX [(sparse\<^sub>0 [(0::nat, 3::nat)], 1::rat)])"

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

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

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

lemma
  "- 1 * X\<^sup>2 * Z ^ 7 + - 2 * Y ^ 3 * Z\<^sup>2 = - X\<^sup>2 * Z ^ 7 + - 2 * Y ^ 3 * Z\<^sup>2"
  by eval

lemma
  "X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 + X\<^sup>2 * Z ^ 4 + - 2 * Y ^ 3 * Z\<^sup>2 = X\<^sup>2 * Z ^ 7 + X\<^sup>2 * Z ^ 4"
  by eval

lemma
  "X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 - X\<^sup>2 * Z ^ 4 + - 2 * Y ^ 3 * Z\<^sup>2 =
    X\<^sup>2 * Z ^ 7 - X\<^sup>2 * Z ^ 4"
  by eval

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

lemma
  "X\<^sup>2 * Z ^ 7 + 2 * Y ^ 3 * Z\<^sup>2 \<noteq>
   X\<^sup>2 * Z ^ 4 + - 2 * Y ^ 3 * Z\<^sup>2"
  by eval

lemma
  "0 * X^2 * Z^7 + 0 * Y^3*Z\<^sup>2 = 0"
  by eval

lemma
  "monom_mult_punit 3 (sparse\<^sub>0 [(1, 2::nat)]) (X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2) =
    3 * Y\<^sup>2 * Z * X\<^sup>2 + 6 * Y ^ 5 * Z\<^sup>2"
  by eval

lemma
  "monomial (-4) (sparse\<^sub>0 [(0, 2::nat)]) = - 4 * X\<^sup>2"
  by eval

lemma "monomial (0::rat) (sparse\<^sub>0 [(0::nat, 2::nat)]) = 0"
  by eval

lemma
  "(X\<^sup>2 * Z + 2 * Y ^ 3 * Z\<^sup>2) * (X\<^sup>2 * Z ^ 3 + - 2 * Y ^ 3 * Z\<^sup>2) =
    X ^ 4 * Z ^ 4 + - 2 * X\<^sup>2 * Z ^ 3 * Y ^ 3 +
 - 4 * Y ^ 6 * Z ^ 4 + 2 * Y ^ 3 * Z ^ 5 * X\<^sup>2"
  by eval

end

subsection \<open>Code setup for type MPoly\<close>

text \<open>postprocessing from \<open>Var\<^sub>0, Const\<^sub>0\<close> to \<open>Var, Const\<close>.\<close>

lemmas [code_post] =
  plus_mpoly.abs_eq[symmetric]
  times_mpoly.abs_eq[symmetric]
  one_mpoly_def[symmetric]
  Var.abs_eq[symmetric]
  Const.abs_eq[symmetric]

instantiation mpoly::("{equal, zero}")equal begin

lift_definition equal_mpoly:: "'a mpoly \<Rightarrow> 'a mpoly \<Rightarrow> bool" is HOL.equal .

instance proof standard qed (transfer, rule equal_eq)

end

end (* theory *)


(*  Title:      ZF/Induct/Term.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section {* Terms over an alphabet *}

theory Term imports Main begin

text {*
  Illustrates the list functor (essentially the same type as in @{text
  Trees_Forest}).
*}

consts
  "term" :: "i => i"

datatype "term(A)" = Apply ("a \<in> A", "l \<in> list(term(A))")
  monos list_mono
  type_elims list_univ [THEN subsetD, elim_format]

declare Apply [TC]

definition
  term_rec :: "[i, [i, i, i] => i] => i"  where
  "term_rec(t,d) ==
    Vrec(t, \<lambda>t g. term_case(\<lambda>x zs. d(x, zs, map(\<lambda>z. g`z, zs)), t))"

definition
  term_map :: "[i => i, i] => i"  where
  "term_map(f,t) == term_rec(t, \<lambda>x zs rs. Apply(f(x), rs))"

definition
  term_size :: "i => i"  where
  "term_size(t) == term_rec(t, \<lambda>x zs rs. succ(list_add(rs)))"

definition
  reflect :: "i => i"  where
  "reflect(t) == term_rec(t, \<lambda>x zs rs. Apply(x, rev(rs)))"

definition
  preorder :: "i => i"  where
  "preorder(t) == term_rec(t, \<lambda>x zs rs. Cons(x, flat(rs)))"

definition
  postorder :: "i => i"  where
  "postorder(t) == term_rec(t, \<lambda>x zs rs. flat(rs) @ [x])"

lemma term_unfold: "term(A) = A * list(term(A))"
  by (fast intro!: term.intros [unfolded term.con_defs]
    elim: term.cases [unfolded term.con_defs])

lemma term_induct2:
  "[| t \<in> term(A);
      !!x.      [| x \<in> A |] ==> P(Apply(x,Nil));
      !!x z zs. [| x \<in> A;  z \<in> term(A);  zs: list(term(A));  P(Apply(x,zs))
                |] ==> P(Apply(x, Cons(z,zs)))
     |] ==> P(t)"
  -- {* Induction on @{term "term(A)"} followed by induction on @{term list}. *}
  apply (induct_tac t)
  apply (erule list.induct)
   apply (auto dest: list_CollectD)
  done

lemma term_induct_eqn [consumes 1, case_names Apply]:
  "[| t \<in> term(A);
      !!x zs. [| x \<in> A;  zs: list(term(A));  map(f,zs) = map(g,zs) |] ==>
              f(Apply(x,zs)) = g(Apply(x,zs))
   |] ==> f(t) = g(t)"
  -- {* Induction on @{term "term(A)"} to prove an equation. *}
  apply (induct_tac t)
  apply (auto dest: map_list_Collect list_CollectD)
  done

text {*
  \medskip Lemmas to justify using @{term "term"} in other recursive
  type definitions.
*}

lemma term_mono: "A \<subseteq> B ==> term(A) \<subseteq> term(B)"
  apply (unfold term.defs)
  apply (rule lfp_mono)
    apply (rule term.bnd_mono)+
  apply (rule univ_mono basic_monos| assumption)+
  done

lemma term_univ: "term(univ(A)) \<subseteq> univ(A)"
  -- {* Easily provable by induction also *}
  apply (unfold term.defs term.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply safe
  apply (assumption | rule Pair_in_univ list_univ [THEN subsetD])+
  done

lemma term_subset_univ: "A \<subseteq> univ(B) ==> term(A) \<subseteq> univ(B)"
  apply (rule subset_trans)
   apply (erule term_mono)
  apply (rule term_univ)
  done

lemma term_into_univ: "[| t \<in> term(A);  A \<subseteq> univ(B) |] ==> t \<in> univ(B)"
  by (rule term_subset_univ [THEN subsetD])

text {*
  \medskip @{text term_rec} -- by @{text Vset} recursion.
*}

lemma map_lemma: "[| l \<in> list(A);  Ord(i);  rank(l)<i |]
    ==> map(\<lambda>z. (\<lambda>x \<in> Vset(i).h(x)) ` z, l) = map(h,l)"
  -- {* @{term map} works correctly on the underlying list of terms. *}
  apply (induct set: list)
   apply simp
  apply (subgoal_tac "rank (a) <i & rank (l) < i")
   apply (simp add: rank_of_Ord)
  apply (simp add: list.con_defs)
  apply (blast dest: rank_rls [THEN lt_trans])
  done

lemma term_rec [simp]: "ts \<in> list(A) ==>
  term_rec(Apply(a,ts), d) = d(a, ts, map (\<lambda>z. term_rec(z,d), ts))"
  -- {* Typing premise is necessary to invoke @{text map_lemma}. *}
  apply (rule term_rec_def [THEN def_Vrec, THEN trans])
  apply (unfold term.con_defs)
  apply (simp add: rank_pair2 map_lemma)
  done

lemma term_rec_type:
  assumes t: "t \<in> term(A)"
    and a: "!!x zs r. [| x \<in> A;  zs: list(term(A));
                   r \<in> list(\<Union>t \<in> term(A). C(t)) |]
                ==> d(x, zs, r): C(Apply(x,zs))"
  shows "term_rec(t,d) \<in> C(t)"
  -- {* Slightly odd typing condition on @{text r} in the second premise! *}
  using t
  apply induct
  apply (frule list_CollectD)
  apply (subst term_rec)
   apply (assumption | rule a)+
  apply (erule list.induct)
   apply auto
  done

lemma def_term_rec:
  "[| !!t. j(t)==term_rec(t,d);  ts: list(A) |] ==>
    j(Apply(a,ts)) = d(a, ts, map(\<lambda>Z. j(Z), ts))"
  apply (simp only:)
  apply (erule term_rec)
  done

lemma term_rec_simple_type [TC]:
  "[| t \<in> term(A);
      !!x zs r. [| x \<in> A;  zs: list(term(A));  r \<in> list(C) |]
                ==> d(x, zs, r): C
   |] ==> term_rec(t,d) \<in> C"
  apply (erule term_rec_type)
  apply (drule subset_refl [THEN UN_least, THEN list_mono, THEN subsetD])
  apply simp
  done

text {*
  \medskip @{term term_map}.
*}

lemma term_map [simp]:
  "ts \<in> list(A) ==>
    term_map(f, Apply(a, ts)) = Apply(f(a), map(term_map(f), ts))"
  by (rule term_map_def [THEN def_term_rec])

lemma term_map_type [TC]:
    "[| t \<in> term(A);  !!x. x \<in> A ==> f(x): B |] ==> term_map(f,t) \<in> term(B)"
  apply (unfold term_map_def)
  apply (erule term_rec_simple_type)
  apply fast
  done

lemma term_map_type2 [TC]:
    "t \<in> term(A) ==> term_map(f,t) \<in> term({f(u). u \<in> A})"
  apply (erule term_map_type)
  apply (erule RepFunI)
  done

text {*
  \medskip @{term term_size}.
*}

lemma term_size [simp]:
    "ts \<in> list(A) ==> term_size(Apply(a, ts)) = succ(list_add(map(term_size, ts)))"
  by (rule term_size_def [THEN def_term_rec])

lemma term_size_type [TC]: "t \<in> term(A) ==> term_size(t) \<in> nat"
  by (auto simp add: term_size_def)

text {*
  \medskip @{text reflect}.
*}

lemma reflect [simp]:
    "ts \<in> list(A) ==> reflect(Apply(a, ts)) = Apply(a, rev(map(reflect, ts)))"
  by (rule reflect_def [THEN def_term_rec])

lemma reflect_type [TC]: "t \<in> term(A) ==> reflect(t) \<in> term(A)"
  by (auto simp add: reflect_def)

text {*
  \medskip @{text preorder}.
*}

lemma preorder [simp]:
    "ts \<in> list(A) ==> preorder(Apply(a, ts)) = Cons(a, flat(map(preorder, ts)))"
  by (rule preorder_def [THEN def_term_rec])

lemma preorder_type [TC]: "t \<in> term(A) ==> preorder(t) \<in> list(A)"
  by (simp add: preorder_def)

text {*
  \medskip @{text postorder}.
*}

lemma postorder [simp]:
    "ts \<in> list(A) ==> postorder(Apply(a, ts)) = flat(map(postorder, ts)) @ [a]"
  by (rule postorder_def [THEN def_term_rec])

lemma postorder_type [TC]: "t \<in> term(A) ==> postorder(t) \<in> list(A)"
  by (simp add: postorder_def)

text {*
  \medskip Theorems about @{text term_map}.
*}

declare map_compose [simp]

lemma term_map_ident: "t \<in> term(A) ==> term_map(\<lambda>u. u, t) = t"
  by (induct rule: term_induct_eqn) simp

lemma term_map_compose:
    "t \<in> term(A) ==> term_map(f, term_map(g,t)) = term_map(\<lambda>u. f(g(u)), t)"
  by (induct rule: term_induct_eqn) simp

lemma term_map_reflect:
    "t \<in> term(A) ==> term_map(f, reflect(t)) = reflect(term_map(f,t))"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric])

text {*
  \medskip Theorems about @{text term_size}.
*}

lemma term_size_term_map: "t \<in> term(A) ==> term_size(term_map(f,t)) = term_size(t)"
  by (induct rule: term_induct_eqn) simp

lemma term_size_reflect: "t \<in> term(A) ==> term_size(reflect(t)) = term_size(t)"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib [symmetric] list_add_rev)

lemma term_size_length: "t \<in> term(A) ==> term_size(t) = length(preorder(t))"
  by (induct rule: term_induct_eqn) (simp add: length_flat)

text {*
  \medskip Theorems about @{text reflect}.
*}

lemma reflect_reflect_ident: "t \<in> term(A) ==> reflect(reflect(t)) = t"
  by (induct rule: term_induct_eqn) (simp add: rev_map_distrib)

text {*
  \medskip Theorems about preorder.
*}

lemma preorder_term_map:
    "t \<in> term(A) ==> preorder(term_map(f,t)) = map(f, preorder(t))"
  by (induct rule: term_induct_eqn) (simp add: map_flat)

lemma preorder_reflect_eq_rev_postorder:
    "t \<in> term(A) ==> preorder(reflect(t)) = rev(postorder(t))"
  by (induct rule: term_induct_eqn)
    (simp add: rev_app_distrib rev_flat rev_map_distrib [symmetric])

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory WorkerWrapperNew
imports
  HOLCF
  FixedPointTheorems
  WorkerWrapper
begin

(*>*)
section{* A totally-correct fusion rule *}

text{*
\label{sec:ww-fixed}

We now show that a termination-preserving worker/wrapper fusion rule
can be obtained by requiring @{term "unwrap"} to be strict. (As we
observed earlier, @{term "wrap"} must always be strict due to the
assumption that @{text "wrap oo unwrap = ID"}.)

Our first result shows that a combined worker/wrapper transformation
and fusion rule is sound, using the assumptions of @{text
"worker_wrapper_id"} and the ubiquitous @{text "lfp_fusion"} rule.

*}

lemma worker_wrapper_fusion_new:
  fixes wrap :: "'b::pcpo \<rightarrow> 'a::pcpo"
  fixes unwrap :: "'a \<rightarrow> 'b"
  fixes body' :: "'b \<rightarrow> 'b"
  assumes wrap_unwrap: "wrap oo unwrap = (ID :: 'a \<rightarrow> 'a)"
  assumes unwrap_strict: "unwrap\<cdot>\<bottom> = \<bottom>"
  assumes body_body': "unwrap oo body oo wrap = body' oo (unwrap oo wrap)"
  shows "fix\<cdot>body = wrap\<cdot>(fix\<cdot>body')"
proof -
  from body_body'
  have "unwrap oo body oo (wrap oo unwrap) = (body' oo unwrap oo (wrap oo unwrap))"
    by (simp add: assoc_oo)
  with wrap_unwrap have "unwrap oo body = body' oo unwrap"
    by simp
  with unwrap_strict have "unwrap\<cdot>(fix\<cdot>body) = fix\<cdot>body'"
    by (rule lfp_fusion)
  hence "(wrap oo unwrap)\<cdot>(fix\<cdot>body) = wrap\<cdot>(fix\<cdot>body')"
    by simp
  with wrap_unwrap show ?thesis by simp
qed

text{*

We can also show a more general result which allows fusion to be
optionally performed on a per-recursive-call basis using
\texttt{parallel\_fix\_ind}:

*}

lemma worker_wrapper_fusion_new_general:
  fixes wrap :: "'b::pcpo \<rightarrow> 'a::pcpo"
  fixes unwrap :: "'a \<rightarrow> 'b"
  assumes wrap_unwrap: "wrap oo unwrap = (ID :: 'a \<rightarrow> 'a)"
  assumes unwrap_strict: "unwrap\<cdot>\<bottom> = \<bottom>"
  assumes body_body': "\<And>r. (unwrap oo wrap)\<cdot>r = r
                        \<Longrightarrow> (unwrap oo body oo wrap)\<cdot>r = body'\<cdot>r"
  shows "fix\<cdot>body = wrap\<cdot>(fix\<cdot>body')"
proof -
  let ?P = "\<lambda>(x, y). x = y \<and> unwrap\<cdot>(wrap\<cdot>x) = x"
  have "?P (fix\<cdot>(unwrap oo body oo wrap), (fix\<cdot>body'))"
  proof(induct rule: parallel_fix_ind)
    case 2 with retraction_strict unwrap_strict wrap_unwrap show "?P (\<bottom>, \<bottom>)"
      by (bestsimp simp add: cfun_eq_iff)
    case (3 x y)
    hence xy: "x = y" and unwrap_wrap: "unwrap\<cdot>(wrap\<cdot>x) = x" by auto
    from body_body' xy unwrap_wrap
    have "(unwrap oo body oo wrap)\<cdot>x = body'\<cdot>y"
      by simp
    moreover
    from wrap_unwrap
    have "unwrap\<cdot>(wrap\<cdot>((unwrap oo body oo wrap)\<cdot>x)) = (unwrap oo body oo wrap)\<cdot>x"
      by (simp add: cfun_eq_iff)
    ultimately show ?case by simp
  qed simp
  thus ?thesis
    using worker_wrapper_id[OF wrap_unwrap refl] by simp
qed

text{*

This justifies the syntactically-oriented rules shown in
Figure~\ref{fig:wwc2}; note the scoping of the fusion rule.

Those familiar with the ``bananas'' work of \citet*{barbed-wire:1991}
will not be surprised that adding a strictness assumption justifies an
equational fusion rule.

\begin{figure}[tb]
 \begin{center}
  \fbox{\parbox{0.96\textwidth}{For a recursive definition @{haskell "comp =
      body"} of type @{haskell "A"} and a pair of functions @{haskell "wrap :: B \\to A"}
      and @{haskell "unwrap :: A \\to B"} where @{haskell "wrap \\circ unwrap = id_A"} and
      @{haskell "unwrap\\ \\bot = \\bot"}, define:

      \parbox{0.35\textwidth}{\begin{haskell}
        comp & = wrap\ work\\
        work & = unwrap\ (body[wrap\ work / comp])
      \end{haskell}}\hfill \textsf{(the worker/wrapper transformation)}

    In the scope of @{haskell "work"}, the following rewrite is admissable:

    \parbox{0.35\textwidth}{\begin{haskell}
        unwrap\ (wrap\ work) \Longrightarrow work
      \end{haskell}}\hfill \textsf{(worker/wrapper fusion)}}}%
 \end{center}%
\caption{The syntactic worker/wrapper transformation and fusion rule.}\label{fig:wwc2}
\end{figure}

*}

(*<*)
end
(*>*)


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Strong_Sim_Pres
  imports Strong_Sim
begin

lemma actPres:
  fixes P    :: ccs
  and   Q    :: ccs
  and   Rel  :: "(ccs \<times> ccs) set"
  and   a    :: name
  and   Rel' :: "(ccs \<times> ccs) set"

  assumes "(P, Q) \<in> Rel"

  shows "\<alpha>.(P) \<leadsto>[Rel] \<alpha>.(Q)"
using assms
by(fastforce simp add: simulation_def elim: actCases intro: Action)

lemma sumPres:
  fixes P   :: ccs
  and   Q   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"

  assumes "P \<leadsto>[Rel] Q"
  and     "Rel \<subseteq> Rel'"
  and     "Id \<subseteq> Rel'"

  shows "P \<oplus> R \<leadsto>[Rel'] Q \<oplus> R"
using assms
by(force simp add: simulation_def elim: sumCases intro: Sum1 Sum2)

lemma parPresAux:
  fixes P   :: ccs
  and   Q   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"

  assumes "P \<leadsto>[Rel] Q"
  and     "(P, Q) \<in> Rel"
  and     "R \<leadsto>[Rel'] T"
  and     "(R, T) \<in> Rel'"
  and     C1: "\<And>P' Q' R' T'. \<lbrakk>(P', Q') \<in> Rel; (R', T') \<in> Rel'\<rbrakk> \<Longrightarrow> (P' \<parallel> R', Q' \<parallel> T') \<in> Rel''"

  shows "P \<parallel> R \<leadsto>[Rel''] Q \<parallel> T"
proof(induct rule: simI)
  case(Sim a QT)
  from `Q \<parallel> T \<longmapsto>a \<prec> QT`
  show ?case
  proof(induct rule: parCases)
    case(cPar1 Q')
    from `P \<leadsto>[Rel] Q` `Q \<longmapsto>a \<prec> Q'` obtain P' where "P \<longmapsto>a \<prec> P'" and "(P', Q') \<in> Rel"
      by(rule simE)
    from `P \<longmapsto>a \<prec> P'` have "P \<parallel> R \<longmapsto>a \<prec> P' \<parallel> R" by(rule Par1)
    moreover from `(P', Q') \<in> Rel` `(R, T) \<in> Rel'` have "(P' \<parallel> R, Q' \<parallel> T) \<in> Rel''" by(rule C1)
    ultimately show ?case by blast
  next
    case(cPar2 T')
    from `R \<leadsto>[Rel'] T` `T \<longmapsto>a \<prec> T'` obtain R' where "R \<longmapsto>a \<prec> R'" and "(R', T') \<in> Rel'"
      by(rule simE)
    from `R \<longmapsto>a \<prec> R'` have "P \<parallel> R \<longmapsto>a \<prec> P \<parallel> R'" by(rule Par2)
    moreover from `(P, Q) \<in> Rel` `(R', T') \<in> Rel'` have "(P \<parallel> R', Q \<parallel> T') \<in> Rel''" by(rule C1)
    ultimately show ?case by blast
  next
    case(cComm Q' T' a)
    from `P \<leadsto>[Rel] Q` `Q \<longmapsto>a \<prec> Q'` obtain P' where "P \<longmapsto>a \<prec> P'" and "(P', Q') \<in> Rel"
      by(rule simE)
    from `R \<leadsto>[Rel'] T` `T \<longmapsto>(coAction a) \<prec> T'` obtain R' where "R \<longmapsto>(coAction a) \<prec> R'" and "(R', T') \<in> Rel'"
      by(rule simE)
    from `P \<longmapsto>a \<prec> P'` `R \<longmapsto>(coAction a) \<prec> R'` `a \<noteq> \<tau>` have "P \<parallel> R \<longmapsto>\<tau> \<prec> P' \<parallel> R'" by(rule Comm)
    moreover from `(P', Q') \<in> Rel` `(R', T') \<in> Rel'` have "(P' \<parallel> R', Q' \<parallel> T') \<in> Rel''" by(rule C1)
    ultimately show ?case by blast
  qed
qed

lemma parPres:
  fixes P   :: ccs
  and   Q   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"

  assumes "P \<leadsto>[Rel] Q"
  and     "(P, Q) \<in> Rel"
  and     C1: "\<And>S T U. (S, T) \<in> Rel \<Longrightarrow> (S \<parallel> U, T \<parallel> U) \<in> Rel'"

  shows "P \<parallel> R \<leadsto>[Rel'] Q \<parallel> R"
using assms
by(rule_tac parPresAux[where Rel''=Rel' and Rel'=Id]) (auto intro: reflexive)

  assumes "P \<leadsto>[Rel] Q"
  and     "\<And>R S y. (R, S) \<in> Rel \<Longrightarrow> (\<lparr>\<nu>y\<rparr>R, \<lparr>\<nu>y\<rparr>S) \<in> Rel'"

  shows "\<lparr>\<nu>x\<rparr>P \<leadsto>[Rel'] \<lparr>\<nu>x\<rparr>Q"
using assms
by(fastforce simp add: simulation_def elim: resCases intro: Res)

  assumes "(P, Q) \<in> Rel"
  and     C1: "\<And>R S. (R, S) \<in> Rel \<Longrightarrow> R \<leadsto>[Rel] S"

  shows "!P \<leadsto>[bangRel Rel] !Q"
proof(induct rule: simI)
  case(Sim \<alpha> Q')
  {
    fix Pa \<alpha> Q'
    assume "!Q \<longmapsto>\<alpha> \<prec> Q'" and "(Pa, !Q) \<in> bangRel Rel"
    hence "\<exists>P'. Pa \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> bangRel Rel"
    proof(nominal_induct arbitrary: Pa rule: bangInduct)
      case(cPar1 \<alpha> Q')
      from `(Pa, Q \<parallel> !Q) \<in> bangRel Rel`
      show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        from `(P, Q) \<in> Rel` have "P \<leadsto>[Rel] Q" by(rule C1)
        with `Q \<longmapsto>\<alpha> \<prec> Q'` obtain P' where "P \<longmapsto>\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
          by(blast dest: simE)
        from `P \<longmapsto>\<alpha> \<prec> P'` have "P \<parallel> R \<longmapsto>\<alpha> \<prec> P' \<parallel> R" by(rule Par1)
        moreover from `(P', Q') \<in> Rel` `(R, !Q) \<in> bangRel Rel` have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel"
          by(rule bangRel.BRPar)
        ultimately show ?case by blast
      qed
    next
      case(cPar2 \<alpha> Q')
      from `(Pa, Q \<parallel> !Q) \<in> bangRel Rel`
      show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        from `(R, !Q) \<in> bangRel Rel` obtain R' where "R \<longmapsto>\<alpha> \<prec> R'" and "(R', Q') \<in> bangRel Rel" using cPar2
          by blast
        from `R \<longmapsto>\<alpha> \<prec> R'` have "P \<parallel> R \<longmapsto>\<alpha> \<prec> P \<parallel> R'" by(rule Par2)
        moreover from `(P, Q) \<in> Rel` `(R', Q') \<in> bangRel Rel` have "(P \<parallel> R', Q \<parallel> Q') \<in> bangRel Rel" by(rule bangRel.BRPar)
        ultimately show ?case by blast
      qed
    next
      case(cComm a Q' Q'' Pa)
      from `(Pa, Q \<parallel> !Q) \<in> bangRel Rel`
      show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        from `(P, Q) \<in> Rel` have "P \<leadsto>[Rel] Q" by(rule C1)
        with `Q \<longmapsto>a \<prec> Q'` obtain P' where "P \<longmapsto>a \<prec> P'" and "(P', Q') \<in> Rel"
          by(blast dest: simE)
        from `(R, !Q) \<in> bangRel Rel` obtain R' where "R \<longmapsto>(coAction a) \<prec> R'" and "(R', Q'') \<in> bangRel Rel" using cComm
          by blast
        from `P \<longmapsto>a \<prec> P'` `R \<longmapsto>(coAction a) \<prec> R'` `a \<noteq> \<tau>` have "P \<parallel> R \<longmapsto>\<tau> \<prec> P' \<parallel> R'" by(rule Comm)
        moreover from `(P', Q') \<in> Rel` `(R', Q'') \<in> bangRel Rel` have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> bangRel Rel" by(rule bangRel.BRPar)
        ultimately show ?case by blast
      qed
    next
      case(cBang \<alpha> Q' Pa)
      from `(Pa, !Q) \<in> bangRel Rel`
      show ?case
      proof(induct rule: BRBangCases)
        case(BRBang P)
        from `(P, Q) \<in> Rel` have "(!P, !Q) \<in> bangRel Rel" by(rule bangRel.BRBang)
        with `(P, Q) \<in> Rel` have "(P \<parallel> !P, Q \<parallel> !Q) \<in> bangRel Rel" by(rule bangRel.BRPar)
        then obtain P' where "P \<parallel> !P \<longmapsto>\<alpha> \<prec> P'" and "(P', Q') \<in> bangRel Rel" using cBang
          by blast
        from `P \<parallel> !P \<longmapsto>\<alpha> \<prec> P'` have "!P \<longmapsto>\<alpha> \<prec> P'" by(rule Bang)
        thus ?case using `(P', Q') \<in> bangRel Rel` by blast
      qed
    qed
  }

  moreover from `(P, Q) \<in> Rel` have "(!P, !Q) \<in> bangRel Rel" by(rule BRBang)
  ultimately show ?case using `!Q \<longmapsto> \<alpha> \<prec> Q'` by blast
qed

end


(*  Title:      Jinja/Compiler/Correctness1.thy
    Author:     Tobias Nipkow
    Copyright   TUM 2003
*)

section \<open>Correctness of Stage 1\<close>

theory Correctness1
imports J1WellForm Compiler1
begin

subsection\<open>Correctness of program compilation\<close>

primrec unmod :: "expr\<^sub>1 \<Rightarrow> nat \<Rightarrow> bool"
  and unmods :: "expr\<^sub>1 list \<Rightarrow> nat \<Rightarrow> bool" where
"unmod (new C) i = True" |
"unmod (Cast C e) i = unmod e i" |
"unmod (Val v) i = True" |
"unmod (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) i = (unmod e\<^sub>1 i \<and> unmod e\<^sub>2 i)" |
"unmod (Var i) j = True" |
"unmod (i:=e) j = (i \<noteq> j \<and> unmod e j)" |
"unmod (e\<bullet>F{D}) i = unmod e i" |
"unmod (e\<^sub>1\<bullet>F{D}:=e\<^sub>2) i = (unmod e\<^sub>1 i \<and> unmod e\<^sub>2 i)" |
"unmod (e\<bullet>M(es)) i = (unmod e i \<and> unmods es i)" |
"unmod {j:T; e} i = unmod e i" |
"unmod (e\<^sub>1;;e\<^sub>2) i = (unmod e\<^sub>1 i \<and>  unmod e\<^sub>2 i)" |
"unmod (if (e) e\<^sub>1 else e\<^sub>2) i = (unmod e i \<and> unmod e\<^sub>1 i \<and> unmod e\<^sub>2 i)" |
"unmod (while (e) c) i = (unmod e i \<and> unmod c i)" |
"unmod (throw e) i = unmod e i" |
"unmod (try e\<^sub>1 catch(C i) e\<^sub>2) j = (unmod e\<^sub>1 j \<and> (if i=j then False else unmod e\<^sub>2 j))" |

"unmods ([]) i = True" |
"unmods (e#es) i = (unmod e i \<and> unmods es i)"

lemma hidden_unmod: "\<And>Vs. hidden Vs i \<Longrightarrow> unmod (compE\<^sub>1 Vs e) i" and
 "\<And>Vs. hidden Vs i \<Longrightarrow> unmods (compEs\<^sub>1 Vs es) i"
(*<*)
proof(induct e and es rule: compE\<^sub>1.induct compEs\<^sub>1.induct)
  case TryCatch
  then show ?case by(simp add:hidden_inacc)(auto simp add:hidden_def)
qed (simp_all add:hidden_inacc)
(*>*)

lemma eval\<^sub>1_preserves_unmod:
  "\<lbrakk> P \<turnstile>\<^sub>1 \<langle>e,(h,ls)\<rangle> \<Rightarrow> \<langle>e',(h',ls')\<rangle>; unmod e i; i < size ls \<rbrakk>
  \<Longrightarrow> ls ! i = ls' ! i"
and "\<lbrakk> P \<turnstile>\<^sub>1 \<langle>es,(h,ls)\<rangle> [\<Rightarrow>] \<langle>es',(h',ls')\<rangle>; unmods es i; i < size ls \<rbrakk>
      \<Longrightarrow> ls ! i = ls' ! i"
(*<*)
proof(induct rule:eval\<^sub>1_evals\<^sub>1_inducts)
qed(auto dest!:eval\<^sub>1_preserves_len evals\<^sub>1_preserves_len split:if_split_asm)
(*>*)

lemma LAss_lem:
  "\<lbrakk>x \<in> set xs; size xs \<le> size ys \<rbrakk>
  \<Longrightarrow> m\<^sub>1 \<subseteq>\<^sub>m m\<^sub>2(xs[\<mapsto>]ys) \<Longrightarrow> m\<^sub>1(x\<mapsto>y) \<subseteq>\<^sub>m m\<^sub>2(xs[\<mapsto>]ys[last_index xs x := y])"
(*<*)
by(simp add:map_le_def fun_upds_apply eq_sym_conv)
(*>*)
lemma Block_lem:
fixes l :: "'a \<rightharpoonup> 'b"
assumes 0: "l \<subseteq>\<^sub>m [Vs [\<mapsto>] ls]"
    and 1: "l' \<subseteq>\<^sub>m [Vs [\<mapsto>] ls', V\<mapsto>v]"
    and hidden: "V \<in> set Vs \<Longrightarrow> ls ! last_index Vs V = ls' ! last_index Vs V"
    and size: "size ls = size ls'"    "size Vs < size ls'"
shows "l'(V := l V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls']"
(*<*)
proof -
  have "l'(V := l V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls', V\<mapsto>v](V := l V)"
    using 1 by(rule map_le_upd)
  also have "\<dots> = [Vs [\<mapsto>] ls'](V := l V)" by simp
  also have "\<dots> \<subseteq>\<^sub>m [Vs [\<mapsto>] ls']"
  proof (cases "l V")
    case None thus ?thesis by simp
  next
    case (Some w)
    hence "[Vs [\<mapsto>] ls] V = Some w"
      using 0 by(force simp add: map_le_def split:if_splits)
    hence VinVs: "V \<in> set Vs" and w: "w = ls ! last_index Vs V"
      using size by(auto simp add:fun_upds_apply split:if_splits)
    hence "w = ls' ! last_index Vs V" using hidden[OF VinVs] by simp
    hence "[Vs [\<mapsto>] ls'](V := l V) = [Vs [\<mapsto>] ls']" using Some size VinVs
      by(simp add: map_upds_upd_conv_last_index)
    thus ?thesis by simp
  qed
  finally show ?thesis .
qed
(*>*)

(*<*)
declare fun_upd_apply[simp del]
(*>*)

text\<open>\noindent The main theorem:\<close>

and evals\<^sub>1_evals: "P \<turnstile> \<langle>es,(h,l)\<rangle> [\<Rightarrow>] \<langle>es',(h',l')\<rangle>
    \<Longrightarrow> (\<And>Vs ls. \<lbrakk> fvs es \<subseteq> set Vs;  l \<subseteq>\<^sub>m [Vs[\<mapsto>]ls]; size Vs + max_varss es \<le> size ls \<rbrakk>
         \<Longrightarrow> \<exists>ls'. compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compEs\<^sub>1 Vs es,(h,ls)\<rangle> [\<Rightarrow>] \<langle>compEs\<^sub>1 Vs es',(h',ls')\<rangle> \<and>
                      l' \<subseteq>\<^sub>m [Vs[\<mapsto>]ls'])"
(*<*)
  (is "_ \<Longrightarrow> (\<And>Vs ls. PROP ?Ps es h l es' h' l' Vs ls)"
   is "_ \<Longrightarrow> (\<And>Vs ls. \<lbrakk> _; _; _\<rbrakk> \<Longrightarrow> \<exists>ls'. ?Posts es h l es' h' l' Vs ls ls')")
proof (induct rule:eval_evals_inducts)
  case Nil thus ?case by(fastforce intro!:Nil\<^sub>1)
next
  case (Cons e h l v h' l' es es' h\<^sub>2 l\<^sub>2)
  have "PROP ?P e h l (Val v) h' l' Vs ls" by fact
  with Cons.prems
  obtain ls' where 1: "?Post e h l (Val v) h' l' Vs ls ls'"
    "size ls = size ls'" by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?Ps es h' l' es' h\<^sub>2 l\<^sub>2 Vs ls'" by fact
  with 1 Cons.prems
  obtain ls\<^sub>2 where 2: "?Posts es h' l' es' h\<^sub>2 l\<^sub>2 Vs ls' ls\<^sub>2" by(auto)
  from 1 2 Cons show ?case by(auto intro!:Cons\<^sub>1)
next
  case ConsThrow thus ?case
    by(fastforce intro!:ConsThrow\<^sub>1 dest: eval_final)
next
  case (Block e h l V e' h' l' T)
  let ?Vs = "Vs @ [V]"
  have IH:
  "\<lbrakk>fv e \<subseteq> set ?Vs; l(V := None) \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls];
    size ?Vs + max_vars e \<le> size ls\<rbrakk>
   \<Longrightarrow> \<exists>ls'. compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 ?Vs e,(h,ls)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h', ls')\<rangle> \<and>
             l' \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls']" and
  fv: "fv {V:T; e} \<subseteq> set Vs" and rel: "l \<subseteq>\<^sub>m [Vs [\<mapsto>] ls]" and
  len: "length Vs + max_vars {V:T; e} \<le> length ls" by fact+
  have len': "length Vs < length ls" using len by auto
  have "fv e \<subseteq> set ?Vs" using fv by auto
  moreover have "l(V := None) \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls]" using rel len' by simp
  moreover have "size ?Vs + max_vars e \<le> size ls" using len by simp
  ultimately obtain ls' where
   1: "compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 ?Vs e,(h,ls)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h',ls')\<rangle>"
   and rel': "l' \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls']" using IH by blast
  have [simp]: "length ls = length ls'" by(rule eval\<^sub>1_preserves_len[OF 1])
  show "\<exists>ls'. compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs {V:T; e},(h,ls)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h',ls')\<rangle>
              \<and> l'(V := l V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls']" (is "\<exists>ls'. ?R ls'")
  proof
    show "?R ls'"
    proof
      show "compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs {V:T; e},(h,ls)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h',ls')\<rangle>"
        using 1 by(simp add:Block\<^sub>1)
    next
      show "l'(V := l V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls']"
      proof -
        have "l' \<subseteq>\<^sub>m [Vs [\<mapsto>] ls', V \<mapsto> ls' ! length Vs]"
          using len' rel' by simp
        moreover
        { assume VinVs: "V \<in> set Vs"
          hence "hidden (Vs @ [V]) (last_index Vs V)"
            by(rule hidden_last_index)
          hence "unmod (compE\<^sub>1 (Vs @ [V]) e) (last_index Vs V)"
            by(rule hidden_unmod)
          moreover have "last_index Vs V < length ls"
            using len' VinVs by simp
          ultimately have "ls ! last_index Vs V = ls' ! last_index Vs V"
            by(rule eval\<^sub>1_preserves_unmod[OF 1])
        }
        ultimately show ?thesis using Block_lem[OF rel] len' by auto
      qed
    qed
  qed
next
  case (TryThrow e' h l a h' l' D fs C V e\<^sub>2)
  have "PROP ?P e' h l (Throw a) h' l' Vs ls" by fact
  with TryThrow.prems
  obtain ls' where 1: "?Post e' h l (Throw a) h' l' Vs ls ls'"  by(auto)
  show ?case using 1 TryThrow.hyps by(auto intro!:eval\<^sub>1_evals\<^sub>1.TryThrow\<^sub>1)
next
  case (TryCatch e\<^sub>1 h l a h\<^sub>1 l\<^sub>1 D fs C e\<^sub>2 V e' h\<^sub>2 l\<^sub>2)
  let ?e = "try e\<^sub>1 catch(C V) e\<^sub>2"
  have IH\<^sub>1: "\<lbrakk>fv e\<^sub>1 \<subseteq> set Vs; l \<subseteq>\<^sub>m [Vs [\<mapsto>] ls];
              size Vs + max_vars e\<^sub>1 \<le> length ls\<rbrakk>
          \<Longrightarrow> \<exists>ls\<^sub>1. compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs e\<^sub>1,(h,ls)\<rangle> \<Rightarrow>
                                \<langle>fin\<^sub>1 (Throw a),(h\<^sub>1,ls\<^sub>1)\<rangle> \<and>
                    l\<^sub>1 \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>1]" and
    fv: "fv ?e \<subseteq> set Vs" and
    rel: "l \<subseteq>\<^sub>m [Vs [\<mapsto>] ls]" and
    len: "length Vs + max_vars ?e \<le> length ls" by fact+
  have "fv e\<^sub>1 \<subseteq> set Vs" using fv by auto
  moreover have "length Vs + max_vars e\<^sub>1 \<le> length ls" using len by(auto)
  ultimately obtain ls\<^sub>1 where
    1: "compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs e\<^sub>1,(h,ls)\<rangle> \<Rightarrow> \<langle>Throw a,(h\<^sub>1,ls\<^sub>1)\<rangle>"
    and rel\<^sub>1: "l\<^sub>1 \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>1]" using IH\<^sub>1 rel by fastforce
  from 1 have [simp]: "size ls = size ls\<^sub>1" by(rule eval\<^sub>1_preserves_len)
  let ?Vs = "Vs @ [V]" let ?ls = "(ls\<^sub>1[size Vs:=Addr a])"
  have IH\<^sub>2: "\<lbrakk>fv e\<^sub>2 \<subseteq> set ?Vs; l\<^sub>1(V \<mapsto> Addr a) \<subseteq>\<^sub>m [?Vs [\<mapsto>] ?ls];
              length ?Vs + max_vars e\<^sub>2 \<le> length ?ls\<rbrakk> \<Longrightarrow> \<exists>ls\<^sub>2.
       compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 ?Vs e\<^sub>2,(h\<^sub>1,?ls)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h\<^sub>2, ls\<^sub>2)\<rangle> \<and>
       l\<^sub>2 \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls\<^sub>2]" by fact
  have len\<^sub>1: "size Vs < size ls\<^sub>1" using len by(auto)
  have "fv e\<^sub>2 \<subseteq> set ?Vs" using fv by auto
  moreover have "l\<^sub>1(V \<mapsto> Addr a) \<subseteq>\<^sub>m [?Vs [\<mapsto>] ?ls]" using rel\<^sub>1 len\<^sub>1 by simp
  moreover have "length ?Vs + max_vars e\<^sub>2 \<le> length ?ls" using len by(auto)
  ultimately obtain ls\<^sub>2 where
    2: "compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 ?Vs e\<^sub>2,(h\<^sub>1,?ls)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h\<^sub>2, ls\<^sub>2)\<rangle>"
    and rel\<^sub>2: "l\<^sub>2 \<subseteq>\<^sub>m [?Vs [\<mapsto>] ls\<^sub>2]"  using IH\<^sub>2 by blast
  from 2 have [simp]: "size ls\<^sub>1 = size ls\<^sub>2"
    by(fastforce dest: eval\<^sub>1_preserves_len)
  show "\<exists>ls\<^sub>2. compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs ?e,(h,ls)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h\<^sub>2,ls\<^sub>2)\<rangle> \<and>
              l\<^sub>2(V := l\<^sub>1 V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>2]"  (is "\<exists>ls\<^sub>2. ?R ls\<^sub>2")
  proof
    show "?R ls\<^sub>2"
    proof
      have hp: "h\<^sub>1 a = Some (D, fs)" by fact
      have "P \<turnstile> D \<preceq>\<^sup>* C" by fact hence caught: "compP\<^sub>1 P \<turnstile> D \<preceq>\<^sup>* C" by simp
      from TryCatch\<^sub>1[OF 1 _ caught len\<^sub>1 2, OF hp]
      show "compP\<^sub>1 P \<turnstile>\<^sub>1 \<langle>compE\<^sub>1 Vs ?e,(h,ls)\<rangle> \<Rightarrow> \<langle>fin\<^sub>1 e',(h\<^sub>2,ls\<^sub>2)\<rangle>" by simp
    next
      show "l\<^sub>2(V := l\<^sub>1 V) \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>2]"
      proof -
        have "l\<^sub>2 \<subseteq>\<^sub>m [Vs [\<mapsto>] ls\<^sub>2, V \<mapsto> ls\<^sub>2 ! length Vs]"
          using len\<^sub>1 rel\<^sub>2 by simp
        moreover
        { assume VinVs: "V \<in> set Vs"
          hence "hidden (Vs @ [V]) (last_index Vs V)" by(rule hidden_last_index)
          hence "unmod (compE\<^sub>1 (Vs @ [V]) e\<^sub>2) (last_index Vs V)"
            by(rule hidden_unmod)
          moreover have "last_index Vs V < length ?ls"
            using len\<^sub>1 VinVs by simp
          ultimately have "?ls ! last_index Vs V = ls\<^sub>2 ! last_index Vs V"
            by(rule eval\<^sub>1_preserves_unmod[OF 2])
          moreover have "last_index Vs V < size Vs" using VinVs by simp
          ultimately have "ls\<^sub>1 ! last_index Vs V = ls\<^sub>2 ! last_index Vs V"
            using len\<^sub>1 by(simp del:size_last_index_conv)
        }
        ultimately show ?thesis using Block_lem[OF rel\<^sub>1] len\<^sub>1  by simp
      qed
    qed
  qed
next
  case Try thus ?case by(fastforce intro!:Try\<^sub>1)
next
  case Throw thus ?case by(fastforce intro!:Throw\<^sub>1)
next
  case ThrowNull thus ?case by(fastforce intro!:ThrowNull\<^sub>1)
next
  case ThrowThrow thus ?case  by(fastforce intro!:ThrowThrow\<^sub>1)
next
  case (CondT e h l h\<^sub>1 l\<^sub>1 e\<^sub>1 e' h\<^sub>2 l\<^sub>2 e\<^sub>2)
  have "PROP ?P e h l true h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with CondT.prems
  obtain ls\<^sub>1 where 1: "?Post e h l true h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"  by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>1 h\<^sub>1 l\<^sub>1 e' h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 CondT.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>1 h\<^sub>1 l\<^sub>1 e' h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 show ?case by(auto intro!:CondT\<^sub>1)
next
  case (CondF e h l h\<^sub>1 l\<^sub>1 e\<^sub>2 e' h\<^sub>2 l\<^sub>2 e\<^sub>1 Vs ls)
  have "PROP ?P e h l false h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with CondF.prems
  obtain ls\<^sub>1 where 1: "?Post e h l false h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"  by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>2 h\<^sub>1 l\<^sub>1 e' h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 CondF.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h\<^sub>1 l\<^sub>1 e' h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 show ?case by(auto intro!:CondF\<^sub>1)
next
  case CondThrow thus ?case by(fastforce intro!:CondThrow\<^sub>1)
next
  case (Seq e h l v h\<^sub>1 l\<^sub>1 e\<^sub>1 e' h\<^sub>2 l\<^sub>2)
  have "PROP ?P e h l (Val v) h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with Seq.prems
  obtain ls\<^sub>1 where 1: "?Post e h l (Val v) h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"  by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>1 h\<^sub>1 l\<^sub>1 e' h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 Seq.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>1 h\<^sub>1 l\<^sub>1 e' h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 Seq show ?case by(auto intro!:Seq\<^sub>1)
next
  case SeqThrow thus ?case by(fastforce intro!:SeqThrow\<^sub>1)
next
  case WhileF thus ?case by(fastforce intro!:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (WhileT e h l h\<^sub>1 l\<^sub>1 c v h\<^sub>2 l\<^sub>2 e' h\<^sub>3 l\<^sub>3)
  have "PROP ?P e h l true h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with WhileT.prems
  obtain ls\<^sub>1 where 1: "?Post e h l true h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"   by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P c h\<^sub>1 l\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 WhileT.prems
  obtain ls\<^sub>2 where 2: "?Post c h\<^sub>1 l\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"
    "size ls\<^sub>1 = size ls\<^sub>2"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P (While (e) c) h\<^sub>2 l\<^sub>2 e' h\<^sub>3 l\<^sub>3 Vs ls\<^sub>2" by fact
  with 1 2 WhileT.prems
  obtain ls\<^sub>3 where 3: "?Post (While (e) c) h\<^sub>2 l\<^sub>2 e' h\<^sub>3 l\<^sub>3 Vs ls\<^sub>2 ls\<^sub>3" by(auto)
  from 1 2 3 show ?case by(auto intro!:WhileT\<^sub>1)
next
  case (WhileBodyThrow e h l h\<^sub>1 l\<^sub>1 c e' h\<^sub>2 l\<^sub>2)
  have "PROP ?P e h l true h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with WhileBodyThrow.prems
  obtain ls\<^sub>1 where 1: "?Post e h l true h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P c h\<^sub>1 l\<^sub>1 (throw e') h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 WhileBodyThrow.prems
  obtain ls\<^sub>2 where 2: "?Post c h\<^sub>1 l\<^sub>1 (throw e') h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2" by auto
  from 1 2 show ?case by(auto intro!:WhileBodyThrow\<^sub>1)
next
  case WhileCondThrow thus ?case by(fastforce intro!:WhileCondThrow\<^sub>1)
next
  case New thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case NewFail thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case Cast thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case CastNull thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case CastThrow thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (CastFail e h l a h\<^sub>1 l\<^sub>1 D fs C)
  have "PROP ?P e h l (addr a) h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with CastFail.prems
  obtain ls\<^sub>1 where 1: "?Post e h l (addr a) h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1" by auto
  show ?case using 1 CastFail.hyps
    by(auto intro!:CastFail\<^sub>1[where D=D])
next
  case Val thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (BinOp e h l v\<^sub>1 h\<^sub>1 l\<^sub>1 e\<^sub>1 v\<^sub>2 h\<^sub>2 l\<^sub>2 bop v)
  have "PROP ?P e h l (Val v\<^sub>1) h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with BinOp.prems
  obtain ls\<^sub>1 where 1: "?Post e h l (Val v\<^sub>1) h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>1 h\<^sub>1 l\<^sub>1 (Val v\<^sub>2) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 BinOp.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>1 h\<^sub>1 l\<^sub>1 (Val v\<^sub>2) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 BinOp show ?case by(auto intro!:BinOp\<^sub>1)
next
  case (BinOpThrow2 e\<^sub>0 h l v\<^sub>1 h\<^sub>1 l\<^sub>1 e\<^sub>1 e h\<^sub>2 l\<^sub>2 bop)
  have "PROP ?P e\<^sub>0 h l (Val v\<^sub>1) h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with BinOpThrow2.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>0 h l (Val v\<^sub>1) h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>1 h\<^sub>1 l\<^sub>1 (throw e) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 BinOpThrow2.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>1 h\<^sub>1 l\<^sub>1 (throw e) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 BinOpThrow2 show ?case by(auto intro!:BinOpThrow\<^sub>2\<^sub>1)
next
  case BinOpThrow1 thus ?case  by(fastforce intro!:eval\<^sub>1_evals\<^sub>1.intros)
next
  case Var thus ?case
    by(force intro!:Var\<^sub>1 simp add: map_le_def fun_upds_apply)
next
  case LAss thus ?case
    by(fastforce simp add: LAss_lem intro:eval\<^sub>1_evals\<^sub>1.intros
                dest:eval\<^sub>1_preserves_len)
next
  case LAssThrow thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case FAcc thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case FAccNull thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case FAccThrow thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (FAss e\<^sub>1 h l a h\<^sub>1 l\<^sub>1 e\<^sub>2 v h\<^sub>2 l\<^sub>2 C fs fs' F D h\<^sub>2')
  have "PROP ?P e\<^sub>1 h l (addr a) h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with FAss.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>1 h l (addr a) h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>2 h\<^sub>1 l\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 FAss.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h\<^sub>1 l\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 FAss show ?case by(auto intro!:FAss\<^sub>1)
next
  case (FAssNull e\<^sub>1 h l h\<^sub>1 l\<^sub>1 e\<^sub>2 v h\<^sub>2 l\<^sub>2 F D)
  have "PROP ?P e\<^sub>1 h l null h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with FAssNull.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>1 h l null h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>2 h\<^sub>1 l\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 FAssNull.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h\<^sub>1 l\<^sub>1 (Val v) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2" by(auto)
  from 1 2 FAssNull show ?case by(auto intro!:FAssNull\<^sub>1)
next
  case FAssThrow1 thus ?case by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (FAssThrow2 e\<^sub>1 h l v h\<^sub>1 l\<^sub>1 e\<^sub>2 e h\<^sub>2 l\<^sub>2 F D)
  have "PROP ?P e\<^sub>1 h l (Val v) h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with FAssThrow2.prems
  obtain ls\<^sub>1 where 1: "?Post e\<^sub>1 h l (Val v) h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"   by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?P e\<^sub>2 h\<^sub>1 l\<^sub>1 (throw e) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 FAssThrow2.prems
  obtain ls\<^sub>2 where 2: "?Post e\<^sub>2 h\<^sub>1 l\<^sub>1 (throw e) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"  by(auto)
  from 1 2 FAssThrow2 show ?case by(auto intro!:FAssThrow\<^sub>2\<^sub>1)
next
  case (CallNull e h l h\<^sub>1 l\<^sub>1 es vs h\<^sub>2 l\<^sub>2 M)
  have "PROP ?P e h l null h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with CallNull.prems
  obtain ls\<^sub>1 where 1: "?Post e h l null h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?Ps es h\<^sub>1 l\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 CallNull.prems
  obtain ls\<^sub>2 where 2: "?Posts es h\<^sub>1 l\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2" by(auto)
  from 1 2 CallNull show ?case
    by (auto simp add: comp_def elim!: CallNull\<^sub>1)
next
  case CallObjThrow thus ?case  by(fastforce intro:eval\<^sub>1_evals\<^sub>1.intros)
next
  case (CallParamsThrow e h l v h\<^sub>1 l\<^sub>1 es vs ex es' h\<^sub>2 l\<^sub>2 M)
  have "PROP ?P e h l (Val v) h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with CallParamsThrow.prems
  obtain ls\<^sub>1 where 1: "?Post e h l (Val v) h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?Ps es h\<^sub>1 l\<^sub>1 (map Val vs @ throw ex # es') h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 CallParamsThrow.prems
  obtain ls\<^sub>2 where 2: "?Posts es h\<^sub>1 l\<^sub>1 (map Val vs @ throw ex # es') h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2" by(auto)
  from 1 2 CallParamsThrow show ?case
    by (auto simp add: comp_def
             elim!: CallParamsThrow\<^sub>1 dest!:evals_final)
next
  case (Call e h l a h\<^sub>1 l\<^sub>1 es vs h\<^sub>2 l\<^sub>2 C fs M Ts T pns body D l\<^sub>2' b' h\<^sub>3 l\<^sub>3)
  have "PROP ?P e h l (addr a) h\<^sub>1 l\<^sub>1 Vs ls" by fact
  with Call.prems
  obtain ls\<^sub>1 where 1: "?Post e h l (addr a) h\<^sub>1 l\<^sub>1 Vs ls ls\<^sub>1"
    "size ls = size ls\<^sub>1"    by(auto intro!:eval\<^sub>1_preserves_len)
  have "PROP ?Ps es h\<^sub>1 l\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1" by fact
  with 1 Call.prems
  obtain ls\<^sub>2 where 2: "?Posts es h\<^sub>1 l\<^sub>1 (map Val vs) h\<^sub>2 l\<^sub>2 Vs ls\<^sub>1 ls\<^sub>2"
    "size ls\<^sub>1 = size ls\<^sub>2"    by(auto intro!:evals\<^sub>1_preserves_len)
  let ?Vs = "this#pns"
  let ?ls = "Addr a # vs @ replicate (max_vars body) undefined"
  have mdecl: "P \<turnstile> C sees M: Ts\<rightarrow>T = (pns, body) in D" by fact
  have fv_body: "fv body \<subseteq> set ?Vs" and wf_size: "size Ts = size pns"
    using wf mdecl by(auto dest!:sees_wf_mdecl simp:wf_mdecl_def)
  have mdecl\<^sub>1: "compP\<^sub>1 P \<turnstile> C sees M: Ts\<rightarrow>T = (compE\<^sub>1 ?Vs body) in D"
    using sees_method_compP[OF mdecl, of "\<lambda>(pns,e). compE\<^sub>1 (this#pns) e"]
    by(simp)
  have [simp]: "l\<^sub>2' = [this \<mapsto> Addr a, pns [\<mapsto>] vs]" by fact
  have Call_size: "size vs = size pns" by fact
  have "PROP ?P body h\<^sub>2 l\<^sub>2' b' h\<^sub>3 l\<^sub>3 ?Vs ?ls" by fact
  with 1 2 fv_body Call_size Call.prems
  obtain ls\<^sub>3 where 3: "?Post body h\<^sub>2 l\<^sub>2' b' h\<^sub>3 l\<^sub>3 ?Vs ?ls ls\<^sub>3"  by(auto)
  have hp: "h\<^sub>2 a = Some (C, fs)" by fact
  from 1 2 3 hp mdecl\<^sub>1 wf_size Call_size show ?case
    by(fastforce simp add: comp_def
                intro!: Call\<^sub>1 dest!:evals_final)
qed
(*>*)

subsection\<open>Preservation of well-formedness\<close>

text\<open>The compiler preserves well-formedness. Is less trivial than it
may appear. We start with two simple properties: preservation of
well-typedness\<close>

lemma compE\<^sub>1_pres_wt: "\<And>Vs Ts U.
  \<lbrakk> P,[Vs[\<mapsto>]Ts] \<turnstile> e :: U; size Ts = size Vs \<rbrakk>
  \<Longrightarrow> compP f P,Ts \<turnstile>\<^sub>1 compE\<^sub>1 Vs e :: U"
and  "\<And>Vs Ts Us.
  \<lbrakk> P,[Vs[\<mapsto>]Ts] \<turnstile> es [::] Us; size Ts = size Vs \<rbrakk>
  \<Longrightarrow> compP f P,Ts \<turnstile>\<^sub>1 compEs\<^sub>1 Vs es [::] Us"
(*<*)
proof(induct e and es rule: compE\<^sub>1.induct compEs\<^sub>1.induct)
  case Var then show ?case
    by (fastforce simp:map_upds_apply_eq_Some split:if_split_asm)
next
  case LAss then show ?case
    by (fastforce simp:map_upds_apply_eq_Some split:if_split_asm)
next
  case Call then show ?case
    by (fastforce dest!: sees_method_compP[where f = f])
next
  case Block then show ?case by (fastforce simp:nth_append)
next
  case TryCatch then show ?case by (fastforce simp:nth_append)
qed fastforce+
(*>*)

text\<open>\noindent and the correct block numbering:\<close>

lemma \<B>: "\<And>Vs n. size Vs = n \<Longrightarrow> \<B> (compE\<^sub>1 Vs e) n"
and \<B>s: "\<And>Vs n. size Vs = n \<Longrightarrow> \<B>s (compEs\<^sub>1 Vs es) n"
(*<*)by (induct e and es rule: \<B>.induct \<B>s.induct)
        (force | simp,metis length_append_singleton)+(*>*)

text\<open>The main complication is preservation of definite assignment
@{term"\<D>"}.\<close>

lemma image_last_index: "A \<subseteq> set(xs@[x]) \<Longrightarrow> last_index (xs @ [x]) ` A =
  (if x \<in> A then insert (size xs) (last_index xs ` (A-{x})) else last_index xs ` A)"
(*<*)
by(auto simp:image_def)
(*>*)

lemma A_compE\<^sub>1_None[simp]:
      "\<And>Vs. \<A> e = None \<Longrightarrow> \<A> (compE\<^sub>1 Vs e) = None"
and "\<And>Vs. \<A>s es = None \<Longrightarrow> \<A>s (compEs\<^sub>1 Vs es) = None"
(*<*)by(induct e and es rule: compE\<^sub>1.induct compEs\<^sub>1.induct)(auto simp:hyperset_defs)(*>*)

lemma A_compE\<^sub>1:
      "\<And>A Vs. \<lbrakk> \<A> e = \<lfloor>A\<rfloor>; fv e \<subseteq> set Vs \<rbrakk> \<Longrightarrow> \<A> (compE\<^sub>1 Vs e) = \<lfloor>last_index Vs ` A\<rfloor>"
and "\<And>A Vs. \<lbrakk> \<A>s es = \<lfloor>A\<rfloor>; fvs es \<subseteq> set Vs \<rbrakk> \<Longrightarrow> \<A>s (compEs\<^sub>1 Vs es) = \<lfloor>last_index Vs ` A\<rfloor>"
(*<*)
proof(induct e and es rule: fv.induct fvs.induct)
  case (Block V' T e)
  hence "fv e \<subseteq> set (Vs@[V'])" by fastforce
  moreover obtain B where "\<A> e = \<lfloor>B\<rfloor>"
    using Block.prems by(simp add: hyperset_defs)
  moreover from calculation have "B \<subseteq> set (Vs@[V'])" by(auto dest!:A_fv)
  ultimately show ?case using Block
    by(auto simp add: hyperset_defs image_last_index last_index_size_conv)
next
  case (TryCatch e\<^sub>1 C V' e\<^sub>2)
  hence fve\<^sub>2: "fv e\<^sub>2 \<subseteq> set (Vs@[V'])" by auto
  show ?case
  proof (cases "\<A> e\<^sub>1")
    assume A\<^sub>1: "\<A> e\<^sub>1 = None"
    then obtain A\<^sub>2 where A\<^sub>2: "\<A> e\<^sub>2 = \<lfloor>A\<^sub>2\<rfloor>" using TryCatch
      by(simp add:hyperset_defs)
    hence "A\<^sub>2 \<subseteq> set (Vs@[V'])" using TryCatch.prems A_fv[OF A\<^sub>2] by simp blast
    thus ?thesis using TryCatch fve\<^sub>2 A\<^sub>1 A\<^sub>2
      by(auto simp add:hyperset_defs image_last_index last_index_size_conv)
  next
    fix A\<^sub>1 assume A\<^sub>1: "\<A> e\<^sub>1 =  \<lfloor>A\<^sub>1\<rfloor>"
    show ?thesis
    proof (cases  "\<A> e\<^sub>2")
      assume A\<^sub>2: "\<A> e\<^sub>2 = None"
      then show ?case using TryCatch A\<^sub>1 by(simp add:hyperset_defs)
    next
      fix A\<^sub>2 assume A\<^sub>2: "\<A> e\<^sub>2 = \<lfloor>A\<^sub>2\<rfloor>"
      have "A\<^sub>1 \<subseteq> set Vs" using TryCatch.prems A_fv[OF A\<^sub>1] by simp blast
      moreover
      have "A\<^sub>2 \<subseteq> set (Vs@[V'])" using TryCatch.prems A_fv[OF A\<^sub>2] by simp blast
      ultimately show ?thesis using TryCatch A\<^sub>1 A\<^sub>2
        by (auto simp add: Diff_subset_conv last_index_size_conv subsetD hyperset_defs dest!: sym [of _ A])
    qed
  qed
next
  case (Cond e e\<^sub>1 e\<^sub>2)
  { assume "\<A> e = None \<or> \<A> e\<^sub>1 = None \<or> \<A> e\<^sub>2 = None"
    hence ?case using Cond by (auto simp add: hyperset_defs)
  }
  moreover
  { fix A A\<^sub>1 A\<^sub>2
    assume "\<A> e = \<lfloor>A\<rfloor>" and A\<^sub>1: "\<A> e\<^sub>1 = \<lfloor>A\<^sub>1\<rfloor>" and A\<^sub>2: "\<A> e\<^sub>2 = \<lfloor>A\<^sub>2\<rfloor>"
    moreover
    have "A\<^sub>1 \<subseteq> set Vs" using Cond.prems A_fv[OF A\<^sub>1] by simp blast
    moreover
    have "A\<^sub>2 \<subseteq> set Vs" using Cond.prems A_fv[OF A\<^sub>2] by simp blast
    ultimately have ?case using Cond
      by(auto simp add:hyperset_defs image_Un
          inj_on_image_Int[OF inj_on_last_index])
  }
  ultimately show ?case by fastforce
qed (auto simp add:hyperset_defs)
(*>*)

lemma D_None[iff]: "\<D> (e::'a exp) None" and [iff]: "\<D>s (es::'a exp list) None"
(*<*)by(induct e and es rule: \<D>.induct \<D>s.induct)(simp_all)(*>*)

lemma last_index_image_set: "distinct xs \<Longrightarrow> last_index xs ` set xs = {..<size xs}"
(*<*)by(induct xs rule:rev_induct) (auto simp add: image_last_index)(*>*)

lemma D_compE\<^sub>1:
  "\<lbrakk> \<D> e \<lfloor>set Vs\<rfloor>; fv e \<subseteq> set Vs; distinct Vs \<rbrakk> \<Longrightarrow> \<D> (compE\<^sub>1 Vs e) \<lfloor>{..<length Vs}\<rfloor>"
(*<*)by(fastforce dest!: D_last_index_compE\<^sub>1[OF subset_refl] simp add:last_index_image_set)(*>*)

lemma D_compE\<^sub>1':
assumes "\<D> e \<lfloor>set(V#Vs)\<rfloor>" and "fv e \<subseteq> set(V#Vs)" and "distinct(V#Vs)"
shows "\<D> (compE\<^sub>1 (V#Vs) e) \<lfloor>{..length Vs}\<rfloor>"
(*<*)
proof -
  have "{..size Vs} = {..<size(V#Vs)}" by auto
  thus ?thesis using assms by (simp only:)(rule D_compE\<^sub>1)
qed
(*>*)

lemma compP\<^sub>1_pres_wf: "wf_J_prog P \<Longrightarrow> wf_J\<^sub>1_prog (compP\<^sub>1 P)"
(*<*)
proof -
  assume wf: "wf_J_prog P"
  let ?f = "(\<lambda>(pns, body). compE\<^sub>1 (this # pns) body)"
  let ?wf\<^sub>2 = "wf_J\<^sub>1_mdecl"

  { fix C M b Ts T m
    assume cM: "P \<turnstile> C sees M :  Ts\<rightarrow>T = m in C"
      and wfm: "wf_mdecl wf_J_mdecl P C (M, Ts, T, m)"
    obtain pns body where [simp]: "m = (pns, body)" by(cases m) simp
    let ?E = "[pns [\<mapsto>] Ts, this \<mapsto> Class C]"
    obtain T' where WT: "P,?E \<turnstile> body :: T'" and subT: "P \<turnstile> T' \<le> T"
      using wfm by(auto simp: wf_mdecl_def)
    have fv: "fv body \<subseteq> dom ?E" by(rule WT_fv[OF WT])
    have "wf_mdecl ?wf\<^sub>2 (compP ?f P) C (M, Ts, T, ?f m)" using cM wfm fv
      by(clarsimp simp add:wf_mdecl_def wf_J\<^sub>1_mdecl_def)
        (fastforce intro!: compE\<^sub>1_pres_wt D_compE\<^sub>1' \<B>)
  }
  then show ?thesis by simp (rule wf_prog_compPI[OF _ wf])
qed
(*>*)

end