section {* Independence of IMAP Commands *}

text\<open>In this section we show that two concurrent operations that reference to the same tag must be
identical.\<close>

theory
  "IMAP-proof-independent"
  imports
    "IMAP-def"
    "IMAP-proof-helpers"
begin

lemma (in imap) Broadcast_Expunge_Deliver_prefix_closed:
  assumes "xs @ [Broadcast (i, Expunge e mo i)] prefix of j"
  shows "Deliver (mo, Append mo e) \<in> set xs \<or>
    (\<exists> mo2 . Deliver (mo, Store e mo2 mo) \<in> set xs)"
proof -
  obtain y where "apply_operations xs = Some y"
    using assms broadcast_only_valid_msgs by blast
  moreover hence "mo \<in> snd (y e)"
    using broadcast_only_valid_msgs[of xs "(i, Expunge e mo i)" j]
      valid_behaviours_def[of y "(i, Expunge e mo i)"] assms by auto
  ultimately show ?thesis
    using assms Deliver_added_files apply_operations_added_files by blast
qed

lemma (in imap) Broadcast_Store_Deliver_prefix_closed:
  assumes "xs @ [Broadcast (i, Store e mo i)] prefix of j"
  shows "Deliver (mo, Append mo e) \<in> set xs \<or>
    (\<exists> mo2 . Deliver (mo, Store e mo2 mo) \<in> set xs)"
proof -
  obtain y where "apply_operations xs = Some y"
    using assms broadcast_only_valid_msgs by blast
  moreover hence "mo \<in> snd (y e)"
    using broadcast_only_valid_msgs[of xs "(i, Store e mo i)" j]
      valid_behaviours_def[of y "(i, Store e mo i)"] assms by auto
  ultimately show ?thesis
    using assms Deliver_added_files apply_operations_added_files by blast
qed

lemma (in imap) Deliver_added_ids:
  assumes "xs prefix of j"
    and "i \<in> set (added_ids xs e)"
  shows "Deliver (i, Create i e) \<in> set xs \<or>
    (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set xs)"
  using assms proof (induct xs rule: rev_induct, clarsimp)
  case (snoc x xs) thus ?case
  proof (cases x, force)
    case X: (Deliver e')
    moreover obtain a b where "e' = (a, b)" by force
    ultimately show ?thesis
      using snoc apply (case_tac b; clarify)
          apply (simp, metis added_ids_Deliver_Create_diff_collapse
          added_ids_Deliver_Create_same_collapse empty_iff list.set(1) set_ConsD create_id_valid
          in_set_conv_decomp prefix_of_appendD, force)
      using append_id_valid apply (simp, metis (no_types, lifting)  prefix_of_appendD, simp, metis
          Un_iff added_ids_Deliver_Expunge_diff_collapse added_ids_Deliver_Expunge_same_collapse
          empty_iff expunge_id_valid list.set(1) list.set_intros(1) prefix_of_appendD set_ConsD
          set_append)
      by (simp, blast)
  qed
qed

lemma (in imap) Broadcast_Deliver_prefix_closed:
  assumes "xs @ [Broadcast (r, Delete ix e)] prefix of j"
    and "i \<in> ix"
  shows "Deliver (i, Create i e) \<in> set xs \<or>
    Deliver (i, Append i e) \<in> set xs \<or>
    (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set xs) \<or>
    (\<exists> mo . Deliver (i, Store e mo i) \<in> set xs)"
proof -
  obtain y where "apply_operations xs = Some y"
    using assms broadcast_only_valid_msgs by blast
  moreover hence "ix = fst (y e) \<union> snd (y e)"
    by (metis (mono_tags, lifting) assms(1) broadcast_only_valid_msgs operation.case(2)
        option.simps(1) valid_behaviours_def case_prodD)
  ultimately show ?thesis
    using assms Deliver_added_ids apply_operations_added_ids
    by (metis Deliver_added_files Un_iff apply_operations_added_files le_iff_sup prefix_of_appendD)
qed

lemma (in imap) concurrent_create_delete_independent_technical:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Create i e) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Create i e) (ir, Delete is e)"
proof -
  have f1: "Deliver (i, Create i e) \<in> set (history j)"
    using assms prefix_msg_in_history by blast
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f2: "Deliver (i, Create i e) \<in> set pre \<or>
                  Deliver (i, Append i e) \<in> set pre \<or>
                  (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set pre) \<or>
                  (\<exists> mo . Deliver (i, Store e mo i) \<in> set pre)"
    using Broadcast_Deliver_prefix_closed assms by auto
  have f3: "Deliver (i, Append i e) \<notin> set pre" using f1 P
    by (metis (full_types) Pair_inject fst_conv network.delivery_has_a_cause network.msg_id_unique
        network_axioms operation.simps(9) prefix_elem_to_carriers prefix_of_appendD)
  have f4: "\<forall> mo . Deliver (i, Expunge e mo i) \<notin> set pre" using f1 P
    by (metis delivery_has_a_cause fst_conv msg_id_unique old.prod.inject operation.simps(11)
        prefix_elem_to_carriers prefix_of_appendD)
  have "\<forall> mo . Deliver (i, Store e mo i) \<notin> set pre" using f1 P
    by (metis delivery_has_a_cause fst_conv msg_id_unique old.prod.inject operation.simps(13)
        prefix_elem_to_carriers prefix_of_appendD)
  thus ?thesis using f2 f3 f4  P events_in_local_order hb_deliver by blast
qed

lemma (in imap) concurrent_store_expunge_independent_technical:
  assumes "xs prefix of j"
    and "(i, Store e mo i) \<in> set (node_deliver_messages xs)"
    and "(r, Expunge e i r) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Store e mo i) (r, Expunge e i r)"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Expunge e i r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence f1: "Deliver (i, Append i e) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (i, Store e mo2 i) \<in> set pre)"
    using Broadcast_Expunge_Deliver_prefix_closed assms(1) by auto
  hence f2: "Deliver (i, Append i e) \<notin> set (history k)"
    by (metis Pair_inject assms(1) assms(2) fst_conv msg_id_unique network.delivery_has_a_cause
        network_axioms operation.distinct(17) prefix_msg_in_history)
  from f1 obtain mo2 :: 'a where
    "Deliver (i, Store e mo2 i) \<in> set (history k)" using f2
    using calculation prefix_elem_to_carriers by blast
  hence "Deliver (i, Store e mo i) \<in> set (history k)" using assms f1 f2 P
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms
        prefix_msg_in_history)
  then show ?thesis
    using hb.intros(2) events_in_local_order f1 f2 P
    by (metis delivery_has_a_cause fst_conv msg_id_unique node_histories.prefix_of_appendD
        node_histories_axioms prefix_elem_to_carriers)
qed

lemma (in imap) concurrent_store_expunge_independent_technical2:
  assumes "xs prefix of j"
    and "(i, Store e1 mo2 i) \<in> set (node_deliver_messages xs)"
    and "(r, Expunge e mo r) \<in> set (node_deliver_messages xs)"
  shows "mo2 \<noteq> r"
proof -
  obtain oid :: "'a \<times> ('a, 'b) operation \<Rightarrow> nat" where
    oid: "\<forall>p n. Deliver p \<notin> set (history n) \<or> Broadcast p \<in> set (history (oid p))"
    by (metis (no_types) delivery_has_a_cause)
  hence f1: "Broadcast (r, Expunge e mo r) \<in> set (history (oid (r, Expunge e mo r)))"
    using assms(1) assms(3) prefix_msg_in_history by blast
  obtain k :: "'a \<Rightarrow> 'b \<Rightarrow> ('a \<times> ('a, 'b) operation) event list \<Rightarrow> 'a" where k:
    "\<forall>i e pre. (\<exists>mo. Deliver (i, Store e mo i) \<in> set pre) =
    (Deliver (i, Store e (k i e pre) i) \<in> set pre)"
    by moura
  obtain pre :: "nat \<Rightarrow> ('a \<times> ('a, 'b) operation) event \<Rightarrow> ('a \<times> ('a, 'b) operation) event list"
    where pre: "\<forall>k op1. (\<exists>op2. op2 @ [op1] prefix of k) = (pre k op1 @ [op1] prefix of k)"
    by moura
  hence f2: "\<forall>e n. e \<notin> set (history n) \<or> pre n e @ [e] prefix of n"
    using events_before_exist by simp
  hence f3: "pre (oid (i, Store e1 mo2 i)) (Broadcast (i, Store e1 mo2 i))
  prefix of oid (i, Store e1 mo2 i)"
    using oid  assms(1) assms(2) prefix_msg_in_history by blast
  have f4: "Deliver (r, Append r e1) \<notin> set (history (oid (i, Store e1 mo2 i)))"
    by (metis (no_types) oid f1 fst_conv msg_id_unique old.prod.inject operation.distinct(15))
  have "Deliver (r, Store e1 (k r e1 (pre (oid (i, Store e1 mo2 i))
  (Broadcast (i, Store e1 mo2 i)))) r) \<notin> set (history (oid (i, Store e1 mo2 i)))"
    by (metis (no_types) oid f1 fst_conv msg_id_unique old.prod.inject operation.distinct(19))
  thus ?thesis using oid k f2 f3 f4 assms
    by (metis (no_types, lifting) Broadcast_Store_Deliver_prefix_closed
        network.prefix_msg_in_history network_axioms prefix_elem_to_carriers)
qed

lemma (in imap) concurrent_store_delete_independent_technical:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Store e mo i) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Store e mo i) (ir, Delete is e)"
proof -
  have f1: "Deliver (i, Store e mo i) \<in> set (history j)" using assms prefix_msg_in_history by auto
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f2: "Deliver (i, Create i e) \<in> set pre \<or>
  Deliver (i, Append i e) \<in> set pre \<or>
  (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set pre) \<or>
  (\<exists> mo . Deliver (i, Store e mo i) \<in> set pre)"
    using Broadcast_Deliver_prefix_closed assms(1) by auto
  have f3: "Deliver (i, Create i e) \<notin> set pre" using f1 P
    by (metis Pair_inject delivery_has_a_cause fst_conv msg_id_unique operation.distinct(7)
        prefix_elem_to_carriers prefix_of_appendD)
  have f4: "Deliver (i, Append i e) \<notin> set pre" using f1 P
    by (metis delivery_has_a_cause fst_conv msg_id_unique operation.distinct(17)
        prefix_elem_to_carriers prefix_of_appendD prod.inject)
  have "\<forall> mo . Deliver (i, Expunge e mo i) \<notin> set pre" using f1 P
    by (metis Pair_inject delivery_has_a_cause fst_conv msg_id_unique operation.simps(25)
        prefix_elem_to_carriers prefix_of_appendD)
  hence "Deliver (i, Store e mo i) \<in> set pre" using f1 f2 f3 f4 P
    by (metis delivery_has_a_cause fst_conv msg_id_unique node_histories.prefix_of_appendD
        node_histories_axioms prefix_elem_to_carriers)
  thus ?thesis using P events_in_local_order hb_deliver by blast
qed

lemma (in imap) concurrent_append_delete_independent_technical:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Append i e) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Append i e) (ir, Delete is e)"
proof -
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f1: "Deliver (i, Create i e) \<in> set pre \<or>
  Deliver (i, Append i e) \<in> set pre \<or>
  (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set pre) \<or>
  (\<exists> mo . Deliver (i, Store e mo i) \<in> set pre)"
    using Broadcast_Deliver_prefix_closed assms(1) by auto
  hence "Deliver (i, Append i e) \<in> set pre" using assms P f1
    by (metis (no_types, hide_lams) delivery_has_a_cause events_in_local_order fst_conv
        hb_broadcast_exists1 hb_deliver msg_id_unique prefix_msg_in_history)
  thus ?thesis using P events_in_local_order hb_deliver by blast
qed

lemma (in imap) concurrent_append_expunge_independent_technical:
  assumes "i = mo"
    and "xs prefix of j"
    and "(i, Append i e) \<in> set (node_deliver_messages xs)"
    and "(r, Expunge e mo r) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Append i e) (r, Expunge e mo r)"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Expunge e mo r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f1: "Deliver (mo, Append mo e) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (mo, Store e mo2 mo) \<in> set pre)"
    using Broadcast_Expunge_Deliver_prefix_closed assms(1) by auto
  hence "(\<forall> mo2 . Deliver (mo, Store e mo2 mo) \<notin> set pre)" using P assms
  proof -
    have "Deliver (mo, Append mo e) \<in> set (history j)"
      using assms(1) assms(2) assms(3) prefix_msg_in_history by blast
    thus ?thesis
      by (metis (no_types) P Pair_inject delivery_has_a_cause fst_conv msg_id_unique
          operation.simps(23) prefix_elem_to_carriers prefix_of_appendD)
  qed
  thus ?thesis
    using hb.intros(2) events_in_local_order assms(1) P f1 by blast
qed

lemma (in imap) concurrent_append_store_independent_technical:
  assumes "i = mo"
    and "xs prefix of j"
    and "(i, Append i e) \<in> set (node_deliver_messages xs)"
    and "(r, Store e mo r) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Append i e) (r, Store e mo r)"
proof -
  obtain pre k where "pre@[Broadcast (r, Store e mo r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence f1: "Deliver (mo, Append mo e) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (mo, Store e mo2 mo) \<in> set pre)"
    using Broadcast_Store_Deliver_prefix_closed assms(1) by auto
  have f2: "Deliver (i, Append i e) \<in> set (history j)"
    by (meson assms network.prefix_msg_in_history network_axioms)
  then show ?thesis using assms f1
    by (metis  calculation delivery_has_a_cause events_in_local_order fst_conv hb_deliver
        msg_id_unique node_histories.prefix_of_appendD node_histories_axioms
        prefix_elem_to_carriers)
qed

lemma (in imap) concurrent_expunge_delete_independent_technical:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Expunge e mo i) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Expunge e mo i) (ir, Delete is e)"
proof -
  obtain pre k where "pre@[Broadcast (ir, Delete is e)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence A: "Deliver (i, Create i e) \<in> set pre \<or>
  Deliver (i, Append i e) \<in> set pre \<or>
  (\<exists> mo . Deliver (i, Expunge e mo i) \<in> set pre) \<or>
  (\<exists> mo . Deliver (i, Store e mo i) \<in> set pre)"
    using Broadcast_Deliver_prefix_closed assms(1) by auto
  hence "Deliver (i, Expunge e mo i) \<in> set pre" using assms
  proof -
    have f1: "\<And>e. e \<notin> set pre \<or> e \<in> set (history k)"
      using calculation prefix_elem_to_carriers by blast
    have f2: "Deliver (i, Expunge e mo i) \<in> set (history j)"
      by (meson assms network.prefix_msg_in_history network_axioms)
    then show ?thesis using f1 A
      by (metis (no_types, lifting) fst_conv msg_id_unique network.delivery_has_a_cause
          network_axioms)
  qed
  ultimately show ?thesis
    using hb.intros(2) events_in_local_order by blast
qed

lemma (in imap) concurrent_store_store_independent_technical:
  assumes "xs prefix of j"
    and "(i, Store e mo i) \<in> set (node_deliver_messages xs)"
    and "(r, Store e i r) \<in> set (node_deliver_messages xs)"
  shows "hb (i, Store e mo i) (r, Store e i r)"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Store e i r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f1: "\<forall>e. e \<notin> set pre \<or> e \<in> set (history k)"
    using prefix_elem_to_carriers by blast
  have f2: "Deliver (i, Append i e) \<in> set pre \<or> (\<exists> mo2 . Deliver (i, Store e mo2 i) \<in> set pre)"
    using Broadcast_Store_Deliver_prefix_closed assms(1) P by auto
  hence "Deliver (i, Store e mo i) \<in> set pre" using assms f1
    by (metis delivery_has_a_cause fst_conv msg_id_unique prefix_msg_in_history)
  then show ?thesis
    using hb.intros(2) events_in_local_order P by blast
qed

lemma (in imap) expunge_delete_tag_causality:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Expunge e1 mo i) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e2) \<in> set (node_deliver_messages xs)"
    and "pre@[Broadcast (ir, Delete is e2)] prefix of k"
  shows "Deliver (i, Expunge e2 mo i) \<in> set (history k)"
proof-
  have f1: "Deliver (i, Append i e2) \<notin> set (history k)" using assms
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.distinct(15) prefix_msg_in_history)
  have f2: "Deliver (i, Create i e2) \<notin> set (history k)" using assms
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.distinct(5) prefix_msg_in_history)
  have f3: "\<forall> mo. Deliver (i, Store e2 mo i) \<notin> set (history k)" using assms
    by (metis Pair_inject fst_conv msg_id_unique network.delivery_has_a_cause network_axioms
        operation.simps(25) prefix_msg_in_history)
  hence "\<exists> mo1. Deliver (i, Expunge e2 mo1 i) \<in> set (history k)" using assms f1 f2
    by (meson imap.Broadcast_Deliver_prefix_closed imap_axioms node_histories.prefix_of_appendD
        node_histories_axioms prefix_elem_to_carriers)
  then obtain mo1 :: 'a where
    "Deliver (i, Expunge e2 mo1 i) \<in> set (history k)" by blast
  then show ?thesis  using assms f1 f2 f3
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.inject(4) prefix_msg_in_history)
qed

lemma (in imap) expunge_delete_ids_imply_messages_same:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Expunge e1 mo i) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e2) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e2)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence "Deliver (i, Expunge e2 mo i) \<in> set (history k)" using assms expunge_delete_tag_causality
    by blast
  then show ?thesis using assms
    by (metis delivery_has_a_cause fst_conv network.msg_id_unique network_axioms
        operation.inject(4) prefix_msg_in_history prod.inject)
qed

lemma (in imap) store_delete_ids_imply_messages_same:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Store e1 mo i) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e2) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e2)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  have f1: "Deliver (i, Append i e2) \<notin> set (history k)" using assms
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.distinct(17) prefix_msg_in_history)
  have f2: "\<forall> mo. Deliver (i, Expunge e2 mo i) \<notin> set (history k)" using assms
    by (metis Pair_inject fst_conv msg_id_unique network.delivery_has_a_cause network_axioms
        operation.distinct(19) prefix_msg_in_history)
  have f3: "Deliver (i, Create i e2) \<notin> set (history k)" using assms
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.distinct(8) prefix_msg_in_history)
  hence "(\<exists> mo1. Deliver (i, Store e2 mo1 i) \<in> set pre)" using assms P f1 f2 imap_axioms
    by (meson imap.Broadcast_Deliver_prefix_closed prefix_elem_to_carriers prefix_of_appendD)
  then obtain mo1 :: 'a where
    f3: "Deliver (i, Store e2 mo1 i) \<in> set pre" by blast
  then have f4: "Deliver (i, Store e2 mo1 i) \<in> set (history k)"
    using P prefix_elem_to_carriers by blast
  hence "Deliver (i, Store e2 mo i) \<in> set pre" using f2 f3 assms
    by (metis fst_conv msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.inject(5) prefix_msg_in_history)
  moreover have "Deliver(i, Store e1 mo i) \<in> set (history j)"
    using assms(2) assms(3) prefix_msg_in_history by blast
  ultimately show ?thesis using f4
    by (metis delivery_has_a_cause fst_conv msg_id_unique old.prod.inject operation.inject(5))
qed

lemma (in imap) create_delete_ids_imply_messages_same:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Create i e1) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e2) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e2)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  have f1: "Deliver (i, Append i e2) \<notin> set (history k)"
    by (metis assms(2) assms(3) delivery_has_a_cause fst_conv network.msg_id_unique
        network.prefix_msg_in_history network_axioms operation.distinct(3) prod.inject)
  have f2: "\<forall> mo. Deliver (i, Expunge e2 mo i) \<notin> set (history k)"
    by (metis assms(2) assms(3) fst_conv msg_id_unique network.delivery_has_a_cause network_axioms
        old.prod.inject operation.distinct(5) prefix_msg_in_history)
  have f3: "\<forall> mo. Deliver (i, Store e2 mo i) \<notin> set (history k)"
    by (metis Pair_inject assms(2) assms(3) delivery_has_a_cause fst_conv msg_id_unique
        operation.distinct(7) prefix_msg_in_history)
  hence "Deliver (i, Create i e2) \<in> set pre" using assms P f2 f1 imap_axioms
    by (meson imap.Broadcast_Deliver_prefix_closed  prefix_elem_to_carriers prefix_of_appendD)
  then show ?thesis using f1 f2 f3
    by (metis (no_types, lifting) P assms(2) assms(3) delivery_has_a_cause fst_conv msg_id_unique
        node_histories.prefix_of_appendD node_histories_axioms old.prod.inject operation.inject(1)
        prefix_elem_to_carriers prefix_msg_in_history)
qed

lemma (in imap) append_delete_ids_imply_messages_same:
  assumes "i \<in> is"
    and "xs prefix of j"
    and "(i, Append i e1) \<in> set (node_deliver_messages xs)"
    and "(ir, Delete is e2) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (ir, Delete is e2)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence f1: "\<forall>e. e \<notin> set pre \<or> e \<in> set (history k)" using prefix_elem_to_carriers by blast
  have f2: "Deliver (i, Create i e2) \<notin> set pre" using P f1
    by (metis assms(2) assms(3) fst_conv msg_id_unique network.delivery_has_a_cause network_axioms
        old.prod.inject operation.distinct(3) prefix_msg_in_history)
  moreover have "\<forall> mo. Deliver (i, Expunge e2 mo i) \<notin> set pre" using P f1
    by (metis Pair_inject assms(2) assms(3) fst_conv msg_id_unique network.delivery_has_a_cause
        network_axioms operation.distinct(15) prefix_msg_in_history)
  moreover have "\<forall> mo. Deliver (i, Store e2 mo i) \<notin> set pre" using P f1
    by (metis Pair_inject assms(2) assms(3) fst_conv msg_id_unique network.delivery_has_a_cause
        network_axioms operation.simps(23) prefix_msg_in_history)
  moreover hence "Deliver (i, Append i e2) \<in> set pre"
    using P calculation(3) f2 assms(1) calculation(2) Broadcast_Deliver_prefix_closed by blast
  moreover have "Deliver (i, Append i e1) \<in> set (history j)"
    using assms(2) assms(3) prefix_msg_in_history by blast
  ultimately show ?thesis using assms
    by (metis f1 msg_id_unique network.delivery_has_a_cause network_axioms old.prod.inject
        operation.inject(3) prod.sel(1))
qed

lemma (in imap) append_expunge_ids_imply_messages_same:
  assumes "i = mo"
    and "xs prefix of j"
    and "(i, Append i e1) \<in> set (node_deliver_messages xs)"
    and "(r, Expunge e2 mo r) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where "pre@[Broadcast (r, Expunge e2 mo r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence "Deliver (mo, Append mo e2) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (mo, Store e2 mo2 mo) \<in> set pre)"
    using Broadcast_Expunge_Deliver_prefix_closed assms(1)
    by (meson imap.Broadcast_Deliver_prefix_closed imap_axioms)
  hence "Deliver (i, Append i e2) \<in> set pre" using assms
    by (metis (no_types, lifting) calculation delivery_has_a_cause fst_conv hb_broadcast_exists1
        msg_id_unique network.hb_deliver network.prefix_msg_in_history network_axioms
        node_histories.events_in_local_order node_histories_axioms operation.distinct(17)
        prod.inject)
  moreover have "Deliver (i, Append i e1) \<in> set (history j)"
    using assms(2) assms(3) prefix_msg_in_history by blast
  ultimately show ?thesis
    by (metis (no_types, lifting) fst_conv network.delivery_has_a_cause network.msg_id_unique
        network_axioms operation.inject(3) prefix_elem_to_carriers prefix_of_appendD prod.inject)
qed

lemma (in imap) append_store_ids_imply_messages_same:
  assumes "i = mo"
    and "xs prefix of j"
    and "(i, Append i e1) \<in> set (node_deliver_messages xs)"
    and "(r, Store e2 mo r) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Store e2 mo r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence A: "Deliver (mo, Append mo e2) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (mo, Store e2 mo2 mo) \<in> set pre)"
    using Broadcast_Store_Deliver_prefix_closed assms(1)
    by (meson imap.Broadcast_Deliver_prefix_closed imap_axioms)
  have f1: "Deliver (i, Append i e1) \<in> set (history j)"
    using assms(2) assms(3) prefix_msg_in_history by blast
  hence "Deliver (i, Append i e2) \<in> set pre" using assms P A
    by (metis Pair_inject assms(1) calculation delivery_has_a_cause fst_conv msg_id_unique
        operation.simps(23) prefix_elem_to_carriers prefix_of_appendD)
  then show ?thesis using f1
    by (metis calculation delivery_has_a_cause fst_conv msg_id_unique
        node_histories.prefix_of_appendD node_histories_axioms operation.inject(3)
        prefix_elem_to_carriers prod.inject)
qed

lemma (in imap) expunge_store_ids_imply_messages_same:
  assumes "xs prefix of j"
    and "(i, Store e1 mo i) \<in> set (node_deliver_messages xs)"
    and "(r, Expunge e2 i r) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Expunge e2 i r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  hence pprefix: "pre prefix of k"
    using P by blast
  have A: "Deliver (i, Append i e2) \<in> set pre \<or>
  (\<exists> mo2 . Deliver (i, Store e2 mo2 i) \<in> set pre)"
    using Broadcast_Expunge_Deliver_prefix_closed assms(1) P by blast
  have "Deliver (i, Store e2 mo i) \<in> set pre" using assms A P
  proof -
    obtain op1 :: "'a \<times> ('a, 'b) operation \<Rightarrow> nat" where
      f1: "Broadcast (i, Store e1 mo i) \<in> set (history (op1 (i, Store e1 mo i)))"
      by (meson assms(1) assms(2) delivery_has_a_cause prefix_msg_in_history)
    then show ?thesis
      using f1 A pprefix delivery_has_a_cause network.msg_id_unique network_axioms
        node_histories.prefix_to_carriers node_histories_axioms
      by fastforce
  qed
  moreover have "Deliver (i, Store e1 mo i) \<in> set (history j)"
    using assms(1) assms(2) prefix_msg_in_history by auto
  ultimately show ?thesis using assms P
    by (metis delivery_has_a_cause fst_conv msg_id_unique operation.inject(5)
        prefix_elem_to_carriers prefix_of_appendD prod.inject)
qed

lemma (in imap) store_store_ids_imply_messages_same:
  assumes "xs prefix of j"
    and "(i, Store e1 mo i) \<in> set (node_deliver_messages xs)"
    and "(r, Store e2 i r) \<in> set (node_deliver_messages xs)"
  shows "e1 = e2"
proof -
  obtain pre k where P: "pre@[Broadcast (r, Store e2 i r)] prefix of k"
    using assms delivery_has_a_cause events_before_exist prefix_msg_in_history by blast
  moreover hence A: "Deliver (i, Append i e2) \<in> set pre \<or>
    (\<exists> mo2 . Deliver (i, Store e2 mo2 i) \<in> set pre)"
    using Broadcast_Store_Deliver_prefix_closed assms(1) by blast
  have "\<forall>e. e \<notin> set pre \<or> e \<in> set (history k)"
    using calculation prefix_elem_to_carriers by auto
  hence "Deliver (i, Store e2 mo i) \<in> set pre"
    by (metis A assms(1) assms(2) delivery_has_a_cause fst_conv msg_id_unique
        operation.distinct(17) operation.inject(5) prefix_msg_in_history prod.inject)
  moreover have "Deliver (i, Store e1 mo i) \<in> set (history j)"
    using assms(1) assms(2) prefix_msg_in_history by auto
  ultimately show ?thesis using assms
    by (metis Pair_inject delivery_has_a_cause msg_id_unique operation.simps(5)
        prefix_elem_to_carriers prefix_of_appendD prod.sel(1))
qed

end


(*  Title:       Abstract Rewriting
    Author:      Christian Sternagel <christian.sternagel@uibk.ac.at>
                 Rene Thiemann       <rene.tiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and Rene Thiemann
    License:     LGPL
*)

(*
Copyright 2010 Christian Sternagel and René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

header {* Relative Rewriting *}

theory Relative_Rewriting
imports Abstract_Rewriting
begin

text {*Considering a relation @{term R} relative to another relation @{term S}, i.e.,
@{term R}-steps may be preceded and followd by arbitrary many @{term S}-steps.*}
abbreviation (input) relto :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "relto R S \<equiv> S^* O R O S^*"

definition SN_rel_on :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a set \<Rightarrow> bool" where
  "SN_rel_on R S \<equiv> SN_on (relto R S)"

definition SN_rel_on_alt :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a set \<Rightarrow> bool" where
  "SN_rel_on_alt R S T = (\<forall>f. chain (R \<union> S) f \<and> f 0 \<in> T \<longrightarrow> \<not> (INFM j. (f j, f (Suc j)) \<in> R))"

abbreviation SN_rel :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool" where
  "SN_rel R S \<equiv> SN_rel_on R S UNIV"

abbreviation SN_rel_alt :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool" where
  "SN_rel_alt R S \<equiv> SN_rel_on_alt R S UNIV"

lemma steps_preserve_SN_on_relto:
  assumes steps: "(a, b) \<in> (R \<union> S)^*"
    and SN: "SN_on (relto R S) {a}"
  shows "SN_on (relto R S) {b}"
proof -
  let ?RS = "relto R S"
  have "(R \<union> S)^* \<subseteq> S^* \<union> ?RS^*" by regexp
  with steps have "(a,b) \<in> S^* \<or> (a,b) \<in> ?RS^*" by auto
  thus ?thesis
  proof
    assume "(a,b) \<in> ?RS^*"
    from steps_preserve_SN_on[OF this SN] show ?thesis .
  next
    assume Ssteps: "(a,b) \<in> S^*"
    show ?thesis
    proof
      fix f
      assume "f 0 \<in> {b}" and "chain ?RS f"
      hence f0: "f 0 = b" and steps: "\<And>i. (f i, f (Suc i)) \<in> ?RS" by auto
      let ?g = "\<lambda> i. if i = 0 then a else f i"
      have "\<not> SN_on ?RS {a}" unfolding SN_on_def not_not
      proof (rule exI[of _ ?g], intro conjI allI)
        fix i
        show "(?g i, ?g (Suc i)) \<in> ?RS"
        proof (cases i)
          case (Suc j)
          show ?thesis using steps[of i] unfolding Suc by simp
        next
          case 0
          from steps[of 0, unfolded f0] Ssteps have steps: "(a,f (Suc 0)) \<in> S^* O ?RS" by auto
          have "(a,f (Suc 0)) \<in> ?RS"
            by (rule set_mp[OF _ steps], regexp)
          thus ?thesis unfolding 0 by simp
        qed
      qed simp
      with SN show False by simp
    qed
  qed
qed

lemma SN_rel_on_imp_SN_rel_on_alt: "SN_rel_on R S T \<Longrightarrow> SN_rel_on_alt R S T"
proof (unfold SN_rel_on_def)
  assume SN: "SN_on (relto R S) T"
  show ?thesis
  proof (unfold SN_rel_on_alt_def, intro allI impI)
    fix f
    assume steps: "chain (R \<union> S) f \<and> f 0 \<in> T"
    with SN have SN: "SN_on (relto R S) {f 0}"
      and steps: "\<And> i. (f i, f (Suc i)) \<in> R \<union> S" unfolding SN_defs by auto
    obtain r where  r: "\<And> j. r j \<equiv>  (f j, f (Suc j)) \<in> R" by auto
    show "\<not> (INFM j. (f j, f (Suc j)) \<in> R)"
    proof (rule ccontr)
      assume "\<not> ?thesis"
      hence ih: "infinitely_many r" unfolding infinitely_many_def r by blast
      obtain r_index where "r_index = infinitely_many.index r" by simp
      with infinitely_many.index_p[OF ih] infinitely_many.index_ordered[OF ih] infinitely_many.index_not_p_between[OF ih]
      have r_index: "\<And> i. r (r_index i) \<and> r_index i < r_index (Suc i) \<and> (\<forall> j. r_index i < j \<and> j < r_index (Suc i) \<longrightarrow> \<not> r j)" by auto
      obtain g where g: "\<And> i. g i \<equiv> f (r_index i)" ..
      {
        fix i
        let ?ri = "r_index i"
        let ?rsi = "r_index (Suc i)"
        from r_index have isi: "?ri < ?rsi" by auto
        obtain ri rsi where ri: "ri = ?ri" and rsi: "rsi = ?rsi" by auto
        with r_index[of i] steps have inter: "\<And> j. ri < j \<and> j < rsi \<Longrightarrow> (f j, f (Suc j)) \<in> S" unfolding r by auto
        from ri isi rsi have risi: "ri < rsi" by simp
        {
          fix n
          assume "Suc n \<le> rsi - ri"
          hence "(f (Suc ri), f (Suc (n + ri))) \<in> S^*"
          proof (induct n, simp)
            case (Suc n)
            hence stepps: "(f (Suc ri), f (Suc (n+ri))) \<in> S^*" by simp
            have "(f (Suc (n+ri)), f (Suc (Suc n + ri))) \<in> S"
              using inter[of "Suc n + ri"] Suc(2) by auto
            with stepps show ?case by simp
          qed
        }
        from this[of "rsi - ri - 1"] risi have
          "(f (Suc ri), f rsi) \<in> S^*" by simp
        with ri rsi have ssteps: "(f (Suc ?ri), f ?rsi) \<in> S^*" by simp
        with r_index[of i] have "(f ?ri, f ?rsi) \<in> R O S^*" unfolding r by auto
        hence "(g i, g (Suc i)) \<in> S^* O R O S^*" using rtrancl_refl unfolding g by auto
      }
      hence nSN: "\<not> SN_on (S^* O R O S^*) {g 0}" unfolding SN_defs by blast
      have SN: "SN_on (S^* O R O S^*) {f (r_index 0)}"
      proof (rule steps_preserve_SN_on_relto[OF _ SN])
        show "(f 0, f (r_index 0)) \<in> (R \<union> S)^*"
          unfolding rtrancl_fun_conv
          by (rule exI[of _ f], rule exI[of _ "r_index 0"], insert steps, auto)
      qed
      with nSN show False unfolding g ..
    qed
  qed
qed

lemma SN_rel_on_alt_imp_SN_rel_on: "SN_rel_on_alt R S T \<Longrightarrow> SN_rel_on R S T"
proof (unfold SN_rel_on_def)
  assume SN: "SN_rel_on_alt R S T"
  show "SN_on (relto R S) T"
  proof
    fix f
    assume start: "f 0 \<in> T" and  "chain (relto R S) f"
    hence steps: "\<And> i. (f i, f (Suc i)) \<in> S^* O R O S^*" by auto
    let ?prop = "\<lambda> i ai bi. (f i, bi) \<in> S^* \<and> (bi, ai) \<in> R \<and> (ai, f (Suc (i))) \<in> S^*"
    {
      fix i
      from steps obtain bi ai where "?prop i ai bi" by blast
      hence "\<exists> ai bi. ?prop i ai bi" by blast
    }
    hence "\<forall> i. \<exists> bi ai. ?prop i ai bi" by blast
    from choice[OF this] obtain b where "\<forall> i. \<exists> ai. ?prop i ai (b i)" by blast
    from choice[OF this] obtain a where steps: "\<And> i. ?prop i (a i) (b i)" by blast
    from steps[of 0] have fa0: "(f 0, a 0) \<in> S^* O R" by auto
    let ?prop = "\<lambda> i li. (b i, a i) \<in> R \<and> (\<forall> j < length li. ((a i # li) ! j, (a i # li) ! Suc j) \<in> S) \<and> last (a i # li) = b (Suc i)"
    {
      fix i
      from steps[of i] steps[of "Suc i"] have "(a i, f (Suc i)) \<in> S^*" and "(f (Suc i), b (Suc i)) \<in> S^*" by auto
      from rtrancl_trans[OF this] steps[of i] have R: "(b i, a i) \<in> R" and S: "(a i, b (Suc i)) \<in> S^*" by blast+
      from S[unfolded rtrancl_list_conv] obtain li where "last (a i # li) = b (Suc i) \<and> (\<forall> j < length li. ((a i # li) ! j, (a i # li) ! Suc j) \<in> S)" ..
      with R have "?prop i li" by blast
      hence "\<exists> li. ?prop i li" ..
    }
    hence "\<forall> i. \<exists> li. ?prop i li" ..
    from choice[OF this] obtain l where steps: "\<And> i. ?prop i (l i)" by auto
    let ?p = "\<lambda> i. ?prop i (l i)"
    from steps have steps: "\<And> i. ?p i" by blast
    let ?l = "\<lambda> i. a i # l i"
    let ?l' = "\<lambda> i. length (?l i)"
    let ?g = "\<lambda> i. inf_concat_simple ?l' i"
    obtain g where g: "\<And> i. g i = (let (ii,jj) = ?g i in ?l ii ! jj)" by auto
    have g0: "g 0 = a 0" unfolding g Let_def by simp
    with fa0 have fg0: "(f 0, g 0) \<in> S^* O R" by auto
    have fg0: "(f 0, g 0) \<in> (R \<union> S)^*"
      by (rule set_mp[OF _ fg0], regexp)
    have len: "\<And> i j n. ?g n = (i,j) \<Longrightarrow> j < length (?l i)"
    proof -
      fix i j n
      assume n: "?g n = (i,j)"
      show "j < length (?l i)"
      proof (cases n)
        case 0
        with n have "j = 0" by auto
        thus ?thesis by simp
      next
        case (Suc nn)
        obtain ii jj where nn: "?g nn = (ii,jj)" by (cases "?g nn", auto)
        show ?thesis
        proof (cases "Suc jj < length (?l ii)")
          case True
          with nn Suc have "?g n = (ii, Suc jj)" by auto
          with n True show ?thesis by simp
        next
          case False
          with nn Suc have "?g n = (Suc ii, 0)" by auto
          with n show ?thesis by simp
        qed
      qed
    qed
    have gsteps: "\<And> i. (g i, g (Suc i)) \<in> R \<union> S"
    proof -
      fix n
      obtain i j where n: "?g n = (i, j)" by (cases "?g n", auto)
      show "(g n, g (Suc n)) \<in> R \<union> S"
      proof (cases "Suc j < length (?l i)")
        case True
        with n have "?g (Suc n) = (i, Suc j)" by auto
        with n have gn: "g n = ?l i ! j" and gsn: "g (Suc n) = ?l i ! (Suc j)" unfolding g by auto
        thus ?thesis using steps[of i] True by auto
      next
        case False
        with n have "?g (Suc n) = (Suc i, 0)" by auto
        with n have gn: "g n = ?l i ! j" and gsn: "g (Suc n) = a (Suc i)" unfolding g by auto
        from gn len[OF n] False have "j = length (?l i) - 1" by auto
        with gn have gn: "g n = last (?l i)" using last_conv_nth[of "?l i"] by auto
        from gn gsn show ?thesis using steps[of i] steps[of "Suc i"] by auto
      qed
    qed
    have infR:  "INFM j. (g j, g (Suc j)) \<in> R" unfolding INFM_nat_le
    proof
      fix n
      obtain i j where n: "?g n = (i,j)" by (cases "?g n", auto)
      from len[OF n] have j: "j < ?l' i" .
      let ?k = "?l' i - 1 - j"
      obtain k where k: "k = j + ?k" by auto
      from j k have k2: "k = ?l' i - 1" and k3: "j + ?k < ?l' i" by auto
      from inf_concat_simple_add[OF n, of ?k, OF k3]
      have gnk: "?g (n + ?k) = (i, k)" by (simp only: k)
      hence "g (n + ?k) = ?l i ! k" unfolding g by auto
      hence gnk2: "g (n + ?k) = last (?l i)" using last_conv_nth[of "?l i"] k2 by auto
      from k2 gnk have "?g (Suc (n+?k)) = (Suc i, 0)" by auto
      hence gnsk2: "g (Suc (n+?k)) = a (Suc i)" unfolding g by auto
      from steps[of i] steps[of "Suc i"] have main: "(g (n+?k), g (Suc (n+?k))) \<in> R"
        by (simp only: gnk2 gnsk2)
      show "\<exists> j \<ge> n. (g j, g (Suc j)) \<in> R"
        by (rule exI[of _ "n + ?k"], auto simp: main[simplified])
    qed
    from fg0[unfolded rtrancl_fun_conv] obtain gg n where start: "gg 0 = f 0"
      and n: "gg n = g 0" and steps: "\<And> i. i < n \<Longrightarrow> (gg i, gg (Suc i)) \<in> R \<union> S" by auto
    let ?h = "\<lambda> i. if i < n then gg i else g (i - n)"
    obtain h where h: "h = ?h" by auto
    {
      fix i
      assume i: "i \<le> n"
      have "h i = gg i" using i unfolding h
        by (cases "i < n", auto simp: n)
    } note gg = this
    from gg[of 0]  `f 0 \<in> T` have h0: "h 0 \<in> T" unfolding start by auto
    {
      fix i
      have "(h i, h (Suc i)) \<in> R \<union> S"
      proof (cases "i < n")
        case True
        from steps[of i] gg[of i] gg[of "Suc i"] True show ?thesis by auto
      next
        case False
        hence "i = n + (i - n)" by auto
        then obtain k where i: "i = n + k" by auto
        from gsteps[of k] show ?thesis unfolding h i by simp
      qed
    } note hsteps = this
    from SN[unfolded SN_rel_on_alt_def, rule_format, OF conjI[OF allI[OF hsteps] h0]]
    have "\<not> (INFM j. (h j, h (Suc j)) \<in> R)" .
    moreover have "INFM j. (h j, h (Suc j)) \<in> R" unfolding INFM_nat_le
    proof (rule)
      fix m
      from infR[unfolded INFM_nat_le, rule_format, of m]
      obtain i where i: "i \<ge> m" and g: "(g i, g (Suc i)) \<in> R" by auto
      show "\<exists> n \<ge> m. (h n , h (Suc n)) \<in> R"
        by (rule exI[of _ "i + n"], unfold h, insert g i, auto)
    qed
    ultimately show False ..
  qed
qed

lemma SN_rel_on_conv: "SN_rel_on = SN_rel_on_alt"
  by (intro ext) (blast intro: SN_rel_on_imp_SN_rel_on_alt SN_rel_on_alt_imp_SN_rel_on)

lemmas SN_rel_defs = SN_rel_on_def SN_rel_on_alt_def

lemma SN_rel_on_alt_r_empty : "SN_rel_on_alt {} S T"
  unfolding SN_rel_defs by auto

lemma SN_rel_on_alt_s_empty : "SN_rel_on_alt R {} = SN_on R"
  by (intro ext, unfold SN_rel_defs SN_defs, auto)

lemma SN_rel_on_mono':
  assumes R: "R \<subseteq> R'" and S: "S \<subseteq> R' \<union> S'" and SN: "SN_rel_on R' S' T"
  shows "SN_rel_on R S T"
proof -
  note conv = SN_rel_on_conv SN_rel_on_alt_def INFM_nat_le
  show ?thesis unfolding conv
  proof(intro allI impI)
    fix f
    assume "chain (R \<union> S) f \<and> f 0 \<in> T"
    with R S have "chain (R' \<union> S') f \<and> f 0 \<in> T" by auto
    from SN[unfolded conv, rule_format, OF this]
    show "\<not> (\<forall> m. \<exists> n \<ge> m. (f n, f (Suc n)) \<in> R)" using R by auto
  qed
qed

lemma relto_mono:
  assumes "R \<subseteq> R'" and "S \<subseteq> S'"
  shows "relto R S \<subseteq> relto R' S'"
  using assms rtrancl_mono by blast

lemma SN_rel_on_mono:
  assumes R: "R \<subseteq> R'" and S: "S \<subseteq> S'"
    and SN: "SN_rel_on R' S' T"
  shows "SN_rel_on R S T"
  using SN
  unfolding SN_rel_on_def using SN_on_mono[OF _ relto_mono[OF R S]] by blast

lemmas SN_rel_on_alt_mono = SN_rel_on_mono[unfolded SN_rel_on_conv]

lemma SN_rel_on_imp_SN_on:
  assumes "SN_rel_on R S T" shows  "SN_on R T"
proof
  fix f
  assume "chain R f"
  and f0: "f 0 \<in> T"
  hence "\<And>i. (f i, f (Suc i)) \<in> relto R S" by blast
  thus False using assms f0 unfolding SN_rel_on_def SN_defs by blast
qed

lemma SN_rel_on_Id:
  shows "SN_rel_on R (S \<union> Id) T = SN_rel_on R S T"
  unfolding SN_rel_on_def by (simp only: relto_Id)

lemma SN_rel_on_empty[simp]: "SN_rel_on R {} T = SN_on R T"
  unfolding SN_rel_on_def by auto

lemma SN_rel_on_ideriv: "SN_rel_on R S T = (\<not> (\<exists> as. ideriv R S as \<and> as 0 \<in> T))" (is "?L = ?R")
proof
  assume ?L
  show ?R
  proof
    assume "\<exists> as. ideriv R S as \<and> as 0 \<in> T"
    then obtain as where id: "ideriv R S as" and T: "as 0 \<in> T" by auto
    note id = id[unfolded ideriv_def]
    from `?L`[unfolded SN_rel_on_conv SN_rel_on_alt_def, THEN spec[of _ as]]
      id T obtain i where i: "\<And> j. j \<ge> i \<Longrightarrow> (as j, as (Suc j)) \<notin> R" by auto
    with id[unfolded INFM_nat, THEN conjunct2, THEN spec[of _ "Suc i"]] show False by auto
  qed
next
  assume ?R
  show ?L
    unfolding SN_rel_on_conv SN_rel_on_alt_def
  proof(intro allI impI)
    fix as
    assume "chain (R \<union> S) as \<and> as 0 \<in> T"
    with `?R`[unfolded ideriv_def] have "\<not> (INFM i. (as i, as (Suc i)) \<in> R)" by auto
    from this[unfolded INFM_nat] obtain i where i: "\<And>j. i < j \<Longrightarrow> (as j, as (Suc j)) \<notin> R" by auto
    show "\<not> (INFM j. (as j, as (Suc j)) \<in> R)" unfolding INFM_nat using i by blast
  qed
qed

lemma SN_rel_to_SN_rel_alt: "SN_rel R S \<Longrightarrow> SN_rel_alt R S"
proof (unfold SN_rel_on_def)
  assume SN: "SN (relto R S)"
  show ?thesis
  proof (unfold SN_rel_on_alt_def, intro allI impI)
    fix f
    presume steps: "chain (R \<union> S) f"
    obtain r where  r: "\<And>j. r j \<equiv>  (f j, f (Suc j)) \<in> R" by auto
    show "\<not> (INFM j. (f j, f (Suc j)) \<in> R)"
    proof (rule ccontr)
      assume "\<not> ?thesis"
      hence ih: "infinitely_many r" unfolding infinitely_many_def r by blast
      obtain r_index where "r_index = infinitely_many.index r" by simp
      with infinitely_many.index_p[OF ih] infinitely_many.index_ordered[OF ih] infinitely_many.index_not_p_between[OF ih]
      have r_index: "\<And> i. r (r_index i) \<and> r_index i < r_index (Suc i) \<and> (\<forall> j. r_index i < j \<and> j < r_index (Suc i) \<longrightarrow> \<not> r j)" by auto
      obtain g where g: "\<And> i. g i \<equiv> f (r_index i)" ..
      {
        fix i
        let ?ri = "r_index i"
        let ?rsi = "r_index (Suc i)"
        from r_index have isi: "?ri < ?rsi" by auto
        obtain ri rsi where ri: "ri = ?ri" and rsi: "rsi = ?rsi" by auto
        with r_index[of i] steps have inter: "\<And> j. ri < j \<and> j < rsi \<Longrightarrow> (f j, f (Suc j)) \<in> S" unfolding r by auto
        from ri isi rsi have risi: "ri < rsi" by simp
        {
          fix n
          assume "Suc n \<le> rsi - ri"
          hence "(f (Suc ri), f (Suc (n + ri))) \<in> S^*"
          proof (induct n, simp)
            case (Suc n)
            hence stepps: "(f (Suc ri), f (Suc (n+ri))) \<in> S^*" by simp
            have "(f (Suc (n+ri)), f (Suc (Suc n + ri))) \<in> S"
              using inter[of "Suc n + ri"] Suc(2) by auto
            with stepps show ?case by simp
          qed
        }
        from this[of "rsi - ri - 1"] risi have
          "(f (Suc ri), f rsi) \<in> S^*" by simp
        with ri rsi have ssteps: "(f (Suc ?ri), f ?rsi) \<in> S^*" by simp
        with r_index[of i] have "(f ?ri, f ?rsi) \<in> R O S^*" unfolding r by auto
        hence "(g i, g (Suc i)) \<in> S^* O R O S^*" using rtrancl_refl unfolding g by auto
      }
      hence "\<not> SN (S^* O R O S^*)" unfolding SN_defs by blast
      with SN show False by simp
    qed
  qed simp
qed

lemma SN_rel_alt_to_SN_rel : "SN_rel_alt R S \<Longrightarrow> SN_rel R S"
proof (unfold SN_rel_on_def)
  assume SN: "SN_rel_alt R S"
  show "SN (relto R S)"
  proof
    fix f
    assume "chain (relto R S) f"
    hence steps: "\<And>i. (f i, f (Suc i)) \<in> S^* O R O S^*" by auto
    let ?prop = "\<lambda> i ai bi. (f i, bi) \<in> S^* \<and> (bi, ai) \<in> R \<and> (ai, f (Suc (i))) \<in> S^*"
    {
      fix i
      from steps obtain bi ai where "?prop i ai bi" by blast
      hence "\<exists> ai bi. ?prop i ai bi" by blast
    }
    hence "\<forall> i. \<exists> bi ai. ?prop i ai bi" by blast
    from choice[OF this] obtain b where "\<forall> i. \<exists> ai. ?prop i ai (b i)" by blast
    from choice[OF this] obtain a where steps: "\<And> i. ?prop i (a i) (b i)" by blast
    let ?prop = "\<lambda> i li. (b i, a i) \<in> R \<and> (\<forall> j < length li. ((a i # li) ! j, (a i # li) ! Suc j) \<in> S) \<and> last (a i # li) = b (Suc i)"
    {
      fix i
      from steps[of i] steps[of "Suc i"] have "(a i, f (Suc i)) \<in> S^*" and "(f (Suc i), b (Suc i)) \<in> S^*" by auto
      from rtrancl_trans[OF this] steps[of i] have R: "(b i, a i) \<in> R" and S: "(a i, b (Suc i)) \<in> S^*" by blast+
      from S[unfolded rtrancl_list_conv] obtain li where "last (a i # li) = b (Suc i) \<and> (\<forall> j < length li. ((a i # li) ! j, (a i # li) ! Suc j) \<in> S)" ..
      with R have "?prop i li" by blast
      hence "\<exists> li. ?prop i li" ..
    }
    hence "\<forall> i. \<exists> li. ?prop i li" ..
    from choice[OF this] obtain l where steps: "\<And> i. ?prop i (l i)" by auto
    let ?p = "\<lambda> i. ?prop i (l i)"
    from steps have steps: "\<And> i. ?p i" by blast
    let ?l = "\<lambda> i. a i # l i"
    let ?l' = "\<lambda> i. length (?l i)"
    let ?g = "\<lambda> i. inf_concat_simple ?l' i"
    obtain g where g: "\<And> i. g i = (let (ii,jj) = ?g i in ?l ii ! jj)" by auto
    have len: "\<And> i j n. ?g n = (i,j) \<Longrightarrow> j < length (?l i)"
    proof -
      fix i j n
      assume n: "?g n = (i,j)"
      show "j < length (?l i)"
      proof (cases n)
        case 0
        with n have "j = 0" by auto
        thus ?thesis by simp
      next
        case (Suc nn)
        obtain ii jj where nn: "?g nn = (ii,jj)" by (cases "?g nn", auto)
        show ?thesis
        proof (cases "Suc jj < length (?l ii)")
          case True
          with nn Suc have "?g n = (ii, Suc jj)" by auto
          with n True show ?thesis by simp
        next
          case False
          with nn Suc have "?g n = (Suc ii, 0)" by auto
          with n show ?thesis by simp
        qed
      qed
    qed
    have gsteps: "\<And> i. (g i, g (Suc i)) \<in> R \<union> S"
    proof -
      fix n
      obtain i j where n: "?g n = (i, j)" by (cases "?g n", auto)
      show "(g n, g (Suc n)) \<in> R \<union> S"
      proof (cases "Suc j < length (?l i)")
        case True
        with n have "?g (Suc n) = (i, Suc j)" by auto
        with n have gn: "g n = ?l i ! j" and gsn: "g (Suc n) = ?l i ! (Suc j)" unfolding g by auto
        thus ?thesis using steps[of i] True by auto
      next
        case False
        with n have "?g (Suc n) = (Suc i, 0)" by auto
        with n have gn: "g n = ?l i ! j" and gsn: "g (Suc n) = a (Suc i)" unfolding g by auto
        from gn len[OF n] False have "j = length (?l i) - 1" by auto
        with gn have gn: "g n = last (?l i)" using last_conv_nth[of "?l i"] by auto
        from gn gsn show ?thesis using steps[of i] steps[of "Suc i"] by auto
      qed
    qed
    have infR:  "INFM j. (g j, g (Suc j)) \<in> R" unfolding INFM_nat_le
    proof
      fix n
      obtain i j where n: "?g n = (i,j)" by (cases "?g n", auto)
      from len[OF n] have j: "j < ?l' i" .
      let ?k = "?l' i - 1 - j"
      obtain k where k: "k = j + ?k" by auto
      from j k have k2: "k = ?l' i - 1" and k3: "j + ?k < ?l' i" by auto
      from inf_concat_simple_add[OF n, of ?k, OF k3]
      have gnk: "?g (n + ?k) = (i, k)" by (simp only: k)
      hence "g (n + ?k) = ?l i ! k" unfolding g by auto
      hence gnk2: "g (n + ?k) = last (?l i)" using last_conv_nth[of "?l i"] k2 by auto
      from k2 gnk have "?g (Suc (n+?k)) = (Suc i, 0)" by auto
      hence gnsk2: "g (Suc (n+?k)) = a (Suc i)" unfolding g by auto
      from steps[of i] steps[of "Suc i"] have main: "(g (n+?k), g (Suc (n+?k))) \<in> R"
        by (simp only: gnk2 gnsk2)
      show "\<exists> j \<ge> n. (g j, g (Suc j)) \<in> R"
        by (rule exI[of _ "n + ?k"], auto simp: main[simplified])
    qed
    from SN[unfolded SN_rel_on_alt_def] gsteps infR show False by blast
  qed
qed

lemma SN_rel_alt_r_empty : "SN_rel_alt {} S"
  unfolding SN_rel_defs by auto

lemma SN_rel_alt_s_empty : "SN_rel_alt R {} = SN R"
  unfolding SN_rel_defs SN_defs by auto

lemma SN_rel_mono':
  "R \<subseteq> R' \<Longrightarrow> S \<subseteq> R' \<union> S' \<Longrightarrow> SN_rel R' S' \<Longrightarrow> SN_rel R S"
  unfolding SN_rel_on_conv SN_rel_defs INFM_nat_le by fast

lemma SN_rel_mono:
  assumes R: "R \<subseteq> R'" and S: "S \<subseteq> S'" and SN: "SN_rel R' S'"
  shows "SN_rel R S"
  using SN unfolding SN_rel_defs using SN_subset[OF _ relto_mono[OF R S]] by blast

lemmas SN_rel_alt_mono = SN_rel_mono[unfolded SN_rel_on_conv]

lemma SN_rel_imp_SN : assumes "SN_rel R S" shows  "SN R"
proof
  fix f
  assume "\<forall> i. (f i, f (Suc i)) \<in> R"
  hence "\<And> i. (f i, f (Suc i)) \<in> relto R S" by blast
  thus False using assms unfolding SN_rel_defs SN_defs by fast
qed

lemma relto_trancl_conv : "(relto R S)^+ = ((R \<union> S))^* O R O ((R \<union> S))^*" by regexp

lemma SN_rel_Id:
  shows "SN_rel R (S \<union> Id) = SN_rel R S"
  unfolding SN_rel_defs by (simp only: relto_Id)

lemma relto_rtrancl: "relto R (S^*) = relto R S" by regexp

lemma SN_rel_empty[simp]: "SN_rel R {} = SN R"
  unfolding SN_rel_defs by auto

lemma SN_rel_ideriv: "SN_rel R S = (\<not> (\<exists> as. ideriv R S as))" (is "?L = ?R")
proof
  assume ?L
  show ?R
  proof
    assume "\<exists> as. ideriv R S as"
    then obtain as where id: "ideriv R S as" by auto
    note id = id[unfolded ideriv_def]
    from `?L`[unfolded SN_rel_on_conv SN_rel_defs, THEN spec[of _ as]]
      id obtain i where i: "\<And> j. j \<ge> i \<Longrightarrow> (as j, as (Suc j)) \<notin> R" by auto
    with id[unfolded INFM_nat, THEN conjunct2, THEN spec[of _ "Suc i"]] show False by auto
  qed
next
  assume ?R
  show ?L
    unfolding SN_rel_on_conv SN_rel_defs
  proof (intro allI impI)
    fix as
    presume "chain (R \<union> S) as"
    with `?R`[unfolded ideriv_def] have "\<not> (INFM i. (as i, as (Suc i)) \<in> R)" by auto
    from this[unfolded INFM_nat] obtain i where i: "\<And> j. i < j \<Longrightarrow> (as j, as (Suc j)) \<notin> R" by auto
    show "\<not> (INFM j. (as j, as (Suc j)) \<in> R)" unfolding INFM_nat using i by blast
  qed simp
qed

lemma SN_rel_map:
  fixes R Rw R' Rw' :: "'a rel"
  defines A: "A \<equiv> R' \<union> Rw'"
  assumes SN: "SN_rel R' Rw'"
  and R: "\<And>s t. (s,t) \<in> R \<Longrightarrow> (f s, f t) \<in> A^* O R' O A^*"
  and Rw: "\<And>s t. (s,t) \<in> Rw \<Longrightarrow> (f s, f t) \<in> A^*"
  shows "SN_rel R Rw"
  unfolding SN_rel_defs
proof
  fix g
  assume steps: "chain (relto R Rw) g"
  let ?f = "\<lambda>i. (f (g i))"
  obtain h where h: "h = ?f" by auto
  {
    fix i
    let ?m = "\<lambda> (x,y). (f x, f y)"
    {
      fix s t
      assume "(s,t) \<in> Rw^*"
      hence "?m (s,t) \<in> A^*"
      proof (induct)
        case base show ?case by simp
      next
        case (step t u)
        from Rw[OF step(2)] step(3)
        show ?case by auto
      qed
    } note Rw = this
    from steps have "(g i, g (Suc i)) \<in> relto R Rw" ..
    from this
    obtain s t where gs: "(g i,s) \<in> Rw^*" and st: "(s,t) \<in> R" and tg: "(t, g (Suc i)) \<in> Rw^*" by auto
    from Rw[OF gs] R[OF st] Rw[OF tg]
    have step: "(?f i, ?f (Suc i)) \<in> A^* O (A^* O R' O A^*) O A^*"
      by auto
    have "(?f i, ?f (Suc i)) \<in> A^* O R' O A^*"
      by (rule set_mp[OF _ step], regexp)
    hence "(h i, h (Suc i)) \<in> (relto R' Rw')^+"
      unfolding A h relto_trancl_conv .
  }
  hence "\<not> SN ((relto R' Rw')^+)" by auto
  with SN_imp_SN_trancl[OF SN[unfolded SN_rel_on_def]]
  show False by simp
qed

datatype SN_rel_ext_type = top_s | top_ns | normal_s | normal_ns

fun SN_rel_ext_step :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> SN_rel_ext_type \<Rightarrow> 'a rel" where
  "SN_rel_ext_step P Pw R Rw top_s = P"
| "SN_rel_ext_step P Pw R Rw top_ns = Pw"
| "SN_rel_ext_step P Pw R Rw normal_s = R"
| "SN_rel_ext_step P Pw R Rw normal_ns = Rw"

(* relative termination with four relations as required in DP-framework *)
definition SN_rel_ext :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "SN_rel_ext P Pw R Rw M \<equiv> (\<not> (\<exists>f t.
    (\<forall> i. (f i, f (Suc i)) \<in> SN_rel_ext_step P Pw R Rw (t i))
    \<and> (\<forall> i. M (f i))
    \<and> (INFM i. t i \<in> {top_s,top_ns})
    \<and> (INFM i. t i \<in> {top_s,normal_s})))"

lemma SN_rel_ext_trans:
  fixes P Pw R Rw :: "'a rel" and M :: "'a \<Rightarrow> bool"
  defines M': "M' \<equiv> {(s,t). M t}"
  defines A: "A \<equiv> (P \<union> Pw \<union> R \<union> Rw) \<inter> M'"
  assumes "SN_rel_ext P Pw R Rw M"
  shows "SN_rel_ext (A^* O (P \<inter> M') O A^*) (A^* O ((P \<union> Pw) \<inter> M') O A^*) (A^* O ((P \<union> R) \<inter> M') O A^*) (A^*) M" (is "SN_rel_ext ?P ?Pw ?R ?Rw M")
proof (rule ccontr)
  let ?relt = "SN_rel_ext_step ?P ?Pw ?R ?Rw"
  let ?rel = "SN_rel_ext_step P Pw R Rw"
  assume "\<not> ?thesis"
  from this[unfolded SN_rel_ext_def]
  obtain f ty
    where steps: "\<And> i. (f i, f (Suc i)) \<in> ?relt (ty i)"
    and min: "\<And> i. M (f i)"
    and inf1: "INFM i. ty i \<in> {top_s, top_ns}"
    and inf2: "INFM i. ty i \<in> {top_s, normal_s}"
    by auto
  let ?Un = "\<lambda> tt. \<Union> (?rel ` tt)"
  let ?UnM = "\<lambda> tt. (\<Union> (?rel ` tt)) \<inter> M'"
  let ?A = "?UnM {top_s,top_ns,normal_s,normal_ns}"
  let ?P' = "?UnM {top_s}"
  let ?Pw' = "?UnM {top_s,top_ns}"
  let ?R' = "?UnM {top_s,normal_s}"
  let ?Rw' = "?UnM {top_s,top_ns,normal_s,normal_ns}"
  have A: "A = ?A" unfolding A by auto
  have P: "(P \<inter> M') = ?P'" by auto
  have Pw: "(P \<union> Pw) \<inter> M' = ?Pw'" by auto
  have R: "(P \<union> R) \<inter> M' = ?R'" by auto
  have Rw: "A = ?Rw'" unfolding A ..
  {
    fix s t tt
    assume m: "M s" and st: "(s,t) \<in> ?UnM tt"
    hence "\<exists> typ \<in> tt. (s,t) \<in> ?rel typ \<and> M s \<and> M t" unfolding M' by auto
  } note one_step = this
  let ?seq = "\<lambda> s t g n ty. s = g 0 \<and> t = g n \<and> (\<forall> i < n. (g i, g (Suc i)) \<in> ?rel (ty i)) \<and> (\<forall> i \<le> n. M (g i))"
  {
    fix s t
    assume m: "M s" and st: "(s,t) \<in> A^*"
    from st[unfolded rtrancl_fun_conv]
    obtain g n where g0: "g 0 = s" and gn: "g n = t" and steps: "\<And> i. i < n \<Longrightarrow> (g i, g (Suc i)) \<in> ?A" unfolding A by auto
    {
      fix i
      assume "i \<le> n"
      have "M (g i)"
      proof (cases i)
        case 0
        show ?thesis unfolding 0 g0 by (rule m)
      next
        case (Suc j)
        with `i \<le> n` have "j < n" by auto
        from steps[OF this] show ?thesis unfolding Suc M' by auto
      qed
    } note min = this
    {
      fix i
      assume i: "i < n" hence i': "i \<le> n" by auto
      from i' one_step[OF min steps[OF i]]
      have "\<exists> ty. (g i, g (Suc i)) \<in> ?rel ty" by blast
    }
    hence "\<forall> i. (\<exists> ty. i < n \<longrightarrow> (g i, g (Suc i)) \<in> ?rel ty)" by auto
    from choice[OF this]
    obtain tt where steps: "\<And> i. i < n \<Longrightarrow> (g i, g (Suc i)) \<in> ?rel (tt i)" by auto
    from g0 gn steps min
    have "?seq s t g n tt" by auto
    hence "\<exists> g n tt. ?seq s t g n tt" by blast
  } note A_steps = this
  let ?seqtt = "\<lambda> s t tt g n ty. s = g 0 \<and> t = g n \<and> n > 0 \<and> (\<forall> i<n. (g i, g (Suc i)) \<in> ?rel (ty i)) \<and> (\<forall> i \<le> n. M (g i)) \<and> (\<exists> i < n. ty i \<in> tt)"
  {
    fix s t tt
    assume m: "M s" and st: "(s,t) \<in> A^* O ?UnM tt O A^*"
    then obtain u v where su: "(s,u) \<in> A^*" and uv: "(u,v) \<in> ?UnM tt" and vt: "(v,t) \<in> A^*"
      by auto
    from A_steps[OF m su] obtain g1 n1 ty1 where seq1: "?seq s u g1 n1 ty1" by auto
    from uv have "M v" unfolding M' by auto
    from A_steps[OF this vt] obtain g2 n2 ty2 where seq2: "?seq v t g2 n2 ty2" by auto
    from seq1 have "M u" by auto
    from one_step[OF this uv] obtain ty where ty: "ty \<in> tt" and uv: "(u,v) \<in> ?rel ty" by auto
    let ?g = "\<lambda> i. if i \<le> n1 then g1 i else g2 (i - (Suc n1))"
    let ?ty = "\<lambda> i. if i < n1 then ty1 i else if i = n1 then ty else ty2 (i - (Suc n1))"
    let ?n = "Suc (n1 + n2)"
    have ex: "\<exists> i < ?n. ?ty i \<in> tt"
      by (rule exI[of _ n1], simp add: ty)
    have steps: "\<forall> i < ?n. (?g i, ?g (Suc i)) \<in> ?rel (?ty i)"
    proof (intro allI impI)
      fix i
      assume "i < ?n"
      show "(?g i, ?g (Suc i)) \<in> ?rel (?ty i)"
      proof (cases "i \<le> n1")
        case True
        with seq1 seq2 uv show ?thesis by auto
      next
        case False
        hence "i = Suc n1 + (i - Suc n1)" by auto
        then obtain k where i: "i = Suc n1 + k" by auto
        with `i < ?n` have "k < n2" by auto
        thus ?thesis using seq2 unfolding i by auto
      qed
    qed
    from steps seq1 seq2 ex
    have seq: "?seqtt s t tt ?g ?n ?ty" by auto
    have "\<exists> g n ty. ?seqtt s t tt g n ty"
      by (intro exI, rule seq)
  } note A_tt_A = this
  let ?tycon = "\<lambda> ty1 ty2 tt ty' n. ty1 = ty2 \<longrightarrow> (\<exists>i < n. ty' i \<in> tt)"
  let ?seqt = "\<lambda> i ty g n ty'. f i = g 0 \<and> f (Suc i) = g n \<and> (\<forall> j < n. (g j, g (Suc j)) \<in> ?rel (ty' j)) \<and> (\<forall> j \<le> n. M (g j))
                \<and> (?tycon (ty i) top_s {top_s} ty' n)
                \<and> (?tycon (ty i) top_ns {top_s,top_ns} ty' n)
                \<and> (?tycon (ty i) normal_s {top_s,normal_s} ty' n)"
  {
    fix i
    have "\<exists> g n ty'. ?seqt i ty g n ty'"
    proof (cases "ty i")
      case top_s
      from steps[of i, unfolded top_s]
      have "(f i, f (Suc i)) \<in> ?P" by auto
      from A_tt_A[OF min this[unfolded P]]
      show ?thesis unfolding top_s by auto
    next
      case top_ns
      from steps[of i, unfolded top_ns]
      have "(f i, f (Suc i)) \<in> ?Pw" by auto
      from A_tt_A[OF min this[unfolded Pw]]
      show ?thesis unfolding top_ns by auto
    next
      case normal_s
      from steps[of i, unfolded normal_s]
      have "(f i, f (Suc i)) \<in> ?R" by auto
      from A_tt_A[OF min this[unfolded R]]
      show ?thesis unfolding normal_s by auto
    next
      case normal_ns
      from steps[of i, unfolded normal_ns]
      have "(f i, f (Suc i)) \<in> ?Rw" by auto
      from A_steps[OF min this]
      show ?thesis unfolding normal_ns by auto
    qed
  }
  hence "\<forall> i. \<exists> g n ty'. ?seqt i ty g n ty'" by auto
  from choice[OF this] obtain g where "\<forall> i. \<exists> n ty'. ?seqt i ty (g i) n ty'" by auto
  from choice[OF this] obtain n where "\<forall> i. \<exists> ty'. ?seqt i ty (g i) (n i) ty'" by auto
  from choice[OF this] obtain ty' where "\<forall> i. ?seqt i ty (g i) (n i) (ty' i)" by auto
  hence partial: "\<And> i. ?seqt i ty (g i) (n i) (ty' i)" ..
  (* it remains to concatenate all these finite sequences to an infinite one *)
  let ?ind = "inf_concat n"
  let ?g = "\<lambda> k. (\<lambda> (i,j). g i j) (?ind k)"
  let ?ty = "\<lambda> k. (\<lambda> (i,j). ty' i j) (?ind k)"
  have inf: "INFM i. 0 < n i"
    unfolding INFM_nat_le
  proof (intro allI)
    fix m
    from inf1[unfolded INFM_nat_le]
    obtain k where k: "k \<ge> m" and ty: "ty k \<in> {top_s, top_ns}" by auto
    show "\<exists> k \<ge> m. 0 < n k"
    proof (intro exI conjI, rule k)
      from partial[of k] ty show "0 < n k" by (cases "n k", auto)
    qed
  qed
  note bounds = inf_concat_bounds[OF inf]
  note inf_Suc = inf_concat_Suc[OF inf]
  note inf_mono = inf_concat_mono[OF inf]
  have "\<not> SN_rel_ext P Pw R Rw M"
    unfolding SN_rel_ext_def simp_thms
  proof (rule exI[of _ ?g], rule exI[of _ ?ty], intro conjI allI)
    fix k
    obtain i j where ik: "?ind k = (i,j)" by force
    from bounds[OF this] have j: "j < n i" by auto
    show "M (?g k)" unfolding ik using partial[of i] j by auto
  next
    fix k
    obtain i j where ik: "?ind k = (i,j)" by force
    from bounds[OF this] have j: "j < n i" by auto
    from partial[of i] j have step: "(g i j, g i (Suc j)) \<in> ?rel (ty' i j)" by auto
    obtain i' j' where isk: "?ind (Suc k) = (i',j')" by force
    have i'j': "g i' j' = g i (Suc j)"
    proof (rule inf_Suc[OF _ ik isk])
      fix i
      from partial[of i]
      have "g i (n i) = f (Suc i)" by simp
      also have "... = g (Suc i) 0" using partial[of "Suc i"] by simp
      finally show "g i (n i) = g (Suc i) 0" .
    qed
    show "(?g k, ?g (Suc k)) \<in> ?rel (?ty k)"
      unfolding ik isk split i'j'
      by (rule step)
  next
    show "INFM i. ?ty i \<in> {top_s, top_ns}"
      unfolding INFM_nat_le
    proof (intro allI)
      fix k
      obtain i j where ik: "?ind k = (i,j)" by force
      from inf1[unfolded INFM_nat] obtain i' where i': "i' > i" and ty: "ty i' \<in> {top_s, top_ns}" by auto
      from partial[of i'] ty obtain j' where j': "j' < n i'" and ty': "ty' i' j' \<in> {top_s, top_ns}" by auto
      from inf_concat_surj[of _ n, OF j'] obtain k' where ik': "?ind k' = (i',j')" ..
      from inf_mono[OF ik ik' i'] have k: "k \<le> k'" by simp
      show "\<exists> k' \<ge> k. ?ty k' \<in> {top_s, top_ns}"
        by (intro exI conjI, rule k, unfold ik' split, rule ty')
    qed
  next
    show "INFM i. ?ty i \<in> {top_s, normal_s}"
      unfolding INFM_nat_le
    proof (intro allI)
      fix k
      obtain i j where ik: "?ind k = (i,j)" by force
      from inf2[unfolded INFM_nat] obtain i' where i': "i' > i" and ty: "ty i' \<in> {top_s, normal_s}" by auto
      from partial[of i'] ty obtain j' where j': "j' < n i'" and ty': "ty' i' j' \<in> {top_s, normal_s}" by auto
      from inf_concat_surj[of _ n, OF j'] obtain k' where ik': "?ind k' = (i',j')" ..
      from inf_mono[OF ik ik' i'] have k: "k \<le> k'" by simp
      show "\<exists> k' \<ge> k. ?ty k' \<in> {top_s, normal_s}"
        by (intro exI conjI, rule k, unfold ik' split, rule ty')
    qed
  qed
  with assms show False by auto
qed

lemma SN_rel_ext_map: fixes P Pw R Rw P' Pw' R' Rw' :: "'a rel" and M M' :: "'a \<Rightarrow> bool"
  defines Ms: "Ms \<equiv> {(s,t). M' t}"
  defines A: "A \<equiv> (P' \<union> Pw' \<union> R' \<union> Rw') \<inter> Ms"
  assumes SN: "SN_rel_ext P' Pw' R' Rw' M'"
  and P: "\<And> s t. M s \<Longrightarrow> M t \<Longrightarrow> (s,t) \<in> P \<Longrightarrow> (f s, f t) \<in> (A^* O (P' \<inter> Ms) O A^*) \<and> I t"
  and Pw: "\<And> s t. M s \<Longrightarrow> M t \<Longrightarrow> (s,t) \<in> Pw \<Longrightarrow> (f s, f t) \<in> (A^* O ((P' \<union> Pw') \<inter> Ms) O A^*) \<and> I t"
  and R: "\<And> s t. I s \<Longrightarrow> M s \<Longrightarrow> M t \<Longrightarrow> (s,t) \<in> R \<Longrightarrow> (f s, f t) \<in> (A^* O ((P' \<union> R') \<inter> Ms) O A^*) \<and> I t"
  and Rw: "\<And> s t. I s \<Longrightarrow> M s \<Longrightarrow> M t \<Longrightarrow> (s,t) \<in> Rw \<Longrightarrow> (f s, f t) \<in> A^* \<and> I t"
  shows "SN_rel_ext P Pw R Rw M"
proof -
  note SN = SN_rel_ext_trans[OF SN]
  let ?P = "(A^* O (P' \<inter> Ms) O A^*)"
  let ?Pw = "(A^* O ((P' \<union> Pw') \<inter> Ms) O A^*)"
  let ?R = "(A^* O ((P' \<union> R') \<inter> Ms) O A^*)"
  let ?Rw = "A^*"
  let ?relt = "SN_rel_ext_step ?P ?Pw ?R ?Rw"
  let ?rel = "SN_rel_ext_step P Pw R Rw"
  show ?thesis
  proof (rule ccontr)
    assume "\<not> ?thesis"
    from this[unfolded SN_rel_ext_def]
    obtain g ty
      where steps: "\<And> i. (g i, g (Suc i)) \<in> ?rel (ty i)"
      and min: "\<And> i. M (g i)"
      and inf1: "INFM i. ty i \<in> {top_s, top_ns}"
      and inf2: "INFM i. ty i \<in> {top_s, normal_s}"
      by auto
    from inf1[unfolded INFM_nat] obtain k where k: "ty k \<in> {top_s, top_ns}" by auto
    let ?k = "Suc k"
    let ?i = "shift id ?k"
    let ?f = "\<lambda> i. f (shift g ?k i)"
    let ?ty = "shift ty ?k"
    {
      fix i
      assume ty: "ty i \<in> {top_s,top_ns}"
      note m = min[of i]
      note ms = min[of "Suc i"]
      from P[OF m ms]
        Pw[OF m ms]
        steps[of i]
        ty
      have "(f (g i), f (g (Suc i))) \<in> ?relt (ty i) \<and> I (g (Suc i))"
        by (cases "ty i", auto)
    } note stepsP = this
    {
      fix i
      assume I: "I (g i)"
      note m = min[of i]
      note ms = min[of "Suc i"]
      from P[OF m ms]
        Pw[OF m ms]
        R[OF I m ms]
        Rw[OF I m ms]
        steps[of i]
      have "(f (g i), f (g (Suc i))) \<in> ?relt (ty i) \<and> I (g (Suc i))"
        by (cases "ty i", auto)
    } note stepsI = this
    {
      fix i
      have "I (g (?i i))"
      proof (induct i)
        case 0
        show ?case using stepsP[OF k] by simp
      next
        case (Suc i)
        from stepsI[OF Suc] show ?case by simp
      qed
    } note I = this
    have "\<not> SN_rel_ext ?P ?Pw ?R ?Rw M'"
      unfolding SN_rel_ext_def simp_thms
    proof (rule exI[of _ ?f], rule exI[of _ ?ty], intro allI conjI)
      fix i
      show "(?f i, ?f (Suc i)) \<in> ?relt (?ty i)"
        using stepsI[OF I[of i]] by auto
    next
      show "INFM i. ?ty i \<in> {top_s, top_ns}"
        unfolding Infm_shift[of "\<lambda>i. i \<in> {top_s,top_ns}" ty ?k]
        by (rule inf1)
    next
      show "INFM i. ?ty i \<in> {top_s, normal_s}"
        unfolding Infm_shift[of "\<lambda>i. i \<in> {top_s,normal_s}" ty ?k]
        by (rule inf2)
    next
      fix i
      have A: "A \<subseteq> Ms" unfolding A by auto
      from rtrancl_mono[OF this] have As: "A^* \<subseteq> Ms^*" by auto
      have PM: "?P \<subseteq> Ms^* O Ms O Ms^*" using As by auto
      have PwM: "?Pw \<subseteq> Ms^* O Ms O Ms^*" using As by auto
      have RM: "?R \<subseteq> Ms^* O Ms O Ms^*" using As by auto
      have RwM: "?Rw \<subseteq> Ms^*" using As by auto
      from PM PwM RM have "?P \<union> ?Pw \<union> ?R \<subseteq> Ms^* O Ms O Ms^*" (is "?PPR \<subseteq> _") by auto
      also have "... \<subseteq> Ms^+" by regexp
      also have "... = Ms"
      proof
        have "Ms^+ \<subseteq> Ms^* O Ms" by regexp
        also have "... \<subseteq> Ms" unfolding Ms by auto
        finally show "Ms^+ \<subseteq> Ms" .
      qed regexp
      finally have PPR: "?PPR \<subseteq> Ms" .
      show "M' (?f i)"
      proof (induct i)
        case 0
        from stepsP[OF k] k
        have "(f (g k), f (g (Suc k))) \<in> ?PPR" by (cases "ty k", auto)
        with PPR show ?case unfolding Ms by simp blast
      next
        case (Suc i)
        show ?case
        proof (cases "?ty i = normal_ns")
          case False
          hence "?ty i \<in> {top_s,top_ns,normal_s}"
            by (cases "?ty i", auto)
          with stepsI[OF I[of i]] have "(?f i, ?f (Suc i)) \<in> ?PPR"
            by auto
          from set_mp[OF PPR this] have "(?f i, ?f (Suc i)) \<in> Ms" .
          thus ?thesis unfolding Ms by auto
        next
          case True
          with stepsI[OF I[of i]] have "(?f i, ?f (Suc i)) \<in> ?Rw" by auto
          with RwM have mem: "(?f i, ?f (Suc i)) \<in> Ms^*" by auto
          thus ?thesis
          proof (cases)
            case base
            with Suc show ?thesis by simp
          next
            case step
            thus ?thesis unfolding Ms by simp
          qed
        qed
      qed
    qed
    with SN
    show False unfolding A Ms by simp
  qed
qed

(* and a version where it is assumed that f always preserves M and that R' and Rw' preserve M' *)
lemma SN_rel_ext_map_min: fixes P Pw R Rw P' Pw' R' Rw' :: "'a rel" and M M' :: "'a \<Rightarrow> bool"
  defines Ms: "Ms \<equiv> {(s,t). M' t}"
  defines A: "A \<equiv> P' \<inter> Ms \<union> Pw' \<inter> Ms \<union> R' \<union> Rw'"
  assumes SN: "SN_rel_ext P' Pw' R' Rw' M'"
  and M: "\<And> t. M t \<Longrightarrow> M' (f t)"
  and M': "\<And> s t. M' s \<Longrightarrow> (s,t) \<in> R' \<union> Rw' \<Longrightarrow> M' t"
  and P: "\<And> s t. M s \<Longrightarrow> M t \<Longrightarrow> M' (f s) \<Longrightarrow> M' (f t) \<Longrightarrow> (s,t) \<in> P \<Longrightarrow> (f s, f t) \<in> (A^* O (P' \<inter> Ms) O A^*) \<and> I t"
  and Pw: "\<And> s t. M s \<Longrightarrow> M t \<Longrightarrow> M' (f s) \<Longrightarrow> M' (f t) \<Longrightarrow> (s,t) \<in> Pw \<Longrightarrow> (f s, f t) \<in> (A^* O (P' \<inter> Ms \<union> Pw' \<inter> Ms) O A^*) \<and> I t"
  and R: "\<And> s t. I s \<Longrightarrow> M s \<Longrightarrow> M t \<Longrightarrow> M' (f s) \<Longrightarrow> M' (f t) \<Longrightarrow> (s,t) \<in> R \<Longrightarrow> (f s, f t) \<in> (A^* O (P' \<inter> Ms \<union> R') O A^*) \<and> I t"
  and Rw: "\<And> s t. I s \<Longrightarrow> M s \<Longrightarrow> M t \<Longrightarrow> M' (f s) \<Longrightarrow> M' (f t) \<Longrightarrow> (s,t) \<in> Rw \<Longrightarrow> (f s, f t) \<in> A^* \<and> I t"
  shows "SN_rel_ext P Pw R Rw M"
proof -
  let ?Ms = "{(s,t). M' t}"
  let ?A = "(P' \<union> Pw' \<union> R' \<union> Rw') \<inter> ?Ms"
  {
    fix s t
    assume s: "M' s" and "(s,t) \<in> A"
    with M'[OF s, of t] have "(s,t) \<in> ?A \<and> M' t" unfolding Ms A by auto
  } note Aone = this
  {
    fix s t
    assume s: "M' s" and steps: "(s,t) \<in> A^*"
    from steps have "(s,t) \<in> ?A^* \<and> M' t"
    proof (induct)
      case base from s show ?case by simp
    next
      case (step t u)
      note one = Aone[OF step(3)[THEN conjunct2] step(2)]
      from step(3) one
      have steps: "(s,u) \<in> ?A^* O ?A" by blast
      have "(s,u) \<in> ?A^*"
        by (rule set_mp[OF _ steps], regexp)
      with one show ?case by simp
    qed
  } note Amany = this
  let ?P = "(A^* O (P' \<inter> Ms) O A^*)"
  let ?Pw = "(A^* O (P' \<inter> Ms \<union> Pw' \<inter> Ms) O A^*)"
  let ?R = "(A^* O (P' \<inter> Ms \<union> R') O A^*)"
  let ?Rw = "A^*"
  let ?P' = "(?A^* O (P' \<inter> ?Ms) O ?A^*)"
  let ?Pw' = "(?A^* O ((P' \<union> Pw') \<inter> ?Ms) O ?A^*)"
  let ?R' = "(?A^* O ((P' \<union> R') \<inter> ?Ms) O ?A^*)"
  let ?Rw' = "?A^*"
  show ?thesis
  proof (rule SN_rel_ext_map[OF SN])
    fix s t
    assume s: "M s" and t: "M t" and step: "(s,t) \<in> P"
    from P[OF s t M[OF s] M[OF t] step]
    have "(f s, f t) \<in> ?P" and I: "I t"  by auto
    then obtain u v where su: "(f s, u) \<in> A^*" and uv: "(u,v) \<in> P' \<inter> Ms"
      and vt: "(v,f t) \<in> A^*" by auto
    from Amany[OF M[OF s] su] have su: "(f s, u) \<in> ?A^*" and u: "M' u" by auto
    from uv have v: "M' v" unfolding Ms by auto
    from Amany[OF v vt] have vt: "(v, f t) \<in> ?A^*" by auto
    from su uv vt I
    show "(f s, f t) \<in> ?P' \<and> I t" unfolding Ms by auto
  next
    fix s t
    assume s: "M s" and t: "M t" and step: "(s,t) \<in> Pw"
    from Pw[OF s t M[OF s] M[OF t] step]
    have "(f s, f t) \<in> ?Pw" and I: "I t"  by auto
    then obtain u v where su: "(f s, u) \<in> A^*" and uv: "(u,v) \<in> P' \<inter> Ms \<union> Pw' \<inter> Ms"
      and vt: "(v,f t) \<in> A^*" by auto
    from Amany[OF M[OF s] su] have su: "(f s, u) \<in> ?A^*" and u: "M' u" by auto
    from uv have uv: "(u,v) \<in> (P' \<union> Pw') \<inter> ?Ms" and v: "M' v" unfolding Ms
      by auto
    from Amany[OF v vt] have vt: "(v, f t) \<in> ?A^*" by auto
    from su uv vt I
    show "(f s, f t) \<in> ?Pw' \<and> I t"  by auto
  next
    fix s t
    assume I: "I s" and s: "M s" and t: "M t" and step: "(s,t) \<in> R"
    from R[OF I s t M[OF s] M[OF t] step]
    have "(f s, f t) \<in> ?R" and I: "I t"  by auto
    then obtain u v where su: "(f s, u) \<in> A^*" and uv: "(u,v) \<in> P' \<inter> Ms \<union> R'"
      and vt: "(v,f t) \<in> A^*" by auto
    from Amany[OF M[OF s] su] have su: "(f s, u) \<in> ?A^*" and u: "M' u" by auto
    from uv M'[OF u, of v] have uv: "(u,v) \<in> (P' \<union> R') \<inter> ?Ms" and v: "M' v" unfolding Ms
      by auto
    from Amany[OF v vt] have vt: "(v, f t) \<in> ?A^*" by auto
    from su uv vt I
    show "(f s, f t) \<in> ?R' \<and> I t"  by auto
  next
    fix s t
    assume I: "I s" and s: "M s" and t: "M t" and step: "(s,t) \<in> Rw"
    from Rw[OF I s t M[OF s] M[OF t] step]
    have steps: "(f s, f t) \<in> ?Rw" and I: "I t"  by auto
    from Amany[OF M[OF s] steps] I
    show "(f s, f t) \<in> ?Rw' \<and> I t"  by auto
  qed
qed

(*OLD PART*)
lemma SN_relto_imp_SN_rel: "SN (relto R S) \<Longrightarrow> SN_rel R S"
proof -
  assume SN: "SN (relto R S)"
  show ?thesis
  proof (simp only: SN_rel_on_conv SN_rel_defs, intro allI impI)
    fix f
    presume steps: "chain (R \<union> S) f"
    obtain r where  r: "\<And> j. r j \<equiv>  (f j, f (Suc j)) \<in> R" by auto
    show "\<not> (INFM j. (f j, f (Suc j)) \<in> R)"
    proof (rule ccontr)
      assume "\<not> ?thesis"
      hence ih: "infinitely_many r" unfolding infinitely_many_def r INFM_nat_le by blast
      obtain r_index where "r_index = infinitely_many.index r" by simp
      with infinitely_many.index_p[OF ih] infinitely_many.index_ordered[OF ih] infinitely_many.index_not_p_between[OF ih]
      have r_index: "\<And> i. r (r_index i) \<and> r_index i < r_index (Suc i) \<and> (\<forall> j. r_index i < j \<and> j < r_index (Suc i) \<longrightarrow> \<not> r j)" by auto
      obtain g where g: "\<And> i. g i \<equiv> f (r_index i)" ..
      {
        fix i
        let ?ri = "r_index i"
        let ?rsi = "r_index (Suc i)"
        from r_index have isi: "?ri < ?rsi" by auto
        obtain ri rsi where ri: "ri = ?ri" and rsi: "rsi = ?rsi" by auto
        with r_index[of i] steps have inter: "\<And> j. ri < j \<and> j < rsi \<Longrightarrow> (f j, f (Suc j)) \<in> S" unfolding r by auto
        from ri isi rsi have risi: "ri < rsi" by simp
        {
          fix n
          assume "Suc n \<le> rsi - ri"
          hence "(f (Suc ri), f (Suc (n + ri))) \<in> S^*"
          proof (induct n, simp)
            case (Suc n)
            hence stepps: "(f (Suc ri), f (Suc (n+ri))) \<in> S^*" by simp
            have "(f (Suc (n+ri)), f (Suc (Suc n + ri))) \<in> S"
              using inter[of "Suc n + ri"] Suc(2) by auto
            with stepps show ?case by simp
          qed
        }
        from this[of "rsi - ri - 1"] risi have
          "(f (Suc ri), f rsi) \<in> S^*" by simp
        with ri rsi have ssteps: "(f (Suc ?ri), f ?rsi) \<in> S^*" by simp
        with r_index[of i] have "(f ?ri, f ?rsi) \<in> R O S^*" unfolding r by auto
        hence "(g i, g (Suc i)) \<in> S^* O R O S^*" using rtrancl_refl unfolding g by auto
      }
      hence "\<not> SN (S^* O R O S^*)" unfolding SN_defs by blast
      with SN show False by simp
    qed
  qed simp
qed

(*FIXME: move*)

fun choice :: "(nat \<Rightarrow> 'a list) \<Rightarrow> nat \<Rightarrow> (nat \<times> nat)" where
  "choice f 0 = (0,0)"
| "choice f (Suc n) = (let (i, j) = choice f n in
    if Suc j < length (f i)
      then (i, Suc j)
      else (Suc i, 0))"

lemma SN_rel_imp_SN_relto : "SN_rel R S \<Longrightarrow> SN (relto R S)"
proof -
  assume SN: "SN_rel R S"
  show "SN (relto R S)"
  proof
    fix f
    assume  "\<forall> i. (f i, f (Suc i)) \<in> relto R S"
    hence steps: "\<And> i. (f i, f (Suc i)) \<in> S^* O R O S^*" by auto
    let ?prop = "\<lambda> i ai bi. (f i, bi) \<in> S^* \<and> (bi, ai) \<in> R \<and> (ai, f (Suc (i))) \<in> S^*"
    {
      fix i
      from steps obtain bi ai where "?prop i ai bi" by blast
      hence "\<exists> ai bi. ?prop i ai bi" by blast
    }
    hence "\<forall> i. \<exists> bi ai. ?prop i ai bi" by blast
    from choice[OF this] obtain b where "\<forall> i. \<exists> ai. ?prop i ai (b i)" by blast
    from choice[OF this] obtain a where steps: "\<And> i. ?prop i (a i) (b i)" by blast
    let ?prop = "\<lambda> i li. (b i, a i) \<in> R \<and> (\<forall> j < length li. ((a i # li) ! j, (a i # li) ! Suc j) \<in> S) \<and> last (a i # li) = b (Suc i)"
    {
      fix i
      from steps[of i] steps[of "Suc i"] have "(a i, f (Suc i)) \<in> S^*" and "(f (Suc i), b (Suc i)) \<in> S^*" by auto
      from rtrancl_trans[OF this] steps[of i] have R: "(b i, a i) \<in> R" and S: "(a i, b (Suc i)) \<in> S^*" by blast+
      from S[unfolded rtrancl_list_conv] obtain li where "last (a i # li) = b (Suc i) \<and> (\<forall> j < length li. ((a i # li) ! j, (a i # li) ! Suc j) \<in> S)" ..
      with R have "?prop i li" by blast
      hence "\<exists> li. ?prop i li" ..
    }
    hence "\<forall> i. \<exists> li. ?prop i li" ..
    from choice[OF this] obtain l where steps: "\<And> i. ?prop i (l i)" by auto
    let ?p = "\<lambda> i. ?prop i (l i)"
    from steps have steps: "\<And> i. ?p i" by blast
    let ?l = "\<lambda> i. a i # l i"
    let ?g = "\<lambda> i. choice (\<lambda> j. ?l j) i"
    obtain g where g: "\<And> i. g i = (let (ii,jj) = ?g i in ?l ii ! jj)" by auto
    have len: "\<And> i j n. ?g n = (i,j) \<Longrightarrow> j < length (?l i)"
    proof -
      fix i j n
      assume n: "?g n = (i,j)"
      show "j < length (?l i)"
      proof (cases n)
        case 0
        with n have "j = 0" by auto
        thus ?thesis by simp
      next
        case (Suc nn)
        obtain ii jj where nn: "?g nn = (ii,jj)" by (cases "?g nn", auto)
        show ?thesis
        proof (cases "Suc jj < length (?l ii)")
          case True
          with nn Suc have "?g n = (ii, Suc jj)" by auto
          with n True show ?thesis by simp
        next
          case False
          with nn Suc have "?g n = (Suc ii, 0)" by auto
          with n show ?thesis by simp
        qed
      qed
    qed
    have gsteps: "\<And> i. (g i, g (Suc i)) \<in> R \<union> S"
    proof -
      fix n
      obtain i j where n: "?g n = (i, j)" by (cases "?g n", auto)
      show "(g n, g (Suc n)) \<in> R \<union> S"
      proof (cases "Suc j < length (?l i)")
        case True
        with n have "?g (Suc n) = (i, Suc j)" by auto
        with n have gn: "g n = ?l i ! j" and gsn: "g (Suc n) = ?l i ! (Suc j)" unfolding g by auto
        thus ?thesis using steps[of i] True by auto
      next
        case False
        with n have "?g (Suc n) = (Suc i, 0)" by auto
        with n have gn: "g n = ?l i ! j" and gsn: "g (Suc n) = a (Suc i)" unfolding g by auto
        from gn len[OF n] False have "j = length (?l i) - 1" by auto
        with gn have gn: "g n = last (?l i)" using last_conv_nth[of "?l i"] by auto
        from gn gsn show ?thesis using steps[of i] steps[of "Suc i"] by auto
      qed
    qed
    have infR:  "\<forall> n. \<exists> j \<ge> n. (g j, g (Suc j)) \<in> R"
    proof
      fix n
      obtain i j where n: "?g n = (i,j)" by (cases "?g n", auto)
      from len[OF n] have j: "j \<le> length (?l i) - 1" by simp
      let ?k = "length (?l i) - 1 - j"
      obtain k where k: "k = j + ?k" by auto
      from j k have k2: "k = length (?l i) - 1" and k3: "j + ?k < length (?l i)" by auto
      {
        fix n i j k l
        assume n: "choice l n = (i,j)" and "j + k < length (l i)"
        hence "choice l (n + k) = (i, j + k)"
          by (induct k arbitrary: j, simp, auto)
      }
      from this[OF n, of ?k, OF k3]
      have gnk: "?g (n + ?k) = (i, k)" by (simp only: k)
      hence "g (n + ?k) = ?l i ! k" unfolding g by auto
      hence gnk2: "g (n + ?k) = last (?l i)" using last_conv_nth[of "?l i"] k2 by auto
      from k2 gnk have "?g (Suc (n+?k)) = (Suc i, 0)" by auto
      hence gnsk2: "g (Suc (n+?k)) = a (Suc i)" unfolding g by auto
      from steps[of i] steps[of "Suc i"] have main: "(g (n+?k), g (Suc (n+?k))) \<in> R"
        by (simp only: gnk2 gnsk2)
      show "\<exists> j \<ge> n. (g j, g (Suc j)) \<in> R"
        by (rule exI[of _ "n + ?k"], auto simp: main[simplified])
    qed
    from SN[simplified SN_rel_on_conv SN_rel_defs] gsteps infR show False
      unfolding INFM_nat_le by fast
  qed
qed

hide_const choice

lemma SN_relto_SN_rel_conv: "SN (relto R S) = SN_rel R S"
  by (blast intro: SN_relto_imp_SN_rel SN_rel_imp_SN_relto)

lemma SN_rel_empty1: "SN_rel {} S"
  unfolding SN_rel_defs by auto

lemma SN_rel_empty2: "SN_rel R {} = SN R"
  unfolding SN_rel_defs SN_defs by auto

lemma SN_relto_mono:
  assumes R: "R \<subseteq> R'" and S: "S \<subseteq> S'"
  and SN: "SN (relto R' S')"
  shows "SN (relto R S)"
  using SN SN_subset[OF _ relto_mono[OF R S]] by blast

lemma SN_relto_imp_SN:
  assumes "SN (relto R S)" shows "SN R"
proof
  fix f
  assume "\<forall>i. (f i, f (Suc i)) \<in> R"
  hence "\<And>i. (f i, f (Suc i)) \<in> relto R S" by blast
  thus False using assms unfolding SN_defs by force
qed

lemma SN_relto_Id:
  "SN (relto R (S \<union> Id)) = SN (relto R S)"
  by (simp only: relto_Id)

text {*Termination inheritance by transitivity (see, e.g., Geser's thesis).*}

lemma trans_subset_SN:
  assumes "trans R" and "R \<subseteq> (r \<union> s)" and "SN r" and "SN s"
  shows "SN R"
proof
  fix f :: "nat \<Rightarrow> 'a"
  assume "f 0 \<in> UNIV"
    and chain: "chain R f"
  have *: "\<And>i j. i < j \<Longrightarrow> (f i, f j) \<in> r \<union> s"
    using assms and chain_imp_trancl [OF chain] by auto
  let ?M = "{i. \<forall>j>i. (f i, f j) \<notin> r}"
  show False
  proof (cases "finite ?M")
    let ?n = "Max ?M"
    assume "finite ?M"
    with Max_ge have "\<forall>i\<in>?M. i \<le> ?n" by simp
    then have "\<forall>k\<ge>Suc ?n. \<exists>k'>k. (f k, f k') \<in> r" by auto
    with steps_imp_chainp [of "Suc ?n" "\<lambda>x y. (x, y) \<in> r"] and assms
      show False by auto
  next
    assume "infinite ?M"
    then have "INFM j. j \<in> ?M" by (simp add: Inf_many_def)
    then interpret infinitely_many "\<lambda>i. i \<in> ?M" by (unfold_locales) assumption
    def [simp]: g \<equiv> "index"
    have "\<forall>i. (f (g i), f (g (Suc i))) \<in> s"
    proof
      fix i
      have less: "g i < g (Suc i)" using index_ordered_less [of i "Suc i"] by simp
      have "g i \<in> ?M" using index_p by simp
      then have "(f (g i), f (g (Suc i))) \<notin> r" using less by simp
      moreover have "(f (g i), f (g (Suc i))) \<in> r \<union> s" using * [OF less] by simp
      ultimately show "(f (g i), f (g (Suc i))) \<in> s" by blast
    qed
    with `SN s` show False by (auto simp: SN_defs)
  qed
qed

lemma SN_Un_conv:
  assumes "trans (r \<union> s)"
  shows "SN (r \<union> s) \<longleftrightarrow> SN r \<and> SN s"
    (is "SN ?r \<longleftrightarrow> ?rhs")
proof
  assume "SN (r \<union> s)" thus "SN r \<and> SN s"
    using SN_subset[of ?r] by blast
next
  assume "SN r \<and> SN s"
  with trans_subset_SN[OF assms subset_refl] show "SN ?r" by simp
qed

lemma SN_relto_Un:
  "SN (relto (R \<union> S) Q) \<longleftrightarrow> SN (relto R (S \<union> Q)) \<and> SN (relto S Q)"
    (is "SN ?a \<longleftrightarrow> SN ?b \<and> SN ?c")
proof -
  have eq: "?a^+ = ?b^+ \<union> ?c^+" by regexp
  from SN_Un_conv[of "?b^+" "?c^+", unfolded eq[symmetric]]
    show ?thesis unfolding SN_trancl_SN_conv by simp
qed

lemma SN_relto_split:
  assumes "SN (relto r (s \<union> q2) \<union> relto q1 (s \<union> q2))" (is "SN ?a")
    and "SN (relto s q2)" (is "SN ?b")
  shows "SN (relto r (q1 \<union> q2) \<union> relto s (q1 \<union> q2))" (is "SN ?c")
proof -
  have "?c^+ \<subseteq> ?a^+ \<union> ?b^+" by regexp
  from trans_subset_SN[OF _ this, unfolded SN_trancl_SN_conv, OF _ assms]
    show ?thesis by simp
qed

end