(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Bisim
  imports Weak_Late_Sim Strong_Late_Bisim
begin

lemma monoAux: "A \<subseteq> B \<Longrightarrow> P \<leadsto>\<^sup>^<A> Q \<longrightarrow> P \<leadsto>\<^sup>^<B> Q"
by(auto intro: Weak_Late_Sim.monotonic)

coinductive_set weakBisim :: "(pi \<times> pi) set"
where
  step: "\<lbrakk>P \<leadsto>\<^sup>^<weakBisim> Q; (Q, P) \<in> weakBisim\<rbrakk> \<Longrightarrow> (P, Q) \<in> weakBisim"
monos monoAux

abbreviation
  "weakBisimJudge" (infixr "\<approx>" 65)  where "P \<approx> Q \<equiv> (P, Q) \<in> weakBisim"

lemma weakBisimCoinductAux[case_names weakBisim, case_conclusion weakBisim step, consumes 1]:
  assumes p: "(P, Q) \<in> X"
  and step:  "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>\<^sup>^<(X \<union> weakBisim)> Q \<and> ((Q, P) \<in> X \<or> Q \<approx> P)"

  shows "P \<approx> Q"
proof -
  have aux: "X \<union> weakBisim = {(P, Q). (P, Q) \<in> X \<or> P \<approx> Q}" by blast

  from p show ?thesis
    by(coinduct, force dest: step simp add: aux)
qed

lemma weakBisimCoinduct[consumes 1, case_names cSim cSym]:
  fixes P :: pi
  and   Q :: pi

  assumes "(P, Q) \<in> X"
  and     "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>\<^sup>^<(X \<union> weakBisim)> Q"
  and     "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> (Q, P) \<in> X"

  shows "P \<approx> Q"
using assms
by(coinduct rule: weakBisimCoinductAux) auto

lemma weak_coinduct[case_names weakBisim, case_conclusion weakBisim step, consumes 1]:
  assumes p: "(P, Q) \<in> X"
  and step:  "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>\<^sup>^<X> Q \<and> (Q, P) \<in> X"

  shows "P \<approx> Q"
using p
proof(coinduct rule: weakBisimCoinductAux)
  case (weakBisim P Q)
  from step[OF this] show ?case using Weak_Late_Sim.monotonic by blast
qed

lemma weakBisimWeakCoinduct[consumes 1, case_names cSim cSym]:
  fixes P :: pi
  and   Q :: pi

  assumes "(P, Q) \<in> X"
  and     "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>\<^sup>^<X> Q"
  and     "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> (Q, P) \<in> X"

  shows "P \<approx> Q"
using assms
by(coinduct rule: weak_coinduct) auto

lemma unfoldE:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx> Q"

  shows "P \<leadsto>\<^sup>^<weakBisim> Q"
  and   "Q \<approx> P"
using assms
by(auto intro: weakBisim.cases)

lemma unfoldI:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<leadsto>\<^sup>^<weakBisim> Q"
  and     "Q \<approx> P"

  shows "P \<approx> Q"
using assms
by(auto intro: weakBisim.cases)

lemma eqvt:
  shows "eqvt weakBisim"
proof(auto simp add: eqvt_def)
  let ?X = "{x. \<exists>P Q (perm::name prm). P \<approx> Q \<and> x = (perm \<bullet> P, perm \<bullet> Q)}"
  fix P Q
  fix perm::"name prm"
  assume PBiSimQ: "P \<approx> Q"

  hence "(perm \<bullet> P, perm \<bullet> Q) \<in> ?X" by blast
  moreover have "\<And>P Q perm::name prm. \<lbrakk>P \<leadsto>\<^sup>^<weakBisim> Q\<rbrakk> \<Longrightarrow> (perm \<bullet> P) \<leadsto>\<^sup>^<?X> (perm \<bullet> Q)"
  proof -
    fix P Q
    fix perm::"name prm"
    assume "P \<leadsto>\<^sup>^<weakBisim> Q"

    moreover have "weakBisim \<subseteq> ?X"
    proof(auto)
      fix P Q
      assume "P \<approx> Q"
      moreover have "P = ([]::name prm) \<bullet> P" and "Q = ([]::name prm) \<bullet> Q" by auto
      ultimately show "\<exists>P' Q'. P' \<approx> Q' \<and> (\<exists>(perm::name prm). P = perm \<bullet> P' \<and> Q = perm \<bullet> Q')"
        by blast
    qed

    moreover have "eqvt ?X"
    proof(auto simp add: eqvt_def)
      fix P Q
      fix perm1::"name prm"
      fix perm2::"name prm"

      assume "P \<approx> Q"
      moreover have "perm1 \<bullet> perm2 \<bullet> P = (perm1 @ perm2) \<bullet> P" by(simp add: pt2[OF pt_name_inst])
      moreover have "perm1 \<bullet> perm2 \<bullet> Q = (perm1 @ perm2) \<bullet> Q" by(simp add: pt2[OF pt_name_inst])

      ultimately show "\<exists>P' Q'. P' \<approx> Q' \<and> (\<exists>(perm::name prm). perm1 \<bullet> perm2 \<bullet> P = perm \<bullet> P' \<and>
                                                              perm1 \<bullet> perm2 \<bullet> Q = perm \<bullet> Q')"
        by blast
    qed

    ultimately show "(perm \<bullet> P) \<leadsto>\<^sup>^<?X> (perm \<bullet> Q)"
      by(rule Weak_Late_Sim.eqvtI)
    qed

    ultimately show "(perm \<bullet> P) \<approx> (perm \<bullet> Q)" by(coinduct rule: weak_coinduct, blast dest: unfoldE)
qed

lemma eqvtI:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<approx> Q"

  shows "(perm \<bullet> P) \<approx> (perm \<bullet> Q)"
using assms
by(rule eqvtRelI[OF eqvt])

lemma weakBisimEqvt[simp]:
  shows "eqvt weakBisim"
by(auto simp add: eqvt_def eqvtI)

lemma strongBisimWeakBisim:
  fixes P :: pi
  and   Q :: pi

  assumes PSimQ: "P \<sim> Q"

  shows "P \<approx> Q"
proof -
  have "\<And>P Q. P \<leadsto>[bisim] Q \<Longrightarrow> P \<leadsto>\<^sup>^<(bisim \<union> weakBisim)> Q"
  proof -
    fix P Q
    assume "P \<leadsto>[bisim] Q"
    hence "P \<leadsto>\<^sup>^<bisim> Q" by(rule strongSimWeakSim)
    thus "P \<leadsto>\<^sup>^<(bisim \<union> weakBisim)> Q"
      by(blast intro: Weak_Late_Sim.monotonic)
  qed

  with PSimQ show ?thesis
    by(coinduct rule: weakBisimCoinductAux, force dest: Strong_Late_Bisim.bisimE symmetric)
qed

lemma reflexive:
  fixes P :: pi

  shows "P \<approx> P"
proof -
  have "(P, P) \<in> Id" by simp
  then show ?thesis

  proof (coinduct rule: weak_coinduct)
    case (weakBisim P Q)
    have "(P, Q) \<in> Id" by fact
    thus ?case by(auto intro: Weak_Late_Sim.reflexive)
  qed
qed

  shows "Q \<approx> P"
using assms
by(auto dest: unfoldE intro: unfoldI)

  assumes PBiSimQ: "P \<approx> Q"
  and     QBiSimR: "Q \<approx> R"

  shows "P \<approx> R"
proof -
  let ?X = "weakBisim O weakBisim"
  from assms have "(P, R) \<in> ?X" by blast
  moreover have "\<And>P Q R. \<lbrakk>Q \<leadsto>\<^sup>^<weakBisim> R; P \<approx> Q\<rbrakk> \<Longrightarrow>
                          P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> R"
  proof -
    fix P Q R
    assume PBiSimQ: "P \<approx> Q"
    assume "Q \<leadsto>\<^sup>^<weakBisim> R"
    moreover have "eqvt weakBisim" by(rule eqvt)
    moreover from eqvt have "eqvt (?X \<union> weakBisim)" by(auto simp add: eqvtTrans)
    moreover have "weakBisim O weakBisim \<subseteq> ?X \<union> weakBisim" by auto
    moreover have "\<And>P Q. P \<approx> Q \<Longrightarrow> P \<leadsto>\<^sup>^<weakBisim> Q" by(rule unfoldE)

    ultimately show "P \<leadsto>\<^sup>^<(?X \<union> weakBisim)> R" using PBiSimQ
      by(rule Weak_Late_Sim.transitive)
  qed

  ultimately show ?thesis
    apply(coinduct rule: weakBisimCoinduct, auto)
    by(blast dest: unfoldE symmetric)+
qed

lemma transitive_coinduct_weak[case_names WeakBisimEarly, case_conclusion WeakBisimEarly step, consumes 2]:
  assumes p: "(P, Q) \<in> X"
  and Eqvt: "eqvt X"
  and step: "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>\<^sup>^<(bisim O X O bisim)> Q \<and> (Q, P) \<in> X"

  shows "P \<approx> Q"
proof -
  let ?X = "bisim O X O bisim"

  have Sim: "\<And>P P' Q' Q. \<lbrakk>P \<sim> P'; P'\<leadsto>\<^sup>^<?X> Q'; Q' \<leadsto>[bisim] Q\<rbrakk> \<Longrightarrow>
                          P \<leadsto>\<^sup>^<?X> Q"
  proof -
    fix P P' Q' Q
    assume PBisimP': "P \<sim> P'"
    assume P'SimQ': "P' \<leadsto>\<^sup>^<?X> Q'"
    assume Q'SimQ: "Q' \<leadsto>[bisim] Q"

    show "P \<leadsto>\<^sup>^<?X> Q"
    proof -
      have "P' \<leadsto>\<^sup>^<?X> Q"
      proof -
        have "?X O bisim \<subseteq> ?X" by(blast intro: Strong_Late_Bisim.transitive)
        moreover from Strong_Late_Bisim.bisimEqvt Eqvt have "eqvt ?X" by blast
        ultimately show ?thesis using P'SimQ' Q'SimQ by(blast intro: strongAppend)
      qed
      moreover have "eqvt bisim" by(rule Strong_Late_Bisim.bisimEqvt)
      moreover from Strong_Late_Bisim.bisimEqvt Eqvt have "eqvt ?X" by blast
      moreover have "bisim O ?X \<subseteq> ?X" by(blast intro: Strong_Late_Bisim.transitive)
      moreover have "\<And>P Q. P \<sim> Q \<Longrightarrow> P \<leadsto>\<^sup>^<bisim> Q" by(blast dest: Strong_Late_Bisim.bisimE strongSimWeakSim)
      ultimately show ?thesis using PBisimP' by(rule Weak_Late_Sim.transitive)
    qed
  qed

  from p have "(P, Q) \<in> ?X" by(blast intro: Strong_Late_Bisim.reflexive)
  moreover from step Sim have "\<And>P Q. (P, Q) \<in> ?X \<Longrightarrow> P \<leadsto>\<^sup>^<?X> Q \<and> (Q, P) \<in> ?X"
    by(blast dest: Strong_Late_Bisim.bisimE Strong_Late_Bisim.symmetric)

  ultimately show ?thesis by(rule weak_coinduct)
qed

lemma weakBisimTransitiveCoinduct[case_names cSim cSym, consumes 2]:
  assumes p: "(P, Q) \<in> X"
  and Eqvt: "eqvt X"
  and rSim: "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> P \<leadsto>\<^sup>^<(bisim O X O bisim)> Q"
  and rSym: "\<And>P Q. (P, Q) \<in> X \<Longrightarrow> (Q, P) \<in> X"

  shows "P \<approx> Q"
using assms
by(coinduct rule: transitive_coinduct_weak) auto

end


(*

This file deals with custom getters and setters in case of custom layouts.
It also register uvals read from the table file in the theory.

The two main functions are
- generate_isa_getset_records_for_file: generates a direct and non monadic definition of custom
getters and setters by inspecting the C (monadic) definition

- local_setup_getset_lemmas which generates the get/set lemmas and prove them (similarly
to local_setup_take_put_member_case_esac_specialised_lemmas)

To show the get/set lemmas that ought to be proven, use the following snippset:
ML \<open> val lems = mk_getset_lems "variant_dargentisa.c" @{context} \<close>
ML \<open>lems  |> map (string_of_getset_lem @{context})|> map tracing\<close>

These get/set lemmas should be proven before the Take, Put, .. lemmas.

*)
theory Complements
  imports AutoCorres.AutoCorres
begin

find_theorems "UCAST(_ \<rightarrow> _) "

lemma unat_8 : "unat (x :: 8 word) < 0x80000000"
  apply(unat_arith)
  by (simp add: unat_ucast_up_simp)

lemma unat_16 : "unat (x :: 16 word) < 0x80000000"
  apply(unat_arith)
  by (simp add: unat_ucast_up_simp)

(* These lemmas seem necessary to prove some
get/set lemmas (more exactly, to prove the correspondence between
the monadic and the direct definitions of custom getter/setters).
It is added to the set of simplification lemmas.

Strangely enough, the statement "unat (x :: 8 word) < 0x80000000"
is not enough for the proof of the get/set lemma.
 *)
lemma unat_ucast_8  : "unat (UCAST(('a :: len0) \<rightarrow> 8)  x) < 0x80000000"
  by(rule unat_8)
lemma unat_ucast_16 : "unat (UCAST(('a :: len0) \<rightarrow> 16) x) < 0x80000000"
  by(rule unat_16)

(* Vincent's complements for his tactic *)

lemma index_update_eq:
  fixes f :: "'a[('b :: finite)]"
  assumes "k < CARD('b)"
  shows
  "(Arrays.update f n x.[k]) = (if n = k then x else f.[k])"
  using assms
  by simp

lemma ucast_and_distrib:
  "UCAST(('a::len) \<rightarrow> ('b::len)) (a && b) = UCAST('a \<rightarrow> 'b) a && UCAST('a \<rightarrow> 'b) b"
  unfolding ucast_def Word.bitAND_word.abs_eq uint_and
  by simp

lemma neg_disj_pos_conj_iff:
  "\<not> A \<and> (A \<or> B) \<longleftrightarrow> \<not> A \<and> B"
  by blast

lemma pos_disj_neg_conj_iff:
  "A \<or> (\<not>A \<and> B) \<longleftrightarrow> A \<or> B"
  by blast

lemma pos_disj_neg_conj_iff2:
  "A \<or> (B \<and> \<not>A) \<longleftrightarrow> A \<or> B"
  by blast

lemma posA_B_negA_iff:
  "A \<or> B \<or> \<not> A \<longleftrightarrow> True"
  by blast

lemma xANDyANDx_eq: "x && y && x = y && x"
  by (metis AND_twice word_bw_comms(1))

lemma ucast_down_shiftr_distrib:
  "LENGTH('b) \<le> LENGTH('a) \<Longrightarrow> UCAST(('a::len) \<rightarrow> ('b::len)) (a << n) = UCAST('a \<rightarrow> 'b) a << n"
  apply (simp add: ucast_def uint_shiftl word_size shiftl_int_def)
  apply (simp add: wi_bintr wi_hom_syms)
  apply (simp add: shiftl_t2n word_of_int_2p)
  done

lemma ucast_up_shiftr_distrib:
  "LENGTH('b) \<ge> LENGTH('a) \<Longrightarrow> UCAST(('a::len) \<rightarrow> ('b::len)) (a << n) = (UCAST('a \<rightarrow> 'b) a << n) && mask LENGTH('a)"
  apply (simp add: ucast_def uint_shiftl word_size shiftl_int_def)
  apply (simp add: and_mask_wi[symmetric])
  apply (simp add: wi_hom_syms)
  apply (simp add: shiftl_t2n word_of_int_2p)
  apply (simp add: semiring_normalization_rules(7))
  done

lemma max_and_word_simps:
  "\<And>a::8 word. 0xFF && a = a"
  "\<And>a::16 word. 0xFFFF && a = a"
  "\<And>a::32 word. 0xFFFFFFFF && a = a"
  "\<And>a::64 word. 0xFFFFFFFFFFFFFFFF && a = a"
  by (simp add: word_and_max_simps word_bw_comms)+

(*
Vincent's tactic.

Originally, it is designed to prove the following get/set lemmas
in the presence of variants:

1. val_rel x v \<Rightarrow> val_rel x (get_a (set_a p v))
2. get_a \<circ> set_b = get_a

It turns out that it may be working (for the second case) even when
no variants are involved.

*)
ML\<open>
(* This tactic was created using the "throw things in and see if it works" strategy.
 * Eventually, we should write something more principled. ~ v.j. / 2020-07-15
 *)
fun solve_dargent_bitwise_tac ctxt tags_distinct i =
  let
  ; val reduce_variant1 (* only *) =  @{thms if_False if_True refl index_update_eq card_bit0 card_bit1}
  ; val reduce_variant2 = tags_distinct @ @{thms disj_imp[symmetric] Inductive.imp_conj_iff
                                 neg_disj_pos_conj_iff pos_disj_neg_conj_iff}
  ; val word_distrib_simpset =
    @{thms word_bool_alg.conj_disj_distrib word_bool_alg.conj_disj_distrib2
           shiftr_over_or_dist shiftr_over_and_dist
           shiftl_over_or_dist shiftl_over_and_dist
           word_bool_alg.conj.assoc
           word_bool_alg.disj.assoc
           ucast_and_distrib ucast_or_distrib ucast_ucast_mask}
  ; val word_simps2 =
    @{thms xANDyANDx_eq and_mask2 word_size ucast_or_distrib mask_def ucast_id word_and_max_simps
           max_and_word_simps}
  ; val word_join_simps =
    @{thms word_bool_alg.conj_disj_distrib[symmetric] word_and_max_simps max_and_word_simps}
  ; val word_left_right_shift_simps =
    @{thms and_mask2 and_not_mask[symmetric] mask_def
           word_bool_alg.conj.assoc word_bool_alg.disj.assoc}
  ; val cleanup_simps =
    @{thms pos_disj_neg_conj_iff pos_disj_neg_conj_iff2 posA_B_negA_iff}
   in ((simp_tac ((clear_simpset ctxt) addsimps reduce_variant1)
        THEN' simp_tac ((clear_simpset ctxt) addsimps reduce_variant2)
        THEN' (fn i => REPEAT_DETERM (DETERM (CHANGED (
          (simp_tac ((clear_simpset ctxt) addsimps word_distrib_simpset)
          THEN' simp_tac (ctxt addsimps word_simps2)
          ) i
        ))))
        THEN' (fn i => (TRY (
          (simp_tac (ctxt addsimps word_left_right_shift_simps)
          THEN' simp_tac (ctxt addsimps word_join_simps)
          THEN' (fn i => TRY (simp_tac (ctxt addsimps cleanup_simps) i))) i
      )))) i)
  end;
fun getput_variant_tac ctxt tags_distinct =
  let val tags_cleanup =
    tags_distinct @ @{thms  if_False if_True refl disj_imp[symmetric] neg_disj_pos_conj_iff}
   in TRYALL (fn i => CHANGED (
        (simp_tac (ctxt addsimps tags_cleanup)
        THEN' solve_dargent_bitwise_tac ctxt tags_distinct) i))
  end;
\<close>

end


theory CoCallImplTTreeSafe
imports CoCallImplTTree CoCallAnalysisSpec TTreeAnalysisSpec
begin

hide_const Multiset.single

lemma valid_lists_many_calls:
  assumes "\<not> one_call_in_path x p"
  assumes "p \<in> valid_lists S G"
  shows "x--x \<in> G"
using assms(2,1)
proof(induction rule:valid_lists.induct[case_names Nil Cons])
  case Nil thus ?case by simp
next
  case (Cons xs x')
  show ?case
  proof(cases "one_call_in_path x xs")
    case False
    from Cons.IH[OF this]
    show ?thesis.
  next
    case True
    with `\<not> one_call_in_path x (x' # xs)`
    have [simp]: "x' = x" by (auto split: if_splits)

    have "x \<in> set xs"
    proof(rule ccontr)
      assume "x \<notin> set xs"
      hence "no_call_in_path x xs" by (metis no_call_in_path_set_conv)
      hence "one_call_in_path x (x # xs)" by simp
      with Cons show False by simp
    qed
    with `set xs \<subseteq> ccNeighbors x' G`
    have "x \<in> ccNeighbors x G" by auto
    thus ?thesis by simp
  qed
qed

context CoCallArityEdom
begin
 lemma carrier_Fexp': "carrier (Texp e\<cdot>a) \<subseteq> fv e"
    unfolding Texp_simp carrier_ccTTree
    by (rule Aexp_edom)

end

context CoCallAritySafe
begin

lemma carrier_AnalBinds_below:
  "carrier ((Texp.AnalBinds  \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) x) \<subseteq> edom ((ABinds \<Delta>)\<cdot>(Aheap \<Delta> e\<cdot>a))"
by (auto simp add: Texp.AnalBinds_lookup Texp_def split: option.splits
         elim!: set_mp[OF edom_mono[OF monofun_cfun_fun[OF ABind_below_ABinds]]])

sublocale TTreeAnalysisCarrier Texp
  apply standard
  unfolding Texp_simp carrier_ccTTree
  apply standard
  done

sublocale TTreeAnalysisSafe Texp
proof
  fix x e a

  from edom_mono[OF Aexp_App]
  have "{x} \<union> edom (Aexp e\<cdot>(inc\<cdot>a)) \<subseteq> edom (Aexp (App e x)\<cdot>a)" by auto
  moreover
  {
  have "ccApprox (many_calls x \<otimes>\<otimes> ccTTree (edom (Aexp e\<cdot>(inc\<cdot>a))) (ccExp e\<cdot>(inc\<cdot>a)))
    = cc_restr (edom (Aexp e\<cdot>(inc\<cdot>a))) (ccExp e\<cdot>(inc\<cdot>a)) \<squnion> ccProd {x} (insert x (edom (Aexp e\<cdot>(inc\<cdot>a))))"
    by (simp add: ccApprox_both ccProd_insert2[where S' = "edom e" for e])
  also
  have "edom (Aexp e\<cdot>(inc\<cdot>a)) \<subseteq> fv e"
    by (rule Aexp_edom)
  also(below_trans[OF eq_imp_below join_mono[OF below_refl ccProd_mono2[OF insert_mono] ]])
  have "cc_restr (edom (Aexp e\<cdot>(inc\<cdot>a))) (ccExp e\<cdot>(inc\<cdot>a)) \<sqsubseteq> ccExp e\<cdot>(inc\<cdot>a)"
    by (rule cc_restr_below_arg)
  also
  have "ccExp e\<cdot>(inc\<cdot>a) \<squnion> ccProd {x} (insert x (fv e)) \<sqsubseteq> ccExp (App e x)\<cdot>a"
    by (rule ccExp_App)
  finally
  have "ccApprox (many_calls x \<otimes>\<otimes> ccTTree (edom (Aexp e\<cdot>(inc\<cdot>a))) (ccExp e\<cdot>(inc\<cdot>a))) \<sqsubseteq> ccExp (App e x)\<cdot>a" by this simp_all
  }
  ultimately
  show "many_calls x \<otimes>\<otimes> Texp e\<cdot>(inc\<cdot>a) \<sqsubseteq> Texp (App e x)\<cdot>a"
    unfolding Texp_simp by (auto intro!: below_ccTTreeI)
next
  fix y e n
  show "without y (Texp e\<cdot>(pred\<cdot>n)) \<sqsubseteq> Texp (Lam [y]. e)\<cdot>n"
    unfolding Texp_simp
    by (auto dest: set_mp[OF Aexp_edom]
             intro!: below_ccTTreeI  below_trans[OF _ ccExp_Lam] cc_restr_mono1 set_mp[OF edom_mono[OF Aexp_Lam]])
next
  fix e y x a

  from edom_mono[OF Aexp_subst]
  have *: "edom (Aexp e[y::=x]\<cdot>a) \<subseteq> insert x (edom (Aexp e\<cdot>a) - {y})" by simp

  have "Texp e[y::=x]\<cdot>a = ccTTree (edom (Aexp e[y::=x]\<cdot>a)) (ccExp e[y::=x]\<cdot>a)"
    unfolding Texp_simp..
  also have "\<dots> \<sqsubseteq> ccTTree (insert x (edom (Aexp e\<cdot>a) - {y})) (ccExp e[y::=x]\<cdot>a)"
    by (rule ccTTree_mono1[OF *])
  also have "\<dots> \<sqsubseteq> many_calls x \<otimes>\<otimes> without x (\<dots>)"
    by (rule paths_many_calls_subset)
  also have "without x (ccTTree (insert x (edom (Aexp e\<cdot>a) - {y})) (ccExp e[y::=x]\<cdot>a))
    = ccTTree (edom (Aexp e\<cdot>a) - {y} - {x}) (ccExp e[y::=x]\<cdot>a)"
    by simp
  also have "\<dots> \<sqsubseteq> ccTTree (edom (Aexp e\<cdot>a) - {y} - {x}) (ccExp e\<cdot>a)"
    by (rule ccTTree_cong_below[OF ccExp_subst]) auto
  also have "\<dots> = without y (ccTTree (edom (Aexp e\<cdot>a) - {x}) (ccExp e\<cdot>a))"
    by simp (metis Diff_insert Diff_insert2)
  also have "ccTTree (edom (Aexp e\<cdot>a) - {x}) (ccExp e\<cdot>a) \<sqsubseteq> ccTTree (edom (Aexp e\<cdot>a)) (ccExp e\<cdot>a)"
    by (rule ccTTree_mono1) auto
  also have "\<dots> = Texp e\<cdot>a"
    unfolding Texp_simp..
  finally
  show "Texp e[y::=x]\<cdot>a \<sqsubseteq> many_calls x \<otimes>\<otimes> without y (Texp e\<cdot>a)"
    by this simp_all
next
  fix v a
  have "up\<cdot>a \<sqsubseteq> (Aexp (Var v)\<cdot>a) v" by (rule Aexp_Var)
  hence "v \<in> edom (Aexp (Var v)\<cdot>a)" by (auto simp add: edom_def)
  thus "single v \<sqsubseteq> Texp (Var v)\<cdot>a"
    unfolding Texp_simp
    by (auto intro: below_ccTTreeI)
next
  fix scrut e1 a e2
  have "ccTTree (edom (Aexp e1\<cdot>a)) (ccExp e1\<cdot>a) \<oplus>\<oplus> ccTTree (edom (Aexp e2\<cdot>a)) (ccExp e2\<cdot>a)
    \<sqsubseteq> ccTTree (edom (Aexp e1\<cdot>a) \<union> edom (Aexp e2\<cdot>a)) (ccExp e1\<cdot>a \<squnion> ccExp e2\<cdot>a)"
      by (rule either_ccTTree)
  note both_mono2'[OF this]
  also
  have "ccTTree (edom (Aexp scrut\<cdot>0)) (ccExp scrut\<cdot>0) \<otimes>\<otimes> ccTTree (edom (Aexp e1\<cdot>a) \<union> edom (Aexp e2\<cdot>a)) (ccExp e1\<cdot>a \<squnion> ccExp e2\<cdot>a)
    \<sqsubseteq> ccTTree (edom (Aexp scrut\<cdot>0) \<union> (edom (Aexp e1\<cdot>a) \<union> edom (Aexp e2\<cdot>a))) (ccExp scrut\<cdot>0 \<squnion> (ccExp e1\<cdot>a \<squnion> ccExp e2\<cdot>a) \<squnion> ccProd (edom (Aexp scrut\<cdot>0)) (edom (Aexp e1\<cdot>a) \<union> edom (Aexp e2\<cdot>a)))"
    by (rule interleave_ccTTree)
  also
  have "edom (Aexp scrut\<cdot>0) \<union> (edom (Aexp e1\<cdot>a) \<union> edom (Aexp e2\<cdot>a)) = edom (Aexp scrut\<cdot>0 \<squnion> Aexp e1\<cdot>a \<squnion> Aexp e2\<cdot>a)" by auto
  also
  have "Aexp scrut\<cdot>0 \<squnion> Aexp e1\<cdot>a \<squnion> Aexp e2\<cdot>a \<sqsubseteq> Aexp (scrut ? e1 : e2)\<cdot>a"
    by (rule Aexp_IfThenElse)
  also
  have "ccExp scrut\<cdot>0 \<squnion> (ccExp e1\<cdot>a \<squnion> ccExp e2\<cdot>a) \<squnion> ccProd (edom (Aexp scrut\<cdot>0)) (edom (Aexp e1\<cdot>a) \<union> edom (Aexp e2\<cdot>a)) \<sqsubseteq>
        ccExp (scrut ? e1 : e2)\<cdot>a"
    by (rule ccExp_IfThenElse)

  show "Texp scrut\<cdot>0 \<otimes>\<otimes> (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<sqsubseteq> Texp (scrut ? e1 : e2)\<cdot>a"
    unfolding Texp_simp
    by (auto simp add: ccApprox_both join_below_iff  below_trans[OF _ join_above2]
             intro!: below_ccTTreeI below_trans[OF cc_restr_below_arg]
                     below_trans[OF _ ccExp_IfThenElse]  set_mp[OF edom_mono[OF Aexp_IfThenElse]])
next
  fix e
  assume "isVal e"
  hence [simp]: "ccExp e\<cdot>0 = ccSquare (fv e)" by (rule ccExp_pap)
  thus "repeatable (Texp e\<cdot>0)"
    unfolding Texp_simp by (auto intro: repeatable_ccTTree_ccSquare[OF Aexp_edom])
qed

definition Theap :: "heap \<Rightarrow> exp \<Rightarrow> Arity \<rightarrow> var ttree"
  where "Theap \<Gamma> e = (\<Lambda> a. if nonrec \<Gamma> then ccTTree (edom (Aheap \<Gamma> e\<cdot>a)) (ccExp e\<cdot>a) else ttree_restr (edom (Aheap \<Gamma> e\<cdot>a)) anything)"

lemma Theap_simp: "Theap \<Gamma> e\<cdot>a = (if nonrec \<Gamma> then ccTTree (edom (Aheap \<Gamma> e\<cdot>a)) (ccExp e\<cdot>a) else ttree_restr (edom (Aheap \<Gamma> e\<cdot>a)) anything)"
  unfolding Theap_def by simp

lemma carrier_Fheap':"carrier (Theap \<Gamma> e\<cdot>a) = edom (Aheap \<Gamma> e\<cdot>a)"
    unfolding Theap_simp carrier_ccTTree by simp

sublocale TTreeAnalysisCardinalityHeap Texp Aexp Aheap Theap
proof
  fix \<Gamma> e a
  show "carrier (Theap \<Gamma> e\<cdot>a) = edom (Aheap \<Gamma> e\<cdot>a)"
    by (rule carrier_Fheap')
next
  fix x \<Gamma> p e a
  assume "x \<in> thunks \<Gamma>"

  assume "\<not> one_call_in_path x p"
  hence "x \<in> set p" by (rule more_than_one_setD)

  assume "p \<in> paths (Theap \<Gamma> e\<cdot>a)" with `x \<in> set p`
  have "x \<in> carrier (Theap \<Gamma> e\<cdot>a)" by (auto simp add: Union_paths_carrier[symmetric])
  hence "x \<in> edom (Aheap \<Gamma> e\<cdot>a)"
    unfolding Theap_simp by (auto split: if_splits)

  show "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>0"
  proof(cases "nonrec \<Gamma>")
    case False
    from False `x \<in> thunks \<Gamma>`  `x \<in> edom (Aheap \<Gamma> e\<cdot>a)`
    show ?thesis  by (rule aHeap_thunks_rec)
  next
    case True
    with `p \<in> paths (Theap \<Gamma> e\<cdot>a)`
    have "p \<in> valid_lists (edom (Aheap \<Gamma> e\<cdot>a)) (ccExp e\<cdot>a)" by (simp add: Theap_simp)

    with `\<not> one_call_in_path x p`
    have "x--x\<in> (ccExp e\<cdot>a)" by (rule valid_lists_many_calls)

    from True `x \<in> thunks \<Gamma>` this
    show ?thesis by (rule aHeap_thunks_nonrec)
  qed
next
  fix \<Delta> e a

  have carrier: "carrier (substitute (Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) \<subseteq> edom (Aheap \<Delta> e\<cdot>a) \<union> edom (Aexp (Let \<Delta> e)\<cdot>a)"
  proof(rule carrier_substitute_below)
    from edom_mono[OF Aexp_Let[of \<Delta> e a]]
    show "carrier (Texp e\<cdot>a) \<subseteq> edom (Aheap \<Delta> e\<cdot>a) \<union> edom (Aexp (Let \<Delta> e)\<cdot>a)"  by (simp add: Texp_def)
  next
    fix x
    assume "x \<in> edom (Aheap \<Delta> e\<cdot>a) \<union> edom (Aexp (Let \<Delta> e)\<cdot>a)"
    hence "x \<in> edom (Aheap \<Delta> e\<cdot>a) \<or> x : (edom (Aexp (Let \<Delta> e)\<cdot>a))" by simp
    thus "carrier ((Texp.AnalBinds  \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) x) \<subseteq> edom (Aheap \<Delta> e\<cdot>a) \<union> edom (Aexp (Let \<Delta> e)\<cdot>a)"
    proof
      assume "x \<in> edom (Aheap \<Delta> e\<cdot>a)"

      have "carrier ((Texp.AnalBinds  \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) x) \<subseteq> edom (ABinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a))"
        by (rule carrier_AnalBinds_below)
      also have "\<dots> \<subseteq> edom (Aheap \<Delta> e\<cdot>a \<squnion> Aexp (Terms.Let \<Delta> e)\<cdot>a)"
        using edom_mono[OF Aexp_Let[of \<Delta> e a]] by simp
      finally show ?thesis by simp
    next
      assume "x \<in> edom (Aexp (Terms.Let \<Delta> e)\<cdot>a)"
      hence "x \<notin> domA \<Delta>" by (auto  dest: set_mp[OF Aexp_edom])
      hence "(Texp.AnalBinds  \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) x = \<bottom>"
        by (rule Texp.AnalBinds_not_there)
      thus ?thesis by simp
    qed
  qed

  show "ttree_restr (- domA \<Delta>) (substitute (Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) \<sqsubseteq> Texp (Let \<Delta> e)\<cdot>a"
  proof (rule below_trans[OF _ eq_imp_below[OF Texp_simp[symmetric]]], rule below_ccTTreeI)
    have "carrier (ttree_restr (- domA \<Delta>) (substitute (Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)))
       = carrier (substitute (Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) - domA \<Delta>" by auto
    also note carrier
    also have "edom (Aheap \<Delta> e\<cdot>a) \<union> edom (Aexp (Terms.Let \<Delta> e)\<cdot>a) - domA \<Delta> = edom (Aexp (Let \<Delta> e)\<cdot>a)"
      by (auto dest: set_mp[OF edom_Aheap] set_mp[OF Aexp_edom])
    finally
    show "carrier (ttree_restr (- domA \<Delta>) (substitute (Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>)(Texp e\<cdot>a)))
          \<subseteq> edom (Aexp (Terms.Let \<Delta> e)\<cdot>a)" by this auto
  next
    let ?x = "ccApprox (ttree_restr (- domA \<Delta>) (substitute (Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)))"

    have "?x = cc_restr (- domA \<Delta>) ?x"  by simp
    also have "\<dots> \<sqsubseteq> cc_restr (- domA \<Delta>) (ccHeap \<Delta> e\<cdot>a)"
    proof(rule cc_restr_mono2[OF wild_recursion_thunked])
      have "ccExp e\<cdot>a \<sqsubseteq> ccHeap \<Delta> e\<cdot>a" by (rule ccHeap_Exp)
      thus "ccApprox (Texp e\<cdot>a) \<sqsubseteq> ccHeap \<Delta> e\<cdot>a"
        by (auto simp add: Texp_simp intro: below_trans[OF cc_restr_below_arg])
    next
      fix x
      assume "x \<notin> domA \<Delta>"
      thus "(Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) x = empty"
        by (metis Texp.AnalBinds_not_there empty_is_bottom)
    next
      fix x
      assume "x \<in> domA \<Delta>"
      then obtain e' where e': "map_of \<Delta> x = Some e'" by (metis domA_map_of_Some_the)

      show "ccApprox ((Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) x) \<sqsubseteq> ccHeap \<Delta> e\<cdot>a"
      proof(cases "(Aheap \<Delta> e\<cdot>a) x")
        case bottom thus ?thesis using e' by (simp add: Texp.AnalBinds_lookup)
      next
        case (up a')
        with e'
        have "ccExp e'\<cdot>a' \<sqsubseteq> ccHeap \<Delta> e\<cdot>a" by (rule ccHeap_Heap)
        thus ?thesis using up e'
          by (auto simp add: Texp.AnalBinds_lookup Texp_simp  intro: below_trans[OF cc_restr_below_arg])
      qed

      show "ccProd (ccNeighbors x (ccHeap \<Delta> e\<cdot>a)- {x} \<inter> thunks \<Delta>) (carrier ((Texp.AnalBinds  \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) x)) \<sqsubseteq> ccHeap \<Delta> e\<cdot>a"
      proof(cases "(Aheap \<Delta> e\<cdot>a) x")
        case bottom thus ?thesis using e' by (simp add: Texp.AnalBinds_lookup)
      next
        case (up a')
        have subset: "(carrier (fup\<cdot>(Texp e')\<cdot>((Aheap \<Delta> e\<cdot>a) x))) \<subseteq> fv e'"
          using up e' by (auto simp add: Texp.AnalBinds_lookup carrier_Fexp dest!: set_mp[OF Aexp_edom])

        from e' up
        have "ccProd (fv e') (ccNeighbors x (ccHeap \<Delta> e\<cdot>a) - {x} \<inter> thunks \<Delta>) \<sqsubseteq> ccHeap \<Delta> e\<cdot>a"
          by (rule ccHeap_Extra_Edges)
        then
        show ?thesis using e'
          by (simp add: Texp.AnalBinds_lookup  Texp_simp ccProd_comm  below_trans[OF ccProd_mono2[OF subset]])
      qed
    qed
    also have "\<dots> \<sqsubseteq> ccExp (Let \<Delta> e)\<cdot>a"
      by (rule ccExp_Let)
    finally
    show "ccApprox (ttree_restr (- domA \<Delta>) (substitute (Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)))
        \<sqsubseteq> ccExp (Terms.Let \<Delta> e)\<cdot>a" by this simp_all
  qed

  note carrier
  hence "carrier (substitute (ExpAnalysis.AnalBinds Texp \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) \<subseteq> edom (Aheap \<Delta> e\<cdot>a) \<union> - domA \<Delta>"
    by (rule order_trans) (auto dest: set_mp[OF Aexp_edom])
  hence "ttree_restr (domA \<Delta>)            (substitute (Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a))
      = ttree_restr (edom (Aheap \<Delta> e\<cdot>a)) (ttree_restr (domA \<Delta>) (substitute (Texp.AnalBinds  \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)))"
    by -(rule ttree_restr_noop[symmetric], auto)
  also
  have "\<dots> = ttree_restr (edom (Aheap \<Delta> e\<cdot>a)) (substitute (Texp.AnalBinds  \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a))"
    by (simp add: inf.absorb2[OF edom_Aheap ])
  also
  have "\<dots> \<sqsubseteq> Theap \<Delta> e \<cdot>a"
  proof(cases "nonrec \<Delta>")
    case False
    have "ttree_restr (edom (Aheap \<Delta> e\<cdot>a)) (substitute (Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a))
      \<sqsubseteq> ttree_restr (edom (Aheap \<Delta> e\<cdot>a)) anything"
      by (rule ttree_restr_mono) simp
    also have "\<dots> = Theap \<Delta> e\<cdot>a"
      by (simp add: Theap_simp False)
    finally show ?thesis.
  next
    case [simp]: True

    from True
    have "ttree_restr (edom (Aheap \<Delta> e\<cdot>a)) (substitute (Texp.AnalBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a))
       = ttree_restr (edom (Aheap \<Delta> e\<cdot>a)) (Texp e\<cdot>a)"
      by (rule nonrecE) (rule ttree_rest_substitute, auto simp add: carrier_Fexp fv_def fresh_def dest!: set_mp[OF edom_Aheap] set_mp[OF Aexp_edom])
    also have "\<dots> = ccTTree (edom (Aexp e\<cdot>a) \<inter> edom (Aheap \<Delta> e\<cdot>a)) (ccExp e\<cdot>a)"
      by (simp add: Texp_simp)
    also have "\<dots> \<sqsubseteq> ccTTree (edom (Aexp e\<cdot>a) \<inter> domA \<Delta>) (ccExp e\<cdot>a)"
      by (rule ccTTree_mono1[OF Int_mono[OF order_refl edom_Aheap]])
    also have "\<dots> \<sqsubseteq> ccTTree (edom (Aheap \<Delta> e\<cdot>a)) (ccExp e\<cdot>a)"
      by (rule ccTTree_mono1[OF edom_mono[OF Aheap_nonrec[OF True], simplified]])
    also have "\<dots> \<sqsubseteq> Theap \<Delta> e\<cdot>a"
      by (simp add: Theap_simp)
    finally
    show ?thesis by this simp_all
  qed
  finally
  show "ttree_restr (domA \<Delta>) (substitute (ExpAnalysis.AnalBinds Texp \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) \<sqsubseteq> Theap \<Delta> e\<cdot>a".

qed
end

(* TODO: Unused stuff from here, mostly about singles. Might be useful later. *)

lemma paths_singles: "xs \<in> paths (singles S) \<longleftrightarrow> (\<forall>x \<in> S. one_call_in_path x xs)"
  by transfer (auto simp add: one_call_in_path_filter_conv)

lemma paths_singles': "xs \<in> paths (singles S) \<longleftrightarrow> (\<forall>x \<in> (set xs \<inter> S). one_call_in_path x xs)"
  apply transfer
  apply (auto simp add: one_call_in_path_filter_conv)
  apply (erule_tac x = x in ballE)
  apply auto
  by (metis (poly_guards_query) filter_empty_conv le0 length_0_conv)

lemma both_below_singles1:
  assumes "t \<sqsubseteq> singles S"
  assumes "carrier t' \<inter> S = {}"
  shows "t \<otimes>\<otimes> t' \<sqsubseteq> singles S"
proof (rule ttree_belowI)
  fix xs
  assume "xs \<in> paths (t \<otimes>\<otimes> t')"
  then obtain ys zs where "ys \<in> paths t" and "zs \<in> paths t'" and "xs \<in> ys \<otimes> zs" by (auto simp add: paths_both)
  with assms
  have "ys \<in> paths (singles S)" and "set zs \<inter> S = {}"
    by (metis below_ttree.rep_eq contra_subsetD paths.rep_eq, auto simp add: Union_paths_carrier[symmetric])
  with `xs \<in> ys \<otimes> zs`
  show "xs \<in> paths (singles S)"
    by (induction) (auto simp add: paths_singles no_call_in_path_set_conv interleave_set dest: more_than_one_setD split: if_splits)
qed

lemma paths_ttree_restr_singles: "xs \<in> paths (ttree_restr S' (singles S)) \<longleftrightarrow> set xs \<subseteq> S' \<and> (\<forall>x \<in> S. one_call_in_path x xs)"
proof
  show "xs \<in> paths (ttree_restr S' (singles S)) \<Longrightarrow>  set xs \<subseteq> S' \<and> (\<forall>x \<in> S. one_call_in_path x xs)"
    by (auto simp add: filter_paths_conv_free_restr[symmetric] paths_singles)
next
  assume *: "set xs \<subseteq> S' \<and> (\<forall>x\<in>S. one_call_in_path x xs)"
  hence "set xs \<subseteq> S'" by auto
  hence [simp]: "filter (\<lambda> x'. x' \<in> S') xs = xs" by (auto simp add: filter_id_conv)

  from *
  have "xs \<in> paths (singles S)"
     by (auto simp add: paths_singles')
  hence "filter (\<lambda> x'. x' \<in> S') xs \<in> filter (\<lambda>x'. x' \<in> S') ` paths (singles S)"
    by (rule imageI)
  thus "xs \<in> paths (ttree_restr S' (singles S))"
    by (auto simp add: filter_paths_conv_free_restr[symmetric] )
qed

(* TODO: unused *)
lemma substitute_not_carrier:
  assumes "x \<notin> carrier t"
  assumes "\<And> x'. x \<notin> carrier (f x')"
  shows "x \<notin>  carrier (substitute f T t)"
proof-
  have "ttree_restr ({x}) (substitute f T t) = ttree_restr ({x}) t"
  proof(rule ttree_rest_substitute)
    fix x'
    from `x \<notin> carrier (f x')`
    show "carrier (f x') \<inter> {x} = {}" by auto
  qed
  hence "x \<notin> carrier (ttree_restr ({x}) (substitute f T t)) \<longleftrightarrow> x \<notin> carrier (ttree_restr ({x}) t)" by metis
  with assms(1)
  show ?thesis by simp
qed

(* TODO: unused *)
lemma substitute_below_singlesI:
  assumes "t \<sqsubseteq> singles S"
  assumes "\<And> x. carrier (f x) \<inter> S = {}"
  shows "substitute f T t \<sqsubseteq> singles S"
proof(rule ttree_belowI)
  fix xs
  assume "xs \<in> paths (substitute f T t)"
  thus "xs \<in> paths (singles S)"
  using assms
  proof(induction f T t xs arbitrary: S rule: substitute_induct)
    case Nil
    thus ?case by simp
  next
    case (Cons f T t x xs)

    from `x#xs \<in> _`
    have xs: "xs \<in> paths (substitute (f_nxt f T x) T (nxt t x \<otimes>\<otimes> f x))" by auto
    moreover

    from `t \<sqsubseteq> singles S`
    have "nxt t x \<sqsubseteq> singles S"
      by (metis "TTree-HOLCF.nxt_mono" below_trans nxt_singles_below_singles)
    from this `carrier (f x) \<inter> S = {}`
    have "nxt t x \<otimes>\<otimes> f x \<sqsubseteq> singles S"
      by (rule both_below_singles1)
    moreover
    { fix x'
      from  `carrier (f x') \<inter> S = {}`
      have "carrier (f_nxt f T x x') \<inter> S = {}"
        by (auto simp add: f_nxt_def)
    }
    ultimately
    have IH: "xs \<in> paths (singles S)"
      by (rule Cons.IH)

  show ?case
    proof(cases "x \<in> S")
      case True
      with `carrier (f x) \<inter> S = {}`
      have "x \<notin> carrier (f x)" by auto
      moreover
      from `t \<sqsubseteq> singles S`
      have "nxt t x \<sqsubseteq> nxt (singles S) x" by (rule nxt_mono)
      hence "carrier (nxt t x) \<subseteq> carrier (nxt (singles S) x)" by (rule carrier_mono)
      from set_mp[OF this] True
      have "x \<notin> carrier (nxt t x)" by auto
      ultimately
      have "x \<notin> carrier (nxt t x \<otimes>\<otimes> f x)" by simp
      hence "x \<notin> carrier (substitute (f_nxt f T x) T (nxt t x \<otimes>\<otimes> f x))"
      proof(rule substitute_not_carrier)
        fix x'
        from `carrier (f x') \<inter> S = {}` `x \<in> S`
        show "x \<notin> carrier (f_nxt f T x x')" by (auto simp add: f_nxt_def)
      qed
      with xs
      have "x \<notin> set xs" by (auto simp add: Union_paths_carrier[symmetric])
      with IH
      have "xs \<in> paths (without x (singles S))" by (rule paths_withoutI)
      thus ?thesis using True by (simp add: Cons_path)
    next
      case False
      with IH
      show ?thesis by (simp add: Cons_path)
    qed
  qed
qed

end


(*  File:       Profile_List_Monadic.thy
    Copyright   2023  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Valentin Springsklee, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Refined Profile Evaluation\<close>

theory Profile_List_Monadic
  imports "Verified_Voting_Rule_Construction.Profile"
    "Verified_Voting_Rule_Construction.Profile_List"
    Ballot_Refinement

begin

subsection \<open>Profile Evaluation on List-based Profiles \<close>

fun win_count_l :: "'a Profile_List \<Rightarrow> 'a \<Rightarrow> nat" where
  "win_count_l p a = fold (\<lambda>x ac.
     if (0 < length x \<and> x!0 = a) then (ac+1) else (ac)) p 0"

fun prefer_count_l :: "'a Profile_List \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat" where
  "prefer_count_l p a b = fold (\<lambda> x ac. (if (b \<lesssim>\<^sub>x a) then (ac+1) else (ac))) p 0"

fun wins_l :: "'a \<Rightarrow> 'a Profile_List \<Rightarrow> 'a \<Rightarrow> bool" where
  "wins_l x p y =
    (prefer_count_l p x y > prefer_count_l p y x)"

fun condorcet_winner_l :: "'a set \<Rightarrow> 'a Profile_List \<Rightarrow> 'a \<Rightarrow> bool" where
  "condorcet_winner_l A p w =
      (finite A \<and> profile_l A p \<and>  w \<in> A \<and> (\<forall> x \<in> A - {w} . wins_l w p x))"

subsection \<open> Monadic definition of profile functions \<close>

lemma w_eq_param [sepref_import_param]: "((=), (=)::'a\<Rightarrow>_) \<in> Id \<rightarrow> Id \<rightarrow> Id" by simp

definition "index_mon_inv ballot a \<equiv> (\<lambda> (i, found).
    (i \<le> List_Index.index ballot a)
  \<and> (found \<longrightarrow> (i = List_Index.index ballot a)))"
(*  \<and> (\<not>found \<longrightarrow> (i \<le> List_Index.index ballot a)))"*)

(* low level optimization for pref count *)
definition index_mon :: "'a::{default, heap, hashable} Preference_List
  \<Rightarrow> 'a::{default, heap, hashable}
   \<Rightarrow> nat nres" where
  "index_mon ballot a \<equiv> do {
    (i, found) \<leftarrow> WHILET
  (\<lambda>(i, found). (i < (length ballot) \<and> \<not>found))
      (\<lambda>(i,_). do {
      ASSERT (i < (length ballot));
      let (c::'a::{default, heap, hashable}) = (ballot ! i);
      if (a = c) then
        RETURN (i,True)
      else
        RETURN (i+1,False)
    })(0::nat, False);
    RETURN (i)
  }"

sepref_definition index_sep is "uncurry index_mon" ::
  "(arl_assn id_assn)\<^sup>k *\<^sub>a (id_assn)\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  unfolding index_mon_def
  apply sepref_dbg_keep
  done

sepref_register index_mon

declare index_sep.refine[sepref_fr_rules]

lemma isl1_measure: "wf (measure (\<lambda>(i, found). length ballot - i - (if found then 1 else 0)))"
  by simp

lemma index_sound:
  fixes a:: 'a and l :: "'a list" and i::nat
  assumes  "i \<le> List_Index.index l a"
  shows "(a = l!i) \<longrightarrow> (i = List_Index.index l a)"
  by (metis assms(1) index_first le_eq_less_or_eq)

lemma index_mon_correct:
  shows "index_mon ballot a \<le> SPEC (\<lambda> r. r = index ballot a)"
  unfolding index_mon_def
  apply (intro WHILET_rule[where I= "index_mon_inv ballot a" and R="measure (\<lambda>(i, found). length ballot - i - (if found then 1 else 0))"] refine_vcg)
proof (unfold index_mon_inv_def, simp+, safe, auto)
  fix aa::nat
  assume bound: "aa \<le> List_Index.index ballot (ballot ! aa)"
  (*assume range : "aa < length ballot"*)
  thus "aa = List_Index.index ballot (ballot ! aa)" by (simp add: index_sound)
next
  fix i
  assume notnow: "a \<noteq> ballot ! i"
  assume notyet: "i \<le> List_Index.index ballot a"
  assume ir: "i < length ballot"
  from notnow have "i \<noteq> List_Index.index ballot a"
    by (metis index_eq_iff ir)
  from notyet this show "Suc i \<le> List_Index.index ballot a"
    by fastforce
next
  assume ir: "List_Index.index ballot a < length ballot"
  assume na: "a \<noteq> ballot ! index ballot a"
  from ir have "a = ballot ! List_Index.index ballot a"
    by (metis index_eq_iff)
  from this na show "False" by simp
next
  fix aa
  assume "aa \<le> List_Index.index ballot a"
    and "aa \<noteq> List_Index.index ballot a"
  thus "aa < length ballot"
    by (metis antisym index_le_size le_neq_implies_less order_trans)
qed

(* TODO: move to IICF Array List *)

lemma index_mon_impl:
  shows "(index_mon, mop_list_index) \<in> \<langle>Id\<rangle>list_rel \<rightarrow> Id \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
  apply (intro fun_relI nres_relI)
  apply clarsimp
  apply (refine_vcg index_mon_correct) by simp

lemma arl_index_nc_correct: "(uncurry index_sep, uncurry mop_list_index)
    \<in> (arl_assn id_assn)\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
  using index_sep.refine[FCOMP index_mon_impl]
list_rel_id hr_comp_Id2
  by metis

(*sepref_decl_impl (ismop) arl_index: arl_index_nc_correct .*)

definition rank_mon :: "'a::{default, heap, hashable} Preference_List
  \<Rightarrow> 'a::{default, heap, hashable} \<Rightarrow> nat nres" where
  "rank_mon ballot a \<equiv> do {
    i \<leftarrow> (index_mon ballot a);
    if (i = length ballot) then RETURN 0 else RETURN (i + 1)
  }"

lemma rank_mon_correct: "rank_mon ballot a \<le> SPEC (\<lambda> r. r = rank_l ballot a)"
  unfolding rank_mon_def
proof (refine_vcg, auto)
  assume mem: "a \<in> set ballot"
  from this have "List_Index.index ballot a \<noteq> length ballot"
    by (simp add: in_set_member index_size_conv)
  from this show "index_mon ballot a \<le> SPEC (\<lambda>i. i = List_Index.index ballot a \<and> i \<noteq> length ballot)"
    using index_mon_correct
    by (metis (mono_tags, lifting) SPEC_cons_rule)
next
  assume nmem: "\<not>a \<in> set ballot"
  from this have "List_Index.index ballot a = length ballot"
    by (simp add: in_set_member)
  from this show "index_mon ballot a \<le> RES {length ballot}"
    using index_mon_correct
    by (metis singleton_conv)
qed

lemma rank_mon_refine:
  shows "(rank_mon, (\<lambda> ballot a. RETURN (rank_l ballot a)))\<in> Id \<rightarrow> Id \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
  by (refine_vcg rank_mon_correct, simp)

definition is_less_preferred_than_ref ::
  "'a::{default, heap, hashable} \<Rightarrow> 'a Preference_List
  \<Rightarrow> 'a
   \<Rightarrow> bool nres" ("_ p\<lesssim>\<^sub>_ _" [50, 1000, 51] 50) where
    "x p\<lesssim>\<^sub>l y \<equiv>  do {
        idxx \<leftarrow> index_mon l x;
        idxy \<leftarrow> index_mon l y;
        RETURN (idxx \<noteq> length l \<and> idxy \<noteq> length l \<and>  idxx \<ge> idxy)}"

lemma is_less_preferred_than_ref_refine:
  shows "(is_less_preferred_than_ref,
      RETURN ooo  is_less_preferred_than_l) \<in> Id \<rightarrow> \<langle>Id\<rangle>list_rel \<rightarrow> Id \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
  unfolding is_less_preferred_than_ref_def is_less_preferred_than_l.simps
  unfolding comp_apply
  by (refine_vcg index_mon_correct, auto)

sepref_definition is_less_preferred_than_sep
  is "uncurry2 is_less_preferred_than_ref" ::
    "(id_assn\<^sup>k *\<^sub>a (ballot_impl_assn id_assn)\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn)"
  unfolding is_less_preferred_than_ref_def[abs_def]
  apply sepref_dbg_keep
  done

sepref_register is_less_preferred_than_ref

declare is_less_preferred_than_sep.refine [sepref_fr_rules]

lemmas is_less_preferred_than_sep_correct =
    is_less_preferred_than_sep.refine[FCOMP is_less_preferred_than_ref_refine]

text \<open>
  win-count, multiple refinement steps
\<close>

definition "wc_invar_fe p0 a \<equiv> \<lambda>(xs,ac).
  xs = drop (length p0 - length xs) p0 \<and>
  ac = card {i. i < (length p0 - length xs) \<and> above (p0!i) a = {a}}"

definition wc_foreach:: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat nres" where
"wc_foreach p a \<equiv> do {
  (xs,ac) \<leftarrow> WHILEIT (wc_invar_fe p a) (FOREACH_cond (\<lambda>_.True))
    (FOREACH_body (\<lambda>x (ac).
     if (above x a = {a}) then RETURN (ac+1) else RETURN (ac)
    )) (p,0);
  RETURN ac
}"

lemma wc_foreach_correct:
  shows "wc_foreach p a \<le> SPEC (\<lambda> wc. wc = win_count p a)"
  unfolding wc_foreach_def wc_invar_fe_def
  FOREACH_cond_def FOREACH_body_def
  apply (intro WHILEIT_rule[where R="measure (\<lambda>(xs,_). length xs)"]  refine_vcg)
  apply (safe, simp_all)
  apply (metis append_Nil diff_le_self drop_Suc drop_all drop_append length_drop tl_drop)
proof (-)
  fix xs:: "'a Profile"
  assume headr: "xs = drop (length p - length xs) p"
  assume pnemp: "xs \<noteq> []"
  from pnemp headr have hdidx: "hd xs = (p!(length p - length xs))"
    by (metis drop_eq_Nil hd_drop_conv_nth linorder_not_le)
  assume atop: "above (hd xs) a = {a}"
  from hdidx this have aba: "above (p!(length p - length xs)) a = {a}" by simp
  from this aba have comp: "{i. i \<le> (length p) - length xs \<and> above (p ! i) a = {a}}
        = ({i. i < length p - length xs \<and> above (p ! i) a = {a}} \<union>
          {(length p - length xs)})"
    by fastforce
  from headr have "{i. i \<le> (length p) - length xs \<and> above (p ! i) a = {a}}
        = {i. i < Suc (length p) - length xs \<and> above (p ! i) a = {a}}"
    by (metis Suc_diff_le diff_le_self length_drop less_Suc_eq_le)
  from this comp have "{i. i < Suc (length p) - length xs \<and> above (p ! i) a = {a}}
        = ({i. i < length p - length xs \<and> above (p ! i) a = {a}} \<union>
          {(length p - length xs)})" by simp
  from this show
         "Suc (card {i. i < (length p) - length xs \<and> above (p ! i) a = {a}}) =
        card {i. i < Suc (length p) - length xs \<and> above (p ! i) a = {a}}"
    by fastforce
next
  fix xs:: "'a Profile"
  fix alt:: "'a"
  assume headr: "xs = drop (length p - length xs) p"
  show "tl xs = drop (Suc (length p) - length xs) p"
    by (metis Suc_diff_le diff_le_self drop_Suc headr length_drop tl_drop)
next
  fix xs:: "'a Profile"
  fix alt:: "'a"
  assume headr: "xs = drop (length p - length xs) p"
  assume pnemp: "xs \<noteq> []"
  from pnemp headr have hdidx: "hd xs = (p!(length p - length xs))"
    by (metis drop_eq_Nil hd_drop_conv_nth linorder_not_le)
  assume xtop: "alt \<in>  above (hd xs) a"
  assume xna: "alt \<noteq> a"
  from hdidx headr xna xtop show
         "card {i. i < (length p) - length xs \<and> above (p ! i) a = {a}} =
        card {i. i < Suc (length p) - length xs \<and> above (p ! i) a = {a}}"
  by (metis  Suc_diff_le diff_le_self insert_absorb insert_iff insert_not_empty length_drop less_Suc_eq )
next
    fix xs:: "'a Profile"
  fix alt:: "'a"
  assume headr: "xs = drop (length p - length xs) p"
  from headr show "tl xs = drop (Suc (length p) - length xs) p"
    by (metis Suc_diff_le diff_le_self drop_Suc length_drop tl_drop)
next
    fix xs:: "'a Profile"
  fix alt:: "'a"
  assume headr: "xs = drop (length p - length xs) p"
  assume pnemp: "xs \<noteq> []"
  from pnemp headr have hdidx: "hd xs = (p!(length p - length xs))"
    by (metis drop_eq_Nil hd_drop_conv_nth linorder_not_le)
  assume xtop: "a \<notin>  above (hd xs) a"
  from hdidx this have aba: "above (p!(length p - length xs)) a \<noteq> {a}"
    by fastforce
  from this show
         "card {i. i < (length p) - length xs \<and> above (p ! i) a = {a}} =
        card {i. i < Suc (length p) - length xs \<and> above (p ! i) a = {a}}"
    by (metis Suc_diff_le diff_le_self headr length_drop less_Suc_eq)
qed

schematic_goal wc_code_aux: "RETURN ?wc_code \<le> wc_foreach p a"
  unfolding wc_foreach_def FOREACH_body_def FOREACH_cond_def
  by (refine_transfer)

concrete_definition win_count_code for p a uses wc_code_aux

thm win_count_code_def

lemma win_count_equiv:
  shows "win_count p a = win_count_code p a"
proof -
  from order_trans[OF win_count_code.refine wc_foreach_correct]
    have "win_count_code p a = win_count p a"
      by fastforce
  thus ?thesis by simp
qed

lemma carde: assumes prof: "profile A p"
  shows "\<forall>ballot \<in> set p. (rank ballot a = 1) = (above ballot a = {a})"
  using prof
  by (metis above_rank profile_set)

lemma cardei: assumes prof: "profile A p"
  shows "\<forall>i < length p. let ballot=(p!i) in ((rank ballot a = 1) = (above ballot a = {a}))"
  using prof
  by (metis carde nth_mem)

definition "f_inner_rel a \<equiv> (\<lambda>(x::'a Preference_Relation) (ac::nat).
     (if (rank x a = 1) then RETURN (ac+1) else RETURN (ac)
    ))"

definition wc_foreach_rank:: "'a Profile \<Rightarrow> 'a \<Rightarrow> nat nres" where
"wc_foreach_rank p a \<equiv> do {
  (xs,ac) \<leftarrow> WHILET (FOREACH_cond (\<lambda>_.True))
    (FOREACH_body (f_inner_rel a)) (p,0::nat);
  RETURN ac
}"

lemma wc_foreach_rank_refine:
  assumes prof: "profile A p"
  shows "wc_foreach_rank p a \<le> \<Down> nat_rel (wc_foreach p a)"
  unfolding wc_foreach_rank_def wc_foreach_def wc_invar_fe_def FOREACH_body_def FOREACH_cond_def
    f_inner_rel_def
  apply (refine_vcg)
    apply (refine_dref_type) \<comment> \<open>Type-based heuristics to instantiate data
    refinement goals\<close>
proof (clarsimp_all simp del: rank.simps)
  fix x1:: "'a Profile"
  assume x1ne: "x1 \<noteq> []"
  assume rest: "x1 = drop (length p - length x1) p"
  from x1ne rest show "(rank (hd x1) a = Suc 0) = (above (hd x1) a = {a})" using carde
    by (metis One_nat_def in_set_dropD list.set_sel(1) prof rank.simps)
qed

lemma rank_refaux:
  assumes prof: "profile A p"
  shows "wc_foreach_rank p a \<le> (wc_foreach p a)"
  using prof wc_foreach_rank_refine
  by (metis refine_IdD)

theorem wc_foreach_rank_correct:
  assumes prof: "profile A p"
  shows "wc_foreach_rank p a \<le> SPEC (\<lambda> wc. wc = win_count p a)"
  using assms ref_two_step[OF wc_foreach_rank_refine wc_foreach_correct]
  by fastforce

subsubsection \<open> Data refinement \<close>

text \<open> these auxiliary lemmas illustrate the equivalence of checking the the first
  candidate on a non empty ballot. \<close>
lemma top_above:
  assumes ne: "length pl > 0"
  shows "pl!0 = a \<longleftrightarrow> above_l pl a = [a]"
  unfolding above_l_def
proof (simp add: rankdef, safe)
  assume mem: "pl ! 0 \<in> set pl"
  assume "a = pl ! 0"
  have "List_Index.index pl (pl ! 0) = 0"
    by (simp add: index_eqI)
  from mem this show "take (Suc (List_Index.index pl (pl ! 0))) pl = [pl ! 0]"
    by (metis append_Nil index_less_size_conv take0 take_Suc_conv_app_nth)
next
  (*assume mem: "List.member pl a"*)
  assume "take (Suc (List_Index.index pl a)) pl = [a]"
  from this show "pl ! 0 = a"
    by (metis append_Cons append_Nil append_take_drop_id hd_conv_nth list.sel(1))
next
  assume nm: "\<not> pl ! 0 \<in> set pl"
  from this have pl_empty: "pl = []"
    by (metis length_greater_0_conv nth_mem)
  from ne this pl_empty show "False"
    by simp
qed

lemma top_l_above_r:
  assumes ballot: "ballot_on A pl"
  and ne: "length pl > 0"
  shows "pl!0 = a \<longleftrightarrow> above (pl_\<alpha> pl) a = {a}"
proof -
  from ne have listeq: "pl!0 = a \<longleftrightarrow> above_l pl a = [a]"
    by (simp add: top_above)
  from assms have above_abstract: "set (above_l pl a) = above (pl_\<alpha> pl) a"
    by (auto simp add: aboveeq)
  have list_set: "above_l pl a = [a] \<longleftrightarrow> set (above_l pl a) = {a}"
    by (metis above_l_def append_self_conv2 gr0I hd_take id_take_nth_drop insert_not_empty list.sel(1) list.set(1) list.set_sel(1) list.simps(15) listeq ne singleton_iff take_eq_Nil)
  from above_abstract listeq this show ?thesis
    by (simp)
qed

definition "f_inner_list a \<equiv> (\<lambda>x ac::nat.
     (if (rank_l x a = 1) then RETURN (ac+1) else RETURN (ac)))"

definition "wc_list_invar p0 a \<equiv> \<lambda>(i,ac::nat).
  0 \<le> i \<and> i \<le> length p0"

definition "wc_list_invar' p0 a \<equiv> \<lambda>(xs,ac).
  xs = drop (length p0 - length xs) p0"

lemma innerf_eq:
  fixes A:: "'a set"  and l :: "'a Preference_List" and a :: 'a
  assumes "(l,r) \<in> ballot_rel"
  shows "f_inner_list a l n \<le> \<Down> nat_rel (f_inner_rel a r n)"
  unfolding f_inner_list_def f_inner_rel_def
  apply (refine_vcg)
  using assms rankeq unfolding ballot_rel_def
  by (metis in_br_conv)

lemma foreachrel:
  assumes "(pl, pr) \<in> profile_rel" and "pl \<noteq> []"
  shows "(hd pl, hd pr) \<in> (ballot_rel) \<and>
  (tl pl, tl pr) \<in> (profile_rel)"
  using assms
  by (metis list.collapse list_rel_simp(2) list_rel_simp(4))

definition wc_foreach_list_rank :: "'a Profile_List \<Rightarrow> 'a \<Rightarrow> nat nres" where
"wc_foreach_list_rank pl a \<equiv> do {
  (xs,ac) \<leftarrow> WHILET (FOREACH_cond (\<lambda>_.True))
    (FOREACH_body (f_inner_list a)) (pl,0::nat);
  RETURN ac
}"

lemma initrel:
  fixes A:: "'a set"
  assumes "(pl, pr) \<in> profile_rel"
  shows "((pl,0::nat), pr , 0::nat) \<in> ((profile_rel \<times>\<^sub>r nat_rel))"
  using assms
  by simp

lemma wc_foreach_list_rank_refine:
  fixes A:: "'a set"
  shows "(wc_foreach_list_rank, wc_foreach_rank) \<in>
  profile_rel \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding wc_foreach_list_rank_def wc_foreach_rank_def
  FOREACH_cond_def FOREACH_body_def
  apply (refine_vcg initrel)
     apply (simp add: initrel)
  apply refine_dref_type
     apply (simp add: refine_rel_defs)
     apply blast
  apply clarsimp_all
  using innerf_eq unfolding ballot_rel_def
  apply (metis param_hd refine_IdD)
  using foreachrel unfolding ballot_rel_def   by (metis)

lemma win_count_list_r_refine_os:
  fixes A:: "'a set"
  assumes "(pl, pr) \<in> (profile_rel)"
  shows "wc_foreach_list_rank pl a \<le> \<Down> Id (wc_foreach_rank pr a)"
  unfolding wc_foreach_list_rank_def wc_foreach_rank_def
  FOREACH_cond_def FOREACH_body_def
  using assms apply (refine_vcg wc_foreach_list_rank_refine initrel)
  apply (simp_all only: refine_rel_defs pl_to_pr_\<alpha>_def)
  apply refine_dref_type
     apply (clarsimp_all, safe)
  using innerf_eq unfolding ballot_rel_def
   apply (metis (mono_tags, lifting) brI list.rel_sel refine_IdD)
  using foreachrel
  using list.rel_sel by blast

lemma wc_foreach_list_rank_correct:
  assumes "(pl, pr) \<in> profile_rel" and "profile_l A pl"
  shows "wc_foreach_list_rank pl a \<le> SPEC (\<lambda> wc. wc = win_count pr a)"
proof (-)
  from assms have "profile A pr" using profile_ref
    by (metis)
  from assms(1) this
  show "wc_foreach_list_rank pl a \<le> (SPEC (\<lambda>wc. wc = win_count pr a))"
  using ref_two_step[OF win_count_list_r_refine_os wc_foreach_rank_correct] refine_IdD
  by (metis)
qed

lemma top_rank1:
  assumes ballot: "ballot_on A ballot" and "length ballot > 0"
  shows "ballot!0 = a \<longleftrightarrow> rank_l ballot a = 1"
  using assms
  apply clarsimp
  apply safe
    apply (simp add: index_eq_iff)
   apply (metis nth_index)
  by simp

definition wc_foreach_top:: "'a Profile_List \<Rightarrow> 'a \<Rightarrow> nat nres" where
"wc_foreach_top p  a \<equiv> do {
  (xs::'a Profile_List,ac) \<leftarrow> WHILET (FOREACH_cond (\<lambda>_.True))
    (FOREACH_body (\<lambda>x (ac).
     if ((length x > 0) \<and> (x!0 = a)) then RETURN (ac+1) else RETURN (ac)
    )) (p,0);
  RETURN ac
}"

lemma wc_foreach_top_refine_os:
  fixes A:: "'a set"
  shows "wc_foreach_top pl a \<le> \<Down> Id (wc_foreach_list_rank pl a)"
  unfolding wc_foreach_list_rank_def f_inner_list_def wc_foreach_top_def
  FOREACH_cond_def FOREACH_body_def
  apply (refine_vcg wc_foreach_list_rank_refine initrel)
  apply (simp_all only: refine_rel_defs pl_to_pr_\<alpha>_def)
  apply refine_dref_type
  apply auto
   apply (metis gr0I index_first)
  by (metis index_eq_iff length_pos_if_in_set)

lemma wc_foreach_top_correct:
  assumes "(pl, pr) \<in> profile_rel" and "profile_l A pl"
  shows "wc_foreach_top pl a \<le> SPEC (\<lambda> wc. wc = win_count pr a)"
  using assms ref_two_step[OF wc_foreach_top_refine_os wc_foreach_list_rank_correct] refine_IdD
  by (metis)

definition wc_fold:: "'a Profile_List \<Rightarrow> 'a \<Rightarrow> nat nres"
  where "wc_fold l a \<equiv>
   nfoldli l (\<lambda>_. True)
    (\<lambda>x (ac).
     RETURN (if ((length x > 0) \<and> (x!0 = a))then (ac+1) else  (ac))
    )
    (0)"

lemma wc_fold_refine:
  shows "wc_fold pl a \<le> \<Down> Id (wc_foreach_top pl a)"
  unfolding wc_fold_def wc_foreach_top_def
  by (simp add: nfoldli_mono(1) while_eq_nfoldli)

theorem wc_fold_correct:
  assumes "(pl, pr) \<in> profile_rel" and "profile_l A pl"
  shows "wc_fold pl a \<le> SPEC (\<lambda> wc. wc = win_count pr a)"
  using assms ref_two_step[OF wc_fold_refine wc_foreach_top_correct] refine_IdD
  by (metis)

lemma nfwcc: "nofail (wc_fold p a)"
  unfolding wc_fold_def
  apply (induction p rule: rev_induct, simp)
   apply simp
  by (simp add: pw_bind_nofail)

lemma win_count_l_correct:
  shows "(win_count_l, win_count)
    \<in> (profile_on_A_rel A) \<rightarrow> Id \<rightarrow> nat_rel"
  apply (auto simp del: win_count_l.simps win_count.simps)
  apply (rename_tac pl pr)
proof (standard, rename_tac a)
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  fix a:: 'a
  assume prel: "(pl, pr) \<in> (profile_on_A_rel A)"
  from prel have profrel: "(pl, pr) \<in> profile_rel" using profile_type_ref by fastforce
  from prel have profprop: "profile_l A pl" using profile_prop_list by fastforce
  have  "RETURN (win_count_l pl a) = (wc_fold pl a)"
  unfolding  wc_fold_def win_count_l.simps
  using fold_eq_nfoldli[where l = pl and f = "(\<lambda>x ac. if (0 < length x \<and> x ! 0 = a)
       then ac + 1 else ac)" and s = 0]
  by fastforce
  from this profrel profprop have meq: "RETURN (win_count_l pl a) = RETURN (win_count pr a)"
  using wc_fold_correct[where pl=pl and pr = pr and A = A and a = a]
    by (metis mem_Collect_eq nres_order_simps(21))
  from meq show "win_count_l pl a = win_count pr a"
    by simp
qed

text \<open>
  pref count
\<close>

definition pc_foldli:: "'a Profile \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat nres" where
"pc_foldli p a b \<equiv>
 nfoldli p (\<lambda>_.True)
     (\<lambda>x (ac).
     if (b \<preceq>\<^sub>x a) then RETURN (ac+1) else RETURN (ac)
    ) (0::nat)"

lemma pc_foldli_correct:
  shows "pc_foldli p a b \<le> SPEC (\<lambda> wc. wc = prefer_count p a b)"
  unfolding pc_foldli_def
  apply (intro nfoldli_rule[where I="\<lambda> proc xs ac.
    ac = card {i::nat. i < length proc \<and> (let r = (p!i) in (b \<preceq>\<^sub>r a))}"]  refine_vcg)
proof (clarsimp_all)
  fix l1:: "'a Profile"
  fix l2:: "'a Profile"
  fix x:: "'a Preference_Relation"
  assume "p = l1 @ x # l2"
  assume blpa: "(b, a) \<in> x"
  have pnemp: "l1 @ x # l2 \<noteq> []" by simp
  have xatl1: "(l1 @ x # l2) ! (length l1) = x"
    by simp
  from xatl1 blpa have stone: "{i. i \<le>(length l1) \<and> (b, a) \<in> (l1 @ x # l2) ! i}
        = {i. i < length l1 \<and> (b, a) \<in> (l1 @ x # l2) ! i} \<union>
        {length l1}"
    by fastforce
  from this have "{i. i < Suc (length l1) \<and> (b, a) \<in> (l1 @ x # l2) ! i} =
  ({i. i < length l1 \<and> (b, a) \<in> (l1 @ x # l2) ! i} \<union> {length l1})"
    using less_Suc_eq_le
    by blast
  from this show "Suc(card {i. i < length l1 \<and> (b, a) \<in> (l1 @ x # l2) ! i}) =
      card {i. i < Suc (length l1) \<and> (b, a) \<in> (l1 @ x # l2) ! i}"
    by fastforce
next
  fix l1:: "'a Profile"
  fix l2:: "'a Profile"
  fix x:: "'a Preference_Relation"
  assume "p = l1 @ x # l2"
  assume blpa: "(b, a) \<notin> x"
  have pnemp: "l1 @ x # l2 \<noteq> []" by simp
  have xatl1: "(l1 @ x # l2) ! (length l1) = x"
    by simp
  from xatl1 blpa have stone: "{i. i < Suc (length l1) \<and> (b, a) \<in> (l1 @ x # l2) ! i}
        = {i. i < length l1 \<and> (b, a) \<in> (l1 @ x # l2) ! i}"
    using less_Suc_eq_le order_le_less by blast
  thus "card {i. i < length l1 \<and> (b, a) \<in> (l1 @ x # l2) ! i} =
       card {i. i < Suc (length l1) \<and> (b, a) \<in> (l1 @ x # l2) ! i}"
    by fastforce
qed

definition pc_foldli_list:: "'a Profile_List \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat nres" where
"pc_foldli_list p a b \<equiv>
  nfoldli p (\<lambda>_.True)
      (\<lambda> x ac. RETURN  (if (b \<lesssim>\<^sub>x a) then (ac+1) else (ac)))
     (0::nat)"

lemma pc_fold_monad_eq:
  shows "RETURN (prefer_count_l p a b) = pc_foldli_list p a b"
  unfolding  pc_foldli_list_def
  using fold_eq_nfoldli
  by fastforce

lemma pc_foldli_list_refine:
  shows "(pc_foldli_list, pc_foldli)
    \<in> profile_rel \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
  unfolding   ballot_rel_def
  apply (auto simp del : is_less_preferred_than.simps)
  apply (rename_tac pl pr a b)
  unfolding pc_foldli_list_def pc_foldli_def
  apply (refine_vcg nfoldli_rule)
  apply (auto simp del : is_less_preferred_than_l.simps is_less_preferred_than.simps)
  apply (rename_tac l r)
  apply (metis in_br_conv is_less_preferred_than_eq)+
  done

lemma pc_foldli_list_correct:
  shows "(pc_foldli_list, (\<lambda> p a b. SPEC (\<lambda> wc. wc = prefer_count p a b)))
    \<in> profile_rel \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
  apply(refine_vcg)
  apply (clarsimp_all simp del: prefer_count.simps)
  apply (rename_tac pl pr a b)
proof -
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  fix a :: 'a
  fix b :: 'a
  assume profr: "(pl, pr) \<in> profile_rel"
  note ref_two_step[OF pc_foldli_list_refine[THEN fun_relD, THEN fun_relD,
          THEN fun_relD, THEN nres_relD]
            pc_foldli_correct, where x5 = pl and p1=pr and x4 = a and a1 = a
             and x3 = b and b1 = b]
refine_IdD
  from profr this show "pc_foldli_list pl a b \<le> RES {prefer_count pr a b}"
    by fastforce
qed

definition prefer_count_monadic_imp:: "'a::{default, heap, hashable} Profile_List
  \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> nat nres" where
"prefer_count_monadic_imp p a b \<equiv>
  nfoldli p (\<lambda>_.True) (\<lambda> x ac.
  do {
    b_less_a \<leftarrow> is_less_preferred_than_ref b x a;
    RETURN  (if b_less_a then (ac+1) else (ac))
  }) (0::nat)"

lemma prefer_count_monadic_imp_refine:
  shows "(prefer_count_monadic_imp, pc_foldli_list)
\<in> \<langle>\<langle>Id\<rangle>list_rel\<rangle>list_rel \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
  unfolding prefer_count_monadic_imp_def pc_foldli_list_def
  apply (refine_vcg is_less_preferred_than_ref_refine)
  apply (refine_dref_type)
    apply (auto simp del : is_less_preferred_than_l.simps)
proof (rename_tac b a l)
  fix a b :: 'a
  fix l :: "'a Preference_List"
  assume alpb: "a \<lesssim>\<^sub>l b"
  note iq = is_less_preferred_than_ref_refine[THEN fun_relD,THEN fun_relD,THEN fun_relD,
        THEN nres_relD]
  from alpb iq[where x3= a and x'3 =a and x2 = l and x'2 =l and x1 =b and x'1 =b]
    show "(a p\<lesssim>\<^sub>l b) \<le> SPEC (\<lambda>b_less_a. b_less_a)"
      using conc_trans_additional(6) by fastforce
  next
    fix a b :: 'a
  fix l :: "'a Preference_List"
  assume alpb: "\<not> a \<lesssim>\<^sub>l b"
  note iq = is_less_preferred_than_ref_refine[THEN fun_relD,THEN fun_relD,THEN fun_relD,
        THEN nres_relD]
  from alpb iq[where x3= a and x'3 =a and x2 = l and x'2 =l and x1 =b and x'1 =b]
  show "(a p\<lesssim>\<^sub>l b) \<le> SPEC (Not)"
    using conc_trans_additional(6) by fastforce
  qed

theorem prefer_count_monadic_imp_correct:
  assumes "(pl, pr) \<in> profile_rel"
  shows "prefer_count_monadic_imp pl a b \<le> SPEC (\<lambda> pc. pc = prefer_count pr a b)"
  using assms(1) ref_two_step[OF prefer_count_monadic_imp_refine [THEN fun_relD,THEN fun_relD,THEN fun_relD,THEN nres_relD]
      pc_foldli_list_correct[THEN fun_relD,THEN fun_relD,THEN fun_relD,THEN nres_relD,THEN refine_IdD],
      where x10 = pl and x5 = pl and x'5 = pr] refine_IdD
  by (metis list_rel_id IdI)

lemma prefer_count_monadic_correct_rel:
  shows "(prefer_count_monadic_imp, RETURN ooo prefer_count)
    \<in> profile_rel \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
proof (refine_vcg, clarify, unfold comp_apply, (clarsimp simp del: prefer_count.simps),
    rename_tac pl pr a b)
  fix a b :: "'a"
  fix pr :: "'a Profile"
  fix pl :: "'a Profile_List"
  assume prel: "(pl, pr) \<in> profile_rel"
  then show "prefer_count_monadic_imp pl a b \<le> RETURN (prefer_count pr a b) "
  using   ref_two_step[OF prefer_count_monadic_imp_refine [THEN fun_relD,THEN fun_relD,THEN fun_relD,THEN nres_relD]
      pc_foldli_list_correct[THEN fun_relD,THEN fun_relD,THEN fun_relD,THEN nres_relD,THEN refine_IdD]]
  IdI
  unfolding SPEC_eq_is_RETURN(2)
  by fastforce
qed

sepref_definition prefer_count_sep is
  "uncurry2 prefer_count_monadic_imp" :: "(profile_impl_assn id_assn)\<^sup>k *\<^sub>a id_assn\<^sup>k  *\<^sub>a id_assn\<^sup>k
    \<rightarrow>\<^sub>a nat_assn"
  unfolding prefer_count_monadic_imp_def
  apply sepref_dbg_keep
  done

sepref_register prefer_count_monadic_imp

declare prefer_count_sep.refine [sepref_fr_rules]

definition wins_monadic :: "'a::{default, heap, hashable}
   \<Rightarrow> 'a Profile_List \<Rightarrow> 'a \<Rightarrow> bool nres" where
  "wins_monadic x p y \<equiv> do {
    pxy \<leftarrow> prefer_count_monadic_imp p x y;
    pyx \<leftarrow> prefer_count_monadic_imp p y x;
    RETURN (pxy > pyx)
}"

lemma prefer_count_l_correct:
  shows "(prefer_count_l, prefer_count)
    \<in> profile_rel \<rightarrow> Id \<rightarrow> Id \<rightarrow> nat_rel"
  apply (auto simp del: prefer_count_l.simps prefer_count.simps)
  apply (rename_tac pl pr)
proof (standard, standard, rename_tac a b)
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  fix a:: 'a and b:: 'a
  assume "(pl, pr) \<in> profile_rel"
  from this have meq: "RETURN (prefer_count_l pl a b) = RETURN (prefer_count pr a b)"
    using pc_fold_monad_eq[where p = pl and a=a and b=b]
        pc_foldli_list_correct[THEN fun_relD,THEN fun_relD,THEN fun_relD,THEN nres_relD,
        where x3 = pl and x'3=pr and x2 = a and x'2 = a
             and x1 = b and x'1 = b]
    by (metis (full_types) RETURN_ref_SPECD pair_in_Id_conv)
  from meq show "prefer_count_l pl a b = prefer_count pr a b"
    by simp
qed

lemma prefer_count_l_eq:
  fixes pl :: "'a Profile_List"
  fixes pr :: "'a Profile"
  assumes prel: "(pl, pr) \<in> profile_rel"
  shows "prefer_count_l pl a b = prefer_count pr a b"
  using prefer_count_l_correct[THEN fun_relD, THEN fun_relD, THEN fun_relD,
      where x2 = pl and x'2 = pr and x1 = a and x'1 = a and x = b and x' = b]
  assms by auto

lemma prefer_count_monadic_imp_ref_l:
  shows "(prefer_count_monadic_imp, RETURN ooo prefer_count_l)
    \<in>  \<langle>\<langle>Id\<rangle>list_rel\<rangle>list_rel \<rightarrow> Id \<rightarrow> Id \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
proof (clarsimp simp del: prefer_count_l.simps, rename_tac pl a b,
    refine_vcg, unfold conc_fun_RETURN[symmetric], rule refine_IdI)
  fix pl :: "'a Profile_List"
  fix a:: 'a and b:: 'a
  note pcr = prefer_count_monadic_imp_refine[THEN fun_relD,THEN fun_relD,THEN fun_relD,
      THEN nres_relD, THEN refine_IdD]
  pc_fold_monad_eq[symmetric]
  from this show "prefer_count_monadic_imp pl a b \<le> RETURN (prefer_count_l pl a b)"
    using IdI list_rel_id by (metis)
qed

lemma imp_direct_ref:
  fixes pl :: "'a::{default, heap, hashable} Profile_List"
  fixes a b :: "'a::{default,  heap, hashable}"
  shows"prefer_count_monadic_imp pl a b \<le> RETURN (prefer_count_l pl a b)"
proof -
  have "(pl, pl) \<in> \<langle>\<langle>Id\<rangle>list_rel\<rangle>list_rel" using list_rel_id IdI by simp
  thus ?thesis
  using prefer_count_monadic_imp_ref_l[THEN fun_relD, THEN fun_relD, THEN fun_relD
      ,THEN nres_relD, THEN refine_IdD] IdI unfolding comp_def
  by metis
qed

lemma wins_monadic_correct:
  shows "(wins_monadic, (\<lambda> A p a. SPEC (\<lambda> is_win. is_win = wins A p a))) \<in> Id \<rightarrow> profile_rel \<rightarrow> Id \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
  unfolding wins_monadic_def wins.simps
  apply (clarsimp simp del: prefer_count.simps)
  apply (refine_vcg prefer_count_monadic_imp_correct)
  by (auto)

sepref_definition wins_imp is "uncurry2 wins_monadic" ::
  "(nat_assn\<^sup>k *\<^sub>a (profile_impl_assn id_assn)\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn )"
  unfolding wins_monadic_def
  apply sepref_dbg_keep
  done

lemma wins_l_correct:
  shows "(wins_l, wins)
    \<in> Id \<rightarrow> profile_rel \<rightarrow> Id \<rightarrow> bool_rel"
  apply(refine_vcg)
proof (clarsimp simp del: prefer_count_l.simps prefer_count.simps, rename_tac a pl pr b, safe)
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  fix a:: 'a and b:: 'a
  assume a1: "(pl, pr) \<in> profile_rel"
  assume a2: "prefer_count_l pl b a < prefer_count_l pl a b"
  note eq = prefer_count_l_correct[THEN fun_relD,THEN fun_relD,THEN fun_relD,
        where x2= pl and x'2=pr]
  from eq a1 have "\<forall> alt1 alt2. prefer_count_l pl alt1 alt2 = prefer_count pr alt1 alt2 "
    by blast
  from a2 this show  "prefer_count pr b a < prefer_count pr a b"
    by fastforce
next
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  fix a:: 'a and b:: 'a
  assume a1: "(pl, pr) \<in> profile_rel"
  assume a2: "prefer_count pr b a < prefer_count pr a b"
  note eq = prefer_count_l_correct[THEN fun_relD,THEN fun_relD,THEN fun_relD,
        where x2= pl and x'2=pr]
  from eq a1 have "\<forall> alt1 alt2. prefer_count_l pl alt1 alt2 = prefer_count pr alt1 alt2 "
    by blast
  from a2 this show  "prefer_count_l pl b a < prefer_count_l pl a b"
    by fastforce
qed

lemma wins_monadic_refine:
  shows "(wins_monadic, RETURN ooo wins_l) \<in> Id \<rightarrow> \<langle>\<langle>Id\<rangle>list_rel\<rangle>list_rel \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
  unfolding wins_monadic_def wins_l.simps
proof (clarsimp simp del: prefer_count_l.simps, rule nres_relI, rule refine_IdI,
   refine_vcg , unfold SPEC_eq_is_RETURN(1), rename_tac a pl b )
  fix pl :: "'a Profile_List"
  fix a:: 'a and b:: 'a
  note pcab = imp_direct_ref[where pl = pl and a = a and b = b]
  note pcba = imp_direct_ref[where pl = pl and a = b and b = a]
  have "prefer_count_monadic_imp pl a b
       \<le> SPEC (\<lambda>pab. pab = prefer_count_l pl a b)"
    using pcab SPEC_eq_is_RETURN(2)[symmetric, where y = "prefer_count_l pl a b"]
    by metis
  from this pcab pcba show "prefer_count_monadic_imp pl a b
       \<le> SPEC (\<lambda>pxy. prefer_count_monadic_imp pl b a \<bind> (\<lambda>pyx. RETURN (pyx < pxy))
                      \<le> RETURN (prefer_count_l pl b a < prefer_count_l pl a b))"
    using bind_rule SPEC_cons_rule SPEC_eq_is_RETURN(1)
    by (smt (z3)  order_eq_refl specify_left)
qed

lemma condorcet_winner_l_correct:
  shows "(condorcet_winner_l, condorcet_winner)
    \<in> \<langle>Id\<rangle>set_rel \<rightarrow> profile_rel \<rightarrow> Id \<rightarrow> bool_rel"
  apply (refine_vcg)
  apply (clarsimp simp del : wins_l.simps wins.simps)
proof (rename_tac A pl pr alt, safe)
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  fix A:: "'a set" and alt:: 'a
  assume a1: "(pl, pr) \<in> profile_rel"
  assume a2: "profile_l A pl"
  note winc = wins_l_correct[unfolded fref_def, THEN fun_relD, THEN fun_relD,THEN fun_relD,
      where x2 = alt and x'2 = alt and x1 = pl and x'1 = pr]
  note profr = profile_ref
  from a1 a2 profr show "(profile A pr)"
    by metis
next
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  fix A:: "'a set" and alt:: 'a
  fix con:: 'a
  assume a1: "(pl, pr) \<in> profile_rel"
  assume a2: "con \<in> A"
  assume a3: "\<not> wins alt pr con"
  assume altwins: "\<forall>x\<in>A - {alt}. wins_l alt pl x"
  note winc = wins_l_correct[unfolded fref_def, THEN fun_relD, THEN fun_relD,THEN fun_relD,
      where x2 = alt and x'2 = alt and x1 = pl and x'1 = pr]
  from a1 a3 winc have "\<not> wins_l alt pl con" by blast
  from altwins a2 this show "con = alt" by blast
next
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  fix A:: "'a set" and alt:: 'a
  assume a1: "(pl, pr) \<in> profile_rel"
  assume a2: "profile A pr"
  note winc = wins_l_correct[unfolded fref_def, THEN fun_relD, THEN fun_relD,THEN fun_relD,
      where x2 = alt and x'2 = alt and x1 = pl and x'1 = pr]
  note profr = profile_ref
  from a1 a2 profr show "(profile_l A pl)"
    by blast
next
  fix pl :: "'a Profile_List"
  fix pr :: "'a Profile"
  fix A:: "'a set" and alt:: 'a
  fix con:: 'a
  assume a1: "(pl, pr) \<in> profile_rel"
  assume a2: "con \<in> A"
  assume a3: "\<not> wins_l alt pl con"
  assume altwins: "\<forall>x\<in>A - {alt}. wins alt pr x"
  note winc = wins_l_correct[THEN fun_relD, THEN fun_relD,THEN fun_relD,
      where x2 = alt and x'2 = alt and x1 = pl and x'1 = pr]
  from a1 a3 winc have "\<not> wins alt pr con" by blast
  from altwins a2 this show "con = alt" by blast
qed

definition condorcet_winner_monadic :: "'a::{default, heap, hashable} set
  \<Rightarrow> 'a Profile_List \<Rightarrow> 'a \<Rightarrow> bool nres" where
  "condorcet_winner_monadic A p w \<equiv>
    if (w \<in> A) then
    FOREACHc A (\<lambda> sigma. sigma = True)
     (\<lambda> x b. do {
     winswx \<leftarrow> wins_monadic w p x;
      RETURN (if (x = w) then True
      else ((winswx)))
    }) (True)
    else RETURN False"

sepref_definition cond_imp is "uncurry2 condorcet_winner_monadic"
  :: "(alts_set_impl_assn id_assn)\<^sup>k *\<^sub>a (profile_impl_assn id_assn)\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn"
  unfolding condorcet_winner_monadic_def wins_monadic_def
  apply sepref_dbg_keep
  done

sepref_register condorcet_winner_monadic

declare cond_imp.refine [sepref_fr_rules]

lemma condorcet_winner_monadic_correct:
  fixes A :: "'a::{default, heap, hashable} set"
  fixes pl :: "'a::{default, heap, hashable} Profile_List"
    and pr :: "'a::{default, heap, hashable} Profile"
   assumes prel: "(pl, pr) \<in> profile_rel" and profp: "profile A pr"
  assumes fina: "finite A"
  shows "condorcet_winner_monadic A pl a
  \<le> SPEC (\<lambda> is_win. is_win = condorcet_winner A pr a)"
proof (unfold condorcet_winner_monadic_def RETURN_SPEC_conv FOREACH_def[symmetric]
    , auto simp del: condorcet_winner.simps)
  assume winner_in: "a \<in> A"
  note winsc = wins_monadic_correct[THEN fun_relD,THEN fun_relD,THEN fun_relD,THEN nres_relD, THEN refine_IdD]
  from winner_in  have  " FOREACH\<^sub>C A (\<lambda>sigma. sigma)
     (\<lambda>x b. wins_monadic a pl x \<bind> (\<lambda>winswx. RES {if x = a then True else winswx})) True
    \<le> SPEC (\<lambda> is_win. is_win =  condorcet_winner A pr a)"
      apply (refine_vcg  FOREACHc_rule [where I =" \<lambda> it b. b =
    (\<forall>x\<in>(A - it) - {a}. wins a pr x)"] winsc prel fina profp)
    by  (auto simp add: winner_in fina  profp simp del: wins.simps)
  from this show " a \<in> A \<Longrightarrow>
    FOREACH\<^sub>C A (\<lambda>sigma. sigma)
     (\<lambda>x b. wins_monadic a pl x \<bind> (\<lambda>winswx. RES {if x = a then True else winswx})) True
    \<le> RES {condorcet_winner A pr a}" by simp
next
  assume aA: "a \<notin> A"
  assume condwa: "condorcet_winner A pr a"
  from aA condwa show "False" by simp
qed

lemma cond_winner_l_unique:
  fixes A:: "'a set"
  fixes pl :: "'a Profile_List"
  fixes pr :: "'a Profile"
  fixes c :: 'a and w :: 'a
  assumes
    prel:     "(pl, pr) \<in> profile_rel"    and
    winner_c: "condorcet_winner_l A pl c" and
    winner_w: "condorcet_winner_l A pl w"
  shows "w = c"
  using condorcet_winner_l_correct[THEN fun_relD,THEN fun_relD, THEN fun_relD,
      where x2 = A and x'2 = A and x1 = pl and x'1 = pr] set_rel_id_simp
    cond_winner_unique[where A = A and p = pr and c = c and w = w]
  assms by blast

lemma cond_winner_l_unique2:
  fixes A:: "'a set"
  fixes pl :: "'a Profile_List"
  fixes pr :: "'a Profile"
  fixes x :: 'a and w :: 'a
  assumes
    prel:     "(pl, pr) \<in> profile_rel"    and
    winner: "condorcet_winner_l A pl w" and
    not_w:  "x \<noteq> w"
  shows "\<not> condorcet_winner_l A pl x"
  using condorcet_winner_l_correct[THEN fun_relD,THEN fun_relD,THEN fun_relD,
      where x2 = A and x'2 = A and x1 = pl and x'1 = pr]  set_rel_id_simp
    cond_winner_unique2[where A = A and p = pr and x = x and w = w]
  assms by blast

lemma cond_winner_unique3_l:
  fixes A:: "'a set"
  fixes pl :: "'a Profile_List"
  fixes pr :: "'a Profile"
  fixes w :: 'a
  assumes
    prel:     "(pl, pr) \<in> profile_rel"    and
    wcond:    "condorcet_winner_l A pl w"
  shows "{a \<in> A. condorcet_winner_l A pl a} = {w}"
  using condorcet_winner_l_correct[THEN fun_relD,THEN fun_relD,THEN fun_relD,
      where x2 = A and x'2 = A and x1 = pl and x'1 = pr]  set_rel_id_simp
    cond_winner_unique3[where A = A and p = pr and w = w]
  assms by blast

subsubsection \<open>Convert HOL types to heap data structures\<close>

definition convert_list :: "'a::{default, heap} list \<Rightarrow> 'a list nres"  where
  "convert_list l \<equiv>
  nfoldli l (\<lambda> x. True)
 (\<lambda> x nl.
    RETURN (nl @ [x])) []"

sepref_definition clist is "convert_list" :: "(list_assn id_assn)\<^sup>d
 \<rightarrow>\<^sub>a (arl_assn nat_assn)"
  unfolding convert_list_def
  apply (rewrite in "nfoldli _ _ _ rewrite_HOLE" arl.fold_custom_empty)
  by sepref

definition convert_list_to_set :: "'a::{default, heap} list \<Rightarrow> 'a set nres"  where
  "convert_list_to_set l \<equiv>
  nfoldli l (\<lambda> x. True)
 (\<lambda> x ns.
    RETURN (insert x ns)) {}"

sepref_definition convert_list_to_hash_set is "convert_list_to_set" :: "(list_assn id_assn)\<^sup>d
 \<rightarrow>\<^sub>a (hs.assn nat_assn)"
  unfolding convert_list_to_set_def
  apply (rewrite in "nfoldli _ _ _ rewrite_HOLE" hs.fold_custom_empty)
  by sepref

lemma convert_list_correct:
  shows "(convert_list, RETURN) \<in> \<langle>Id\<rangle>list_rel \<rightarrow> \<langle>\<langle>Id\<rangle>list_rel\<rangle>nres_rel"
  unfolding convert_list_def
  apply (clarsimp, intro nres_relI refine_IdI)
  apply (refine_vcg nfoldli_rule[where I = "(\<lambda> l1 l2 r.
      (r = l1))"])
  by auto

lemma convert_list_to_set_correct:
  shows "(convert_list_to_set, RETURN o set) \<in> \<langle>Id\<rangle>list_rel \<rightarrow> \<langle>\<langle>Id\<rangle>set_rel\<rangle>nres_rel"
  unfolding convert_list_to_set_def
  apply (clarsimp, intro nres_relI refine_IdI)
  apply (refine_vcg nfoldli_rule[where I = "(\<lambda> l1 l2 r.
      (r = set l1))"])
  by auto

subsection \<open>Monadic Implementation for Limiting Profiles\<close>

definition limit_profile_l :: "'a::{default, hashable, heap} set \<Rightarrow>
    'a Profile_List \<Rightarrow> 'a Profile_List nres" where
  "limit_profile_l A p =
    nfoldli p (\<lambda>_. True)
      (\<lambda> x np. do {
         newb \<leftarrow> (limit_monadic A x);
        RETURN (op_list_append np newb)}) []"

sepref_register limit_monadic
declare limit_sep.refine [sepref_fr_rules]

sepref_definition limit_profile_sep is "uncurry (limit_profile_l)" ::
  "(hs.assn id_assn)\<^sup>k *\<^sub>a (profile_impl_assn id_assn )\<^sup>k \<rightarrow>\<^sub>a (profile_impl_assn id_assn )"
  unfolding limit_profile_l_def
  apply (rewrite in "nfoldli _ _ _ rewrite_HOLE" HOL_list.fold_custom_empty)
  apply sepref_dbg_keep
  done

sepref_register limit_profile_l

lemma limitp_correct:
  shows "(uncurry limit_profile_l, uncurry (RETURN oo limit_profile)) \<in>
  [\<lambda> (A, pl). finite A ]\<^sub>f (\<langle>Id\<rangle>set_rel \<times>\<^sub>r  profile_rel) \<rightarrow> \<langle>profile_rel\<rangle>nres_rel"
proof(intro frefI, unfold limit_profile_l_def comp_apply SPEC_eq_is_RETURN(2)[symmetric],
    refine_vcg, auto, rename_tac A pl pr)
  fix A :: "'a set"
  fix pl:: "'a Profile_List"
  fix pr :: "'a Profile"
  assume fina : "finite A"
  assume prel: " (pl, pr) \<in> profile_rel"
  show " nfoldli pl (\<lambda>_. True) (\<lambda>x np. limit_monadic A x \<bind> (\<lambda>newb. RES {np @ [newb]})) []
       \<le> \<Down> profile_rel (RES {map (limit A) pr})"
    apply (refine_vcg limit_monadic_refine  nfoldli_rule[where I = "(\<lambda> proc rem r.
              r = map (limit_l A) proc)"] )
        apply (auto simp add: fina)
    unfolding  ballot_rel_def well_formed_pl_def  relAPP_def in_br_conv
     in_br_conv  length_map limit_l_sound list_rel_eq_listrel listrel_iff_nth
        nth_map prel  relAPP_def
    apply safe using length_preserving
    using prel list_rel_imp_same_length prel  apply blast
    using limit_eq
      apply (metis ballot_rel_def list_rel_imp_same_length map_in_list_rel_conv nth_map
          nth_mem prel  profile_rel_imp_map_ballots)
     using limit_eq
      apply (metis ballot_rel_def list_rel_imp_same_length map_in_list_rel_conv nth_map
          nth_mem prel  profile_rel_imp_map_ballots)
     using prel limit_l_sound
     by (metis ballot_rel_def  map_in_list_rel_conv nth_map nth_mem
         profile_rel_imp_map_ballots well_formed_pl_def)

qed

definition "ballot_assn R \<equiv> (hr_comp (ballot_impl_assn R) ballot_rel)"

lemma limit_profile_sep_correct:
  shows "(uncurry limit_profile_sep, uncurry (RETURN \<circ>\<circ> limit_profile))
    \<in> [\<lambda>(a, b).
           finite
            a]\<^sub>a (alts_set_impl_assn id_assn)\<^sup>k *\<^sub>a
                 (list_assn
                   (ballot_assn id_assn))\<^sup>k \<rightarrow> list_assn
                                        (ballot_assn id_assn)"

  using limit_profile_sep.refine[FCOMP limitp_correct]  set_rel_id hr_comp_Id2
  unfolding ballot_assn_def
    by (simp)

declare limit_profile_sep_correct [sepref_fr_rules]

lemma limit_profile_sound_sep:
  shows "s \<subseteq> A \<and> finite_profile A p \<Longrightarrow> <(alts_set_impl_assn nat_assn) s hs *
            (list_assn (ballot_assn nat_assn)) p hp> limit_profile_sep hs hp
  < \<lambda>r. \<exists>\<^sub>Ares.  list_assn (ballot_assn nat_assn) p hp *
                (list_assn (ballot_assn nat_assn)) res r * \<up> (finite_profile s res) >\<^sub>t"
proof (clarsimp)
  assume sA: "s \<subseteq> A"
  assume fina: "finite A"
  assume prof: "profile A p"
  from sA fina have fins: "finite s"
    using rev_finite_subset by blast
  have postapp: "\<And>x. (\<exists>\<^sub>Axa. alts_set_impl_assn nat_assn s hs *
                list_assn (ballot_assn nat_assn) p hp *
                list_assn (ballot_assn nat_assn) xa x *
                true *
                \<up> (xa = map (limit s) p)) \<Longrightarrow>\<^sub>A
        ( \<exists>\<^sub>Ares.  list_assn (ballot_assn nat_assn) p hp *
             list_assn (ballot_assn nat_assn) res x * true *
             \<up> (finite_profile s res))"
    using limit_profile_sound[where S = A and p = p and A = s]
    apply sep_auto
    using fins apply blast
    by (simp add: fina prof sA)
  from this fins show "<alts_set_impl_assn nat_assn s hs *
     list_assn (ballot_assn nat_assn) p hp>
    limit_profile_sep hs hp
    <\<lambda>r. \<exists>\<^sub>Ares.  list_assn (ballot_assn nat_assn) p hp *
             list_assn (ballot_assn nat_assn) res r * true *
             \<up> (finite_profile s res)>"
    using limit_profile_sep_correct[THEN hfrefD, THEN hn_refineD, of "(s, p)" "(hs, hp)", simplified]
          cons_rule[where P = "(alts_set_impl_assn nat_assn) s hs *
            (list_assn (ballot_assn nat_assn)) p hp"
          and P' = "(alts_set_impl_assn nat_assn) s hs *
            (list_assn
                   (hr_comp (ballot_impl_assn nat_assn)
                     ballot_rel)) p hp" and Q = "(\<lambda> r. \<exists>\<^sub>Ax. alts_set_impl_assn nat_assn s hs *
                list_assn (ballot_assn nat_assn) p hp *
                list_assn (ballot_assn nat_assn) x r *
                true *
                \<up> (x = map (limit s) p))"
           and Q' = "\<lambda>r. \<exists>\<^sub>Ares.  list_assn (ballot_assn nat_assn) p hp *
             list_assn (ballot_assn nat_assn) res r * true *
             \<up> (finite_profile s res)"
            and c = "limit_profile_sep hs hp"]
      using ent_refl
      by (simp add: ballot_assn_def)

qed

end