(*  Title:      FOL/ex/Locale_Test/Locale_Test.thy
    Author:     Clemens Ballarin

Test environment for the locale implementation.
*)

theory Locale_Test
imports Locale_Test1 Locale_Test2 Locale_Test3
begin

text \<open>Result of theory merge with distinct but identical interpretations\<close>

context mixin_thy_merge
begin
lemmas less_mixin_thy_merge1 = le.less_def
lemmas less_mixin_thy_merge2 = le'.less_def
end

lemma \<open>gless(x, y) \<longleftrightarrow> gle(x, y) \<and> x \<noteq> y\<close> (* mixin from first interpretation applied *)
  by (rule le1.less_mixin_thy_merge1)
lemma \<open>gless'(x, y) \<longleftrightarrow> gle'(x, y) \<and> x \<noteq> y\<close> (* mixin from second interpretation applied *)
  by (rule le1.less_mixin_thy_merge2)

end


(* Author: Alexander Maletzky *)

section \<open>Sample Computations of Syzygies\<close>

theory Syzygy_Examples
  imports Buchberger Algorithm_Schema_Impl Syzygy Code_Target_Rat
begin

subsection \<open>Preparations\<close>

text \<open>We must define the following four constants outside the global interpretation, since otherwise
  their types are too general.\<close>

definition splus_pprod :: "('a::nat, 'b::nat) pp \<Rightarrow> _"
  where "splus_pprod = pprod.splus"

definition monom_mult_pprod :: "'c::semiring_0 \<Rightarrow> ('a::nat, 'b::nat) pp \<Rightarrow> ((('a, 'b) pp \<times> nat) \<Rightarrow>\<^sub>0 'c) \<Rightarrow> _"
  where "monom_mult_pprod = pprod.monom_mult"

definition mult_scalar_pprod :: "(('a::nat, 'b::nat) pp \<Rightarrow>\<^sub>0 'c::semiring_0) \<Rightarrow> ((('a, 'b) pp \<times> nat) \<Rightarrow>\<^sub>0 'c) \<Rightarrow> _"
  where "mult_scalar_pprod = pprod.mult_scalar"

definition adds_term_pprod :: "(('a::nat, 'b::nat) pp \<times> _) \<Rightarrow> _"
  where "adds_term_pprod = pprod.adds_term"

lemma (in gd_term) compute_trd_aux [code]:
  "trd_aux fs p r =
    (if is_zero p then
      r
    else
      case find_adds fs (lt p) of
        None   \<Rightarrow> trd_aux fs (tail p) (plus_monomial_less r (lc p) (lt p))
      | Some f \<Rightarrow> trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r
    )"
  by (simp only: trd_aux.simps[of fs p r] plus_monomial_less_def is_zero_def)

locale gd_nat_inf_term = gd_nat_term pair_of_term term_of_pair cmp_term
    for pair_of_term::"'t::nat_term \<Rightarrow> ('a::{nat_term,graded_dickson_powerprod} \<times> nat)"
    and term_of_pair::"('a \<times> nat) \<Rightarrow> 't"
    and cmp_term
begin

sublocale aux: gd_inf_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" ..

definition lift_keys :: "nat \<Rightarrow> ('t, 'b) oalist_ntm \<Rightarrow> ('t, 'b::semiring_0) oalist_ntm"
  where "lift_keys i xs = oalist_of_list_ntm (map_raw (\<lambda>kv. (map_component ((+) i) (fst kv), snd kv)) (list_of_oalist_ntm xs))"

lemma list_of_oalist_lift_keys:
  "list_of_oalist_ntm (lift_keys i xs) = (map_raw (\<lambda>kv. (map_component ((+) i) (fst kv), snd kv)) (list_of_oalist_ntm xs))"
  unfolding lift_keys_def oops

text \<open>Regardless of whether the above lemma holds (which might be the case) or not, we can use
  @{const lift_keys} in computations. Now, however, it is implemented rather inefficiently, because
  the list resulting from the application of @{const map_raw} is sorted again. That should not be
  a big problem though, since @{const lift_keys} is applied only once to every input polynomial
  before computing syzygies.\<close>

lemma lookup_lift_keys_plus:
  "lookup (MP_oalist (lift_keys i xs)) (term_of_pair (t, i + k)) = lookup (MP_oalist xs) (term_of_pair (t, k))"
    (is "?l = ?r")
proof -
  let ?f = "\<lambda>kv::'t \<times> 'b. (map_component ((+) i) (fst kv), snd kv)"
  obtain xs' ox where xs: "list_of_oalist_ntm xs = (xs', ox)" by fastforce
  from oalist_inv_list_of_oalist_ntm[of xs] have inv: "ko_ntm.oalist_inv_raw ox xs'"
    by (simp add: xs ko_ntm.oalist_inv_def nat_term_compare_inv_conv)
  let ?rel = "ko.lt (key_order_of_nat_term_order_inv ox)"
  have "irreflp ?rel" by (simp add: irreflp_def)
  moreover have "transp ?rel" by (simp add: lt_of_nat_term_order_alt)
  moreover from oa_ntm.list_of_oalist_sorted[of xs]
  have "sorted_wrt (ko.lt (key_order_of_nat_term_order_inv ox)) (map fst xs')" by (simp add: xs)
  ultimately have dist1: "distinct (map fst xs')" by (rule distinct_sorted_wrt_irrefl)
  have 1: "u = v" if "map_component ((+) i) u = map_component ((+) i) v" for u v
  proof -
    have "inj ((+) i)" by (simp add: inj_def)
    thus ?thesis using that by (rule map_component_inj)
  qed
  have dist2: "distinct (map fst (map_pair (\<lambda>kv. (map_component ((+) i) (fst kv), snd kv)) xs'))"
    by (rule ko_ntm.distinct_map_pair, fact dist1, simp add: 1)
  have "?l = lookup_dflt (map_pair ?f xs') (term_of_pair (t, i + k))"
    by (simp add: oa_ntm.lookup_def lift_keys_def xs oalist_of_list_ntm_def list_of_oalist_OAlist_ntm
        ko_ntm.lookup_pair_sort_oalist'[OF dist2])
  also have "... = lookup_dflt (map_pair ?f xs') (fst (?f (term_of_pair (t, k), b)))"
    by (simp add: map_component_term_of_pair)
  also have "... = snd (?f (term_of_pair (t, k), lookup_dflt xs' (term_of_pair (t, k))))"
    by (rule ko_ntm.lookup_dflt_map_pair, fact dist1, auto intro: 1)
  also have "... = ?r" by (simp add: oa_ntm.lookup_def xs ko_ntm.lookup_dflt_eq_lookup_pair[OF inv])
  finally show ?thesis .
qed

lemma keys_lift_keys_subset:
  "keys (MP_oalist (lift_keys i xs)) \<subseteq> (map_component ((+) i)) ` keys (MP_oalist xs)" (is "?l \<subseteq> ?r")
proof -
  let ?f = "\<lambda>kv::'t \<times> 'b. (map_component ((+) i) (fst kv), snd kv)"
  obtain xs' ox where xs: "list_of_oalist_ntm xs = (xs', ox)" by fastforce
  let ?rel = "ko.lt (key_order_of_nat_term_order_inv ox)"
  have "irreflp ?rel" by (simp add: irreflp_def)
  moreover have "transp ?rel" by (simp add: lt_of_nat_term_order_alt)
  moreover from oa_ntm.list_of_oalist_sorted[of xs]
  have "sorted_wrt (ko.lt (key_order_of_nat_term_order_inv ox)) (map fst xs')" by (simp add: xs)
  ultimately have dist1: "distinct (map fst xs')" by (rule distinct_sorted_wrt_irrefl)
  have 1: "u = v" if "map_component ((+) i) u = map_component ((+) i) v" for u v
  proof -
    have "inj ((+) i)" by (simp add: inj_def)
    thus ?thesis using that by (rule map_component_inj)
  qed
  have dist2: "distinct (map fst (map_pair (\<lambda>kv. (map_component ((+) i) (fst kv), snd kv)) xs'))"
    by (rule ko_ntm.distinct_map_pair, fact dist1, simp add: 1)
  have "?l \<subseteq> fst ` set (fst (map_raw ?f (list_of_oalist_ntm xs)))"
    by (auto simp: keys_MP_oalist lift_keys_def oalist_of_list_ntm_def list_of_oalist_OAlist_ntm xs
        ko_ntm.set_sort_oalist[OF dist2])
  also from ko_ntm.map_raw_subset have "... \<subseteq> fst ` ?f ` set (fst (list_of_oalist_ntm xs))"
    by (rule image_mono)
  also have "... \<subseteq> ?r" by (simp add: keys_MP_oalist image_image)
  finally show ?thesis .
qed

end

global_interpretation pprod': gd_nat_inf_term "\<lambda>x::('a, 'b) pp \<times> nat. x" "\<lambda>x. x" cmp_term
  rewrites "pprod.pp_of_term = fst"
  and "pprod.component_of_term = snd"
  and "pprod.splus = splus_pprod"
  and "pprod.monom_mult = monom_mult_pprod"
  and "pprod.mult_scalar = mult_scalar_pprod"
  and "pprod.adds_term = adds_term_pprod"
  for cmp_term :: "(('a::nat, 'b::nat) pp \<times> nat) nat_term_order"
  defines shift_map_keys_pprod = pprod'.shift_map_keys
  and lift_keys_pprod = pprod'.lift_keys
  and min_term_pprod = pprod'.min_term
  and lt_pprod = pprod'.lt
  and lc_pprod = pprod'.lc
  and tail_pprod = pprod'.tail
  and comp_opt_p_pprod = pprod'.comp_opt_p
  and ord_p_pprod = pprod'.ord_p
  and ord_strict_p_pprod = pprod'.ord_strict_p
  and find_adds_pprod = pprod'.find_adds
  and trd_aux_pprod= pprod'.trd_aux
  and trd_pprod = pprod'.trd
  and spoly_pprod = pprod'.spoly
  and count_const_lt_components_pprod = pprod'.count_const_lt_components
  and count_rem_components_pprod = pprod'.count_rem_components
  and const_lt_component_pprod = pprod'.const_lt_component
  and full_gb_pprod = pprod'.full_gb
  and keys_to_list_pprod = pprod'.keys_to_list
  and Keys_to_list_pprod = pprod'.Keys_to_list
  and add_pairs_single_sorted_pprod = pprod'.add_pairs_single_sorted
  and add_pairs_pprod = pprod'.add_pairs
  and canon_pair_order_aux_pprod = pprod'.canon_pair_order_aux
  and canon_basis_order_pprod = pprod'.canon_basis_order
  and new_pairs_sorted_pprod = pprod'.new_pairs_sorted
  and component_crit_pprod = pprod'.component_crit
  and chain_ncrit_pprod = pprod'.chain_ncrit
  and chain_ocrit_pprod = pprod'.chain_ocrit
  and apply_icrit_pprod = pprod'.apply_icrit
  and apply_ncrit_pprod = pprod'.apply_ncrit
  and apply_ocrit_pprod = pprod'.apply_ocrit
  and trdsp_pprod = pprod'.trdsp
  and gb_sel_pprod = pprod'.gb_sel
  and gb_red_aux_pprod = pprod'.gb_red_aux
  and gb_red_pprod = pprod'.gb_red
  and gb_aux_pprod = pprod'.gb_aux
  and gb_pprod = pprod'.gb
  and filter_syzygy_basis_pprod = pprod'.aux.filter_syzygy_basis
  and init_syzygy_list_pprod = pprod'.aux.init_syzygy_list
  and lift_poly_syz_pprod = pprod'.aux.lift_poly_syz
  and map_component_pprod = pprod'.map_component
  subgoal by (rule gd_nat_inf_term.intro, fact gd_nat_term_id)
  subgoal by (fact pprod_pp_of_term)
  subgoal by (fact pprod_component_of_term)
  subgoal by (simp only: splus_pprod_def)
  subgoal by (simp only: monom_mult_pprod_def)
  subgoal by (simp only: mult_scalar_pprod_def)
  subgoal by (simp only: adds_term_pprod_def)
  done

lemma compute_adds_term_pprod [code]:
  "adds_term_pprod u v = (snd u = snd v \<and> adds_pp_add_linorder (fst u) (fst v))"
  by (simp add: adds_term_pprod_def pprod.adds_term_def adds_pp_add_linorder_def)

lemma compute_splus_pprod [code]: "splus_pprod t (s, i) = (t + s, i)"
  by (simp add: splus_pprod_def pprod.splus_def)

lemma compute_shift_map_keys_pprod [code abstract]:
  "list_of_oalist_ntm (shift_map_keys_pprod t f xs) = map_raw (\<lambda>(k, v). (splus_pprod t k, f v)) (list_of_oalist_ntm xs)"
  by (simp add: pprod'.list_of_oalist_shift_keys case_prod_beta')

lemma compute_trd_pprod [code]: "trd_pprod to fs p = trd_aux_pprod to fs p (change_ord to 0)"
  by (simp only: pprod'.trd_def change_ord_def)

lemmas [code] = conversep_iff

lemma POT_is_pot_ord: "pprod'.is_pot_ord (TYPE('a::nat)) (TYPE('b::nat)) (POT to)"
  by (rule pprod'.is_pot_ordI, simp add: lt_of_nat_term_order nat_term_compare_POT pot_comp rep_nat_term_prod_def,
      simp add: comparator_of_def)

definition Vec\<^sub>0 :: "nat \<Rightarrow> (('a, nat) pp \<Rightarrow>\<^sub>0 'b) \<Rightarrow> (('a::nat, nat) pp \<times> nat) \<Rightarrow>\<^sub>0 'b::semiring_1" where
  "Vec\<^sub>0 i p = mult_scalar_pprod p (Poly_Mapping.single (0, i) 1)"

definition "syzygy_basis to bs =
    filter_syzygy_basis_pprod (length bs) (map fst (gb_pprod (POT to) (map (\<lambda>p. (p, ())) (init_syzygy_list_pprod bs)) ()))"

thm pprod'.aux.filter_syzygy_basis_isGB[OF POT_is_pot_ord]

lemma lift_poly_syz_MP_oalist [code]:
  "lift_poly_syz_pprod n (MP_oalist xs) i = MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))"
proof (rule poly_mapping_eqI, simp add: pprod'.aux.lookup_lift_poly_syz del: MP_oalist.rep_eq, intro conjI impI)
  fix v::"('a, 'b) pp \<times> nat"
  assume "n \<le> snd v"
  moreover obtain t k where "v = (t, k)" by fastforce
  ultimately have k: "n + (k - n) = k" by simp
  hence v: "v = (t, n + (k - n))" by (simp only: \<open>v = (t, k)\<close>)
  assume "v \<noteq> (0, i)"
  hence "lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v =
          lookup (MP_oalist (lift_keys_pprod n xs)) v" by (simp add: oa_ntm.lookup_insert)
  also have "... = lookup (MP_oalist xs) (t, k - n)" by (simp only: v pprod'.lookup_lift_keys_plus)
  also have "... = lookup (MP_oalist xs) (map_component_pprod (\<lambda>k. k - n) v)"
    by (simp add: v pprod'.map_component_term_of_pair)
  finally show "lookup (MP_oalist xs) (map_component_pprod (\<lambda>k. k - n) v) =
                  lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v" by (rule HOL.sym)
next
  fix v::"('a, 'b) pp \<times> nat"
  assume "\<not> n \<le> snd v"
  assume "v \<noteq> (0, i)"
  hence "lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v =
          lookup (MP_oalist (lift_keys_pprod n xs)) v" by (simp add: add: oa_ntm.lookup_insert)
  also have "... = 0"
  proof (rule ccontr)
    assume "lookup (MP_oalist (lift_keys_pprod n xs)) v \<noteq> 0"
    hence "v \<in> keys (MP_oalist (lift_keys_pprod n xs))" by (simp add: in_keys_iff del: MP_oalist.rep_eq)
    also have "... \<subseteq> map_component_pprod ((+) n) ` keys (MP_oalist xs)"
      by (fact pprod'.keys_lift_keys_subset)
    finally obtain u where "v = map_component_pprod ((+) n) u" ..
    hence "snd v = n + snd u" by (simp add: pprod'.component_of_map_component)
    with \<open>\<not> n \<le> snd v\<close> show False by simp
  qed
  finally show "lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v = 0" .
qed (simp_all add: oa_ntm.lookup_insert)

subsection \<open>Computations\<close>

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

lemma
  "syzygy_basis DRLEX [Vec\<^sub>0 0 (X\<^sup>2 * Z ^ 3 + 3 * X\<^sup>2 * Y), Vec\<^sub>0 0 (X * Y * Z + 2 * Y\<^sup>2)] =
  [Vec\<^sub>0 0 (C\<^sub>0 (1 / 3) * X * Y * Z + C\<^sub>0 (2 / 3) * Y\<^sup>2) + Vec\<^sub>0 1 (C\<^sub>0 (- 1 / 3) * X\<^sup>2 * Z ^ 3 - X\<^sup>2 * Y)]"
  by eval

value [code] "syzygy_basis DRLEX [Vec\<^sub>0 0 (X\<^sup>2 * Z ^ 3 + 3 * X\<^sup>2 * Y), Vec\<^sub>0 0 (X * Y * Z + 2 * Y\<^sup>2), Vec\<^sub>0 0 (X - Y + 3 * Z)]"

lemma
  "map fst (gb_pprod (POT DRLEX) (map (\<lambda>p. (p, ())) (init_syzygy_list_pprod
    [Vec\<^sub>0 0 (X ^ 4 + 3 * X\<^sup>2 * Y), Vec\<^sub>0 0 (Y ^ 3 + 2 * X * Z), Vec\<^sub>0 0 (Z\<^sup>2 - X - Y)])) ()) =
  [
    Vec\<^sub>0 0 1 + Vec\<^sub>0 3 (X ^ 4 + 3 * X\<^sup>2 * Y),
    Vec\<^sub>0 1 1 + Vec\<^sub>0 3 (Y ^ 3 + 2 * X * Z),
    Vec\<^sub>0 0 (Y ^ 3 + 2 * X * Z) - Vec\<^sub>0 1 (X ^ 4 + 3 * X\<^sup>2 * Y),
    Vec\<^sub>0 2 1 + Vec\<^sub>0 3 (Z\<^sup>2 - X - Y),
    Vec\<^sub>0 1 (Z\<^sup>2 - X - Y) - Vec\<^sub>0 2 (Y ^ 3 + 2 * X * Z),
    Vec\<^sub>0 0 (Z\<^sup>2 - X - Y) - Vec\<^sub>0 2 (X ^ 4 + 3 * X\<^sup>2 * Y),
    Vec\<^sub>0 0 (- (Y ^ 3 * Z\<^sup>2) + Y ^ 4 + X * Y ^ 3 + 2 * X\<^sup>2 * Z + 2 * X * Y * Z - 2 * X * Z ^ 3) +
      Vec\<^sub>0 1 (X ^ 4 * Z\<^sup>2 - X ^ 5 - X ^ 4 * Y - 3 * X ^ 3 * Y - 3 * X\<^sup>2 * Y\<^sup>2 + 3 * X\<^sup>2 * Y * Z\<^sup>2)
  ]"
  by eval

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

value [code] "syzygy_basis DRLEX [Vec\<^sub>0 0 (X * Y - Z), Vec\<^sub>0 0 (X * Z - Y), Vec\<^sub>0 0 (Y * Z - X)]"

lemma
  "map fst (gb_pprod (POT DRLEX) (map (\<lambda>p. (p, ())) (init_syzygy_list_pprod
    [Vec\<^sub>0 0 (X * Y - Z), Vec\<^sub>0 0 (X * Z - Y), Vec\<^sub>0 0 (Y * Z - X)])) ()) =
  [
    Vec\<^sub>0 0 1 + Vec\<^sub>0 3 (X * Y - Z),
    Vec\<^sub>0 1 1 + Vec\<^sub>0 3 (X * Z - Y),
    Vec\<^sub>0 2 1 + Vec\<^sub>0 3 (Y * Z - X),
    Vec\<^sub>0 0 (- X * Z + Y) + Vec\<^sub>0 1 (X * Y - Z),
    Vec\<^sub>0 0 (- Y * Z + X) + Vec\<^sub>0 2 (X * Y - Z),
    Vec\<^sub>0 1 (- Y * Z + X) + Vec\<^sub>0 2 (X * Z - Y),
    Vec\<^sub>0 1 (-Y) + Vec\<^sub>0 2 (X) + Vec\<^sub>0 3 (Y ^ 2 - X ^ 2),
    Vec\<^sub>0 0 (Z) + Vec\<^sub>0 2 (-X) + Vec\<^sub>0 3 (X ^ 2 - Z ^ 2),
    Vec\<^sub>0 0 (Y - Y * Z ^ 2) + Vec\<^sub>0 1 (Y ^ 2 * Z - Z) + Vec\<^sub>0 2 (Y ^ 2 - Z ^ 2),
    Vec\<^sub>0 0 (- Y) + Vec\<^sub>0 1 (- (X * Y)) + Vec\<^sub>0 2 (X ^ 2 - 1) + Vec\<^sub>0 3 (X - X ^ 3)
  ]"
  by eval

lemma
  "syzygy_basis DRLEX [Vec\<^sub>0 0 (X * Y - Z), Vec\<^sub>0 0 (X * Z - Y), Vec\<^sub>0 0 (Y * Z - X)] =
  [
    Vec\<^sub>0 0 (- X * Z + Y) + Vec\<^sub>0 1 (X * Y - Z),
    Vec\<^sub>0 0 (- Y * Z + X) + Vec\<^sub>0 2 (X * Y - Z),
    Vec\<^sub>0 1 (- Y * Z + X) + Vec\<^sub>0 2 (X * Z - Y),
    Vec\<^sub>0 0 (Y - Y * Z ^ 2) + Vec\<^sub>0 1 (Y ^ 2 * Z - Z) + Vec\<^sub>0 2 (Y ^ 2 - Z ^ 2)
  ]"
  by eval

end

end (* theory *)


(*<*)
(*
 * 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\<open>A totally-correct fusion rule\<close>

text\<open>
\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 \<open>wrap oo unwrap = ID\<close>.)

Our first result shows that a combined worker/wrapper transformation
and fusion rule is sound, using the assumptions of \<open>worker_wrapper_id\<close> and the ubiquitous \<open>lfp_fusion\<close> rule.

\<close>

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\<open>

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}:

\<close>

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\<open>

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}

\<close>

(*<*)
end
(*>*)


theory  Correspondence_theory  imports DDLE
begin
lemma limited_corresponds_to_Dstar: (*System F*)
 "(\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x)) \<longleftrightarrow> (\<forall>\<Phi> \<Psi>. \<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>>  \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>)"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddevalid_def sledgehammer by auto

lemma limited_trans_corresponds_to_SP_Dstar_1:(*System G*)
 "((\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x)) \<and> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z))
  \<longrightarrow>
((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def
  sledgehammer by smt     (* this direction is provable *)

lemma limited_trans_corresponds_to_SP_Dstar_2: (* this is still too hard for the ATPs *)
 "((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))
  \<longrightarrow>
  ((\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x)) \<and> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def oops
  (* this direction unfortunately not yet, but we also do not get a countermodel; proof might be to hard *)

lemma limited_trans_corresponds_to_SP_Dstar_2a: (* splitting the conjunct, limitednedd is easy for the ATPs*)
 "((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))
  \<longrightarrow> (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def
  sledgehammer by auto
lemma limited_trans_corresponds_to_SP_Dstar_2b: (* splitting the conjunct, transitivity is too hard for the ATPs*)
 "((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))
  \<longrightarrow> ((\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def
  (* this direction unfortunately not yet, but we also do not get a countermodel; proof might be to hard *)
  sorry

(*** end of header part ***)

end


(* Author: Andreas Lochbihler, Digital Asset
   Author: Ognjen Maric, Digital Asset *)

theory Inclusion_Proof_Construction imports
  ADS_Construction
begin

primrec blind_blindable :: "('a\<^sub>m \<Rightarrow> 'a\<^sub>h) \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) blindable\<^sub>m \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) blindable\<^sub>m" where
  "blind_blindable h (Blinded x) = Blinded x"
| "blind_blindable h (Unblinded x) = Blinded (Content (h x))"

lemma hash_blind_blindable [simp]: "hash_blindable h (blind_blindable h x) = hash_blindable h x"
  by(cases x) simp_all

subsection \<open>Inclusion proof construction for rose trees\<close>

(************************************************************)
subsubsection \<open> Hashing, embedding and blinding source trees \<close>
(************************************************************)

context fixes h :: "'a \<Rightarrow> 'a\<^sub>h" begin
fun hash_source_tree :: "'a rose_tree \<Rightarrow> 'a\<^sub>h rose_tree\<^sub>h" where
  "hash_source_tree (Tree (data, subtrees)) = Tree\<^sub>h (Content (h data, map hash_source_tree subtrees))"
end

context fixes e :: "'a \<Rightarrow> 'a\<^sub>m" begin
fun embed_source_tree :: "'a rose_tree \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m" where
  "embed_source_tree (Tree (data, subtrees)) =
    Tree\<^sub>m (Unblinded (e data, map embed_source_tree subtrees))"
end

context fixes h :: "'a \<Rightarrow> 'a\<^sub>h" begin
fun blind_source_tree :: "'a rose_tree \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m" where
  "blind_source_tree (Tree (data, subtrees)) = Tree\<^sub>m (Blinded (Content (h data, map (hash_source_tree h) subtrees)))"
end

case_of_simps blind_source_tree_cases: blind_source_tree.simps

fun is_blinded :: "('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m \<Rightarrow> bool" where
  "is_blinded (Tree\<^sub>m (Blinded _)) = True"
| "is_blinded _ = False"

lemma hash_blinded_simp: "hash_tree h' (blind_source_tree h st) = hash_source_tree h st"
  by(cases st rule: blind_source_tree.cases)(simp_all add: hash_rt_F\<^sub>m_def)

lemma hash_embedded_simp:
  "hash_tree h (embed_source_tree e st) = hash_source_tree (h \<circ> e) st"
  by(induction st rule: embed_source_tree.induct)(simp add: hash_rt_F\<^sub>m_def)

lemma blinded_embedded_same_hash:
  "hash_tree h'' (blind_source_tree (h o e) st) = hash_tree h (embed_source_tree e st)"
  by(simp add: hash_blinded_simp hash_embedded_simp)

lemma blinding_blinds [simp]:
  "is_blinded (blind_source_tree h t)"
  by(simp add: blind_source_tree_cases split: rose_tree.split)

lemma blinded_blinds_embedded:
  "blinding_of_tree h bo (blind_source_tree (h o e) st) (embed_source_tree e st)"
  by(cases st rule: blind_source_tree.cases)(simp_all add: hash_embedded_simp)

fun embed_hash_tree :: "'ha rose_tree\<^sub>h \<Rightarrow> ('a, 'ha) rose_tree\<^sub>m" where
  "embed_hash_tree (Tree\<^sub>h h) = Tree\<^sub>m (Blinded h)"

(************************************************************)
subsubsection \<open>Auxiliary definitions: selectors and list splits\<close>
(************************************************************)

fun children :: "'a rose_tree \<Rightarrow> 'a rose_tree list" where
  "children (Tree (data, subtrees)) = subtrees"

fun children\<^sub>m :: "('a, 'a\<^sub>h) rose_tree\<^sub>m \<Rightarrow> ('a, 'a\<^sub>h) rose_tree\<^sub>m list" where
  "children\<^sub>m (Tree\<^sub>m (Unblinded (data, subtrees))) = subtrees"
| "children\<^sub>m _ = undefined"

fun splits :: "'a list \<Rightarrow> ('a list \<times> 'a \<times> 'a list) list" where
  "splits [] = []"
| "splits (x#xs) = ([], x, xs) # map (\<lambda>(l, y, r). (x # l, y, r)) (splits xs)"

lemma splits_iff: "(l, a, r) \<in> set (splits ll) = (ll = l @ a # r)"
  by(induction ll arbitrary: l a r)(auto simp add: Cons_eq_append_conv)

(************************************************************)
subsubsection \<open> Zippers \<close>
(************************************************************)

text \<open> Zippers provide a neat representation of tree-like ADSs when they have only a single
  unblinded subtree. The zipper path provides the "inclusion proof" that the unblinded subtree is
  included in a larger structure. \<close>

type_synonym 'a path_elem = "'a \<times> 'a rose_tree list \<times> 'a rose_tree list"
type_synonym 'a path = "'a path_elem list"
type_synonym 'a zipper = "'a path \<times> 'a rose_tree"

definition zipper_of_tree :: "'a rose_tree \<Rightarrow> 'a zipper" where
  "zipper_of_tree t \<equiv> ([], t)"

fun tree_of_zipper :: "'a zipper \<Rightarrow> 'a rose_tree" where
  "tree_of_zipper ([], t) = t"
| "tree_of_zipper ((a, l, r) # z, t) = tree_of_zipper (z, (Tree (a, (l @ t # r))))"

case_of_simps tree_of_zipper_cases: tree_of_zipper.simps

lemma tree_of_zipper_id[iff]: "tree_of_zipper (zipper_of_tree t) = t"
  by(simp add: zipper_of_tree_def)

fun zipper_children :: "'a zipper \<Rightarrow> 'a zipper list" where
  "zipper_children (p, Tree (a, ts)) = map (\<lambda>(l, t, r). ((a, l, r) # p, t)) (splits ts)"

lemma zipper_children_same_tree:
  assumes "z' \<in> set (zipper_children z)"
  shows "tree_of_zipper z' = tree_of_zipper z"
proof-
  obtain p a ts where z: "z = (p, Tree (a, ts))"
    using assms
    by(cases z rule: zipper_children.cases) (simp_all)

  then obtain l t r where ltr: "z' = ((a, l, r) # p, t)" and "(l, t, r) \<in> set (splits ts)"
    using assms
    by(auto)

  with z show ?thesis
    by(simp add: splits_iff)
qed

type_synonym ('a\<^sub>m, 'a\<^sub>h) path_elem\<^sub>m = "'a\<^sub>m \<times> ('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m list \<times> ('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m list"
type_synonym ('a\<^sub>m, 'a\<^sub>h) path\<^sub>m = "('a\<^sub>m, 'a\<^sub>h) path_elem\<^sub>m list"
type_synonym ('a\<^sub>m, 'a\<^sub>h) zipper\<^sub>m = "('a\<^sub>m, 'a\<^sub>h) path\<^sub>m \<times> ('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m"

definition zipper_of_tree\<^sub>m :: "('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) zipper\<^sub>m" where
  "zipper_of_tree\<^sub>m t \<equiv> ([], t)"

fun tree_of_zipper\<^sub>m :: "('a\<^sub>m, 'a\<^sub>h) zipper\<^sub>m \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) rose_tree\<^sub>m" where
  "tree_of_zipper\<^sub>m ([], t) = t"
| "tree_of_zipper\<^sub>m ((m, l, r) # z, t) = tree_of_zipper\<^sub>m (z, Tree\<^sub>m (Unblinded (m, l @ t # r)))"

lemma tree_of_zipper\<^sub>m_append:
  "tree_of_zipper\<^sub>m (p @ p', t) = tree_of_zipper\<^sub>m (p', tree_of_zipper\<^sub>m (p, t))"
  by(induction p arbitrary: p' t) auto

fun zipper_children\<^sub>m :: "('a\<^sub>m, 'a\<^sub>h) zipper\<^sub>m \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) zipper\<^sub>m list" where
  "zipper_children\<^sub>m (p, Tree\<^sub>m (Unblinded (a, ts))) = map (\<lambda>(l, t, r). ((a, l, r) # p, t)) (splits ts) "
| "zipper_children\<^sub>m _ = []"

lemma zipper_children_same_tree\<^sub>m:
  assumes "z' \<in> set (zipper_children\<^sub>m z)"
  shows "tree_of_zipper\<^sub>m z' = tree_of_zipper\<^sub>m z"
proof-
  obtain p a ts where z: "z = (p, Tree\<^sub>m (Unblinded (a, ts)))"
    using assms
    by(cases z rule: zipper_children\<^sub>m.cases) (simp_all)

  then obtain l t r where ltr: "z' = ((a, l, r) # p, t)" and "(l, t, r) \<in> set (splits ts)"
    using assms
    by(auto)

  with z show ?thesis
    by(simp add: splits_iff)
qed

fun blind_path_elem :: "('a \<Rightarrow> 'a\<^sub>m) \<Rightarrow> ('a\<^sub>m \<Rightarrow> 'a\<^sub>h) \<Rightarrow> 'a path_elem \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) path_elem\<^sub>m"  where
  "blind_path_elem e h (x, l, r) = (e x, map (blind_source_tree (h \<circ> e)) l, map (blind_source_tree (h \<circ> e)) r)"

case_of_simps blind_path_elem_cases: blind_path_elem.simps

definition blind_path :: "('a \<Rightarrow> 'a\<^sub>m) \<Rightarrow> ('a\<^sub>m \<Rightarrow> 'a\<^sub>h) \<Rightarrow> 'a path \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) path\<^sub>m" where
  "blind_path e h \<equiv> map (blind_path_elem e h)"

fun embed_path_elem :: "('a \<Rightarrow> 'a\<^sub>m) \<Rightarrow> 'a path_elem \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) path_elem\<^sub>m" where
  "embed_path_elem e (d, l, r) = (e d, map (embed_source_tree e) l, map (embed_source_tree e) r)"

definition embed_path :: "('a \<Rightarrow> 'a\<^sub>m) \<Rightarrow> 'a path \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) path\<^sub>m" where
  "embed_path embed_elem \<equiv> map (embed_path_elem embed_elem)"

lemma hash_tree_of_zipper_same_path:
  "hash_tree h (tree_of_zipper\<^sub>m (p, v)) = hash_tree h (tree_of_zipper\<^sub>m (p, v'))
        \<longleftrightarrow> hash_tree h v = hash_tree h v'"
  by(induction p arbitrary: v v')(auto simp add: hash_rt_F\<^sub>m_def)

fun hash_path_elem :: "('a\<^sub>m \<Rightarrow> 'a\<^sub>h) \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) path_elem\<^sub>m \<Rightarrow> ('a\<^sub>h \<times> 'a\<^sub>h rose_tree\<^sub>h list \<times> 'a\<^sub>h rose_tree\<^sub>h list)" where
  "hash_path_elem h (e, l, r) = (h e, map (hash_tree h) l, map (hash_tree h) r)"

lemma hash_view_zipper_eqI:
  "\<lbrakk> hash_list (hash_path_elem h) p = hash_list (hash_path_elem h') p';
    hash_tree h v = hash_tree h' v' \<rbrakk> \<Longrightarrow>
    hash_tree h (tree_of_zipper\<^sub>m (p, v)) = hash_tree h' (tree_of_zipper\<^sub>m (p', v'))"
  by(induction p arbitrary: p' v v')(auto simp add: hash_rt_F\<^sub>m_def)

lemma blind_embed_path_same_hash:
  "hash_tree h (tree_of_zipper\<^sub>m (blind_path e h p, t)) = hash_tree h (tree_of_zipper\<^sub>m (embed_path e p, t))"
proof -
  have "hash_path_elem h \<circ> blind_path_elem e h = hash_path_elem h \<circ> embed_path_elem e"
    by(clarsimp simp add: hash_blinded_simp hash_embedded_simp fun_eq_iff intro!: arg_cong2[where f=hash_source_tree, OF _ refl])
  then show ?thesis
    by(intro hash_view_zipper_eqI)(simp_all add: embed_path_def blind_path_def list.map_comp)
qed

lemma tree_of_embed_commute:
  "tree_of_zipper\<^sub>m (embed_path e p, embed_source_tree e t) = embed_source_tree e (tree_of_zipper (p, t))"
  by(induction "(p, t)" arbitrary: p t rule: tree_of_zipper.induct)(simp_all add: embed_path_def)

lemma childz_same_tree:
  "(l, t, r) \<in> set (splits ts) \<Longrightarrow>
  tree_of_zipper\<^sub>m (embed_path e p, embed_source_tree e (Tree (d, ts)))
  = tree_of_zipper\<^sub>m (embed_path e ((d, l, r) # p), embed_source_tree e t)"
  by(simp add: tree_of_embed_commute splits_iff del: embed_source_tree.simps)

lemma blinding_of_same_path:
  assumes bo: "blinding_of_on UNIV h bo"
  shows
  "blinding_of_tree h bo (tree_of_zipper\<^sub>m (p, t)) (tree_of_zipper\<^sub>m (p, t'))
  \<longleftrightarrow> blinding_of_tree h bo t t'"
proof -
  interpret a: blinding_of_on UNIV h bo by fact
  interpret tree: blinding_of_on UNIV "hash_tree h" "blinding_of_tree h bo" ..
  show ?thesis
    by(induction p arbitrary: t t')(auto simp add: list_all2_append list.rel_refl a.refl tree.refl)
qed

lemma zipper_children_size_change [termination_simp]: "(a, b) \<in> set (zipper_children (p, v)) \<Longrightarrow> size b < size v"
  by(cases v)(clarsimp simp add: splits_iff Set.image_iff)

subsection \<open>All zippers of a rose tree\<close>

context fixes e :: "'a \<Rightarrow> 'a\<^sub>m" and h :: "'a\<^sub>m \<Rightarrow> 'a\<^sub>h" begin

fun zippers_rose_tree :: "'a zipper \<Rightarrow> ('a\<^sub>m, 'a\<^sub>h) zipper\<^sub>m list" where
  "zippers_rose_tree (p, t) = (blind_path e h p, embed_source_tree e t) #
    concat (map zippers_rose_tree (zipper_children (p, t)))"

end

lemmas [simp del] = zippers_rose_tree.simps zipper_children.simps

lemma zippers_rose_tree_same_hash':
  assumes "z \<in> set (zippers_rose_tree e h (p, t))"
  shows "hash_tree h (tree_of_zipper\<^sub>m z) =
    hash_tree h (tree_of_zipper\<^sub>m (embed_path e p, embed_source_tree e t))"
  using assms(1)
proof(induction "(p, t)" arbitrary: p t rule: zippers_rose_tree.induct)
  case (1 p t)
  from "1.prems"[unfolded zippers_rose_tree.simps]
  consider (find) "z = (blind_path e h p, embed_source_tree e t)"
    | (rec) x ts l t' r where "t = Tree (x, ts)" "(l, t', r) \<in> set (splits ts)" "z \<in> set (zippers_rose_tree e h ((x, l, r) # p, t'))"
    by(cases t)(auto simp add: zipper_children.simps)
  then show ?case
  proof cases
    case rec
    then show ?thesis
      apply(subst "1.hyps"[of "(x, l, r) # p" "t'"])
      apply(simp_all add: rev_image_eqI zipper_children.simps)
      by (metis (no_types) childz_same_tree comp_apply embed_source_tree.simps rec(2))
  qed(simp add: blind_embed_path_same_hash)
qed

lemma zippers_rose_tree_blinding_of:
  assumes "blinding_of_on UNIV h bo"
    and z: "z \<in> set (zippers_rose_tree e h (p, t))"
  shows "blinding_of_tree h bo (tree_of_zipper\<^sub>m z) (tree_of_zipper\<^sub>m (blind_path e h p, embed_source_tree e t))"
  using z
proof(induction "(p, t)" arbitrary: p t rule: zippers_rose_tree.induct)
  case (1 p t)

  interpret a: blinding_of_on UNIV h bo by fact
  interpret rt: blinding_of_on UNIV "hash_tree h" "blinding_of_tree h bo" ..

  from "1.prems"[unfolded zippers_rose_tree.simps]
  consider (find) "z = (blind_path e h p, embed_source_tree e t)"
    | (rec) x ts l t' r where "t = Tree (x, ts)" "(l, t', r) \<in> set (splits ts)" "z \<in> set (zippers_rose_tree e h ((x, l, r) # p, t'))"
    by(cases t)(auto simp add: zipper_children.simps)
  then show ?case
  proof cases
    case find
    then show ?thesis by(simp add: rt.refl)
  next
    case rec
    then have "blinding_of_tree h bo
      (tree_of_zipper\<^sub>m z)
      (tree_of_zipper\<^sub>m (blind_path e h ((x, l, r) # p), embed_source_tree e t'))"
      by(intro 1)(simp add: rev_image_eqI zipper_children.simps)
    also have "blinding_of_tree h bo
      (tree_of_zipper\<^sub>m (blind_path e h ((x, l, r) # p), embed_source_tree e t'))
      (tree_of_zipper\<^sub>m (blind_path e h p, embed_source_tree e (Tree (x, ts))))"
      using rec
      by(simp add: blind_path_def splits_iff blinding_of_same_path[OF assms(1)] a.refl list_all2_append list_all2_same list.rel_map blinded_blinds_embedded rt.refl)
    finally (rt.trans) show ?thesis using rec by simp
  qed
qed

lemma zippers_rose_tree_neq_Nil: "zippers_rose_tree e h (p, t) \<noteq> []"
  by(simp add: zippers_rose_tree.simps)

lemma (in comp_fun_idem) fold_set_union:
  assumes "finite A" "finite B"
  shows "Finite_Set.fold f z (A \<union> B) = Finite_Set.fold f (Finite_Set.fold f z A) B"
  using assms(2,1) by induct simp_all

context merkle_interface begin

lemma comp_fun_idem_merge: "comp_fun_idem (\<lambda>x yo. yo \<bind> m x)"
  apply(unfold_locales; clarsimp simp add: fun_eq_iff split: bind_split)
  subgoal by (metis assoc bind.bind_lunit bind.bind_lzero idem option.distinct(1))
  subgoal by (simp add: join)
  done

interpretation merge: comp_fun_idem "\<lambda>x yo. yo \<bind> m x" by(rule comp_fun_idem_merge)

definition Merge :: "'a\<^sub>m set \<Rightarrow> 'a\<^sub>m option" where
  "Merge A = (if A = {} \<or> infinite A then None else Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some (SOME x. x \<in> A)) A)"

lemma Merge_empty [simp]: "Merge {} = None"
  by(simp add: Merge_def)

lemma Merge_infinite [simp]: "infinite A \<Longrightarrow> Merge A = None"
  by(simp add: Merge_def)

lemma Merge_cong_start:
  "Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some x) A = Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some y) A" (is "?lhs = ?rhs")
  if "x \<in> A" "y \<in> A" "finite A"
proof -
  have "?lhs = Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some x) (insert y A)" using that by(simp add: insert_absorb)
  also have "\<dots> = Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (m x y) A" using that
    by(simp only: merge.fold_insert_idem2)(simp add: commute)
  also have "\<dots> = Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some y) (insert x A)" using that
    by(simp only: merge.fold_insert_idem2)(simp)
  also have "\<dots> = ?rhs" using that by(simp add: insert_absorb)
  finally show ?thesis .
qed

lemma Merge_insert [simp]: "Merge (insert x A) = (if A = {} then Some x else Merge A \<bind> m x)" (is "?lhs = ?rhs")
proof(cases "finite A \<and> A \<noteq> {}")
  case True
  then have "?lhs = Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some (SOME x. x \<in> A)) (insert x A)"
    unfolding Merge_def by(subst Merge_cong_start[where y="SOME x. x \<in> A", OF someI])(auto intro: someI)
  also have "\<dots> = ?rhs" using True by(simp add: Merge_def)
  finally show ?thesis .
qed(auto simp add: Merge_def idem)

lemma Merge_insert_alt:
  "Merge (insert x A) = Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some x) A" (is "?lhs = ?rhs") if "finite A"
proof -
  have "?lhs = Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some x) (insert x A)" using that
    unfolding Merge_def by(subst Merge_cong_start[where y=x, OF someI]) auto
  also have "\<dots> = ?rhs" using that by(simp only: merge.fold_insert_idem2)(simp add: idem)
  finally show ?thesis .
qed

lemma Merge_None [simp]: "Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) None A = None"
proof(cases "finite A")
  case True
  then show ?thesis by(induction) auto
qed simp

lemma Merge_union:
  "Merge (A \<union> B) = (if A = {} then Merge B else if B = {} then Merge A else (Merge A \<bind> (\<lambda>a. Merge B \<bind> m a)))"
  (is "?lhs = ?rhs")
proof(cases "finite (A \<union> B) \<and> A \<noteq> {} \<and> B \<noteq> {}")
  case True
  then have "?lhs = Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some (SOME x. x \<in> B)) (B \<union> A)"
    unfolding Merge_def by(subst Merge_cong_start[where y="SOME x. x \<in> B", OF someI])(auto intro: someI simp add: Un_commute)
  also have "\<dots> = Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Merge B) A" using True
    by(simp add: Merge_def merge.fold_set_union)
  also have "\<dots> = Merge A \<bind> (\<lambda>a. Merge B \<bind> m a)"
  proof(cases "Merge B")
    case (Some b)
    thus ?thesis using True
      by simp(subst Merge_insert_alt[symmetric]; simp add: commute; metis commute)
  qed simp
  finally show ?thesis using True by simp
qed auto

lemma Merge_upper:
  assumes m: "Merge A = Some x" and y: "y \<in> A"
  shows "bo y x"
proof -
  have "Merge A = Merge (insert y A)" using y by(simp add: insert_absorb)
  also have "\<dots> = Merge A \<bind> m y" using y by auto
  finally have "m y x = Some x" using m by simp
  thus ?thesis by(simp add: bo_def)
qed

lemma Merge_least:
  assumes m: "Merge A = Some x" and u[rule_format]: "\<forall>a\<in>A. bo a u"
  shows "bo x u"
proof -
  define a where "a \<equiv> SOME x. x \<in> A"
  from m have A: "finite A" "A \<noteq> {}"
    and *: "Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some a) A = Some x"
    by(auto simp add: Merge_def a_def split: if_splits)
  from A have "bo a u" by(auto intro: someI u simp add: a_def)
  with A * u show ?thesis
  proof(induction A arbitrary: a)
    case (insert x A)
    then show ?case
      by(cases "m x a"; cases "A = {}"; simp only: merge.fold_insert_idem2; simp)(auto simp add: join)
  qed simp
qed

lemma Merge_defined:
  assumes "finite A" "A \<noteq> {}" "\<forall>a\<in>A. \<forall>b \<in> A. h a = h b"
  shows "Merge A \<noteq> None"
proof
  define a where "a \<equiv> SOME a. a \<in> A"
  have a: "a \<in> A" unfolding a_def using assms by(auto intro: someI)
  hence ha: "\<forall>b \<in> A. h b = h a" using assms by blast

  assume m: "Merge A = None"
  hence "Finite_Set.fold (\<lambda>x yo. yo \<bind> m x) (Some a) A = None"
    using assms by(simp add: Merge_def a_def)
  with assms(1) show False using ha
  proof(induction arbitrary: a)
    case (insert x A)
    thus ?case
      apply(cases "m x a"; use nothing in \<open>simp only: merge.fold_insert_idem2\<close>)
       apply(simp add: merge_respects_hashes)
      apply(fastforce simp add: join vimage2p_def dest: hash[THEN predicate2D])
      done
  qed simp
qed

lemma Merge_hash:
  assumes "Merge A = Some x" "a \<in> A"
  shows "h a = h x"
  using Merge_upper[OF assms] hash by(auto simp add: vimage2p_def)

end

end


section\<open>Routing Table\<close>
theory Routing_Table
imports IP_Addresses.Prefix_Match
        IP_Addresses.IPv4 IP_Addresses.IPv6
        Linorder_Helper
        IP_Addresses.Prefix_Match_toString
begin

text\<open>This section makes the necessary definitions to work with a routing table using longest prefix matching.\<close>
subsection\<open>Definition\<close>

record(overloaded) 'i routing_action =
  output_iface :: string
  next_hop :: "'i word option" (* no next hop iff locally attached *)

(* Routing rule matching ip route unicast type *)
record(overloaded) 'i routing_rule =
  routing_match :: "('i::len) prefix_match" (* done on the dst *)
  metric :: nat
  routing_action :: "'i routing_action"

text\<open>This definition is engineered to model routing tables on packet forwarding devices.
It eludes, e.g., the source address hint, which is only relevant for packets originating from the device itself.\<close>
(* See also: http://linux-ip.net/html/routing-saddr-selection.html *)

context
begin

definition "default_metric = 0"

type_synonym 'i prefix_routing = "('i routing_rule) list"

abbreviation "routing_oiface a \<equiv> output_iface (routing_action a)" (* I needed this a lot... *)
abbreviation "routing_prefix r \<equiv> pfxm_length (routing_match r)"

definition valid_prefixes where
  "valid_prefixes r = foldr conj (map (\<lambda>rr. valid_prefix (routing_match rr)) r) True"
lemma valid_prefixes_split: "valid_prefixes (r#rs) \<Longrightarrow> valid_prefix (routing_match r) \<and> valid_prefixes rs"
  using valid_prefixes_def by force

lemma foldr_True_set: "foldr (\<lambda>x. (\<and>) (f x)) l True = (\<forall>x \<in> set l. f x)"
  by (induction l) simp_all
lemma valid_prefixes_alt_def: "valid_prefixes r = (\<forall>e \<in> set r. valid_prefix (routing_match e))"
  unfolding valid_prefixes_def
  unfolding foldr_map
  unfolding comp_def
  unfolding foldr_True_set
  ..

fun has_default_route :: "('i::len) prefix_routing \<Rightarrow> bool" where
"has_default_route (r#rs) = (((pfxm_length (routing_match r)) = 0) \<or> has_default_route rs)" |
"has_default_route Nil = False"

lemma has_default_route_alt: "has_default_route rt \<longleftrightarrow> (\<exists>r \<in> set rt. pfxm_length (routing_match r) = 0)" by(induction rt) simp_all

subsection\<open>Single Packet Semantics\<close>

fun routing_table_semantics :: "('i::len) prefix_routing \<Rightarrow> 'i word \<Rightarrow> 'i routing_action" where
"routing_table_semantics [] _ = routing_action (undefined::'i routing_rule)" |
"routing_table_semantics (r#rs) p = (if prefix_match_semantics (routing_match r) p then routing_action r else routing_table_semantics rs p)"
lemma routing_table_semantics_ports_from_table: "valid_prefixes rtbl \<Longrightarrow> has_default_route rtbl \<Longrightarrow>
  routing_table_semantics rtbl packet = r \<Longrightarrow> r \<in> routing_action ` set rtbl"
proof(induction rtbl)
  case (Cons r rs)
  note v_pfxs = valid_prefixes_split[OF Cons.prems(1)]
  show ?case
  proof(cases "pfxm_length (routing_match r) = 0")
    case True
    note zero_prefix_match_all[OF conjunct1[OF v_pfxs] True] Cons.prems(3)
    then show ?thesis by simp
  next
    case False
    hence "has_default_route rs" using Cons.prems(2) by simp
    from Cons.IH[OF conjunct2[OF v_pfxs] this] Cons.prems(3) show ?thesis by force
  qed
qed simp

subsection\<open>Longest Prefix Match\<close>

text\<open>We can abuse @{const LinordHelper} to sort.\<close>
definition "routing_rule_sort_key \<equiv> \<lambda>r. LinordHelper (0 - (of_nat :: nat \<Rightarrow> int) (pfxm_length (routing_match r))) (metric r)"
text\<open>There is actually a slight design choice here. We can choose to sort based on @{thm less_eq_prefix_match_def} (thus including the address) or only the prefix length (excluding it).
  Which is taken does not matter gravely, since the bits of the prefix can't matter. They're either eqal or the rules don't overlap and the metric decides. (It does matter for the resulting list though.)
  Ignoring the prefix and taking only its length is slightly easier.\<close>

(*example: get longest prefix match by sorting by pfxm_length*)
definition "rr_ctor m l a nh me \<equiv> \<lparr> routing_match = PrefixMatch (ipv4addr_of_dotdecimal m) l, metric = me, routing_action =\<lparr>output_iface = a, next_hop = (map_option ipv4addr_of_dotdecimal nh)\<rparr> \<rparr>"
value "sort_key routing_rule_sort_key [
  rr_ctor (0,0,0,1) 3 '''' None 0,
  rr_ctor (0,0,0,2) 8 [] None 0,
  rr_ctor (0,0,0,3) 4 [] None 13,
  rr_ctor (0,0,0,3) 4 [] None 42]"

definition "is_longest_prefix_routing \<equiv> sorted \<circ> map routing_rule_sort_key"

definition correct_routing :: "('i::len) prefix_routing \<Rightarrow> bool" where
  "correct_routing r \<equiv> is_longest_prefix_routing r \<and> valid_prefixes r"
text\<open>Many proofs and functions around routing require at least parts of @{const correct_routing} as an assumption.
Obviously, @{const correct_routing} is not given for arbitrary routing tables. Therefore,
@{const correct_routing} is made to be executable and should be checked for any routing table after parsing.
Note: @{const correct_routing} used to also require @{const has_default_route},
but none of the proofs require it anymore and it is not given for any routing table.\<close>

lemma is_longest_prefix_routing_rule_exclusion:
  assumes "is_longest_prefix_routing (r1 # rn # rss)"
  shows "is_longest_prefix_routing (r1 # rss)"
using assms by(case_tac rss) (auto simp add: is_longest_prefix_routing_def)

lemma is_longest_prefix_routing_sorted_by_length:
  assumes "is_longest_prefix_routing r"
     and "r = r1 # rs @ r2 # rss"
  shows "(pfxm_length (routing_match r1) \<ge> pfxm_length (routing_match r2))"
using assms
proof(induction rs arbitrary: r)
  case (Cons rn rs)
  let ?ro = "r1 # rs @ r2 # rss"
  have "is_longest_prefix_routing ?ro" using Cons.prems is_longest_prefix_routing_rule_exclusion[of r1 rn "rs @ r2 # rss"] by simp
  from Cons.IH[OF this] show ?case by simp
next
  case Nil thus ?case by(auto simp add: is_longest_prefix_routing_def routing_rule_sort_key_def linord_helper_less_eq1_def less_eq_linord_helper_def int_of_nat_def)
qed

definition "sort_rtbl :: ('i::len) routing_rule list \<Rightarrow> 'i routing_rule list \<equiv> sort_key routing_rule_sort_key"

lemma is_longest_prefix_routing_sort: "is_longest_prefix_routing (sort_rtbl r)" unfolding sort_rtbl_def is_longest_prefix_routing_def by simp

definition "unambiguous_routing rtbl \<equiv> (\<forall>rt1 rt2 rr ra. rtbl = rt1 @ rr # rt2 \<longrightarrow> ra \<in> set (rt1 @ rt2) \<longrightarrow> routing_match rr = routing_match ra \<longrightarrow> routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra)"
lemma unambiguous_routing_Cons: "unambiguous_routing (r # rtbl) \<Longrightarrow> unambiguous_routing rtbl"
  unfolding unambiguous_routing_def by(clarsimp) (metis append_Cons in_set_conv_decomp)
lemma "unambiguous_routing (rr # rtbl) \<Longrightarrow> is_longest_prefix_routing (rr # rtbl) \<Longrightarrow> ra \<in> set rtbl \<Longrightarrow> routing_match rr = routing_match ra \<Longrightarrow> routing_rule_sort_key rr < routing_rule_sort_key ra"
  unfolding is_longest_prefix_routing_def unambiguous_routing_def by(fastforce)
primrec unambiguous_routing_code where
"unambiguous_routing_code [] = True" |
"unambiguous_routing_code (rr#rtbl) = (list_all (\<lambda>ra. routing_match rr \<noteq> routing_match ra \<or> routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra) rtbl \<and> unambiguous_routing_code rtbl)"
lemma unambiguous_routing_code[code_unfold]: "unambiguous_routing rtbl \<longleftrightarrow> unambiguous_routing_code rtbl"
proof(induction rtbl)
  case (Cons rr rtbl) show ?case (is "?l \<longleftrightarrow> ?r") proof
    assume l: ?l
    with unambiguous_routing_Cons Cons.IH have "unambiguous_routing_code rtbl" by blast
    moreover have "list_all (\<lambda>ra. routing_match rr \<noteq> routing_match ra \<or> routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra) rtbl"
      using l unfolding unambiguous_routing_def by(fastforce simp add: list_all_iff)
    ultimately show ?r by simp
  next
    assume r: ?r
    with Cons.IH have "unambiguous_routing rtbl" by simp
    from r have *: "list_all (\<lambda>ra. routing_match rr \<noteq> routing_match ra \<or>  routing_rule_sort_key rr \<noteq> routing_rule_sort_key ra) rtbl" by simp
    have False if "rr # rtbl = rt1 @ rra # rt2" "ra \<in> set (rt1 @ rt2)" "routing_rule_sort_key rra = routing_rule_sort_key ra \<and> routing_match rra = routing_match ra" for rt1 rt2 rra ra
    proof(cases "rt1 = []")
      case True thus ?thesis using that * by(fastforce simp add: list_all_iff)
    next
      case False
      with that(1) have rtbl: "rtbl = tl rt1 @ rra # rt2" by (metis list.sel(3) tl_append2)
      show ?thesis proof(cases "ra = hd rt1") (* meh case split\<dots> *)
        case False hence "ra \<in> set (tl rt1 @ rt2)" using that by(cases rt1; simp)
        with \<open>unambiguous_routing rtbl\<close> show ?thesis  using that(3) rtbl unfolding unambiguous_routing_def by fast
      next
        case True hence "rr = ra" using that \<open>rt1 \<noteq> []\<close> by(cases rt1; simp)
        thus ?thesis using that * unfolding rtbl by(fastforce simp add: list_all_iff)
      qed
    qed
    thus ?l unfolding unambiguous_routing_def by blast
  qed
qed(simp add: unambiguous_routing_def)

lemma unambigous_prefix_routing_weak_mono:
  assumes lpfx: "is_longest_prefix_routing (rr#rtbl)"
  assumes e:"rr' \<in> set rtbl"
  shows "routing_rule_sort_key rr' \<ge> routing_rule_sort_key rr"
using assms  by(simp add: is_longest_prefix_routing_def)
lemma unambigous_prefix_routing_strong_mono:
  assumes lpfx: "is_longest_prefix_routing (rr#rtbl)"
  assumes uam: "unambiguous_routing (rr#rtbl)"
  assumes e:"rr' \<in> set rtbl"
  assumes ne: "routing_match rr' = routing_match rr"
  shows "routing_rule_sort_key rr' > routing_rule_sort_key rr"
proof -
  from uam e ne have "routing_rule_sort_key rr \<noteq> routing_rule_sort_key rr'" by(fastforce simp add: unambiguous_routing_def)
  moreover from unambigous_prefix_routing_weak_mono lpfx e have "routing_rule_sort_key rr \<le> routing_rule_sort_key rr'" .
  ultimately show ?thesis by simp
qed

lemma "routing_rule_sort_key (rr_ctor (0,0,0,0) 8 [] None 0) > routing_rule_sort_key (rr_ctor (0,0,0,0) 24 [] None 0)" by eval
(* get the inequality right\<dots> bigger means lower priority *)
text\<open>In case you don't like that formulation of @{const is_longest_prefix_routing} over sorting, this is your lemma.\<close>
theorem existential_routing: "valid_prefixes rtbl \<Longrightarrow> is_longest_prefix_routing rtbl \<Longrightarrow> has_default_route rtbl \<Longrightarrow> unambiguous_routing rtbl \<Longrightarrow>
routing_table_semantics rtbl addr = act \<longleftrightarrow> (\<exists>rr \<in> set rtbl. prefix_match_semantics (routing_match rr) addr \<and> routing_action rr = act \<and>
  (\<forall>ra \<in> set rtbl. routing_rule_sort_key ra < routing_rule_sort_key rr \<longrightarrow> \<not>prefix_match_semantics (routing_match ra) addr))"
proof(induction rtbl)
  case Nil thus ?case by simp
next
  case (Cons rr rtbl)
  show ?case proof(cases "prefix_match_semantics (routing_match rr) addr")
    case False
    hence [simp]: "routing_table_semantics (rr # rtbl) addr = routing_table_semantics (rr # rtbl) addr" by simp
    show ?thesis proof(cases "routing_prefix rr = 0")
      case True text\<open>Need special treatment, rtbl won't have a default route, so the IH is not usable.\<close>
      have "valid_prefix (routing_match rr)" using Cons.prems valid_prefixes_split by blast
      with True False have False using zero_prefix_match_all by blast
      thus ?thesis ..
    next
      case False
      with Cons.prems have mprems: "valid_prefixes rtbl" "is_longest_prefix_routing rtbl" "has_default_route rtbl" "unambiguous_routing rtbl"
        by(simp_all add: valid_prefixes_split unambiguous_routing_Cons is_longest_prefix_routing_def)
      show ?thesis using Cons.IH[OF mprems] False \<open>\<not> prefix_match_semantics (routing_match rr) addr\<close> by simp
    qed
  next
    case True
    from True have [simp]: "routing_table_semantics (rr # rtbl) addr = routing_action rr" by simp
    show ?thesis (is "?l \<longleftrightarrow> ?r") proof
      assume ?l
      hence [simp]: "act = routing_action rr" by(simp add: True)
      have *: "(\<forall>ra\<in>set (rr # rtbl). routing_rule_sort_key rr \<le> routing_rule_sort_key ra)"
        using \<open>is_longest_prefix_routing (rr # rtbl)\<close>  by(clarsimp simp: is_longest_prefix_routing_def)
      thus ?r by(fastforce simp add: True)
    next
      assume ?r
      then guess rr' .. note rr' = this
      have "rr' = rr" proof(rule ccontr)
        assume C: "rr' \<noteq> rr"
        from C have e: "rr' \<in> set rtbl" using rr' by simp
        show False proof cases
          assume eq: "routing_match rr' = routing_match rr"
          with e have "routing_rule_sort_key rr < routing_rule_sort_key rr'" using unambigous_prefix_routing_strong_mono[OF Cons.prems(2,4) _ eq] by simp
          with True rr' show False by simp
        next
          assume ne: "routing_match rr' \<noteq> routing_match rr"
          from rr' Cons.prems have "valid_prefix (routing_match rr)" "valid_prefix (routing_match rr')" "prefix_match_semantics (routing_match rr') addr" by(auto simp add: valid_prefixes_alt_def)
          note same_length_prefixes_distinct[OF this(1,2) ne[symmetric] _ True this(3)]
          moreover have "routing_prefix rr = routing_prefix rr'" (is ?pe) proof -
            have "routing_rule_sort_key rr < routing_rule_sort_key rr' \<longrightarrow> \<not> prefix_match_semantics (routing_match rr) addr" using rr' by simp
            with unambigous_prefix_routing_weak_mono[OF Cons.prems(2) e] True have "routing_rule_sort_key rr = routing_rule_sort_key rr'" by simp
            thus ?pe by(simp add: routing_rule_sort_key_def int_of_nat_def)
          qed
          ultimately show False .
        qed
      qed
      thus ?l using rr' by simp
    qed
  qed
qed

subsection\<open>Printing\<close>

definition "routing_rule_32_toString (rr::32 routing_rule) \<equiv>
  prefix_match_32_toString (routing_match rr)
@ (case next_hop (routing_action rr) of Some nh \<Rightarrow> '' via '' @ ipv4addr_toString nh | _ \<Rightarrow> [])
@ '' dev '' @ routing_oiface rr
@ '' metric '' @ string_of_nat (metric rr)"

definition "routing_rule_128_toString (rr::128 routing_rule) \<equiv>
  prefix_match_128_toString (routing_match rr)
@ (case next_hop (routing_action rr) of Some nh \<Rightarrow> '' via '' @ ipv6addr_toString nh | _ \<Rightarrow> [])
@ '' dev '' @ routing_oiface rr
@ '' metric '' @ string_of_nat (metric rr)"

lemma "map routing_rule_32_toString
[rr_ctor (42,0,0,0) 7 ''eth0'' None 808,
 rr_ctor (0,0,0,0) 0 ''eth1'' (Some (222,173,190,239)) 707] =
[''42.0.0.0/7 dev eth0 metric 808'',
 ''0.0.0.0/0 via 222.173.190.239 dev eth1 metric 707'']" by eval

section\<open>Routing table to Relation\<close>

text\<open>Walking through a routing table splits the (remaining) IP space when traversing a routing table into a pair of sets:
 the pair contains the IPs concerned by the current rule and those left alone.\<close>
private definition ipset_prefix_match where
  "ipset_prefix_match pfx rg = (let pfxrg = prefix_to_wordset pfx in (rg \<inter> pfxrg, rg - pfxrg))"
private lemma ipset_prefix_match_m[simp]:  "fst (ipset_prefix_match pfx rg) = rg \<inter> (prefix_to_wordset pfx)" by(simp only: Let_def ipset_prefix_match_def, simp)
private lemma ipset_prefix_match_nm[simp]: "snd (ipset_prefix_match pfx rg) = rg - (prefix_to_wordset pfx)" by(simp only: Let_def ipset_prefix_match_def, simp)
private lemma ipset_prefix_match_distinct: "rpm = ipset_prefix_match pfx rg \<Longrightarrow>
  (fst rpm) \<inter> (snd rpm) = {}" by force
private lemma ipset_prefix_match_complete: "rpm = ipset_prefix_match pfx rg \<Longrightarrow>
  (fst rpm) \<union> (snd rpm) = rg" by force
private

subsection\<open>Wordintervals for Ports by Routing\<close>
text\<open>This split, although rather trivial,
can be used to construct the sets (or rather: the intervals)
of IPs that are actually matched by an entry in a routing table.\<close>

private fun routing_port_ranges :: "'i prefix_routing \<Rightarrow> 'i wordinterval \<Rightarrow> (string \<times> ('i::len) wordinterval) list" where
"routing_port_ranges [] lo = (if wordinterval_empty lo then [] else [(routing_oiface (undefined::'i routing_rule),lo)])" | (* insert default route to nirvana. has to match what routing_table_semantics does. *)
"routing_port_ranges (a#as) lo = (
	let rpm = range_prefix_match (routing_match a) lo; m = fst rpm; nm = snd rpm in (
	(routing_oiface a,m) # routing_port_ranges as nm))"

private lemma routing_port_ranges_subsets:
"(a1, b1) \<in> set (routing_port_ranges tbl s) \<Longrightarrow> wordinterval_to_set b1 \<subseteq> wordinterval_to_set s"
  by(induction tbl arbitrary: s; fastforce simp add: Let_def split: if_splits)

private lemma routing_port_ranges_sound: "e \<in> set (routing_port_ranges tbl s) \<Longrightarrow> k \<in> wordinterval_to_set (snd e) \<Longrightarrow> valid_prefixes tbl \<Longrightarrow>
	fst e = output_iface (routing_table_semantics tbl k)"
proof(induction tbl arbitrary: s)
	case (Cons a as)
	note s = Cons.prems(1)[unfolded routing_port_ranges.simps Let_def list.set]
	note vpfx = valid_prefixes_split[OF Cons.prems(3)]
	show ?case (is ?kees) proof(cases "e = (routing_oiface a, fst (range_prefix_match (routing_match a) s))")
		case False
		hence es: "e \<in> set (routing_port_ranges as (snd (range_prefix_match (routing_match a) s)))" using s by blast
		note eq = Cons.IH[OF this Cons.prems(2) conjunct2[OF vpfx]]
		have "\<not>prefix_match_semantics (routing_match a) k" (is ?nom)
		proof -
		  from routing_port_ranges_subsets[of "fst e" "snd e", unfolded prod.collapse, OF es]
		  have *: "wordinterval_to_set (snd e) \<subseteq> wordinterval_to_set (snd (range_prefix_match (routing_match a) s))" .
			show ?nom unfolding prefix_match_semantics_wordset[OF conjunct1[OF vpfx]]
			  using * Cons.prems(2)	unfolding wordinterval_subset_set_eq
				by(auto simp add: range_prefix_match_def Let_def)
		qed
		thus ?kees using eq by simp
	next
		case True
		hence fe: "fst e = routing_oiface a" by simp
		from True have "k \<in> wordinterval_to_set (fst (range_prefix_match (routing_match a) s))"
			using Cons.prems(2) by(simp)
		hence "prefix_match_semantics (routing_match a) k"
			unfolding prefix_match_semantics_wordset[OF conjunct1, OF vpfx]
			unfolding range_prefix_match_def Let_def
			by simp
		thus ?kees by(simp add: fe)
	qed
qed (simp split: if_splits)

private lemma routing_port_ranges_disjoined:
assumes vpfx: "valid_prefixes tbl"
  and ins:  "(a1, b1) \<in> set (routing_port_ranges tbl s)" "(a2, b2) \<in> set (routing_port_ranges tbl s)"
  and nemp: "wordinterval_to_set b1 \<noteq> {}"
shows "b1 \<noteq> b2 \<longleftrightarrow> wordinterval_to_set b1 \<inter> wordinterval_to_set b2 = {}"
using assms
proof(induction tbl arbitrary: s)
  case (Cons r rs)
  have vpfx: "valid_prefix (routing_match r)" "valid_prefixes rs" using Cons.prems(1) using valid_prefixes_split by blast+
  { (* In case that one of b1 b2 stems from r and one does not, we assume it is b1 WLOG. *)
    fix a1 b1 a2 b2
    assume one: "b1 = fst (range_prefix_match (routing_match r) s)"
    assume two: "(a2, b2) \<in> set (routing_port_ranges rs (snd (range_prefix_match (routing_match r) s)))"
    have dc: "wordinterval_to_set (snd (range_prefix_match (routing_match r) s)) \<inter>
          wordinterval_to_set (fst (range_prefix_match (routing_match r) s)) = {}" by force
    hence "wordinterval_to_set b1 \<inter> wordinterval_to_set b2 = {}"
    unfolding one using two[THEN routing_port_ranges_subsets] by fast
  } note * = this
  show ?case
  using \<open>(a1, b1) \<in> set (routing_port_ranges (r # rs) s)\<close> \<open>(a2, b2) \<in> set (routing_port_ranges (r # rs) s)\<close> nemp
    Cons.IH[OF vpfx(2)] *
    by(fastforce simp add: Let_def)
qed (simp split: if_splits)

private lemma routing_port_rangesI:
"valid_prefixes tbl \<Longrightarrow>
 output_iface (routing_table_semantics tbl k) = output_port \<Longrightarrow>
 k \<in> wordinterval_to_set wi \<Longrightarrow>
 (\<exists>ip_range. (output_port, ip_range) \<in> set (routing_port_ranges tbl wi) \<and> k \<in> wordinterval_to_set ip_range)"
proof(induction tbl arbitrary: wi)
  case Nil thus ?case by simp blast
next
  case (Cons r rs)
  from Cons.prems(1) have vpfx: "valid_prefix (routing_match r)" and vpfxs: "valid_prefixes rs"
    by(simp_all add: valid_prefixes_split)
  show ?case
  proof(cases "prefix_match_semantics (routing_match r) k")
    case True
    thus ?thesis
      using Cons.prems(2) using vpfx \<open>k \<in> wordinterval_to_set wi\<close>
      by (intro exI[where x =  "fst (range_prefix_match (routing_match r) wi)"])
         (simp add: prefix_match_semantics_wordset Let_def)
  next
    case False
    with \<open>k \<in> wordinterval_to_set wi\<close> have ksnd: "k \<in> wordinterval_to_set (snd (range_prefix_match (routing_match r) wi))"
      by (simp add: prefix_match_semantics_wordset vpfx)
    have mpr: "output_iface (routing_table_semantics rs k) = output_port" using Cons.prems False by simp
    note Cons.IH[OF vpfxs mpr ksnd]
    thus ?thesis by(fastforce simp: Let_def)
  qed
qed

subsection\<open>Reduction\<close>
text\<open>So far, one entry in the list would be generated for each routing table entry.
This next step reduces it to one for each port.
The resulting list will represent a function from port to IP wordinterval.
(It can also be understood as a function from IP (interval) to port (where the intervals don't overlap).\<close>

definition "reduce_range_destination l \<equiv>
let ps = remdups (map fst l) in
let c = \<lambda>s. (wordinterval_Union \<circ> map snd \<circ> filter (((=) s) \<circ> fst)) l in
[(p, c p). p \<leftarrow> ps]
"

definition "routing_ipassmt_wi tbl \<equiv> reduce_range_destination (routing_port_ranges tbl wordinterval_UNIV)"

lemma routing_ipassmt_wi_distinct: "distinct (map fst (routing_ipassmt_wi tbl))"
  unfolding routing_ipassmt_wi_def reduce_range_destination_def
  by(simp add: comp_def)

private lemma routing_port_ranges_superseted:
"(a1,b1) \<in> set (routing_port_ranges tbl wordinterval_UNIV) \<Longrightarrow>
  \<exists>b2. (a1,b2) \<in> set (routing_ipassmt_wi tbl) \<and> wordinterval_to_set b1 \<subseteq> wordinterval_to_set b2"
  unfolding routing_ipassmt_wi_def reduce_range_destination_def
  by(force simp add: Set.image_iff wordinterval_Union)

private lemma routing_ipassmt_wi_subsetted:
"(a1,b1) \<in> set (routing_ipassmt_wi tbl) \<Longrightarrow>
 (a1,b2) \<in> set (routing_port_ranges tbl wordinterval_UNIV) \<Longrightarrow>  wordinterval_to_set b2 \<subseteq> wordinterval_to_set b1"
  unfolding routing_ipassmt_wi_def reduce_range_destination_def
  by(fastforce simp add: Set.image_iff wordinterval_Union comp_def)

text\<open>This lemma should hold without the @{const valid_prefixes} assumption, but that would break the semantic argument and make the proof a lot harder.\<close>
lemma routing_ipassmt_wi_disjoint:
assumes vpfx: "valid_prefixes (tbl::('i::len) prefix_routing)"
  and dif: "a1 \<noteq> a2"
  and ins:  "(a1, b1) \<in> set (routing_ipassmt_wi tbl)" "(a2, b2) \<in> set (routing_ipassmt_wi tbl)"
shows "wordinterval_to_set b1 \<inter> wordinterval_to_set b2 = {}"
proof(rule ccontr)
  note iuf = ins[unfolded routing_ipassmt_wi_def reduce_range_destination_def Let_def, simplified, unfolded Set.image_iff comp_def, simplified]
  assume "(wordinterval_to_set b1 \<inter> wordinterval_to_set b2 \<noteq> {})"
  hence "wordinterval_to_set b1 \<inter> wordinterval_to_set b2 \<noteq> {}" by simp
  text\<open>If the intervals are not disjoint, there exists a witness of that.\<close>
  then obtain x where x[simp]: "x \<in> wordinterval_to_set b1" "x \<in> wordinterval_to_set b2" by blast
  text\<open>This witness has to have come from some entry in the result of @{const routing_port_ranges}, for both of @{term b1} and @{term b2}.\<close>
  hence "\<exists>b1g. x \<in> wordinterval_to_set b1g \<and> wordinterval_to_set b1g \<subseteq> wordinterval_to_set b1 \<and> (a1, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)"
    using iuf(1) by(fastforce simp add: wordinterval_Union) (* strangely, this doesn't work with obtain *)
  then obtain b1g where b1g: "x \<in> wordinterval_to_set b1g" "wordinterval_to_set b1g \<subseteq> wordinterval_to_set b1" "(a1, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)" by clarsimp
  from x have "\<exists>b2g. x \<in> wordinterval_to_set b2g \<and> wordinterval_to_set b2g \<subseteq> wordinterval_to_set b2 \<and> (a2, b2g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)"
    using iuf(2) by(fastforce simp add: wordinterval_Union)
  then obtain b2g where b2g: "x \<in> wordinterval_to_set b2g" "wordinterval_to_set b2g \<subseteq> wordinterval_to_set b2" "(a2, b2g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)" by clarsimp
  text\<open>Soudness tells us that the both @{term a1} and @{term a2} have to be the result of routing @{term x}.\<close>
  note routing_port_ranges_sound[OF b1g(3), unfolded fst_conv snd_conv, OF b1g(1) vpfx] routing_port_ranges_sound[OF b2g(3), unfolded fst_conv snd_conv, OF b2g(1) vpfx]
  text\<open>A contradiction follows from @{thm dif}.\<close>
  with dif show False by simp
qed

lemma routing_ipassmt_wi_sound:
  assumes vpfx: "valid_prefixes tbl"
  and ins: "(ea,eb) \<in> set (routing_ipassmt_wi tbl)"
  and x: "k \<in> wordinterval_to_set eb"
  shows "ea = output_iface (routing_table_semantics tbl k)"
proof -
  note iuf = ins[unfolded routing_ipassmt_wi_def reduce_range_destination_def Let_def, simplified, unfolded Set.image_iff comp_def, simplified]
  from x have "\<exists>b1g. k \<in> wordinterval_to_set b1g \<and> wordinterval_to_set b1g \<subseteq> wordinterval_to_set eb \<and> (ea, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)"
    using iuf(1) by(fastforce simp add: wordinterval_Union)
  then obtain b1g where b1g: "k \<in> wordinterval_to_set b1g" "wordinterval_to_set b1g \<subseteq> wordinterval_to_set eb" "(ea, b1g) \<in> set (routing_port_ranges tbl wordinterval_UNIV)" by clarsimp
  note routing_port_ranges_sound[OF b1g(3), unfolded fst_conv snd_conv, OF b1g(1) vpfx]
  thus ?thesis .
qed

theorem routing_ipassmt_wi:
assumes vpfx: "valid_prefixes tbl"
  shows
  "output_iface (routing_table_semantics tbl k) = output_port \<longleftrightarrow>
    (\<exists>ip_range. k \<in> wordinterval_to_set ip_range \<and> (output_port, ip_range) \<in> set (routing_ipassmt_wi tbl))"
proof (intro iffI, goal_cases)
  case 2 with vpfx routing_ipassmt_wi_sound show ?case by blast
next
  case 1
  then obtain ip_range where "(output_port, ip_range) \<in> set (routing_port_ranges tbl wordinterval_UNIV) \<and> k \<in> wordinterval_to_set ip_range"
    using routing_port_rangesI[where wi = wordinterval_UNIV, OF vpfx] by auto
  thus ?case
    unfolding routing_ipassmt_wi_def reduce_range_destination_def
    unfolding Let_def comp_def
    by(force simp add: Set.image_iff wordinterval_Union)
qed

(* this was not given for the old reduced_range_destination *)
lemma routing_ipassmt_wi_has_all_interfaces:
  assumes in_tbl: "r \<in> set tbl"
  shows "\<exists>s. (routing_oiface r,s) \<in> set (routing_ipassmt_wi tbl)"
proof -
  from in_tbl have "\<exists>s. (routing_oiface r,s) \<in> set (routing_port_ranges tbl S)" for S
  proof(induction tbl arbitrary: S)
    case (Cons l ls)
    show ?case
    proof(cases "r = l")
      case True thus ?thesis using Cons.prems by(auto simp: Let_def)
    next
      case False with Cons.prems have "r \<in> set ls" by simp
      from Cons.IH[OF this] show ?thesis by(simp add: Let_def) blast
    qed
  qed simp
  thus ?thesis
    unfolding routing_ipassmt_wi_def reduce_range_destination_def
    by(force simp add: Set.image_iff)
qed

end

end


theory Denotational
  imports "Abstract-Denotational-Props" "Value-Nominal"
begin

text \<open>
This is the actual denotational semantics as found in \<^cite>\<open>"launchbury"\<close>.
\<close>

interpretation semantic_domain Fn Fn_project B B_project "(\<Lambda> x. x)".

notation ESem_syn ("\<lbrakk> _ \<rbrakk>\<^bsub>_\<^esub>"  [60,60] 60)
notation EvalHeapSem_syn  ("\<^bold>\<lbrakk> _ \<^bold>\<rbrakk>\<^bsub>_\<^esub>"  [0,0] 110)
notation HSem_syn ("\<lbrace>_\<rbrace>_"  [60,60] 60)
notation AHSem_bot ("\<lbrace>_\<rbrace>"  [60] 60)

lemma ESem_simps_as_defined:
  "\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub> =  Fn\<cdot>(\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>(\<rho> f|` (fv (Lam [x].e)))(x := v)\<^esub>)"
  "\<lbrakk> App e x \<rbrakk>\<^bsub>\<rho>\<^esub>    =  \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub> \<down>Fn \<rho> x"
  "\<lbrakk> Var x \<rbrakk>\<^bsub>\<rho>\<^esub>      =  \<rho>  x"
  "\<lbrakk> Bool b \<rbrakk>\<^bsub>\<rho>\<^esub>     =  B\<cdot>(Discr b)"
  "\<lbrakk> (scrut ? e\<^sub>1 : e\<^sub>2) \<rbrakk>\<^bsub>\<rho>\<^esub> = B_project\<cdot>(\<lbrakk> scrut \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<rho>\<^esub>)"
  "\<lbrakk> Let \<Gamma> body \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk>body\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>(\<rho> f|` fv (Let \<Gamma> body))\<^esub>"
  by (simp_all del: ESem_Lam ESem_Let add: ESem.simps(1,4) )

lemma ESem_simps:
  "\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub> =  Fn\<cdot>(\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>)"
  "\<lbrakk> App e x \<rbrakk>\<^bsub>\<rho>\<^esub>    =  \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub> \<down>Fn \<rho> x"
  "\<lbrakk> Var x \<rbrakk>\<^bsub>\<rho>\<^esub>      =  \<rho>  x"
  "\<lbrakk> Bool b \<rbrakk>\<^bsub>\<rho>\<^esub>     =  B\<cdot>(Discr b)"
  "\<lbrakk> (scrut ? e\<^sub>1 : e\<^sub>2) \<rbrakk>\<^bsub>\<rho>\<^esub> = B_project\<cdot>(\<lbrakk> scrut \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<rho>\<^esub>)"
  "\<lbrakk> Let \<Gamma> body \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk>body\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>"
  by simp_all
(*<*)

text \<open>
Excluded from the document, as these are unused in the current development.
\<close>

subsubsection \<open>Replacing subexpressions by variables\<close>

lemma HSem_subst_var_app:
  assumes fresh: "atom n \<sharp> x"
  shows "\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho> = \<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho> "
proof(rule HSem_subst_expr)
  from fresh have [simp]: "n \<noteq> x" by (simp add: fresh_at_base)
  have ne: "(n,e) \<in> set ((x, App e y) # (n, e) # \<Gamma>)" by simp

  have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = (\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>) n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    by (subst HSem_eq, simp)
  finally
  show "\<lbrakk> App (Var n) y \<rbrakk>\<^bsub>\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> App e y \<rbrakk>\<^bsub>\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp

 have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = (\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>) n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    by (subst HSem_eq, simp)
  finally
  show "\<lbrakk> App e y \<rbrakk>\<^bsub>\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> App (Var n) y \<rbrakk>\<^bsub>\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp
qed

lemma HSem_subst_var_var:
  assumes fresh: "atom n \<sharp> x"
  shows "\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho> = \<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho> "
proof(rule HSem_subst_expr)
  from fresh have [simp]: "n \<noteq> x" by (simp add: fresh_at_base)
  have ne: "(n,e) \<in> set ((x, e) # (n, e) # \<Gamma>)" by simp

  have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = (\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>) n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    by (subst HSem_eq, simp)
  finally
  show "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp

  have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = (\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>) n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    by (subst HSem_eq, simp)
  finally
  show "\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp
qed
(*>*)

end


(* The Call-by-Value Lambda Calculus *)
theory Lt
imports "../../Nominal2"
begin

atom_decl name

nominal_datatype lt =
    Var name       ("_~"  [150] 149)
  | App lt lt         (infixl "$$" 100)
  | Lam x::"name" t::"lt"  binds  x in t

nominal_function
  subst :: "lt \<Rightarrow> name \<Rightarrow> lt \<Rightarrow> lt"  ("_ [_ ::= _]" [90, 90, 90] 90)
where
  "(Var x)[y ::= s] = (if x = y then s else (Var x))"
| "(App t1 t2)[y ::= s] = App (t1[y ::= s]) (t2[y ::= s])"
| "atom x \<sharp> (y, s) \<Longrightarrow> (Lam x t)[y ::= s] = Lam x (t[y ::= s])"
  unfolding eqvt_def subst_graph_aux_def
  apply (simp)
  apply(rule TrueI)
  using [[simproc del: alpha_lst]]
  apply(auto simp add: lt.distinct lt.eq_iff)
  apply(rule_tac y="a" and c="(aa, b)" in lt.strong_exhaust)
  apply blast
  apply(simp_all add: fresh_star_def fresh_Pair_elim)
  apply (erule_tac c="(ya,sa)" in Abs_lst1_fcb2)
  apply(simp add: Abs_fresh_iff)
  apply(simp add: fresh_star_def fresh_Pair)
  apply(simp add: eqvt_at_def)
  apply(simp add: perm_supp_eq fresh_star_Pair)
  apply(simp add: eqvt_at_def)
  apply(simp add: perm_supp_eq fresh_star_Pair)
done

nominal_termination (eqvt) by lexicographic_order

lemma forget[simp]:
  shows "atom x \<sharp> M \<Longrightarrow> M[x ::= s] = M"
  by (nominal_induct M avoiding: x s rule: lt.strong_induct)
     (auto simp add: lt.fresh fresh_at_base)

nominal_function
  isValue:: "lt => bool"
where
  "isValue (Var x) = True"
| "isValue (Lam y N) = True"
| "isValue (A $$ B) = False"
  unfolding eqvt_def isValue_graph_aux_def
  by (auto)
     (erule lt.exhaust, auto)

nominal_termination (eqvt)
  by (relation "measure size") (simp_all)

inductive
  eval :: "[lt, lt] \<Rightarrow> bool" (" _ \<longrightarrow>\<^isub>\<beta> _" [80,80] 80)
  where
   evbeta: "\<lbrakk>atom x \<sharp> V; isValue V\<rbrakk> \<Longrightarrow> ((Lam x M) $$ V) \<longrightarrow>\<^isub>\<beta> (M[x ::= V])"
|  ev1: "\<lbrakk>isValue V; M \<longrightarrow>\<^isub>\<beta> M' \<rbrakk> \<Longrightarrow> (V $$ M) \<longrightarrow>\<^isub>\<beta> (V $$ M')"
|  ev2: "M \<longrightarrow>\<^isub>\<beta> M' \<Longrightarrow> (M $$ N) \<longrightarrow>\<^isub>\<beta> (M' $$ N)"

equivariance eval

nominal_inductive eval
done

(*lemmas [simp] = lt.supp(2)*)

lemma closedev1: assumes "s \<longrightarrow>\<^isub>\<beta> t"
  shows "supp t <= supp s"
  using assms
    by (induct, auto simp add: lt.supp)

lemma [simp]: "~ ((Lam x M) \<longrightarrow>\<^isub>\<beta> N)"
by (rule, erule eval.cases, simp_all)

lemma [simp]: assumes "M \<longrightarrow>\<^isub>\<beta> N" shows "~ isValue M"
using assms
by (cases, auto)

inductive
  eval_star :: "[lt, lt] \<Rightarrow> bool" (" _ \<longrightarrow>\<^isub>\<beta>\<^sup>* _" [80,80] 80)
  where
   evs1: "M \<longrightarrow>\<^isub>\<beta>\<^sup>* M"
|  evs2: "\<lbrakk>M \<longrightarrow>\<^isub>\<beta> M'; M' \<longrightarrow>\<^isub>\<beta>\<^sup>*  M'' \<rbrakk> \<Longrightarrow> M \<longrightarrow>\<^isub>\<beta>\<^sup>*  M''"

lemma eval_evs: assumes *: "M \<longrightarrow>\<^isub>\<beta> M'" shows "M \<longrightarrow>\<^isub>\<beta>\<^sup>* M'"
by (rule evs2, rule *, rule evs1)

lemma eval_trans[trans]:
  assumes "M1  \<longrightarrow>\<^isub>\<beta>\<^sup>* M2"
      and "M2  \<longrightarrow>\<^isub>\<beta>\<^sup>*  M3"
  shows "M1  \<longrightarrow>\<^isub>\<beta>\<^sup>* M3"
  using assms
  by (induct, auto intro: evs2)

lemma evs3[rule_format]: assumes "M1  \<longrightarrow>\<^isub>\<beta>\<^sup>* M2"
  shows "M2  \<longrightarrow>\<^isub>\<beta> M3 \<longrightarrow> M1  \<longrightarrow>\<^isub>\<beta>\<^sup>* M3"
  using assms
    by (induct, auto intro: eval_evs evs2)

equivariance eval_star

lemma evbeta':
  fixes x :: name
  assumes "isValue V" and "atom x\<sharp>V" and "N = (M[x ::= V])"
  shows "((Lam x M) $$ V) \<longrightarrow>\<^isub>\<beta>\<^sup>* N"
  using assms by simp (rule evs2, rule evbeta, simp_all add: evs1)

end


(*  File:       Copeland_Rule.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Stephan Bohr, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Copeland Rule\<close>

theory Copeland_Rule
  imports "Compositional_Structures/Basic_Modules/Copeland_Module"
          "Compositional_Structures/Elect_Composition"
begin

text
\<open>This is the Copeland voting rule. The idea is to elect the alternatives with
the highest difference between the amount of simple-majority wins and the
amount of simple-majority losses.\<close>

subsection \<open>Definition\<close>

fun copeland_rule :: "'a Electoral_Module" where
  "copeland_rule A p = elector copeland A p"

subsection \<open>Condorcet Consistency Property\<close>

theorem copeland_condorcet: "condorcet_consistency copeland_rule"
proof -
  have
    "condorcet_consistency (elector copeland)"
    using copeland_is_dcc dcc_imp_cc_elector
    by metis
  thus ?thesis
    using condorcet_consistency2 electoral_module_def
          copeland_rule.simps
    by metis
qed

end