(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Tau_Laws_No_Weak
  imports Tau_Sim Tau_Stat_Imp
begin

context tauSum
begin

lemma tauLaw2:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<approx> \<tau>.(P)"
proof -
  let ?X = "{(\<Psi>, P \<oplus> \<tau>.(P), \<tau>.(P)) | \<Psi> P. True}"
  let ?Y = "{(\<Psi>, \<tau>.(P), P \<oplus> \<tau>.(P)) | \<Psi> P. True}"

  from assms have "(\<Psi>, P \<oplus> \<tau>.(P), \<tau>.(P)) \<in> ?X \<union> ?Y" by auto
  moreover have "eqvt(?X \<union> ?Y)" by(auto simp add: eqvt_def eqvts)
  ultimately show ?thesis
  proof(coinduct rule: weakTransitiveCoinduct)
    case(cStatImp \<Psi> P Q)
    show ?case
    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      note `(\<Psi>, P, Q) \<in> ?X`
      moreover {
        fix \<Psi> P
        have "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', P \<oplus> \<tau>.(P), \<tau>.(P)) \<in> ?X \<union> ?Y \<union> weakBisim" by auto
        hence "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<lessapprox><(?X \<union> ?Y \<union> weakBisim)> \<tau>.(P)" by(rule tauLaw2StatImpLeft)
      }
      ultimately show ?thesis by blast
    next
      case False
      from `(\<Psi>, P, Q) \<notin> ?X` `(\<Psi>, P, Q) \<in> ?X \<union> ?Y` have "(\<Psi>, P, Q) \<in> ?Y" by auto
      moreover {
        fix \<Psi> P
        have "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<tau>.(P), P \<oplus> \<tau>.(P)) \<in> ?X \<union> ?Y \<union> weakBisim" by auto
        hence "\<Psi> \<rhd> \<tau>.(P) \<lessapprox><(?X \<union> ?Y \<union> weakBisim)> P \<oplus> \<tau>.(P)" by(rule tauLaw2StatImpRight)
      }
      ultimately show ?thesis by blast
    qed
  next
    case(cSim \<Psi> P Q)
    let ?Z = "{(\<Psi>, P, S) | \<Psi> P S. \<exists>Q R. \<Psi> \<rhd> P \<sim> Q \<and> (\<Psi>, Q, R) \<in> ?X \<union> ?Y \<union> weakBisim \<and> \<Psi> \<rhd> R \<sim> S}"
    show ?case

    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      note `(\<Psi>, P, Q) \<in> ?X`
      moreover {
        fix \<Psi> P
        have "\<And>\<Psi> P. (\<Psi>, P, P) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        moreover have "\<And>\<Psi> P Q R S. \<lbrakk>\<Psi> \<rhd> P \<sim> Q; (\<Psi>, Q, R) \<in> ?Z; \<Psi> \<rhd> R \<sim> S\<rbrakk> \<Longrightarrow> (\<Psi>, P, S) \<in> ?Z"
          by(blast intro: bisimTransitive dest: bisimE(4))
        ultimately have "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<leadsto><?Z> \<tau>.(P)" by(rule tauLaw2SimLeft)
      }
      ultimately show ?thesis by blast
    next
      case False
      from `(\<Psi>, P, Q) \<notin> ?X` `(\<Psi>, P, Q) \<in> ?X \<union> ?Y` have "(\<Psi>, P, Q) \<in> ?Y" by auto
      moreover {
        fix \<Psi> P
        have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> (\<Psi>, P, Q) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        hence "\<Psi> \<rhd> \<tau>.(P) \<leadsto><?Z> P \<oplus> \<tau>.(P)" by(rule tauLaw2SimRight)
      }
      ultimately show ?thesis by blast
    qed
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by auto
  next
    case(cSym \<Psi> P Q)
    thus ?case by auto
  qed
qed

lemma tauLawPsiCong2:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<oplus> \<tau>.(P) \<doteq> \<tau>.(P)"
proof(induct rule: weakPsiCongI)
  case cWeakBisim
  thus ?case by(rule tauLaw2)
next
  case cSimLeft
  note weakBisimReflexive
  moreover have "\<And>\<Psi> P Q R S. \<lbrakk>\<Psi> \<rhd> P \<sim> Q; \<Psi> \<rhd> Q \<approx> R; \<Psi> \<rhd> R \<sim> S\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> P \<approx> S"
    by(metis weakBisimTransitive strongBisimWeakBisim)
  ultimately show ?case by(rule tauLaw2CongSimLeft)
next
  case cSimRight
  from strongBisimWeakBisim show ?case by(rule tauLaw2CongSimRight)
qed

lemma tauLawCong2:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  shows "P \<oplus> \<tau>.(P) \<doteq>\<^sub>c \<tau>.(P)"
using tauLawPsiCong2
by(rule_tac weakCongI) auto

lemma tauLaw4:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   \<alpha> :: "'a prefix"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<approx> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)"
proof -
  let ?X = "{(\<Psi>, \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) | \<Psi> P \<alpha> Q. True}"
  let ?Y = "{(\<Psi>, \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) | \<Psi> P \<alpha> Q. True}"
  from assms have "(\<Psi>, \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> ?X \<union> ?Y" by auto
  moreover have "eqvt(?X \<union> ?Y)" by(fastforce simp add: eqvt_def eqvts)
  ultimately show ?thesis
  proof(coinduct rule: weakTransitiveCoinduct)
    case(cStatImp \<Psi> P Q)
    show ?case
    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      note `(\<Psi>, P, Q) \<in> ?X`
      moreover {
        fix \<Psi> \<alpha> P Q
        have "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> ?X \<union> ?Y \<union> weakBisim" by blast
        hence "\<Psi> \<rhd>  \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<lessapprox><(?X \<union> ?Y \<union> weakBisim)>  \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by(rule tauLaw4StatImpLeft)
      }
      ultimately show ?thesis by blast
    next
      case False
      from `(\<Psi>, P, Q) \<notin> ?X` `(\<Psi>, P, Q) \<in> ?X \<union> ?Y` have "(\<Psi>, P, Q) \<in> ?Y" by blast
      moreover {
        fix \<Psi> \<alpha> P Q
        have "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q), \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)) \<in> ?X \<union> ?Y \<union> weakBisim" by auto
        hence "\<Psi> \<rhd>  \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<lessapprox><(?X \<union> ?Y \<union> weakBisim)> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by(rule tauLaw4StatImpRight)
      }
      ultimately show ?thesis by blast
    qed
  next
    case(cSim \<Psi> P Q)
    let ?Z = "{(\<Psi>, P, S) | \<Psi> P S. \<exists>Q R. \<Psi> \<rhd> P \<sim> Q \<and> (\<Psi>, Q, R) \<in> ?X \<union> ?Y \<union> weakBisim \<and> \<Psi> \<rhd> R \<sim> S}"
    show ?case
    proof(cases "(\<Psi>, P, Q) \<in> ?X")
      case True
      note `(\<Psi>, P, Q) \<in> ?X`
      moreover {
        fix \<Psi> P \<alpha> Q
        have "\<And>\<Psi> P. (\<Psi>, P, P) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        moreover have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> (\<Psi>, P, Q) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        ultimately have "\<Psi> \<rhd>  \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<leadsto><?Z>  \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by(rule tauLaw4SimLeft)
      }
      ultimately show ?thesis by blast
    next
      case False
      from `(\<Psi>, P, Q) \<notin> ?X` `(\<Psi>, P, Q) \<in> ?X \<union> ?Y` have "(\<Psi>, P, Q) \<in> ?Y" by blast
      moreover {
        fix \<Psi> P \<alpha> Q
        have "\<And>\<Psi> P Q. \<Psi> \<rhd> P \<sim> Q \<Longrightarrow> (\<Psi>, P, Q) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        moreover have "\<And>\<Psi> P. (\<Psi>, P, P) \<in> ?Z" by(blast intro: weakBisimReflexive bisimReflexive)
        ultimately have "\<Psi> \<rhd> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<leadsto><?Z> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)" by(rule tauLaw4SimRight)
      }
      ultimately show ?thesis by blast
    qed
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by auto
  next
    case(cSym \<Psi> P Q)
    thus ?case by blast
  qed
qed

lemma tauLaw4PsiCong:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   \<alpha> :: "'a prefix"
  and   Q :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> \<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<doteq> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)"
proof(induct rule: weakPsiCongI)
  case cWeakBisim
  show ?case by(rule tauLaw4)
next
  case cSimLeft
  from weakBisimReflexive strongBisimWeakBisim show ?case by(rule tauLaw4CongSimLeft)
next
  case cSimRight
  from strongBisimWeakBisim show ?case by(rule tauLaw4CongSimRight)
qed

lemma tauLaw4Cong:
  fixes P :: "('a, 'b, 'c) psi"
  and   \<alpha> :: "'a prefix"
  and   Q :: "('a, 'b, 'c) psi"

  shows "\<alpha>\<cdot>P \<oplus> \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q) \<doteq>\<^sub>c \<alpha>\<cdot>(\<tau>.(P) \<oplus> Q)"
proof(induct rule: weakCongI)
  case(cWeakPsiCong \<Psi> \<sigma>)
  show ?case
  proof(nominal_induct \<alpha> rule: prefix.strong_inducts)
  next
    case(pInput M yvec N)
    obtain p where "set p \<subseteq> set yvec \<times> set(p \<bullet> yvec)" and "(p \<bullet> yvec) \<sharp>* N" and "(p \<bullet> yvec) \<sharp>* P" and "(p \<bullet> yvec) \<sharp>* Q" and "(p \<bullet> yvec) \<sharp>* \<sigma>"
      by(rule_tac xvec=yvec and c="(N, P, Q, \<sigma>)" in name_list_avoiding) auto
    thus ?case using `wellFormedSubst \<sigma>` tauLaw4PsiCong[where \<alpha>="pInput (substTerm.seqSubst M \<sigma>) (p \<bullet> yvec) (substTerm.seqSubst (p \<bullet> N) \<sigma>)"]
      by(simp add: inputChainAlpha' eqvts)
  next
    case(pOutput M N)
    thus ?case using  `wellFormedSubst \<sigma>` tauLaw4PsiCong[where \<alpha>="pOutput (substTerm.seqSubst M \<sigma>) (substTerm.seqSubst N \<sigma>)"]
      by simp
  next
    case pTau
    thus ?case using  `wellFormedSubst \<sigma>` tauLaw4PsiCong[where \<alpha>="pTau"]
      by simp
  qed
qed

end

end


subsection \<open>Binary and is Diophantine\<close>

theory Binary_And
  imports Binary_Masking Binary_Orthogonal
begin

lemma lm0244: "(a && b) \<preceq> a"
proof (induct a b rule: bitAND_nat.induct)
  case (1 uu)
  then show ?case by simp
next
  case (2 v n)
  then show ?case
    apply (auto simp add: mult.commute)
    by (smt One_nat_def add_cancel_left_right even_succ_div_two masks.elims(3) mod_Suc_le_divisor
          mod_by_Suc_0 mod_mod_trivial mod_mult_self4 mult_numeral_1_right mult_zero_right
          nonzero_mult_div_cancel_left not_mod2_eq_Suc_0_eq_0 numeral_2_eq_2 numeral_One
          odd_two_times_div_two_succ zero_neq_numeral)
qed

lemma lm0245: "(a && b) \<preceq> b"
  by (subst bitAND_commutes) (simp add: lm0244)

lemma bitAND_lt_left: "m && n \<le> m"
  using lm0244 masks_leq by auto
lemma bitAND_lt_right: "m && n \<le> n"
  using lm0245 masks_leq by auto

lemmas bitAND_lt = bitAND_lt_right bitAND_lt_left

lemma auxm3_lm0246:
  shows "bin_carry a b k = bin_carry a b k mod 2"
  using bin_carry_bounded by auto

lemma auxm2_lm0246:
  assumes "(\<forall>r< n.(nth_bit a r + nth_bit b r \<le> 1))"
  shows "(nth_bit (a+b) n) = (nth_bit a n + nth_bit b n) mod 2"
  using assms no_carry by auto

lemma auxm1_lm0246: "a \<preceq> (a+b) \<Longrightarrow> (\<forall>n. nth_bit a n + nth_bit b n \<le> 1)" (is "?P \<Longrightarrow> ?Q")
proof-
{
  assume asm: "\<not>?Q"
  then obtain n where n1:"\<not>(nth_bit a n + nth_bit b n \<le> 1)"
    and n2:"\<forall>r < n. (nth_bit a r + nth_bit b r \<le> 1)"
    using obtain_smallest by (auto dest: obtain_smallest)
  hence ab1: "nth_bit a n =1  \<and>  nth_bit b n = 1" using nth_bit_def by auto
  hence "nth_bit (a+b) n = 0" using n2 auxm2_lm0246 by auto
  hence "\<not>?P" using masks_leq_equiv ab1 by auto (metis One_nat_def not_one_le_zero)
} then show "?P \<Longrightarrow> ?Q" by auto
qed

lemma aux0_lm0246:"a \<preceq> (a+b) \<longrightarrow>(a+b)\<exclamdown> n = a \<exclamdown> n + b \<exclamdown> n"
proof-
  show ?thesis using auxm1_lm0246 auxm2_lm0246 less_Suc_eq_le numeral_2_eq_2 by auto
qed

lemma aux1_lm0246:"a\<preceq>b \<longrightarrow> (\<forall>n. nth_bit (b-a) n = nth_bit b n - nth_bit a n)"
  using aux0_lm0246 masks_leq by auto (metis add_diff_cancel_left' le_add_diff_inverse)

lemma lm0246:"(a - (a && b)) \<bottom> (b - (a && b))"
  apply (subst ortho_mult_equiv)
  apply (rule allI) subgoal for k
  proof(cases "nth_bit a k = 0")
    case True
    have "nth_bit (a- (a && b)) k = 0" by (auto simp add: lm0244 aux1_lm0246 "True")
    then show ?thesis by simp
  next
    case False
    then show ?thesis proof(cases "nth_bit b k = 0")
      case True
      have "nth_bit (b- (a && b)) k = 0" by (auto simp add: lm0245 aux1_lm0246 "True")
      then show ?thesis by simp
    next
      case False2: False
      have "nth_bit a k = 1" using False nth_bit_def by auto
      moreover have "nth_bit b k = 1" using False2 nth_bit_def by auto
      ultimately have "nth_bit (b- (a && b)) k = 0"
        by (auto simp add: lm0245 aux1_lm0246 bitAND_digit_mult)
      then show ?thesis by simp
    qed
  qed
done

lemma aux0_lm0247:"(nth_bit a k) * (nth_bit b k) \<le> 1"
  using eq_iff nth_bit_def by fastforce

lemma lm0247_masking_equiv:
  fixes a b c :: nat
  shows "(c = a && b) \<longleftrightarrow> (c \<preceq> a \<and> c \<preceq> b \<and> (a - c) \<bottom> (b - c))" (is "?P \<longleftrightarrow> ?Q")
proof (rule)
  assume ?P
  thus ?Q
    apply (auto simp add: lm0244 lm0245)
    using lm0246 orthogonal.simps by blast
next
  assume Q: ?Q
  have "(\<forall>k. nth_bit c k \<le> nth_bit a k \<and> nth_bit c k \<le> nth_bit b k)"
    using Q masks_leq_equiv by auto
  moreover have "(\<forall>k x. nth_bit x k \<le> 1)"
    by (auto simp add: nth_bit_def)
  ultimately have f0:"(\<forall>k. nth_bit c k \<le> ((nth_bit a k) * (nth_bit b k)))"
    by (metis mult.right_neutral mult_0_right not_mod_2_eq_0_eq_1 nth_bit_def)
  show "?Q \<Longrightarrow> ?P"
  proof (rule ccontr)
    assume contr:"c \<noteq> a && b"
    have k_exists:"(\<exists>k. (nth_bit c k) < ((nth_bit a k) * (nth_bit b k)))"
      using bitAND_mult_equiv by (meson f0 contr le_less)
    then obtain k
      where "(nth_bit c k) < ((nth_bit a k) * (nth_bit b k))" ..
    hence abc_kth:"((nth_bit c k) = 0) \<and> ((nth_bit a k) = 1) \<and> ((nth_bit b k) = 1)"
      using aux0_lm0247 less_le_trans
      by (metis One_nat_def Suc_leI nth_bit_bounded less_le less_one one_le_mult_iff)
    hence "(nth_bit (a - c) k) = 1 \<and> (nth_bit (b - c) k) = 1"
      by (auto simp add: abc_kth aux1_lm0246 Q)
    hence "\<not> ((a - c) \<bottom> (b - c))"
      by (metis mult.left_neutral not_mod_2_eq_0_eq_1 ortho_mult_equiv)
    then show False
      using Q by blast
  qed
qed

definition binary_and ("[_ = _ && _]" 1000)
  where "[A = B && C] \<equiv> (TERNARY (\<lambda>a b c. a = b && c) A B C)"

lemma binary_and_dioph[dioph]:
  fixes A B C :: polynomial
  defines "DR \<equiv> [A = B && C]"
  shows "is_dioph_rel DR"
proof -
  define DS where "DS \<equiv> (A [\<preceq>] B) [\<and>] (A [\<preceq>] C) [\<and>] (B [-] A) [\<bottom>] (C [-] A)"

  have "eval DS a = eval DR a" for a
    unfolding DS_def DR_def binary_and_def defs
    by (simp add: lm0247_masking_equiv)

  moreover have "is_dioph_rel DS"
    unfolding DS_def by (auto simp: dioph)

  ultimately show ?thesis
    by (auto simp: is_dioph_rel_def)
qed

declare binary_and_def[defs]

definition binary_and_attempt :: "polynomial \<Rightarrow> polynomial \<Rightarrow> polynomial" ("_ &? _") where
  "A &? B \<equiv> Const 0"

end


(*
  File:    SDS_Automation.thy
  Author:  Manuel Eberl <eberlm@in.tum.de>

  This theory provides a number of commands to automatically derive restrictions on the
  results of Social Decision Schemes fulfilling properties like Anonymity, Neutrality,
  Ex-post- or SD-efficiency, and SD-Strategy-Proofness.
*)

section \<open>Automatic Fact Gathering for Social Decision Schemes\<close>

theory SDS_Automation
imports Preference_Profile_Cmd
keywords
  "derive_orbit_equations"
  "derive_support_conditions"
  "derive_ex_post_conditions"
  "find_inefficient_supports"
  "prove_inefficient_supports"
  "derive_strategyproofness_conditions" :: thy_goal
begin

text \<open>
  We now provide the following commands to automatically derive restrictions on the results
  of Social Decision Schemes satisfying Anonymity, Neutrality, Efficiency, or Strategy-Proofness:
  \begin{description}
    \item[@{command derive_orbit_equations}] to derive equalities arising from automorphisms of the
      given profiles due to Anonymity and Neutrality
    \item[@{command derive_ex_post_conditions}] to find all Pareto losers and the given profiles and
      derive the facts that they must be assigned probability 0 by any \textit{ex-post}-efficient
      SDS
    \item[@{command find_inefficient_supports}] to use Linear Programming to find all minimal SD-inefficient
      (but not \textit{ex-post}-inefficient) supports in the given profiles and output a
      corresponding witness lottery for each of them
    \item[@{command prove_inefficient_supports}] to prove a specified set of support conditions arising from
      \textit{ex-post}- or \textit{SD}-Efficiency. For conditions arising from \textit{SD}-Efficiency,
      a witness lottery must be specified (e.\,g. as computed by @{command derive_orbit_equations}).
    \item[@{command derive_support_conditions}] to automatically find and prove all support conditions
      arising from \textit{ex-post-} and \textit{SD}-Efficiency
    \item [@{command derive_strategyproofness_conditions}] to automatically derive all conditions
      arising from weak Strategy-Proofness and any manipulations between the given preference
      profiles. An optional maximum manipulation size can be specified.
  \end{description}
  All commands except @{command find_inefficient_supports} open a proof state and leave behind
  proof obligations for the user to discharge. This should always be possible using the Simplifier,
  possibly with a few additional rules, depending on the context.

\<close>

lemma disj_False_right: "P \<or> False \<longleftrightarrow> P" by simp

lemmas multiset_add_ac = add_ac[where ?'a = "'a multiset"]

lemma less_or_eq_real:
  "(x::real) < y \<or> x = y \<longleftrightarrow> x \<le> y" "x < y \<or> y = x \<longleftrightarrow> x \<le> y" by linarith+

lemma multiset_Diff_single_normalize:
  fixes a c assumes "a \<noteq> c"
  shows   "({#a#} + B) - {#c#} = {#a#} + (B - {#c#})"
  using assms by (metis diff_union_swap multiset_add_ac(2))

lemma ex_post_efficient_aux:
  assumes "prefs_from_table_wf agents alts xss" "R \<equiv> prefs_from_table xss"
  assumes "i \<in> agents" "\<forall>i\<in>agents. y \<succeq>[prefs_from_table xss i] x" "\<not>y \<preceq>[prefs_from_table xss i] x"
  shows   "ex_post_efficient_sds agents alts sds \<longrightarrow> pmf (sds R) x = 0"
proof
  assume ex_post: "ex_post_efficient_sds agents alts sds"
  from assms(1,2) have wf: "pref_profile_wf agents alts R"
    by (simp add: pref_profile_from_tableI')
  from ex_post interpret ex_post_efficient_sds agents alts sds .
  from assms(2-) show "pmf (sds R) x = 0"
    by (intro ex_post_efficient''[OF wf, of i x y]) simp_all
qed

lemma SD_inefficient_support_aux:
  assumes R: "prefs_from_table_wf agents alts xss" "R \<equiv> prefs_from_table xss"
  assumes as: "as \<noteq> []" "set as \<subseteq> alts" "distinct as" "A = set as"
  assumes ys: "\<forall>x\<in>set (map snd ys). 0 \<le> x" "listsum (map snd ys) = 1" "set (map fst ys) \<subseteq> alts"
  assumes i: "i \<in> agents"
  assumes SD1: "\<forall>i\<in>agents. \<forall>x\<in>alts.
    listsum (map snd (filter (\<lambda>y. prefs_from_table xss i x (fst y)) ys)) \<ge>
    real (length (filter (prefs_from_table xss i x) as)) / real (length as)"
  assumes SD2: "\<exists>x\<in>alts. listsum (map snd (filter (\<lambda>y. prefs_from_table xss i x (fst y)) ys)) >
                        real (length (filter (prefs_from_table xss i x) as)) / real (length as)"
  shows   "sd_efficient_sds agents alts sds \<longrightarrow> (\<exists>x\<in>A. pmf (sds R) x = 0)"
proof
  assume "sd_efficient_sds agents alts sds"
  from R have wf: "pref_profile_wf agents alts R"
    by (simp add: pref_profile_from_tableI')
  then interpret pref_profile_wf agents alts R .
  interpret sd_efficient_sds agents alts sds by fact
  from ys have ys': "pmf_of_list_wf ys" by (intro pmf_of_list_wfI) auto

  {
    fix i x assume "x \<in> alts" "i \<in> agents"
    with ys' have "lottery_prob (pmf_of_list ys) (preferred_alts (R i) x) =
      listsum (map snd (filter (\<lambda>y. prefs_from_table xss i x (fst y)) ys))"
      by (subst measure_pmf_of_list) (simp_all add: preferred_alts_def R)
  } note A = this
  {
    fix i x assume "x \<in> alts" "i \<in> agents"
    with as have "lottery_prob (pmf_of_set (set as)) (preferred_alts (R i) x) =
      real (card (set as \<inter> preferred_alts (R i) x)) / real (card (set as))"
      by (subst measure_pmf_of_set) simp_all
    also have "set as \<inter> preferred_alts (R i) x = set (filter (\<lambda>y. R i x y) as)"
      by (auto simp add: preferred_alts_def)
    also have "card \<dots> = length (filter (\<lambda>y. R i x y) as)"
      by (intro distinct_card distinct_filter assms)
    also have "card (set as) = length as" by (intro distinct_card assms)
    finally have "lottery_prob (pmf_of_set (set as)) (preferred_alts (R i) x) =
      real (length (filter (prefs_from_table xss i x) as)) / real (length as)"
      by (simp add: R)
  } note B = this

  from wf show "\<exists>x\<in>A. pmf (sds R) x = 0"
  proof (rule SD_inefficient_support')
    from ys ys' show lottery1: "pmf_of_list ys \<in> lotteries" by (intro pmf_of_list_lottery)
    show i: "i \<in> agents" by fact
    from as have lottery2: "pmf_of_set (set as) \<in> lotteries"
      by (intro pmf_of_set_lottery) simp_all
    from i as SD2 lottery1 lottery2 show "\<not>SD (R i) (pmf_of_list ys) (pmf_of_set A)"
      by (subst preorder_on.SD_preorder[of alts]) (auto simp: A B not_le)
    from as SD1 lottery1 lottery2
      show "\<forall>i\<in>agents. SD (R i) (pmf_of_set A) (pmf_of_list ys)"
        by safe (auto simp: preorder_on.SD_preorder[of alts] A B)
  qed (insert as, simp_all)
qed

definition pref_classes where
  "pref_classes alts le = preferred_alts le ` alts - {alts}"

primrec pref_classes_lists where
  "pref_classes_lists [] = {}"
| "pref_classes_lists (xs#xss) = insert (\<Union>(set (xs#xss))) (pref_classes_lists xss)"

fun pref_classes_lists_aux where
  "pref_classes_lists_aux acc [] = {}"
| "pref_classes_lists_aux acc (xs#xss) = insert acc (pref_classes_lists_aux (acc \<union> xs) xss)"

lemma pref_classes_lists_append:
  "pref_classes_lists (xs @ ys) = (op \<union> (\<Union>set ys)) ` pref_classes_lists xs \<union> pref_classes_lists ys"
  by (induction xs) auto

lemma pref_classes_lists_aux:
  assumes "is_weak_ranking xss" "acc \<inter> (\<Union>set xss) = {}"
  shows  "pref_classes_lists_aux acc xss =
            (insert acc ((\<lambda>A. A \<union> acc) ` pref_classes_lists (rev xss)) - {acc \<union> \<Union>(set xss)})"
using assms
proof (induction acc xss rule: pref_classes_lists_aux.induct [case_names Nil Cons])
  case (Cons acc xs xss)
  from Cons.prems have A: "acc \<inter> (xs \<union> \<Union>set xss) = {}" "xs \<noteq> {}"
    by (simp_all add: is_weak_ranking_Cons)
  from Cons.prems have "pref_classes_lists_aux (acc \<union> xs) xss =
                          insert (acc \<union> xs) ((\<lambda>A. A \<union> (acc \<union> xs)) `pref_classes_lists (rev xss)) -
                          {acc \<union> xs \<union> \<Union>set xss}"
    by (intro Cons.IH) (auto simp: is_weak_ranking_Cons)
  with Cons.prems have "pref_classes_lists_aux acc (xs # xss) =
      insert acc (insert (acc \<union> xs) ((\<lambda>A. A \<union> (acc \<union> xs)) ` pref_classes_lists (rev xss)) -
         {acc \<union> (xs \<union> \<Union>set xss)})"
    by (simp_all add: is_weak_ranking_Cons pref_classes_lists_append image_image Un_ac)
  also from  A have "\<dots> = insert acc (insert (acc \<union> xs) ((\<lambda>x. x \<union> (acc \<union> xs)) `
                            pref_classes_lists (rev xss))) - {acc \<union> (xs \<union> \<Union>set xss)}"
    by blast
  finally show ?case
    by (simp_all add: pref_classes_lists_append image_image Un_ac)
qed simp_all

lemma pref_classes_list_aux_hd_tl:
  assumes "is_weak_ranking xss" "xss \<noteq> []"
  shows   "pref_classes_lists_aux (hd xss) (tl xss) = pref_classes_lists (rev xss) - {\<Union>set xss}"
proof -
  from assms have A: "xss = hd xss # tl xss" by simp
  from assms have "hd xss \<inter> \<Union>set (tl xss) = {} \<and> is_weak_ranking (tl xss)"
    by (subst (asm) A, subst (asm) is_weak_ranking_Cons) simp_all
  hence "pref_classes_lists_aux (hd xss) (tl xss) =
           insert (hd xss) ((\<lambda>A. A \<union> hd xss) ` pref_classes_lists (rev (tl xss))) -
           {hd xss \<union> \<Union>set (tl xss)}" by (intro pref_classes_lists_aux) simp_all
  also have "hd xss \<union> \<Union>set (tl xss) = \<Union>(set xss)" by (subst (3) A, subst set_simps) simp_all
  also have "insert (hd xss) ((\<lambda>A. A \<union> hd xss) ` pref_classes_lists (rev (tl xss))) =
               pref_classes_lists (rev (tl xss) @ [hd xss])"
    by (subst pref_classes_lists_append) auto
  also have "rev (tl xss) @ [hd xss] = rev xss" by (subst (3) A) (simp only: rev.simps)
  finally show ?thesis .
qed

lemma pref_classes_of_weak_ranking_aux:
  assumes "is_weak_ranking xss"
  shows   "of_weak_ranking_Collect_ge xss ` (\<Union>(set xss)) = pref_classes_lists xss"
proof safe
  fix X x assume "x \<in> X" "X \<in> set xss"
  with assms show "of_weak_ranking_Collect_ge xss x \<in> pref_classes_lists xss"
    by (induction xss) (auto simp: is_weak_ranking_Cons of_weak_ranking_Collect_ge_Cons')
next
  fix x assume "x \<in> pref_classes_lists xss"
  with assms show "x \<in> of_weak_ranking_Collect_ge xss ` \<Union>set xss"
  proof (induction xss)
    case (Cons xs xss)
    from Cons.prems consider "x = xs \<union> \<Union>set xss" | "x \<in> pref_classes_lists xss" by auto
    thus ?case
    proof cases
      assume "x = xs \<union> \<Union>set xss"
      with Cons.prems show ?thesis
        by (auto simp: is_weak_ranking_Cons of_weak_ranking_Collect_ge_Cons')
    next
      assume x: "x \<in> pref_classes_lists xss"
      from Cons.prems x have "x \<in> of_weak_ranking_Collect_ge xss ` \<Union>set xss"
        by (intro Cons.IH) (simp_all add: is_weak_ranking_Cons)
      moreover from Cons.prems have "xs \<inter> \<Union>set xss = {}"
        by (simp add: is_weak_ranking_Cons)
      ultimately have "x \<in> of_weak_ranking_Collect_ge xss `
                         ((xs \<union> \<Union>set xss) \<inter> {x. x \<notin> xs})" by blast
      thus ?thesis by (simp add: of_weak_ranking_Collect_ge_Cons')
    qed
  qed simp_all
qed

(* TODO: Move *)
lemma is_weak_ranking_rev [simp]: "is_weak_ranking (rev xs) \<longleftrightarrow> is_weak_ranking xs"
  by (simp add: is_weak_ranking_iff)

lemma eval_pref_classes_of_weak_ranking:
  assumes "\<Union>(set xss) = alts" "is_weak_ranking xss" "alts \<noteq> {}"
  shows   "pref_classes alts (of_weak_ranking xss) = pref_classes_lists_aux (hd xss) (tl xss)"
proof -
  have "pref_classes alts (of_weak_ranking xss) =
               preferred_alts (of_weak_ranking xss) ` (\<Union>(set (rev xss))) - {\<Union>set xss}"
    by (simp add: pref_classes_def assms)
  also {
    have "of_weak_ranking_Collect_ge (rev xss) ` (\<Union>(set (rev xss))) = pref_classes_lists (rev xss)"
      using assms by (intro pref_classes_of_weak_ranking_aux) simp_all
    also have "of_weak_ranking_Collect_ge (rev xss) = preferred_alts (of_weak_ranking xss)"
      by (intro ext) (simp_all add: of_weak_ranking_Collect_ge_def preferred_alts_def)
    finally have "preferred_alts (of_weak_ranking xss) ` (\<Union>(set (rev xss))) =
                    pref_classes_lists (rev xss)" .
  }
  also from assms have "pref_classes_lists (rev xss) - {\<Union>set xss} =
                          pref_classes_lists_aux (hd xss) (tl xss)"
    by (intro pref_classes_list_aux_hd_tl [symmetric]) auto
  finally show ?thesis by simp
qed

context preorder_on
begin

(* TODO: Move *)
lemma preferred_alts_subset: "preferred_alts le x \<subseteq> carrier"
  unfolding preferred_alts_def using not_outside by blast

lemma SD_iff_pref_classes:
  assumes "p \<in> lotteries_on carrier" "q \<in> lotteries_on carrier"
  shows   "p \<preceq>[SD(le)] q \<longleftrightarrow>
             (\<forall>A\<in>pref_classes carrier le. measure_pmf.prob p A \<le> measure_pmf.prob q A)"
proof safe
  fix A assume "p \<preceq>[SD(le)] q" "A \<in> pref_classes carrier le"
  thus "measure_pmf.prob p A \<le> measure_pmf.prob q A"
    by (auto simp: SD_preorder pref_classes_def)
next
  assume A: "\<forall>A\<in>pref_classes carrier le. measure_pmf.prob p A \<le> measure_pmf.prob q A"
  show "p \<preceq>[SD(le)] q"
  proof (rule SD_preorderI)
    fix x assume x: "x \<in> carrier"
    show "measure_pmf.prob p (preferred_alts le x)
             \<le> measure_pmf.prob q (preferred_alts le x)"
    proof (cases "preferred_alts le x = carrier")
      case False
      with x have "preferred_alts le x \<in> pref_classes carrier le"
        unfolding pref_classes_def by (intro DiffI imageI) simp_all
      with A show ?thesis by simp
    next
      case True
      from assms have "measure_pmf.prob p carrier = 1" "measure_pmf.prob q carrier = 1"
        by (auto simp: measure_pmf.prob_eq_1 lotteries_on_def AE_measure_pmf_iff)
      with True show ?thesis by simp
    qed
  qed (insert assms, simp_all)
qed

end

lemma (in strategyproof_an_sds) strategyproof':
  assumes wf: "is_pref_profile R" "total_preorder_on alts Ri'" and i: "i \<in> agents"
  shows   "(\<exists>A\<in>pref_classes alts (R i). lottery_prob (sds (R(i := Ri'))) A <
                        lottery_prob (sds R) A) \<or>
           (\<forall>A\<in>pref_classes alts (R i). lottery_prob (sds (R(i := Ri'))) A =
                        lottery_prob (sds R) A)"
proof -
  from wf(1) interpret R: pref_profile_wf agents alts R .
  from i interpret total_preorder_on alts "R i" by simp
  from assms have "\<not> manipulable_profile R i Ri'" by (intro strategyproof)
  moreover from wf i have "sds R \<in> lotteries" "sds (R(i := Ri')) \<in> lotteries"
    by (simp_all add: sds_wf)
  ultimately show ?thesis
    by (fastforce simp: manipulable_profile_def strongly_preferred_def
                        SD_iff_pref_classes not_le not_less)
qed

lemma pref_classes_lists_aux_finite:
  "A \<in> pref_classes_lists_aux acc xss \<Longrightarrow> finite acc \<Longrightarrow> (\<And>A. A \<in> set xss \<Longrightarrow> finite A)
      \<Longrightarrow> finite A"
  by (induction acc xss rule: pref_classes_lists_aux.induct) auto

lemma strategyproof_aux:
  assumes wf: "prefs_from_table_wf agents alts xss1" "R1 = prefs_from_table xss1"
              "prefs_from_table_wf agents alts xss2" "R2 = prefs_from_table xss2"
  assumes sds: "strategyproof_an_sds agents alts sds" and i: "i \<in> agents" and j: "j \<in> agents"
  assumes eq:  "R1(i := R2 j) = R2" "the (map_of xss1 i) = xs"
               "pref_classes_lists_aux (hd xs) (tl xs) = ps"
  shows   "(\<exists>A\<in>ps. (\<Sum>x\<in>A. pmf (sds R2) x) < (\<Sum>x\<in>A. pmf (sds R1) x)) \<or>
           (\<forall>A\<in>ps. (\<Sum>x\<in>A. pmf (sds R2) x) = (\<Sum>x\<in>A. pmf (sds R1) x))"
proof -
  from sds interpret strategyproof_an_sds agents alts sds .
  let ?Ri' = "R2 j"
  from wf j have wf': "is_pref_profile R1" "total_preorder_on alts ?Ri'"
    by (auto intro: pref_profile_from_tableI pref_profile_wf.prefs_wf'(1))

  from wf(1) i have "i \<in> set (map fst xss1)" by (simp add: prefs_from_table_wf_def)
  with prefs_from_table_wfD(3)[OF wf(1)] eq
    have "xs \<in> set (map snd xss1)" by force
  note xs = prefs_from_table_wfD(2)[OF wf(1)] prefs_from_table_wfD(5,6)[OF wf(1) this]

  {
    fix p A assume A: "A \<in> pref_classes_lists_aux (hd xs) (tl xs)"
    from xs have "xs \<noteq> []" by auto
    with xs have "finite A"
      by (intro pref_classes_lists_aux_finite[OF A])
         (auto simp: is_finite_weak_ranking_def list.set_sel)
    hence "lottery_prob p A = (\<Sum>x\<in>A. pmf p x)"
      by (rule measure_measure_pmf_finite)
  } note A = this

  from strategyproof'[OF wf' i] eq have
    "(\<exists>A\<in>pref_classes alts (R1 i). lottery_prob (sds R2) A < lottery_prob (sds R1) A) \<or>
     (\<forall>A\<in>pref_classes alts (R1 i). lottery_prob (sds R2) A = lottery_prob (sds R1) A)"
    by simp
  also from wf eq i have "R1 i = of_weak_ranking xs"
    by (simp add: prefs_from_table_map_of)
  also from xs have "pref_classes alts (of_weak_ranking xs) = pref_classes_lists_aux (hd xs) (tl xs)"
    unfolding is_finite_weak_ranking_def by (intro eval_pref_classes_of_weak_ranking) simp_all
  finally show ?thesis by (simp add: A eq)
qed

lemma strategyproof_aux':
  assumes wf: "prefs_from_table_wf agents alts xss1" "R1 \<equiv> prefs_from_table xss1"
              "prefs_from_table_wf agents alts xss2" "R2 \<equiv> prefs_from_table xss2"
  assumes sds: "strategyproof_an_sds agents alts sds" and i: "i \<in> agents" and j: "j \<in> agents"
  assumes perm: "list_permutes ys alts"
  defines "\<sigma> \<equiv> permutation_of_list ys" and "\<sigma>' \<equiv> inverse_permutation_of_list ys"
  defines "xs \<equiv> the (map_of xss1 i)"
  defines xs': "xs' \<equiv> map (op ` \<sigma>) (the (map_of xss2 j))"
  defines "Ri' \<equiv> of_weak_ranking xs'"
  assumes distinct_ps: "\<forall>A\<in>ps. distinct A"
  assumes eq:  "mset (map snd xss1) - {#the (map_of xss1 i)#} + {#xs'#} =
                  mset (map (map (op ` \<sigma>) \<circ> snd) xss2)"
               "pref_classes_lists_aux (hd xs) (tl xs) = set ` ps"
  shows   "list_permutes ys alts \<and>
             ((\<exists>A\<in>ps. (\<Sum>x\<leftarrow>A. pmf (sds R2) (\<sigma>' x)) < (\<Sum>x\<leftarrow>A. pmf (sds R1) x)) \<or>
              (\<forall>A\<in>ps. (\<Sum>x\<leftarrow>A. pmf (sds R2) (\<sigma>' x)) = (\<Sum>x\<leftarrow>A. pmf (sds R1) x)))"
            (is "_ \<and> ?th")
proof
  from perm have perm': "\<sigma> permutes alts" by (simp add: \<sigma>_def)
  from sds interpret strategyproof_an_sds agents alts sds .
  from wf(3) j have "j \<in> set (map fst xss2)" by (simp add: prefs_from_table_wf_def)
  with prefs_from_table_wfD(3)[OF wf(3)]
    have xs'_aux: "the (map_of xss2 j) \<in> set (map snd xss2)" by force
  with wf(3) have xs'_aux': "is_finite_weak_ranking (the (map_of xss2 j))"
    by (auto simp: prefs_from_table_wf_def)
  hence "is_weak_ranking xs'" unfolding xs'
    by (intro is_weak_ranking_map_inj permutes_inj_on[OF perm'])
       (auto simp add: is_finite_weak_ranking_def)
  moreover from this xs'_aux' have "is_finite_weak_ranking xs'"
    by (auto simp: xs' is_finite_weak_ranking_def)
  moreover from prefs_from_table_wfD(5)[OF wf(3) xs'_aux]
    have "\<Union>set xs' = alts" unfolding xs'
    by (simp add: image_Union [symmetric] permutes_image[OF perm'])
  ultimately have wf_xs': "is_weak_ranking xs'" "is_finite_weak_ranking xs'" "\<Union>set xs' = alts"
    by (simp_all add: is_finite_weak_ranking_def)
  from this wf j have wf': "is_pref_profile R1" "total_preorder_on alts Ri'"
                      "is_pref_profile R2" "finite_total_preorder_on alts Ri'"
    unfolding Ri'_def by (auto intro: pref_profile_from_tableI pref_profile_wf.prefs_wf'(1)
                                 total_preorder_of_weak_ranking)

 interpret R1: pref_profile_wf agents alts R1 by fact
 interpret R2: pref_profile_wf agents alts R2 by fact

  from wf(1) i have "i \<in> set (map fst xss1)" by (simp add: prefs_from_table_wf_def)
  with prefs_from_table_wfD(3)[OF wf(1)] eq(2)
    have "xs \<in> set (map snd xss1)" unfolding xs_def by force
  note xs = prefs_from_table_wfD(2)[OF wf(1)] prefs_from_table_wfD(5,6)[OF wf(1) this]

  from wf i wf' wf_xs' xs eq
    have eq': "anonymous_profile (R1(i := Ri')) = image_mset (map (op ` \<sigma>)) (anonymous_profile R2)"
    by (subst R1.anonymous_profile_update)
       (simp_all add: Ri'_def weak_ranking_of_weak_ranking mset_map multiset.map_comp xs_def
          anonymise_prefs_from_table prefs_from_table_map_of)

  {
    fix p A assume A: "A \<in> pref_classes_lists_aux (hd xs) (tl xs)"
    from xs have "xs \<noteq> []" by auto
    with xs have "finite A"
      by (intro pref_classes_lists_aux_finite[OF A])
         (auto simp: is_finite_weak_ranking_def list.set_sel)
    hence "lottery_prob p A = (\<Sum>x\<in>A. pmf p x)"
      by (rule measure_measure_pmf_finite)
  } note A = this

  from strategyproof'[OF wf'(1,2) i] eq' have
    "(\<exists>A\<in>pref_classes alts (R1 i). lottery_prob (sds (R1(i := Ri'))) A < lottery_prob (sds R1) A) \<or>
     (\<forall>A\<in>pref_classes alts (R1 i). lottery_prob (sds (R1(i := Ri'))) A = lottery_prob (sds R1) A)"
    by simp
  also from eq' i have "sds (R1(i := Ri')) = map_pmf \<sigma> (sds R2)"
    unfolding \<sigma>_def by (intro sds_anonymous_neutral permutation_of_list_permutes perm wf'
                              pref_profile_wf.wf_update eq)
  also from wf eq i have "R1 i = of_weak_ranking xs"
    by (simp add: prefs_from_table_map_of xs_def)
  also from xs have "pref_classes alts (of_weak_ranking xs) = pref_classes_lists_aux (hd xs) (tl xs)"
    unfolding is_finite_weak_ranking_def by (intro eval_pref_classes_of_weak_ranking) simp_all
  finally have "(\<exists>A\<in>ps. (\<Sum>x\<leftarrow>A. pmf (map_pmf \<sigma> (sds R2)) x) < (\<Sum>x\<leftarrow>A. pmf (sds R1) x)) \<or>
                (\<forall>A\<in>ps. (\<Sum>x\<leftarrow>A. pmf (map_pmf \<sigma> (sds R2)) x) = (\<Sum>x\<leftarrow>A. pmf (sds R1) x))"
    using distinct_ps
    by (simp add: A eq setsum.distinct_set_conv_list del: measure_map_pmf)
  also from perm' have "pmf (map_pmf \<sigma> (sds R2)) = (\<lambda>x. pmf (sds R2) (inv \<sigma> x))"
    using pmf_map_inj'[of \<sigma> _ "inv \<sigma> x" for x]
    by (simp add: fun_eq_iff permutes_inj permutes_inverses)
  also from perm have "inv \<sigma> = \<sigma>'" unfolding \<sigma>_def \<sigma>'_def
    by (rule inverse_permutation_of_list_correct [symmetric])
  finally show ?th .
qed fact+

ML_file "sds_automation.ML"

end


theory DataField
  imports
    Main
    "Ecore-GROOVE-Mapping.Type_Model_Graph_Mapping"
    "Ecore-GROOVE-Mapping.Identifier_List"
begin

section "Definition of a type model which introduces a field typed by a data type."

definition tmod_data_field :: "'t Id \<Rightarrow> 't \<Rightarrow> 't TypeDef \<Rightarrow> 't type_model" where
  "tmod_data_field classtype name fieldtype = \<lparr>
    Class = {classtype},
    Enum = {},
    UserDataType = {},
    Field = {(classtype, name)},
    FieldSig = (\<lambda>x. if x = (classtype, name) then (fieldtype, \<^bold>1..\<^bold>1) else undefined),
    EnumValue = {},
    Inh = {},
    Prop = {},
    Constant = {},
    ConstType = (\<lambda>x. undefined)
  \<rparr>"

lemma tmod_data_field_correct:
  assumes fieldtype_is_datatype: "fieldtype \<in> DataType"
  shows "type_model (tmod_data_field classtype name fieldtype)"
proof (intro type_model.intro)
  fix f
  assume "f \<in> Field (tmod_data_field classtype name fieldtype)"
  then have "f = (classtype, name)"
    unfolding tmod_data_field_def
    by simp
  then have "FieldSig (tmod_data_field classtype name fieldtype) f = (fieldtype, \<^bold>1..\<^bold>1)"
    unfolding tmod_data_field_def
    by simp
  then show "fst (FieldSig (tmod_data_field classtype name fieldtype) f) \<in> Type (tmod_data_field classtype name fieldtype) \<and>
    multiplicity (snd (FieldSig (tmod_data_field classtype name fieldtype) f))"
  proof (intro conjI)
    assume "FieldSig (tmod_data_field classtype name fieldtype) f = (fieldtype, \<^bold>1..\<^bold>1)"
    then have "fst (FieldSig (tmod_data_field classtype name fieldtype) f) = fieldtype"
      by simp
    then show "fst (FieldSig (tmod_data_field classtype name fieldtype) f) \<in> Type (tmod_data_field classtype name fieldtype)"
      unfolding Type_def NonContainerType_def
      by (simp add: fieldtype_is_datatype)
  next
    assume "FieldSig (tmod_data_field classtype name fieldtype) f = (fieldtype, \<^bold>1..\<^bold>1)"
    then have snd_def: "snd (FieldSig (tmod_data_field classtype name fieldtype) f) = \<^bold>1..\<^bold>1"
      by simp
    then show "multiplicity (snd (FieldSig (tmod_data_field classtype name fieldtype) f))"
      by (intro multiplicity.intro) (simp_all)
  qed
next
  have "asym {} \<and> irrefl {}"
    by (simp add: asym.intros irrefl_def)
  then show "asym (Inh (tmod_data_field classtype name fieldtype)) \<and> irrefl ((Inh (tmod_data_field classtype name fieldtype))\<^sup>+)"
    unfolding tmod_data_field_def
    by simp
next
  fix f
  assume "f \<in> Field (tmod_data_field classtype name fieldtype) \<and>
    Type_Model.type (tmod_data_field classtype name fieldtype) f \<in> DataType \<union>
      EnumType (tmod_data_field classtype name fieldtype) \<union>
      UserDataTypeType (tmod_data_field classtype name fieldtype) \<union>
      ProperClassType (tmod_data_field classtype name fieldtype)"
  then have "f = (classtype, name)"
    unfolding tmod_data_field_def
    by simp
  then show "lower (tmod_data_field classtype name fieldtype) f = \<^bold>1"
    unfolding lower_def tmod_data_field_def
    by simp
next
  fix f
  assume assump: "f \<in> Field (tmod_data_field classtype name fieldtype) \<and>
    Type_Model.type (tmod_data_field classtype name fieldtype) f \<in> NullableClassType (tmod_data_field classtype name fieldtype)"
  then have "f = (classtype, name)"
    unfolding tmod_data_field_def
    by simp
  then have "Type_Model.type (tmod_data_field classtype name fieldtype) f = fieldtype"
    unfolding Type_Model.type_def tmod_data_field_def
    by simp
  then have "Type_Model.type (tmod_data_field classtype name fieldtype) f \<in> DataType"
    using fieldtype_is_datatype
    by simp
  then show "lower (tmod_data_field classtype name fieldtype) f = \<^bold>0"
    using assump nullable_class_type_datatype_intersect
    by blast
next
  fix f
  assume "f \<in> Field (tmod_data_field classtype name fieldtype) \<and>
    Type_Model.type (tmod_data_field classtype name fieldtype) f \<in> NonContainerType (tmod_data_field classtype name fieldtype)"
  then have "f = (classtype, name)"
    unfolding tmod_data_field_def
    by simp
  then show "upper (tmod_data_field classtype name fieldtype) f = \<^bold>1"
    unfolding upper_def tmod_data_field_def
    by simp
qed (simp_all add: tmod_data_field_def)

lemma tmod_data_field_combine_correct:
  assumes "type_model Tmod"
  assumes fieldtype_is_datatype: "fieldtype \<in> DataType"
  assumes existing_class: "classtype \<in> Class Tmod"
  assumes new_field: "(classtype, name) \<notin> Field Tmod"
  shows "type_model (tmod_combine Tmod (tmod_data_field classtype name fieldtype))"
proof (intro tmod_combine_merge_correct)
  show "type_model (tmod_data_field classtype name fieldtype)"
    using fieldtype_is_datatype
    by (fact tmod_data_field_correct)
next
  fix c
  assume "c \<in> Class (tmod_data_field classtype name fieldtype)"
  then have "c \<in> Class Tmod"
    unfolding tmod_data_field_def
    by (simp add: existing_class)
  then show "c \<notin> Enum Tmod \<and> c \<notin> UserDataType Tmod"
    using assms(1) type_model.property_class_disjoint
    by blast
next
  fix e
  assume "e \<in> Enum Tmod"
  then have "e \<noteq> classtype"
    using assms(1) existing_class type_model.property_enum_disjoint
    by blast
  then show "e \<notin> Class (tmod_data_field classtype name fieldtype) \<and> e \<notin> UserDataType (tmod_data_field classtype name fieldtype)"
    unfolding tmod_data_field_def
    by simp
next
  fix x y
  assume x_def: "x \<in> Class Tmod \<union> Enum Tmod \<union> UserDataType Tmod"
  assume "y \<in> Class (tmod_data_field classtype name fieldtype) \<union> Enum (tmod_data_field classtype name fieldtype) \<union> UserDataType (tmod_data_field classtype name fieldtype)"
  then have y_def: "y \<in> Class Tmod \<union> Enum Tmod \<union> UserDataType Tmod"
    unfolding tmod_data_field_def
    using existing_class
    by simp
  show "\<not>id_in_ns x (Identifier y)"
    using x_def y_def assms(1) type_model.property_namespace_restriction
    by blast
  show "\<not>id_in_ns y (Identifier x)"
    using x_def y_def assms(1) type_model.property_namespace_restriction
    by blast
next
  have "irrefl ((Inh Tmod)\<^sup>+)"
    using assms(1) type_model.property_inh_wellformed_trancl_irrefl
    by blast
  then show "irrefl ((Inh Tmod \<union> Inh (tmod_data_field classtype name fieldtype))\<^sup>+)"
    unfolding tmod_data_field_def
    by simp
next
  have inh_wellformed_classes: "\<And>c. c \<in> Inh (tmod_combine Tmod (tmod_data_field classtype name fieldtype)) \<Longrightarrow>
    fst c \<in> Class (tmod_combine Tmod (tmod_data_field classtype name fieldtype)) \<and> snd c \<in> Class (tmod_combine Tmod (tmod_data_field classtype name fieldtype))"
  proof
    fix c
    assume "c \<in> Inh (tmod_combine Tmod (tmod_data_field classtype name fieldtype))"
    then have c_def: "c \<in> Inh Tmod"
      unfolding tmod_combine_def tmod_data_field_def
      by simp
    have "fst c \<in> Class Tmod"
      using c_def assms(1) type_model.structure_inh_wellformed_fst_class
      by blast
    then show "fst c \<in> Class (tmod_combine Tmod (tmod_data_field classtype name fieldtype))"
      unfolding tmod_combine_def
      by simp
    have "snd c \<in> Class Tmod"
      using c_def assms(1) type_model.structure_inh_wellformed_snd_class
      by blast
    then show "snd c \<in> Class (tmod_combine Tmod (tmod_data_field classtype name fieldtype))"
      unfolding tmod_combine_def
      by simp
  qed
  fix c1 c2 A B
  assume "identity c1 A \<in> tmod_combine_prop Tmod (tmod_data_field classtype name fieldtype)"
  then have "identity c1 A \<in> Prop Tmod"
  proof (cases)
    case identity_property_tmod1
    then show ?thesis
      by blast
  next
    case identity_property_tmod2
    then show ?thesis
      unfolding tmod_data_field_def
      by simp
  next
    case identity_property_both
    then show ?thesis
      unfolding tmod_data_field_def
      by simp
  qed
  assume "identity c2 B \<in> tmod_combine_prop Tmod (tmod_data_field classtype name fieldtype)"
  then have "identity c2 B \<in> Prop Tmod"
  proof (cases)
    case identity_property_tmod1
    then show ?thesis
      by blast
  next
    case identity_property_tmod2
    then show ?thesis
      unfolding tmod_data_field_def
      by simp
  next
    case identity_property_both
    then show ?thesis
      unfolding tmod_data_field_def
      by simp
  qed
  assume c1_c2_neq: "c1 \<noteq> c2"
  assume not_extend_tmod: "\<not>\<exclamdown>c1 \<sqsubseteq>[Tmod] \<exclamdown>c2"
  assume "\<exclamdown>c1 \<sqsubseteq>[tmod_combine Tmod (tmod_data_field classtype name fieldtype)] \<exclamdown>c2"
  then have "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_rel_altdef (tmod_combine Tmod (tmod_data_field classtype name fieldtype))"
    unfolding subtype_def
    using inh_wellformed_classes subtype_rel_alt
    by blast
  then have "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_tuple ` Type (tmod_combine Tmod (tmod_data_field classtype name fieldtype)) \<union>
    subtype_conv nullable nullable ` (Inh (tmod_combine Tmod (tmod_data_field classtype name fieldtype)))\<^sup>+ \<union>
    subtype_conv proper proper ` (Inh (tmod_combine Tmod (tmod_data_field classtype name fieldtype)))\<^sup>+ \<union>
    subtype_conv proper nullable ` subtype_tuple ` Class (tmod_combine Tmod (tmod_data_field classtype name fieldtype)) \<union>
    subtype_conv proper nullable ` (Inh (tmod_combine Tmod (tmod_data_field classtype name fieldtype)))\<^sup>+"
    unfolding subtype_rel_altdef_def
    by simp
  then have "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_rel_altdef Tmod"
  proof (elim UnE)
    assume "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_tuple ` Type (tmod_combine Tmod (tmod_data_field classtype name fieldtype))"
    then have "c1 = c2"
      unfolding subtype_tuple_def
      by blast
    then show ?thesis
      using c1_c2_neq
      by blast
  next
    assume "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_conv nullable nullable ` (Inh (tmod_combine Tmod (tmod_data_field classtype name fieldtype)))\<^sup>+"
    then show ?thesis
      unfolding subtype_conv_def
      by blast
  next
    assume "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_conv proper proper ` (Inh (tmod_combine Tmod (tmod_data_field classtype name fieldtype)))\<^sup>+"
    then have "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_conv proper proper ` (Inh Tmod)\<^sup>+"
      unfolding tmod_combine_def tmod_data_field_def
      by simp
    then show ?thesis
      unfolding subtype_rel_altdef_def
      by blast
  next
    assume "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_conv proper nullable ` subtype_tuple ` Class (tmod_combine Tmod (tmod_data_field classtype name fieldtype))"
    then show ?thesis
      unfolding subtype_conv_def
      by blast
  next
    assume "(\<exclamdown>c1, \<exclamdown>c2) \<in> subtype_conv proper nullable ` (Inh (tmod_combine Tmod (tmod_data_field classtype name fieldtype)))\<^sup>+"
    then show ?thesis
      unfolding subtype_conv_def
      by blast
  qed
  then have "\<exclamdown>c1 \<sqsubseteq>[Tmod] \<exclamdown>c2"
    unfolding subtype_def
    by (simp add: assms(1) subtype_rel_alt type_model.structure_inh_wellformed_classes)
  then show "A \<subseteq> B"
    using not_extend_tmod
    by blast
qed (simp_all add: assms tmod_data_field_def)

section "Encoding of a string-typed field as edge type in GROOVE"

fun datatype_to_labdef :: "'t TypeDef \<Rightarrow> ('t list) LabDef" where
  "datatype_to_labdef TypeDef.boolean = LabDef.bool" |
  "datatype_to_labdef TypeDef.integer = LabDef.int" |
  "datatype_to_labdef TypeDef.real = LabDef.real" |
  "datatype_to_labdef TypeDef.string = LabDef.string" |
  "datatype_to_labdef _ = undefined"

fun labdef_to_datatype :: "('t list) LabDef \<Rightarrow> 't TypeDef" where
  "labdef_to_datatype LabDef.bool = TypeDef.boolean" |
  "labdef_to_datatype LabDef.int = TypeDef.integer" |
  "labdef_to_datatype LabDef.real = TypeDef.real" |
  "labdef_to_datatype LabDef.string = TypeDef.string" |
  "labdef_to_datatype _ = undefined"

definition tg_data_field_as_edge_type :: "'t Id \<Rightarrow> 't \<Rightarrow> 't TypeDef \<Rightarrow> ('t list) type_graph" where
  "tg_data_field_as_edge_type classtype name fieldtype = \<lparr>
    NT = {type (id_to_list classtype), datatype_to_labdef fieldtype},
    ET = {(type (id_to_list classtype), edge [name], datatype_to_labdef fieldtype)},
    inh = {(type (id_to_list classtype), type (id_to_list classtype)), (datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)},
    abs = {},
    mult = (\<lambda>x. if x = (type (id_to_list classtype), edge [name], datatype_to_labdef fieldtype) then (\<^bold>0..\<^emph>, \<^bold>1..\<^bold>1) else undefined),
    contains = {}
  \<rparr>"

lemma tg_data_field_as_edge_type_correct:
  assumes fieldtype_is_datatype: "fieldtype \<in> DataType"
  shows "type_graph (tg_data_field_as_edge_type classtype name fieldtype)"
proof (intro type_graph.intro)
  fix n
  assume "n \<in> NT (tg_data_field_as_edge_type classtype name fieldtype)"
  then have "n = type (id_to_list classtype) \<or> n = datatype_to_labdef fieldtype"
    unfolding tg_data_field_as_edge_type_def
    by simp
  then have "n = type (id_to_list classtype) \<or> n = bool \<or> n = int \<or> n = real \<or> n = string"
    using fieldtype_is_datatype
    unfolding DataType_def
    by fastforce
  then show "n \<in> Lab\<^sub>t \<union> Lab\<^sub>p"
    using Lab\<^sub>p_def Lab\<^sub>t.rule_type_labels
    by fastforce
next
  fix s l t
  assume "(s, l, t) \<in> ET (tg_data_field_as_edge_type classtype name fieldtype)"
  then have "(s, l, t) = (type (id_to_list classtype), edge [name], datatype_to_labdef fieldtype)"
    unfolding tg_data_field_as_edge_type_def
    by simp
  then have "s \<in> {type (id_to_list classtype), datatype_to_labdef fieldtype} \<and> l \<in> Lab\<^sub>e \<union> Lab\<^sub>f \<and> t \<in> {type (id_to_list classtype), datatype_to_labdef fieldtype}"
  proof (intro conjI)
    assume "(s, l, t) = (type (id_to_list classtype), edge [name], datatype_to_labdef fieldtype)"
    then show "l \<in> Lab\<^sub>e \<union> Lab\<^sub>f"
      using Lab\<^sub>e.rule_edge_labels
      by fastforce
  qed (simp_all)
  then show "s \<in> NT (tg_data_field_as_edge_type classtype name fieldtype) \<and> l \<in> Lab\<^sub>e \<union> Lab\<^sub>f \<and> t \<in> NT (tg_data_field_as_edge_type classtype name fieldtype)"
    unfolding tg_data_field_as_edge_type_def
    by simp
next
  show "Relation.Field (inh (tg_data_field_as_edge_type classtype name fieldtype)) = NT (tg_data_field_as_edge_type classtype name fieldtype)"
    unfolding Relation.Field_def tg_data_field_as_edge_type_def
    by simp
next
  fix e
  assume "e \<in> ET (tg_data_field_as_edge_type classtype name fieldtype)"
  then have "mult (tg_data_field_as_edge_type classtype name fieldtype) e = (\<^bold>0..\<^emph>, \<^bold>1..\<^bold>1)"
    unfolding tg_data_field_as_edge_type_def
    by simp
  then show "multiplicity_pair (mult (tg_data_field_as_edge_type classtype name fieldtype) e)"
  proof (intro multiplicity_pair.intro)
    assume mult_e_def: "mult (tg_data_field_as_edge_type classtype name fieldtype) e = (\<^bold>0..\<^emph>, \<^bold>1..\<^bold>1)"
    show "multiplicity (m_in (mult (tg_data_field_as_edge_type classtype name fieldtype) e))"
      using mult_e_def
      by (intro multiplicity.intro) (simp_all)
    show "multiplicity (m_out (mult (tg_data_field_as_edge_type classtype name fieldtype) e))"
      using mult_e_def
      by (intro multiplicity.intro) (simp_all)
  qed
next
  show "Partial_order (inh (tg_data_field_as_edge_type classtype name fieldtype))"
    unfolding tg_data_field_as_edge_type_def partial_order_on_def preorder_on_def refl_on_def antisym_def trans_def
    by simp
qed (simp_all add: tg_data_field_as_edge_type_def)

lemma tg_data_field_as_edge_type_combine_inh:
  assumes "type_graph TG"
  assumes fieldtype_is_datatype: "fieldtype \<in> DataType"
  assumes existing_node_type: "type (id_to_list classtype) \<in> NT TG"
  shows "(inh TG \<union> {(type (id_to_list classtype), type (id_to_list classtype)), (datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)})\<^sup>+ =
    inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)}"
proof
  show "(inh TG \<union> {(type (id_to_list classtype), type (id_to_list classtype)), (datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)})\<^sup>+ \<subseteq>
    inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)}"
  proof
    fix x
    assume "x \<in> (inh TG \<union> {(type (id_to_list classtype), type (id_to_list classtype)), (datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)})\<^sup>+"
    then show "x \<in> inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)}"
    proof (induct x)
      case (Pair a b)
      then show ?case
      proof (induct)
        case (base y)
        then show ?case
          using assms(1) existing_node_type type_graph.validity_inh_node
          by fastforce
      next
        case (step y z)
        then show ?case
        proof (induct "datatype_to_labdef fieldtype \<in> NT TG")
          case True
          then have ay_def: "(a, y) \<in> inh TG"
            using assms(1) type_graph.validity_inh_node
            by fastforce
          have "(y, z) \<in> inh TG"
            using True.hyps assms(1) existing_node_type step.hyps(2) type_graph.validity_inh_node
            by fastforce
          then have "(a, z) \<in> inh TG"
            using assms(1) ay_def r_r_into_trancl type_graph.validity_inh_trans
            by fastforce
          then show ?case
            by simp
        next
          case False
          show ?case
            using step.hyps(3)
          proof (elim UnE)
            assume ay_def: "(a, y) \<in> inh TG"
            then have "y \<noteq> datatype_to_labdef fieldtype"
              using False.hyps assms(1) type_graph.structure_inheritance_wellformed_second_node
              by blast
            then have "(y, z) \<in> inh TG"
              using assms(1) existing_node_type step.hyps(2) type_graph.validity_inh_node
              by fastforce
            then have "(a, z) \<in> inh TG"
              using assms(1) ay_def r_r_into_trancl type_graph.validity_inh_trans
              by fastforce
            then show ?case
              by simp
          next
            assume "(a, y) \<in> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)}"
            then have "(a, y) = (datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)"
              by simp
            then have "y = datatype_to_labdef fieldtype"
              by simp
            then have "(y, z) = (datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)"
              using False.hyps assms(1) step.hyps(2) type_graph.structure_inheritance_wellformed_first_node
              by fastforce
            then show ?case
              using step.hyps(3)
              by blast
          qed
        qed
      qed
    qed
  qed
next
  show "inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)} \<subseteq>
    (inh TG \<union> {(type (id_to_list classtype), type (id_to_list classtype)), (datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)})\<^sup>+"
    by fastforce
qed

lemma tg_data_field_as_edge_type_combine_correct:
  assumes "type_graph TG"
  assumes fieldtype_is_datatype: "fieldtype \<in> DataType"
  assumes existing_node_type: "type (id_to_list classtype) \<in> NT TG"
  assumes new_edge_type: "\<And>s l t. (s, type (id_to_list classtype)) \<in> inh TG \<or> (type (id_to_list classtype), s) \<in> inh TG \<Longrightarrow> l = edge [name] \<Longrightarrow> (s, l, t) \<notin> ET TG"
  shows "type_graph (tg_combine TG (tg_data_field_as_edge_type classtype name fieldtype))"
proof (intro tg_combine_merge_correct)
  show "type_graph (tg_data_field_as_edge_type classtype name fieldtype)"
    using fieldtype_is_datatype
    by (fact tg_data_field_as_edge_type_correct)
next
  show "ET TG \<inter> ET (tg_data_field_as_edge_type classtype name fieldtype) = {}"
    unfolding tg_data_field_as_edge_type_def
    by (simp add: assms(1) existing_node_type new_edge_type type_graph.validity_inh_node)
next
  fix l s1 t1 s2 t2
  assume e1_def: "(s1, l, t1) \<in> ET TG"
  assume e2_def: "(s2, l, t2) \<in> ET TG"
  assume "(s1, s2) \<in> (inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+ - inh TG \<or> (s2, s1) \<in> (inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+ - inh TG"
  then have src_inh: "(s1, s2) \<in> inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)} - inh TG \<or>
    (s2, s1) \<in> inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)} - inh TG"
    using assms(1) existing_node_type fieldtype_is_datatype tg_data_field_as_edge_type_combine_inh tg_data_field_as_edge_type_def type_graph.simps(3)
    by metis
  assume "(t1, t2) \<in> (inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+ \<or> (t2, t1) \<in> (inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+"
  show "s1 = s2 \<and> t1 = t2"
    using assms(1) e1_def src_inh type_graph.structure_edges_wellformed type_graph.validity_inh_node
    by fastforce
next
  fix l s1 t1 s2 t2
  assume e1_def: "(s1, l, t1) \<in> ET TG"
  assume e2_def: "(s2, l, t2) \<in> ET TG"
  assume "(s1, s2) \<in> (inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+ \<or> (s2, s1) \<in> (inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+"
  assume "(t1, t2) \<in> (inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+ - inh TG \<or> (t2, t1) \<in> (inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+ - inh TG"
  then have src_inh: "(t1, t2) \<in> inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)} - inh TG \<or> (t2, t1) \<in> inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)} - inh TG"
    using assms(1) existing_node_type fieldtype_is_datatype tg_data_field_as_edge_type_combine_inh tg_data_field_as_edge_type_def type_graph.simps(3)
    by metis
  show "s1 = s2 \<and> t1 = t2"
    using assms(1) e1_def src_inh type_graph.structure_edges_wellformed type_graph.validity_inh_node
    by fastforce
next
  fix l s1 t1 s2 t2
  assume e1_def: "(s1, l, t1) \<in> ET TG"
  assume "(s2, l, t2) \<in> ET (tg_data_field_as_edge_type classtype name fieldtype)"
  then have e2_def: "(s2, l, t2) = (type (id_to_list classtype), edge [name], datatype_to_labdef fieldtype)"
    unfolding tg_data_field_as_edge_type_def
    by simp
  then have l_def: "l = edge [name]"
    by blast
  assume "(s1, s2) \<in> (inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+ \<or> (s2, s1) \<in> (inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+"
  then have "(s1, s2) \<in> inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)} \<or> (s2, s1) \<in> inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)}"
    using assms(1) existing_node_type fieldtype_is_datatype tg_data_field_as_edge_type_combine_inh tg_data_field_as_edge_type_def type_graph.simps(3)
    by metis
  then have src_inh: "(s1, s2) \<in> inh TG \<or> (s2, s1) \<in> inh TG"
    using e2_def assms(1) existing_node_type refl_onD type_graph.structure_inheritance_wellformed type_graph.validity_inh_refl
    by fastforce
  then show "s1 = s2 \<and> t1 = t2"
    using e1_def e2_def new_edge_type
    by simp
next
  have "antisym (inh TG \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)})"
    using Un_empty_right Un_insert_right antisym_def assms(1) insert_iff pair_in_Id_conv type_graph.validity_inh_antisym
    by metis
  then show "antisym ((inh TG \<union> inh (tg_data_field_as_edge_type classtype name fieldtype))\<^sup>+)"
    using assms(1) existing_node_type fieldtype_is_datatype tg_data_field_as_edge_type_combine_inh tg_data_field_as_edge_type_def type_graph.simps(3)
    by metis
qed (simp_all add: tg_data_field_as_edge_type_def assms)

subsection "Transformation functions"

definition tmod_data_field_to_tg_data_field_as_edge_type :: "'t TypeDef \<Rightarrow> 't type_model \<Rightarrow> ('t list) type_graph" where
  "tmod_data_field_to_tg_data_field_as_edge_type fieldtype Tmod = \<lparr>
    NT = type ` id_to_list ` Class Tmod \<union> {datatype_to_labdef fieldtype},
    ET = (\<lambda>x. (type (id_to_list (fst x)), edge [(snd x)], datatype_to_labdef fieldtype)) ` Field Tmod,
    inh = (\<lambda>x. (x, x)) ` type ` id_to_list ` Class Tmod \<union> {(datatype_to_labdef fieldtype, datatype_to_labdef fieldtype)},
    abs = {},
    mult = (\<lambda>x. if x \<in> (\<lambda>x. (type (id_to_list (fst x)), edge [(snd x)], datatype_to_labdef fieldtype)) ` Field Tmod then (\<^bold>0..\<^emph>, \<^bold>1..\<^bold>1) else undefined),
    contains = {}
  \<rparr>"

lemma tmod_data_field_to_tg_data_field_as_edge_type_proj:
  shows "tmod_data_field_to_tg_data_field_as_edge_type fieldtype (tmod_data_field classtype name fieldtype) = tg_data_field_as_edge_type classtype name fieldtype"
  unfolding tmod_data_field_to_tg_data_field_as_edge_type_def tmod_data_field_def tg_data_field_as_edge_type_def
  by auto

lemma tmod_data_field_to_tg_data_field_as_edge_type_func:
  shows "tg_combine_mapping_function (tmod_data_field_to_tg_data_field_as_edge_type fieldtype) (tmod_data_field classtype name fieldtype) (tg_data_field_as_edge_type classtype name fieldtype)"
  by (intro tg_combine_mapping_function.intro)
    (auto simp add: tmod_data_field_to_tg_data_field_as_edge_type_def tmod_data_field_def tg_data_field_as_edge_type_def tmod_combine_def)

definition tg_data_field_as_edge_type_to_tmod_data_field :: "'t TypeDef \<Rightarrow> ('t list) type_graph \<Rightarrow> 't type_model" where
  "tg_data_field_as_edge_type_to_tmod_data_field fieldtype TG = \<lparr>
    Class = list_to_id ` unlabel ` {n \<in> NT TG. n \<in> Lab\<^sub>t},
    Enum = {},
    UserDataType = {},
    Field = (\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) ` ET TG,
    FieldSig = (\<lambda>x. if x \<in> (\<lambda>x. (list_to_id (unlabel (src x)), last (unlabel (lab x)))) ` ET TG then (fieldtype, \<^bold>1..\<^bold>1) else undefined),
    EnumValue = {},
    Inh = {},
    Prop = {},
    Constant = {},
    ConstType = (\<lambda>x. undefined)
  \<rparr>"

lemma tg_data_field_as_edge_type_to_tmod_data_field_proj:
  assumes fieldtype_is_datatype: "fieldtype \<in> DataType"
  shows "tg_data_field_as_edge_type_to_tmod_data_field fieldtype (tg_data_field_as_edge_type classtype name fieldtype) = tmod_data_field classtype name fieldtype"
proof-
  have "{n. (n = type (id_to_list classtype) \<or> n = datatype_to_labdef fieldtype) \<and> n \<in> Lab\<^sub>t} = {type (id_to_list classtype)}"
  proof
    show "{n. (n = LabDef.type (id_to_list classtype) \<or> n = datatype_to_labdef fieldtype) \<and> n \<in> Lab\<^sub>t} \<subseteq> {LabDef.type (id_to_list classtype)}"
    proof
      fix x
      assume "x \<in> {n. (n = type (id_to_list classtype) \<or> n = datatype_to_labdef fieldtype) \<and> n \<in> Lab\<^sub>t}"
      then show "x \<in> {type (id_to_list classtype)}"
      proof
        assume "(x = LabDef.type (id_to_list classtype) \<or> x = datatype_to_labdef fieldtype) \<and> x \<in> Lab\<^sub>t"
        then show "x \<in> {LabDef.type (id_to_list classtype)}"
          using fieldtype_is_datatype
          unfolding DataType_def
          by fastforce
      qed
    qed
  next
    show "{type (id_to_list classtype)} \<subseteq> {n. (n = type (id_to_list classtype) \<or> n = datatype_to_labdef fieldtype) \<and> n \<in> Lab\<^sub>t}"
    proof
      fix x
      assume "x \<in> {type (id_to_list classtype)}"
      then show "x \<in> {n. (n = type (id_to_list classtype) \<or> n = datatype_to_labdef fieldtype) \<and> n \<in> Lab\<^sub>t}"
        by (simp add: Lab\<^sub>t.rule_type_labels)
    qed
  qed
  then show "tg_data_field_as_edge_type_to_tmod_data_field fieldtype (tg_data_field_as_edge_type classtype name fieldtype) = tmod_data_field classtype name fieldtype"
    unfolding tg_data_field_as_edge_type_to_tmod_data_field_def tmod_data_field_def tg_data_field_as_edge_type_def
    by (simp add: id_to_list_inverse)
qed

lemma tg_data_field_as_edge_type_to_tmod_data_field_func:
  assumes fieldtype_is_datatype: "fieldtype \<in> DataType"
  shows "tmod_combine_mapping_function (tg_data_field_as_edge_type_to_tmod_data_field fieldtype) (tg_data_field_as_edge_type classtype name fieldtype) (tmod_data_field classtype name fieldtype)"
proof (intro tmod_combine_mapping_function.intro)
  show "tg_data_field_as_edge_type_to_tmod_data_field fieldtype (tg_data_field_as_edge_type classtype name fieldtype) = tmod_data_field classtype name fieldtype"
    using fieldtype_is_datatype
    by (fact tg_data_field_as_edge_type_to_tmod_data_field_proj)
next
  fix TGX
  show "Class (tg_data_field_as_edge_type_to_tmod_data_field fieldtype (tg_data_field_as_edge_type classtype name fieldtype)) \<subseteq>
    Class (tg_data_field_as_edge_type_to_tmod_data_field fieldtype (tg_combine (tg_data_field_as_edge_type classtype name fieldtype) TGX))"
  proof
    fix x
    assume "x \<in> Class (tg_data_field_as_edge_type_to_tmod_data_field fieldtype (tg_data_field_as_edge_type classtype name fieldtype))"
    then show "x \<in> Class (tg_data_field_as_edge_type_to_tmod_data_field fieldtype (tg_combine (tg_data_field_as_edge_type classtype name fieldtype) TGX))"
      unfolding tg_data_field_as_edge_type_to_tmod_data_field_def tmod_data_field_def tg_data_field_as_edge_type_def tg_combine_def
      by fastforce
  qed
qed (simp_all add: tg_data_field_as_edge_type_to_tmod_data_field_def tmod_data_field_def tg_data_field_as_edge_type_def tg_combine_def id_to_list_inverse)

end


section \<open>\isaheader{Iterators}\<close>
theory Gen_Iterator
imports Refine_Monadic.Refine_Monadic Proper_Iterator
begin
  text \<open>
    Iterators are realized by to-list functions followed by folding.
    A post-optimization step then replaces these constructions by
    real iterators.\<close>

  lemma param_it_to_list[param]: "(it_to_list,it_to_list) \<in>
    (Rs \<rightarrow> (Ra \<rightarrow> bool_rel) \<rightarrow>
    (Rb \<rightarrow> \<langle>Rb\<rangle>list_rel \<rightarrow> \<langle>Rb\<rangle>list_rel) \<rightarrow> \<langle>Rc\<rangle>list_rel \<rightarrow> Rd) \<rightarrow> Rs \<rightarrow> Rd"
    unfolding it_to_list_def[abs_def]
    by parametricity

  definition key_rel :: "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> ('k\<times>'v) \<Rightarrow> ('k\<times>'v) \<Rightarrow> bool"
    where "key_rel R a b \<equiv> R (fst a) (fst b)"

  lemma key_rel_UNIV[simp]: "key_rel (\<lambda>_ _. True) = (\<lambda>_ _. True)"
    unfolding key_rel_def[abs_def] by auto

  subsection \<open>Setup for Autoref\<close>
  text \<open>Default pattern rules for \<open>it_to_sorted_list\<close>\<close>
  definition "set_to_sorted_list R S \<equiv> it_to_sorted_list R S"

context begin interpretation autoref_syn .
  lemma set_to_sorted_list_pat[autoref_op_pat]:
    "it_to_sorted_list R S \<equiv> OP (set_to_sorted_list R) S"
    unfolding set_to_sorted_list_def[abs_def] by auto
end

  definition "map_to_sorted_list R M
    \<equiv> it_to_sorted_list (key_rel R) (map_to_set M)"
  lemma map_to_sorted_list_itype[autoref_itype]:
    "map_to_sorted_list R ::\<^sub>i \<langle>Rk,Rv\<rangle>\<^sub>ii_map \<rightarrow>\<^sub>i \<langle>\<langle>\<langle>Rk,Rv\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_list\<rangle>\<^sub>ii_nres"
    by simp

context begin interpretation autoref_syn .
  lemma map_to_sorted_list_pat[autoref_op_pat]:
    "it_to_sorted_list (key_rel R) (map_to_set M)
      \<equiv> OP (map_to_sorted_list R) M"
    "it_to_sorted_list (\<lambda>_ _. True) (map_to_set M)
      \<equiv> OP (map_to_sorted_list (\<lambda>_ _. True)) M"
    unfolding map_to_sorted_list_def[abs_def] by auto
end

  subsection \<open>Set iterators\<close>
  (*definition "is_set_to_sorted_list_deprecated ordR Rk Rs tsl \<equiv> \<forall>s s'.
    (s,s')\<in>\<langle>Rk\<rangle>Rs \<longrightarrow>
      (RETURN (tsl s),it_to_sorted_list ordR s')\<in>\<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
    *)

  definition "is_set_to_sorted_list ordR Rk Rs tsl \<equiv> \<forall>s s'.
    (s,s')\<in>\<langle>Rk\<rangle>Rs
      \<longrightarrow> ( \<exists>l'. (tsl s,l')\<in>\<langle>Rk\<rangle>list_rel
            \<and> RETURN l' \<le> it_to_sorted_list ordR s')"

  definition "is_set_to_list \<equiv> is_set_to_sorted_list (\<lambda>_ _. True)"

  lemma is_set_to_sorted_listE:
    assumes "is_set_to_sorted_list ordR Rk Rs tsl"
    assumes "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    obtains l' where "(tsl s,l')\<in>\<langle>Rk\<rangle>list_rel"
    and "RETURN l' \<le> it_to_sorted_list ordR s'"
    using assms unfolding is_set_to_sorted_list_def by blast

  (* TODO: Move *)
  lemma it_to_sorted_list_weaken:
    "R\<le>R' \<Longrightarrow> it_to_sorted_list R s \<le> it_to_sorted_list R' s"
    unfolding it_to_sorted_list_def
    by (auto intro!: sorted_wrt_mono_rel[where P=R])

  lemma set_to_list_by_set_to_sorted_list[autoref_ga_rules]:
    assumes "GEN_ALGO_tag (is_set_to_sorted_list ordR Rk Rs tsl)"
    shows "is_set_to_list Rk Rs tsl"
    using assms
    unfolding is_set_to_list_def is_set_to_sorted_list_def autoref_tag_defs
    apply (safe)
    apply (drule spec, drule spec, drule (1) mp)
    apply (elim exE conjE)
    apply (rule exI, rule conjI, assumption)
    apply (rule order_trans, assumption)
    apply (rule it_to_sorted_list_weaken)
    by blast

  definition "det_fold_set R c f \<sigma> result \<equiv>
    \<forall>l. distinct l \<and> sorted_wrt R l \<longrightarrow> foldli l c f \<sigma> = result (set l)"

  lemma det_fold_setI[intro?]:
    assumes "\<And>l. \<lbrakk>distinct l; sorted_wrt R l\<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (set l)"
    shows "det_fold_set R c f \<sigma> result"
    using assms unfolding det_fold_set_def by auto

  text \<open>Template lemma for generic algorithm using set iterator\<close>
  lemma det_fold_sorted_set:
    assumes 1: "det_fold_set ordR c' f' \<sigma>' result"
    assumes 2: "is_set_to_sorted_list ordR Rk Rs tsl"
    assumes SREF[param]: "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    assumes [param]:  "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes [param]: "(f,f')\<in>Rk \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes [param]: "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl s) c f \<sigma>, result s') \<in> R\<sigma>"
  proof -
    obtain tsl' where
      [param]: "(tsl s,tsl') \<in> \<langle>Rk\<rangle>list_rel"
      and IT: "RETURN tsl' \<le> it_to_sorted_list ordR s'"
      using 2 SREF
      by (rule is_set_to_sorted_listE)

    have "(foldli (tsl s) c f \<sigma>, foldli tsl' c' f' \<sigma>') \<in> R\<sigma>"
      by parametricity
    also have "foldli tsl' c' f' \<sigma>' = result s'"
      using 1 IT
      unfolding det_fold_set_def it_to_sorted_list_def
      by simp
    finally show ?thesis .
  qed

  lemma det_fold_set:
    assumes "det_fold_set (\<lambda>_ _. True) c' f' \<sigma>' result"
    assumes "is_set_to_list Rk Rs tsl"
    assumes "(s,s')\<in>\<langle>Rk\<rangle>Rs"
    assumes "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes "(f,f')\<in>Rk \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl s) c f \<sigma>, result s') \<in> R\<sigma>"
    using assms
    unfolding  is_set_to_list_def
    by (rule det_fold_sorted_set)

  subsection \<open>Map iterators\<close>

  text \<open>Build relation on keys\<close>

  (*definition "is_map_to_sorted_list_deprecated ordR Rk Rv Rm tsl \<equiv> \<forall>m m'.
    (m,m')\<in>\<langle>Rk,Rv\<rangle>Rm \<longrightarrow>
      (RETURN (tsl m),it_to_sorted_list (key_rel ordR) (map_to_set m'))
      \<in>\<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"*)

  definition "is_map_to_sorted_list ordR Rk Rv Rm tsl \<equiv> \<forall>m m'.
    (m,m')\<in>\<langle>Rk,Rv\<rangle>Rm \<longrightarrow> (
      \<exists>l'. (tsl m,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel
        \<and> RETURN l' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m'))"

  definition "is_map_to_list Rk Rv Rm tsl
    \<equiv> is_map_to_sorted_list (\<lambda>_ _. True) Rk Rv Rm tsl"

  lemma is_map_to_sorted_listE:
    assumes "is_map_to_sorted_list ordR Rk Rv Rm tsl"
    assumes "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    obtains l' where "(tsl m,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
    and "RETURN l' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m')"
    using assms unfolding is_map_to_sorted_list_def by blast

  lemma map_to_list_by_map_to_sorted_list[autoref_ga_rules]:
    assumes "GEN_ALGO_tag (is_map_to_sorted_list ordR Rk Rv Rm tsl)"
    shows "is_map_to_list Rk Rv Rm tsl"
    using assms
    unfolding is_map_to_list_def is_map_to_sorted_list_def autoref_tag_defs
    apply (safe)
    apply (drule spec, drule spec, drule (1) mp)
    apply (elim exE conjE)
    apply (rule exI, rule conjI, assumption)
    apply (rule order_trans, assumption)
    apply (rule it_to_sorted_list_weaken)
    unfolding key_rel_def[abs_def]
    by blast

  definition "det_fold_map R c f \<sigma> result \<equiv>
    \<forall>l. distinct (map fst l) \<and> sorted_wrt (key_rel R) l
      \<longrightarrow> foldli l c f \<sigma> = result (map_of l)"

  lemma det_fold_mapI[intro?]:
    assumes "\<And>l. \<lbrakk>distinct (map fst l); sorted_wrt (key_rel R) l\<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (map_of l)"
    shows "det_fold_map R c f \<sigma> result"
    using assms unfolding det_fold_map_def by auto

  lemma det_fold_map_aux:
    assumes 1: "\<lbrakk>distinct (map fst l); sorted_wrt (key_rel R) l \<rbrakk>
      \<Longrightarrow> foldli l c f \<sigma> = result (map_of l)"
    assumes 2: "RETURN l \<le> it_to_sorted_list (key_rel R) (map_to_set m)"
    shows "foldli l c f \<sigma> = result m"
  proof -
    from 2 have "distinct l" and "set l = map_to_set m"
      and SORTED: "sorted_wrt (key_rel R) l"
      unfolding it_to_sorted_list_def by simp_all
    hence "\<forall>(k,v)\<in>set l. \<forall>(k',v')\<in>set l. k=k' \<longrightarrow> v=v'"
      apply simp
      unfolding map_to_set_def
      apply auto
      done
    with \<open>distinct l\<close> have DF: "distinct (map fst l)"
      apply (induct l)
      apply simp
      apply force
      done
    with \<open>set l = map_to_set m\<close> have [simp]: "m = map_of l"
      by (metis map_of_map_to_set)

    from 1[OF DF SORTED] show ?thesis by simp
  qed

  text \<open>Template lemma for generic algorithm using map iterator\<close>
  lemma det_fold_sorted_map:
    assumes 1: "det_fold_map ordR c' f' \<sigma>' result"
    assumes 2: "is_map_to_sorted_list ordR Rk Rv Rm tsl"
    assumes MREF[param]: "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    assumes [param]:  "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes [param]: "(f,f')\<in>\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes [param]: "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl m) c f \<sigma>, result m') \<in> R\<sigma>"
  proof -
    obtain tsl' where
      [param]: "(tsl m,tsl') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
      and IT: "RETURN tsl' \<le> it_to_sorted_list (key_rel ordR) (map_to_set m')"
      using 2 MREF by (rule is_map_to_sorted_listE)

    have "(foldli (tsl m) c f \<sigma>, foldli tsl' c' f' \<sigma>') \<in> R\<sigma>"
      by parametricity
    also have "foldli tsl' c' f' \<sigma>' = result m'"
      using det_fold_map_aux[of tsl' ordR c' f' \<sigma>' result] 1 IT
      unfolding det_fold_map_def
      by clarsimp
    finally show ?thesis .
  qed

  lemma det_fold_map:
    assumes "det_fold_map (\<lambda>_ _. True) c' f' \<sigma>' result"
    assumes "is_map_to_list Rk Rv Rm tsl"
    assumes "(m,m')\<in>\<langle>Rk,Rv\<rangle>Rm"
    assumes "(c,c')\<in>R\<sigma>\<rightarrow>Id"
    assumes "(f,f')\<in>\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> R\<sigma> \<rightarrow> R\<sigma>"
    assumes "(\<sigma>,\<sigma>')\<in>R\<sigma>"
    shows "(foldli (tsl m) c f \<sigma>, result m') \<in> R\<sigma>"
    using assms
    unfolding is_map_to_list_def
    by (rule det_fold_sorted_map)

lemma set_to_sorted_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 11)"
  assumes TSL: "SIDE_GEN_ALGO (is_set_to_sorted_list R Rk Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), set_to_sorted_list R)
    \<in> \<langle>Rk\<rangle>Rs \<rightarrow> \<langle>\<langle>Rk\<rangle>list_rel\<rangle>nres_rel"
proof (intro fun_relI nres_relI)
  fix s s'
  assume "(s,s')\<in>\<langle>Rk\<rangle>Rs"
  with TSL obtain l' where
    R1: "(tsl s, l') \<in> \<langle>Rk\<rangle>list_rel"
      and R2: "RETURN l' \<le> set_to_sorted_list R s'"
    unfolding is_set_to_sorted_list_def set_to_sorted_list_def autoref_tag_defs
    by blast

  have "RETURN (tsl s) \<le> \<Down>(\<langle>Rk\<rangle>list_rel) (RETURN l')"
    by (rule RETURN_refine) fact
  also note R2
  finally show "RETURN (tsl s) \<le> \<Down> (\<langle>Rk\<rangle>list_rel) (set_to_sorted_list R s')" .
qed

lemma map_to_sorted_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 11)"
  assumes TSL: "SIDE_GEN_ALGO (is_map_to_sorted_list R Rk Rv Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), map_to_sorted_list R)
    \<in> \<langle>Rk,Rv\<rangle>Rs \<rightarrow> \<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"
proof (intro fun_relI nres_relI)
  fix s s'
  assume "(s,s')\<in>\<langle>Rk,Rv\<rangle>Rs"
  with TSL obtain l' where
    R1: "(tsl s, l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
      and R2: "RETURN l' \<le> map_to_sorted_list R s'"
    unfolding is_map_to_sorted_list_def map_to_sorted_list_def autoref_tag_defs
    by blast

  have "RETURN (tsl s) \<le> \<Down>(\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel) (RETURN l')"
    apply (rule RETURN_refine)
    by fact
  also note R2
  finally show
    "RETURN (tsl s) \<le> \<Down> (\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel) (map_to_sorted_list R s')" .
qed

lemma map_to_list_by_tsl[autoref_rules]:
  assumes "MINOR_PRIO_TAG (- 10)"
  assumes TSL: "SIDE_GEN_ALGO (is_map_to_list Rk Rv Rs tsl)"
  shows "(\<lambda>s. RETURN (tsl s), map_to_sorted_list (\<lambda>_ _. True))
    \<in> \<langle>Rk,Rv\<rangle>Rs \<rightarrow> \<langle>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel\<rangle>nres_rel"
  using assms(2-) unfolding is_map_to_list_def
  by (rule map_to_sorted_list_by_tsl[OF PRIO_TAGI])

(*lemma dres_it_FOREACH_it_simp[iterator_simps]:
  "dres_it_FOREACH (\<lambda>s. dRETURN (i s)) s c f \<sigma>
    = foldli (i s) (case_dres False False c) (\<lambda>x s. s \<bind> f x) (dRETURN \<sigma>)"
  unfolding dres_it_FOREACH_def
  by simp
*)

text \<open>
  TODO/FIXME:
    * Integrate mono-prover properly into solver-infrastructure,
        i.e. tag a mono-goal.
    * Tag iterators, such that, for the mono-prover, we can just convert
        a proper iterator back to its foldli-equivalent!
\<close>
lemma proper_it_mono_dres_pair:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>k v x. f k v x \<le> f' k v x"
  shows "
    it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>
    \<le> it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>" (is "?a \<le> ?b")
proof -
  from proper_itE[OF PR[THEN proper_it'D]] obtain l where
    A_FMT:
      "?a = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>"
        (is "_ = ?a'")
    and B_FMT:
      "?b = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>"
        (is "_ = ?b'")
    by metis

  from A have A': "\<And>kv x. case_prod f kv x \<le> case_prod f' kv x"
    by auto

  note A_FMT
  also have
    "?a' = foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f kv) \<sigma>"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note foldli_mono_dres[OF A']
  also have
    "foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f' kv) \<sigma> = ?b'"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note B_FMT[symmetric]
  finally show ?thesis .
qed

lemma proper_it_mono_dres_pair_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>k v x. flat_ge (f k v x) (f' k v x)"
  shows "
    flat_ge (it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>)
      (it' s (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>)"
      (is "flat_ge ?a ?b")
proof -
  from proper_itE[OF PR[THEN proper_it'D]] obtain l where
    A_FMT:
      "?a = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f k v) \<sigma>"
        (is "_ = ?a'")
    and B_FMT:
      "?b = foldli l (case_dres False False c) (\<lambda>(k,v) s. s \<bind> f' k v) \<sigma>"
        (is "_ = ?b'")
    by metis

  from A have A': "\<And>kv x. flat_ge (case_prod f kv x) (case_prod f' kv x)"
    by auto

  note A_FMT
  also have
    "?a' = foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f kv) \<sigma>"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note foldli_mono_dres_flat[OF A']
  also have
    "foldli l (case_dres False False c) (\<lambda>kv s. s \<bind> case_prod f' kv) \<sigma> = ?b'"
    apply (fo_rule fun_cong)
    apply (fo_rule arg_cong)
    by auto
  also note B_FMT[symmetric]
  finally show ?thesis .
qed

lemma proper_it_mono_dres:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. f kv x \<le> f' kv x"
  shows "
    it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>
    \<le> it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>"
  apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
  apply (erule_tac t="it' s" in ssubst)
  apply (rule foldli_mono_dres[OF A])
  done

lemma proper_it_mono_dres_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. flat_ge (f kv x) (f' kv x)"
  shows "
    flat_ge (it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>)
      (it' s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>)"
  apply (rule proper_itE[OF PR[THEN proper_it'D[where s=s]]])
  apply (erule_tac t="it' s" in ssubst)
  apply (rule foldli_mono_dres_flat[OF A])
  done

lemma pi'_dom[icf_proper_iteratorI]: "proper_it' it it'
  \<Longrightarrow> proper_it' (map_iterator_dom o it) (map_iterator_dom o it')"
  apply (rule proper_it'I)
  apply (simp add: comp_def)
  apply (rule icf_proper_iteratorI)
  apply (erule proper_it'D)
  done

lemma proper_it_mono_dres_dom:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. f kv x \<le> f' kv x"
  shows "
    (map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>
    \<le>
    (map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>"

  apply (rule proper_it_mono_dres)
  apply (rule icf_proper_iteratorI)
  by fact+

lemma proper_it_mono_dres_dom_flat:
  assumes PR: "proper_it' it it'"
  assumes A: "\<And>kv x. flat_ge (f kv x) (f' kv x)"
  shows "flat_ge
    ((map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f kv) \<sigma>)
    ((map_iterator_dom o it') s (case_dres False False c) (\<lambda>kv s. s \<bind> f' kv) \<sigma>)"
  apply (rule proper_it_mono_dres_flat)
  apply (rule icf_proper_iteratorI)
  by fact+

(* TODO/FIXME: Hack! Mono-prover should be able to find proper-iterators itself
*)
lemmas proper_it_monos =
  proper_it_mono_dres_pair proper_it_mono_dres_pair_flat
  proper_it_mono_dres proper_it_mono_dres_flat
  proper_it_mono_dres_dom proper_it_mono_dres_dom_flat

(* TODO: Conceptually, this leads to some kind of bundles:
  Each bundle has a list of processors, that are invoked for every registered
  theorem. *)

attribute_setup "proper_it" = \<open>
  Scan.succeed (Thm.declaration_attribute (fn thm => fn context =>
    let
      val mono_thms = map_filter (try (curry (RS) thm)) @{thms proper_it_monos}
      (*val mono_thms = map (fn mt => thm RS mt) @{thms proper_it_monos}*)
      val context = context
        |> Icf_Proper_Iterator.add_thm thm
        |> fold Refine_Mono_Prover.add_mono_thm mono_thms
    in
      context
    end
  ))
\<close>
  "Proper iterator declaration"

end