           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               February 2005               |
            |                   June 2005  (modified)   |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law_fp
imports CSP_T_law_ufp
begin

(*****************************************************************

         1. cpo fixed point theory in CSP-Prover
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)

(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(*=======================================================*
 |                                                       |
 |                        CPO                            |
 |                                                       |
 *=======================================================*)

(*-------------*
 |  existency  |
 *-------------*)

lemma semT_hasLFP_cpo:
 "Pf = PNfun ==> [[Pf]]Tfun hasLFP"
apply (rule Tarski_thm_EX)
apply (rule continuous_semTfun)
done

lemma semT_LFP_cpo:
  "[| Pf = PNfun ;
      FPmode = CPOmode | FPmode = MIXmode |]
  ==> [[$p]]T = LFP [[Pf]]Tfun p"
apply (simp add: semT_def semTf_def)
apply (simp add: traces_iff)
apply (simp add: MT_def)
apply (simp add: semTfix_def)
apply (force)
done

lemma semT_LFP_fun_cpo:
  "[| Pf = PNfun ;
      FPmode = CPOmode | FPmode = MIXmode |]
  ==> (%p. [[$p]]T) = LFP [[Pf]]Tfun"
apply (simp (no_asm) add: fun_eq_iff)
apply (simp add: semT_LFP_cpo)
done

(*---------*
 |    MT   |
 *---------*)

lemma MT_fixed_point_cpo:
      "[| (Pf::'p=>('p,'a) proc) = PNfun; FPmode = CPOmode | FPmode = MIXmode |]
        ==> [[Pf]]Tfun (MT::'p => 'a domT) = (MT::'p => 'a domT)"
apply (simp add: MT_def)
apply (simp add: semTfix_def)
apply (erule disjE)
apply (simp_all)
apply (rule LFP_fp)
apply (simp add: semT_hasLFP_cpo)
apply (rule LFP_fp)
apply (simp add: semT_hasLFP_cpo)
done

(*-------------*
 |  greatest   |
 *-------------*)

lemma ALL_cspT_greatest_cpo:
  "[| Pf = PNfun ;
       FPmode = CPOmode ;
       ALL p. (Pf p) << f =T f p |] ==> ALL p. f p <=T $p"
apply (simp add: eqT_def refT_def)
apply (fold semT_def)
apply (simp add: fun_eq_iff[THEN sym])
apply (fold order_prod_def)
apply (insert semT_LFP_fun_cpo[of "Pf"])
apply (simp)

apply (rule LFP_least)
apply (simp add: semT_hasLFP_cpo)

apply (simp add: semT_def semTfun_def semTf_def)
apply (simp add: traces_subst)
done

lemma cspT_greatest_cpo:
  "[| Pf = PNfun ;
       FPmode = CPOmode ;
       ALL p. (Pf p) << f =T f p |] ==> f p <=T $p"
by (simp add: ALL_cspT_greatest_cpo)

(*-------------------------------------------------------*
 |                                                       |
 |           Fixpoint unwind (CSP-Prover rule)           |
 |                                                       |
 *-------------------------------------------------------*)

lemma ALL_cspT_unwind_cpo:
   "[| Pf = PNfun ;
       FPmode = CPOmode | FPmode = MIXmode |]
     ==> ALL p. ($p =T Pf p)"
apply (simp add: cspT_semantics)
apply (simp add: traces_iff)
apply (simp add: MT_def)
apply (simp add: semTfix_def)
apply (simp add: fun_eq_iff[THEN sym])
apply (simp add: traces_semTfun)
apply (simp add: LFP_fp semT_hasLFP_cpo)
apply (force)
done

(*  csp law  *)

lemma cspT_unwind_cpo:
   "[| Pf = PNfun ;
       FPmode = CPOmode | FPmode = MIXmode |]
     ==> $p =T Pf p"
by (simp add: ALL_cspT_unwind_cpo)

(*-------------------------------------------------------*
 |                                                       |
 |    fixed point inducntion (CSP-Prover intro rule)     |
 |                                                       |
 *-------------------------------------------------------*)

(*** right ***)

lemma cspT_fp_induct_cpo_ref_right_ALL:
   "[| Pf = PNfun ;
       FPmode = CPOmode | FPmode = MIXmode ;
       Q <=T f p;
       ALL p. f p <=T (Pf p)<<f |]
    ==> Q <=T $p"
apply (simp add: refT_semT)
apply (insert cpo_fixpoint_induction_rev
       [of "[[Pf]]Tfun" "(%p. [[f p]]T)"])
apply (simp add: LFP_fp semT_hasLFP_cpo)
apply (simp add: fold_order_prod_def)
apply (simp add: semT_subst_semTfun)

apply (simp add: continuous_semTfun)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)+

apply (simp add: semT_LFP_cpo)
done

(*  csp law  *)

lemma cspT_fp_induct_cpo_ref_right:
   "[| Pf = PNfun ;
       FPmode = CPOmode | FPmode = MIXmode ;
       Q <=T f p;
       !! p. f p <=T (Pf p)<<f |]
    ==> Q <=T $p"
by (simp add: cspT_fp_induct_cpo_ref_right_ALL)

lemmas cspT_fp_induct_cpo_right
     = cspT_fp_induct_cpo_ref_right

(*=======================================================*
 |                                                       |
 |                    LFP <--> UFP                       |
 |                                                       |
 |                       MIXmode                         |
 |                                                       |
 *=======================================================*)

lemma semT_guarded_LFP_UFP:
  "[| Pf = PNfun ; guardedfun Pf |]
   ==> LFP [[Pf]]Tfun = UFP [[Pf]]Tfun"
by (simp add: semT_hasUFP_cms hasUFP_LFP_UFP)

(*----------- refinement -----------*)

(*** left ***)

lemma cspT_fp_induct_mix_ref_left_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = MIXmode ;
       f p <=T Q ;
       ALL p. (Pf p)<<f <=T f p |]
    ==> $p <=T Q"
apply (simp add: refT_semT)
apply (insert cms_fixpoint_induction_ref
       [of "[[Pf]]Tfun" "(%p. [[f p]]T)" "UFP [[Pf]]Tfun"])
apply (simp add: semT_guarded_LFP_UFP[THEN sym])
apply (simp add: LFP_fp semT_hasLFP_cpo)

apply (simp add: fold_order_prod_def)
apply (simp add: semT_subst_semTfun)
apply (simp add: mono_semTfun)

apply (simp add: contra_alpha_to_contst contraction_alpha_semTfun)
apply (simp add: to_distance_rs)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)+
apply (simp add: semT_LFP_cpo)
done

(*  csp law  *)

lemma cspT_fp_induct_mix_ref_left:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = MIXmode ;
       f p <=T Q ;
       !! p. (Pf p)<<f <=T f p |]
    ==> $p <=T Q"
by (simp add: cspT_fp_induct_mix_ref_left_ALL)

(*----------- equality -----------*)

(*** left ***)

lemma cspT_fp_induct_mix_eq_left_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = MIXmode ;
       f p =T Q ;
       ALL p. (Pf p)<<f =T f p |]
    ==> $p =T Q"
apply (simp add: eqT_semT)
apply (simp add: fun_eq_iff[THEN sym])
apply (simp add: semT_subst_semTfun)
apply (insert semT_LFP_fun_cpo[of Pf])
apply (simp add: semT_guarded_LFP_UFP)
apply (subgoal_tac "(%p. [[$p]]T) = (%p. [[f p]]T)")
apply (simp add: fun_eq_iff)

apply (rule hasUFP_unique_solution[of "[[Pf]]Tfun"])
apply (simp_all add: semT_hasUFP_cms)
apply (simp add: UFP_fp semT_hasUFP_cms)
done

(*  csp law  *)

lemma cspT_fp_induct_mix_eq_left:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = MIXmode ;
       f p =T Q;
       !! p. (Pf p)<<f =T f p |]
    ==> $p =T Q"
by (simp add: cspT_fp_induct_mix_eq_left_ALL)

lemma cspT_fp_induct_mix_eq_right:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = MIXmode ;
       Q =T f p;
       !! p. f p =T (Pf p)<<f |]
    ==> Q =T $p"
apply (rule cspT_sym)
apply (rule cspT_fp_induct_mix_eq_left[of Pf f p Q])
apply (simp_all)
apply (rule cspT_sym)
apply (simp)
apply (rule cspT_sym)
apply (simp)
done

lemmas cspT_fp_induct_mix_left
     = cspT_fp_induct_mix_ref_left cspT_fp_induct_mix_eq_left

lemmas cspT_fp_induct_mix_right
     = cspT_fp_induct_cpo_ref_right cspT_fp_induct_mix_eq_right

(*=======================================================*
 |                                                       |
 |            mixing CPOmode and CMSmode                 |
 |                                                       |
 *=======================================================*)

lemma cspT_unwind:
   "[| Pf = PNfun ;
       FPmode = CPOmode
     | FPmode = CMSmode & guardedfun Pf
     | FPmode = MIXmode |]
     ==> $p =T Pf p"
apply (erule disjE)
apply (simp add: cspT_unwind_cpo)
apply (erule disjE)
apply (simp add: cspT_unwind_cms)
apply (simp add: cspT_unwind_cpo)
done

lemma cspT_fp_induct_ref_right:
   "[| Pf = PNfun ;
       FPmode = CPOmode
     | FPmode = CMSmode & guardedfun Pf
     | FPmode = MIXmode ;
       Q <=T f p;
       !! p. f p <=T (Pf p)<<f |]
    ==> Q <=T $p"
apply (erule disjE)
apply (simp add: cspT_fp_induct_cpo_right)
apply (erule disjE)
apply (simp add: cspT_fp_induct_cms_right)
apply (simp add: cspT_fp_induct_cpo_right)
done

lemma cspT_fp_induct_ref_left:
   "[| Pf = PNfun ;
       FPmode = CMSmode
     | FPmode = MIXmode ;
       guardedfun Pf ;
       f p <=T Q ;
       !! p. (Pf p)<<f <=T f p |]
    ==> $p <=T Q"
apply (erule disjE)
apply (simp add: cspT_fp_induct_cms_left)
apply (simp add: cspT_fp_induct_mix_left)
done

lemma cspT_fp_induct_eq_left:
   "[| Pf = PNfun ;
       FPmode = CMSmode
     | FPmode = MIXmode ;
       guardedfun Pf ;
       f p =T Q ;
       !! p. (Pf p)<<f =T f p |]
    ==> $p =T Q"
apply (erule disjE)
apply (simp add: cspT_fp_induct_cms_left)
apply (simp add: cspT_fp_induct_mix_left)
done

lemma cspT_fp_induct_eq_right:
   "[| Pf = PNfun ;
       FPmode = CMSmode
     | FPmode = MIXmode ;
       guardedfun Pf ;
       Q =T f p;
       !! p. f p =T (Pf p)<<f |]
    ==> Q =T $p"
apply (erule disjE)
apply (simp add: cspT_fp_induct_cms_right)
apply (simp add: cspT_fp_induct_mix_right)
done

(*** cpo and cms ***)

lemmas cspT_fp_induct_right = cspT_fp_induct_ref_right cspT_fp_induct_eq_right
lemmas cspT_fp_induct_left = cspT_fp_induct_ref_left cspT_fp_induct_eq_left

(****************** to add them again ******************)
(* 2013
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(* 2017
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


theory BDD_select
  imports Main BDD_basic
begin

definition select :: "nat \<Rightarrow> BDD \<Rightarrow> BDD \<Rightarrow> BDD" where
  "select a t e = (if t = e then t else Select a t e)"

lemma select_noop [simp]: "norm n t \<Longrightarrow> norm n e \<Longrightarrow> t \<noteq> e \<Longrightarrow> select v t e = Select v t e"
  by (auto simp: select_def)

theorem norm_select [simp]: "n > a \<Longrightarrow> norm a t \<Longrightarrow> norm a e \<Longrightarrow> norm n (select a t e)"
  by (simp add: select_def)

theorem ordered_select [simp]: "n > a \<Longrightarrow> ordered a t \<Longrightarrow> ordered a e \<Longrightarrow> ordered n (select a t e)"
  by (simp add: select_def)

theorem select_correct [simp]: "contains (select a t e) f = contains (Select a t e) f"
  apply (rule iffI)
  apply (auto simp add: select_def)
  apply (metis (full_types) contains_sel_e contains_sel_t)
  using contains.cases by auto

end


theory "EvalHeap"
  imports "AList-Utils" "Env" "Nominal2" "Env" "HOLCF-Utils"
begin

subsubsection {* Conversion from heaps to environments *}

fun evalHeap :: "('var \<times> 'exp) list \<Rightarrow> ('exp \<Rightarrow> 'value::{pure,pcpo}) \<Rightarrow> 'var \<Rightarrow> 'value"
where
  "evalHeap [] _ = \<bottom>"
| "evalHeap ((x,e)#h) eval = (evalHeap h eval) (x := eval e)"
(*

syntax
  "_map_evalHeap" :: "['var \<Rightarrow> 'value, 'value, pttrn, ('var \<times> 'exp) list] => ('var \<Rightarrow> 'value)"    ("(2_[x := _ | '(x , _') \<in> _])" [1000,0,0,0] 900)

abbreviation map_evalHeap :: "('var \<Rightarrow> 'value) \<Rightarrow>  ('var \<times> 'exp) list \<Rightarrow> ('exp \<Rightarrow> 'value::{pure,pcpo}) \<Rightarrow> ('var \<Rightarrow> 'value)"
  where "map_evalHeap f \<Gamma> eval == f ++\<^bsub>domA \<Gamma>\<^esub> evalHeap \<Gamma> eval"

translations
  "f[x := v | (x,e) \<in> \<Gamma>]"== "CONST map_evalHeap f \<Gamma> (%e. v)"

print_translation {*
  [(@{const_syntax map_evalHeap}, fn _ => fn [f, g, Abs abs] =>
    let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
    in Syntax.const @{syntax_const "_map_evalHeap"} $ f $ t $ x $ g end)]
*}  -- {* To avoid eta-contraction of body,
           suggested by Andreas Lochbihler in http://stackoverflow.com/a/23290443/946226 *}
*)

lemma cont2cont_evalHeap[simp, cont2cont]:
  "(\<And> e . e \<in> snd ` set h \<Longrightarrow> cont (\<lambda>\<rho>. eval \<rho> e)) \<Longrightarrow> cont (\<lambda> \<rho>. evalHeap h (eval \<rho>))"
  by(induct h, auto)

lemma evalHeap_eqvt[eqvt]:
  "\<pi> \<bullet> evalHeap h eval = evalHeap (\<pi> \<bullet> h) (\<pi> \<bullet> eval)"
  by (induct h) (auto simp add:fun_upd_eqvt  simp del: fun_upd_apply)

lemma edom_evalHeap_subset:"edom (evalHeap h eval) \<subseteq> domA h"
  by (induct h eval rule:evalHeap.induct) (auto dest:set_mp[OF edom_fun_upd_subset] simp del: fun_upd_apply)

lemma evalHeap_cong[fundef_cong]:
  "\<lbrakk> heap1 = heap2 ;  (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> eval1 e = eval2 e) \<rbrakk>
    \<Longrightarrow>  evalHeap heap1 eval1 = evalHeap heap2 eval2"
 by (induct heap2 eval2 arbitrary:heap1 rule:evalHeap.induct, auto)

lemma lookupEvalHeap:
  assumes "v \<in> domA h"
  shows "(evalHeap h f) v = f (the (map_of h v))"
  using assms
  by (induct h f rule: evalHeap.induct) auto

lemma lookupEvalHeap':
  assumes "map_of \<Gamma> v = Some e"
  shows "(evalHeap \<Gamma> f) v = f e"
  using assms
  by (induct \<Gamma> f rule: evalHeap.induct) auto

lemma lookupEvalHeap_other[simp]:
  assumes "v \<notin> domA \<Gamma>"
  shows "(evalHeap \<Gamma> f) v = \<bottom>"
  using assms
  by (induct \<Gamma> f rule: evalHeap.induct) auto

lemma env_restr_evalHeap_noop:
  "domA h \<subseteq> S \<Longrightarrow> env_restr S (evalHeap h eval) = evalHeap h eval"
  apply (rule ext)
  apply (case_tac "x \<in> S")
  apply (auto simp add: lookupEvalHeap intro: lookupEvalHeap_other)
  done

lemma env_restr_evalHeap_same[simp]:
  "env_restr (domA h) (evalHeap h eval) = evalHeap h eval"
  by (simp add: env_restr_evalHeap_noop)

lemma evalHeap_cong':
  "\<lbrakk> (\<And> x. x \<in> domA heap \<Longrightarrow> eval1 (the (map_of heap x)) = eval2 (the (map_of heap x))) \<rbrakk>
    \<Longrightarrow>  evalHeap heap eval1 = evalHeap heap eval2"
 apply (rule ext)
 apply (case_tac "x \<in> domA heap")
 apply (auto simp add: lookupEvalHeap)
 done

lemma lookupEvalHeapNotAppend[simp]:
  assumes "x \<notin> domA \<Gamma>"
  shows "(evalHeap (\<Gamma>@h) f) x = evalHeap h f x"
  using assms by (induct \<Gamma>, auto)

lemma evalHeap_delete[simp]: "evalHeap (delete x \<Gamma>) eval = env_delete x (evalHeap \<Gamma> eval)"
  by (induct \<Gamma>) auto

lemma evalHeap_mono:
  "x \<notin> domA \<Gamma> \<Longrightarrow>
  evalHeap \<Gamma> eval \<sqsubseteq> evalHeap ((x, e) # \<Gamma>) eval"
   apply simp
   apply (rule fun_belowI)
   apply (case_tac "xa \<in> domA \<Gamma>")
   apply (case_tac "xa = x")
   apply auto
   done

subsubsection {* Reordering lemmas *}

lemma evalHeap_reorder:
  assumes "map_of \<Gamma> = map_of \<Delta>"
  shows "evalHeap \<Gamma> h = evalHeap \<Delta> h"
proof (rule ext)
  from assms
  have *: "domA \<Gamma> = domA \<Delta>" by (metis dom_map_of_conv_domA)

  fix x
  show "evalHeap \<Gamma> h x = evalHeap \<Delta> h x"
    using assms(1) *
    apply (cases "x \<in> domA \<Gamma>")
    apply (auto simp add: lookupEvalHeap)
    done
qed

lemma evalHeap_reorder_head:
  assumes "x \<noteq> y"
  shows "evalHeap ((x,e1)#(y,e2)#\<Gamma>) eval = evalHeap ((y,e2)#(x,e1)#\<Gamma>) eval"
  by (rule evalHeap_reorder) (simp add: fun_upd_twist[OF assms])

lemma evalHeap_reorder_head_append:
  assumes "x \<notin> domA \<Gamma>"
  shows "evalHeap ((x,e)#\<Gamma>@\<Delta>) eval = evalHeap (\<Gamma> @ ((x,e)#\<Delta>)) eval"
  by (rule evalHeap_reorder) (simp, metis assms dom_map_of_conv_domA map_add_upd_left)

lemma evalHeap_subst_exp:
  assumes "eval e = eval e'"
  shows "evalHeap ((x,e)#\<Gamma>) eval = evalHeap ((x,e')#\<Gamma>) eval"
  by (simp add: assms)

end


theory Transition_System
imports
  Residual
begin

section \<open>Nominal Transition Systems and Bisimulations\<close>

subsection \<open>Basic Lemmas\<close>

lemma symp_on_eqvt [eqvt]:
  assumes "symp_on A R" shows "symp_on (p \<bullet> A) (p \<bullet> R)"
  using assms
  by (auto simp: symp_on_def permute_fun_def permute_set_def permute_pure)

lemma symp_eqvt:
  assumes "symp R" shows "symp (p \<bullet> R)"
  using assms
  by (auto simp: symp_on_def permute_fun_def permute_pure)

subsection \<open>Nominal transition systems\<close>

locale nominal_ts =
  fixes satisfies :: "'state::fs \<Rightarrow> 'pred::fs \<Rightarrow> bool"                (infix "\<turnstile>" 70)
    and transition :: "'state \<Rightarrow> ('act::bn,'state) residual \<Rightarrow> bool"  (infix "\<rightarrow>" 70)
  assumes satisfies_eqvt [eqvt]: "P \<turnstile> \<phi> \<Longrightarrow> p \<bullet> P \<turnstile> p \<bullet> \<phi>"
      and transition_eqvt [eqvt]: "P \<rightarrow> \<alpha>Q \<Longrightarrow> p \<bullet> P \<rightarrow> p \<bullet> \<alpha>Q"
begin

  lemma transition_eqvt':
    assumes "P \<rightarrow> \<langle>\<alpha>,Q\<rangle>" shows "p \<bullet> P \<rightarrow> \<langle>p \<bullet> \<alpha>, p \<bullet> Q\<rangle>"
  using assms by (metis abs_residual_pair_eqvt transition_eqvt)

end

subsection \<open>Bisimulations\<close>

context nominal_ts
begin

  definition is_bisimulation :: "('state \<Rightarrow> 'state \<Rightarrow> bool) \<Rightarrow> bool" where
    "is_bisimulation R \<equiv>
      symp R \<and>
      (\<forall>P Q. R P Q \<longrightarrow> (\<forall>\<phi>. P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>)) \<and>
      (\<forall>P Q. R P Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> R P' Q')))"

  definition bisimilar :: "'state \<Rightarrow> 'state \<Rightarrow> bool"  (infix "\<sim>\<cdot>" 100) where
    "P \<sim>\<cdot> Q \<equiv> \<exists>R. is_bisimulation R \<and> R P Q"

  text \<open>@{const bisimilar} is an equivariant equivalence relation.\<close>

  lemma is_bisimulation_eqvt (*[eqvt]*):
    assumes "is_bisimulation R" shows "is_bisimulation (p \<bullet> R)"
  using assms unfolding is_bisimulation_def
  proof (clarify)
    assume 1: "symp R"
    assume 2: "\<forall>P Q. R P Q \<longrightarrow> (\<forall>\<phi>. P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>)"
    assume 3: "\<forall>P Q. R P Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> R P' Q'))"
    have "symp (p \<bullet> R)" (is ?S)
      using 1 by (simp add: symp_eqvt)
    moreover have "\<forall>P Q. (p \<bullet> R) P Q \<longrightarrow> (\<forall>\<phi>. P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>)" (is ?T)
      proof (clarify)
        fix P Q \<phi>
        assume *: "(p \<bullet> R) P Q" and **: "P \<turnstile> \<phi>"
        from * have "R (-p \<bullet> P) (-p \<bullet> Q)"
          by (simp add: eqvt_lambda permute_bool_def unpermute_def)
        then show "Q \<turnstile> \<phi>"
          using 2 ** by (metis permute_minus_cancel(1) satisfies_eqvt)
      qed
    moreover have "\<forall>P Q. (p \<bullet> R) P Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> (p \<bullet> R) P' Q'))" (is ?U)
      proof (clarify)
        fix P Q \<alpha> P'
        assume *: "(p \<bullet> R) P Q" and **: "bn \<alpha> \<sharp>* Q" and ***: "P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
        from * have "R (-p \<bullet> P) (-p \<bullet> Q)"
          by (simp add: eqvt_lambda permute_bool_def unpermute_def)
        moreover have "bn (-p \<bullet> \<alpha>) \<sharp>* (-p \<bullet> Q)"
          using ** by (metis bn_eqvt fresh_star_permute_iff)
        moreover have "-p \<bullet> P \<rightarrow> \<langle>-p \<bullet> \<alpha>, -p \<bullet> P'\<rangle>"
          using *** by (metis transition_eqvt')
        ultimately obtain Q' where T: "-p \<bullet> Q \<rightarrow> \<langle>-p \<bullet> \<alpha>,Q'\<rangle>" and R: "R (-p \<bullet> P') Q'"
          using 3 by metis
        from T have "Q \<rightarrow> \<langle>\<alpha>, p \<bullet> Q'\<rangle>"
          by (metis permute_minus_cancel(1) transition_eqvt')
        moreover from R have "(p \<bullet> R) P' (p \<bullet> Q')"
          by (metis eqvt_apply eqvt_lambda permute_bool_def unpermute_def)
        ultimately show "\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> (p \<bullet> R) P' Q'"
          by metis
      qed
    ultimately show "?S \<and> ?T \<and> ?U" by simp
  qed

  lemma bisimilar_eqvt (*[eqvt]*):
    assumes "P \<sim>\<cdot> Q" shows "(p \<bullet> P) \<sim>\<cdot> (p \<bullet> Q)"
  proof -
    from assms obtain R where *: "is_bisimulation R \<and> R P Q"
      unfolding bisimilar_def ..
    then have "is_bisimulation (p \<bullet> R)"
      by (simp add: is_bisimulation_eqvt)
    moreover from "*" have "(p \<bullet> R) (p \<bullet> P) (p \<bullet> Q)"
      by (metis eqvt_apply permute_boolI)
    ultimately show "(p \<bullet> P) \<sim>\<cdot> (p \<bullet> Q)"
      unfolding bisimilar_def by auto
  qed

  lemma bisimilar_reflp: "reflp bisimilar"
  proof (rule reflpI)
    fix x
    have "is_bisimulation (=)"
      unfolding is_bisimulation_def by (simp add: symp_def)
    then show "x \<sim>\<cdot> x"
      unfolding bisimilar_def by auto
  qed

  lemma bisimilar_symp: "symp bisimilar"
  proof (rule sympI)
    fix P Q
    assume "P \<sim>\<cdot> Q"
    then obtain R where *: "is_bisimulation R \<and> R P Q"
      unfolding bisimilar_def ..
    then have "R Q P"
      unfolding is_bisimulation_def by (simp add: symp_def)
    with "*" show "Q \<sim>\<cdot> P"
      unfolding bisimilar_def by auto
  qed

  lemma bisimilar_is_bisimulation: "is_bisimulation bisimilar"
  unfolding is_bisimulation_def proof
    show "symp (\<sim>\<cdot>)"
      by (fact bisimilar_symp)
  next
    show "(\<forall>P Q. P \<sim>\<cdot> Q \<longrightarrow> (\<forall>\<phi>. P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>)) \<and>
      (\<forall>P Q. P \<sim>\<cdot> Q \<longrightarrow> (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> P' \<sim>\<cdot> Q')))"
      by (auto simp add: is_bisimulation_def bisimilar_def) blast
  qed

  lemma bisimilar_transp: "transp bisimilar"
  proof (rule transpI)
    fix P Q R
    assume PQ: "P \<sim>\<cdot> Q" and QR: "Q \<sim>\<cdot> R"
    let ?bisim = "bisimilar OO bisimilar"
    have "symp ?bisim"
      proof (rule sympI)
        fix P R
        assume "?bisim P R"
        then obtain Q where "P \<sim>\<cdot> Q" and "Q \<sim>\<cdot> R"
          by blast
        then have "R \<sim>\<cdot> Q" and "Q \<sim>\<cdot> P"
          by (metis bisimilar_symp sympE)+
        then show "?bisim R P"
          by blast
      qed
    moreover have "\<forall>P Q. ?bisim P Q \<longrightarrow> (\<forall>\<phi>. P \<turnstile> \<phi> \<longrightarrow> Q \<turnstile> \<phi>)"
      using bisimilar_is_bisimulation is_bisimulation_def by auto
    moreover have "\<forall>P Q. ?bisim P Q \<longrightarrow>
           (\<forall>\<alpha> P'. bn \<alpha> \<sharp>* Q \<longrightarrow> P \<rightarrow> \<langle>\<alpha>,P'\<rangle> \<longrightarrow> (\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> ?bisim P' Q'))"
      proof (clarify)
        fix P R Q \<alpha> P'
        assume PR: "P \<sim>\<cdot> R" and RQ: "R \<sim>\<cdot> Q" and fresh: "bn \<alpha> \<sharp>* Q" and trans: "P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
        \<comment> \<open>rename~@{term "\<langle>\<alpha>,P'\<rangle>"} to avoid~@{term R}, without touching~@{term Q}\<close>
        obtain p where 1: "(p \<bullet> bn \<alpha>) \<sharp>* R" and 2: "supp (\<langle>\<alpha>,P'\<rangle>, Q) \<sharp>* p"
          proof (rule at_set_avoiding2[of "bn \<alpha>" R "(\<langle>\<alpha>,P'\<rangle>, Q)", THEN exE])
            show "finite (bn \<alpha>)" by (fact bn_finite)
          next
            show "finite (supp R)" by (fact finite_supp)
          next
            show "finite (supp (\<langle>\<alpha>,P'\<rangle>, Q))" by (simp add: finite_supp supp_Pair)
          next
            show "bn \<alpha> \<sharp>* (\<langle>\<alpha>,P'\<rangle>, Q)" by (simp add: fresh fresh_star_Pair)
          qed metis
        from 2 have 3: "supp \<langle>\<alpha>,P'\<rangle> \<sharp>* p" and 4: "supp Q \<sharp>* p"
          by (simp add: fresh_star_Un supp_Pair)+
        from 3 have "\<langle>p \<bullet> \<alpha>, p \<bullet> P'\<rangle> = \<langle>\<alpha>,P'\<rangle>"
          using supp_perm_eq by fastforce
        then obtain pR' where 5: "R \<rightarrow> \<langle>p \<bullet> \<alpha>, pR'\<rangle>" and 6: "(p \<bullet> P') \<sim>\<cdot> pR'"
          using PR trans 1 by (metis (mono_tags, lifting) bisimilar_is_bisimulation bn_eqvt is_bisimulation_def)
        from fresh and 4 have "bn (p \<bullet> \<alpha>) \<sharp>* Q"
          by (metis bn_eqvt fresh_star_permute_iff supp_perm_eq)
        then obtain pQ' where 7: "Q \<rightarrow> \<langle>p \<bullet> \<alpha>, pQ'\<rangle>" and 8: "pR' \<sim>\<cdot> pQ'"
          using RQ 5 by (metis (full_types) bisimilar_is_bisimulation is_bisimulation_def)
        from 7 have "Q \<rightarrow> \<langle>\<alpha>, -p \<bullet> pQ'\<rangle>"
          using 4 by (metis permute_minus_cancel(2) supp_perm_eq transition_eqvt')
        moreover from 6 and 8 have "?bisim P' (-p \<bullet> pQ')"
          by (metis (no_types, opaque_lifting) bisimilar_eqvt permute_minus_cancel(2) relcompp.simps)
        ultimately show "\<exists>Q'. Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle> \<and> ?bisim P' Q'"
          by metis
      qed
    ultimately have "is_bisimulation ?bisim"
      unfolding is_bisimulation_def by metis
    moreover have "?bisim P R"
      using PQ QR by blast
    ultimately show "P \<sim>\<cdot> R"
      unfolding bisimilar_def by meson
  qed

  lemma bisimilar_equivp: "equivp bisimilar"
  by (metis bisimilar_reflp bisimilar_symp bisimilar_transp equivp_reflp_symp_transp)

  lemma bisimilar_simulation_step:
    assumes "P \<sim>\<cdot> Q" and "bn \<alpha> \<sharp>* Q" and "P \<rightarrow> \<langle>\<alpha>,P'\<rangle>"
    obtains Q' where "Q \<rightarrow> \<langle>\<alpha>,Q'\<rangle>" and "P' \<sim>\<cdot> Q'"
  using assms by (metis (poly_guards_query) bisimilar_is_bisimulation is_bisimulation_def)

end

end


section \<open>IRV_Rule\<close>

theory IRV_Rule
  imports Pairwise_Majority_Rule
        "Compositional_Structures/Basic_Modules/abs_module"
          "Compositional_Structures/Defer_One_Loop_Composition"
          "Compositional_Structures/Basic_Modules/drop_module"
begin

fun IRV_score :: "'a Evaluation_Function" where
  "IRV_score x A p = win_count p x"

fun IRV_rule_drop :: "'a Preference_Relation \<Rightarrow> 'a Electoral_Module" where
  "IRV_rule_drop r A p= (((absolute_max \<triangleright> ( eliminate_least_score IRV_score r) )\<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d)\<triangleright> elect_module) A p"

fun IRV_step_drop_test ::"'a Preference_Relation \<Rightarrow> 'a Electoral_Module" where
  "IRV_step_drop_test r A p=(absolute_max \<triangleright>  eliminate_least_score IRV_score r) A p "

fun IRV_step_drop ::"'a Preference_Relation \<Rightarrow> 'a Electoral_Module" where
  "IRV_step_drop r A p=eliminate_least_score IRV_score r A p "

fun IRV_rule :: "'a Electoral_Module" where
  "IRV_rule A p= (((absolute_max \<triangleright> min_eliminator IRV_score )\<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d)\<triangleright> elect_module) A p"

(*Garbage *)

(*
fun sum_IRV_score :: "'a::finite set \<Rightarrow> 'a Profile \<Rightarrow> nat" where
  "sum_IRV_score A p =  (\<Sum> y \<in> A. (IRV_score y A p))"

fun max_IRV_score :: "'a::finite set \<Rightarrow> 'a Profile \<Rightarrow> nat" where
  "max_IRV_score A p = Max ((\<lambda> a. IRV_score a A p) ` A)"

fun step_2 :: "'a Electoral_Module" where
  "step_2 A p= min_eliminator IRV_score_2 A p*)

(*fun mid_step :: "'a Electoral_Module" where
  "mid_step A p= (absolute_max \<triangleright> min_eliminator IRV_score) A p"*)

(*fun IRV_tie :: "'a set \<Rightarrow> 'a Profile \<Rightarrow> bool" where
  "IRV_tie A p = (\<exists>x \<in> A. \<exists>y \<in> A. x \<noteq> y \<and> win_count p x = win_count p y \<and>
                   (\<forall>z \<in> A. z \<noteq> x \<longrightarrow> z \<noteq> y \<longrightarrow> win_count p z \<ge> win_count p x))"
*)

(*fun IRV_score_2 :: "'a Evaluation_Function" where
  "IRV_score_2 x A p =
     (if (\<exists>y \<in> A. x \<noteq> y \<and> win_count p x = win_count p y \<and>
                  (\<forall>z \<in> A. (z \<noteq> x \<longrightarrow> z \<noteq> y \<longrightarrow> win_count p z \<ge> win_count p x)))
      then win_count p x - loose_count_code p x
      else win_count p x)"*)

(*
fun IRV_tie_cand :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> bool" where
  "IRV_tie_cand x A p =
     (if (\<exists>y \<in> A. x \<noteq> y \<and> win_count p x = win_count p y \<and>
                  (\<forall>z \<in> A. (z \<noteq> x \<longrightarrow> z \<noteq> y \<longrightarrow> win_count p z \<ge> win_count p x)))
      then True
      else False)"*)

(*
lemma not_both_lowest_score_after_clone:
  fixes p :: "'a Profile"
    and a :: 'a
    and c :: 'a
  assumes introduces_clone: "introduces_clone_in_candidate a c p pc"
  assumes Ac_def: "Ac = A \<union> {c}"
  shows "\<not>(IRV_score_2 a Ac pc = Min {IRV_score_2 x Ac pc | x. x \<in> Ac}) \<and>
         \<not>(IRV_score_2 c Ac pc = Min {IRV_score_2 x Ac pc | x. x \<in> Ac})"
proof
  assume "IRV_score_2 a Ac pc = Min {IRV_score_2 x Ac pc | x. x \<in> Ac} \<and>
          IRV_score_2 c Ac pc = Min {IRV_score_2 x Ac pc | x. x \<in> Ac}"
  then have "IRV_score_2 a Ac pc = Min {IRV_score_2 x Ac pc | x. x \<in> Ac}"
    and "IRV_score_2 c Ac pc = Min {IRV_score_2 x Ac pc | x. x \<in> Ac}" by simp_all
  moreover have "win_count p a = Min {win_count p x | x. x \<in> Ac}"
      proof -
    have "introduces_clone_in_candidate a c p pc"
      using introduces_clone by simp
    moreover {
      fix b r r'
      assume "dir_pref_in_ballot a b r" "linear_order_on Ac r" "a \<in> Ac" "b \<in> Ac"
             "r \<in> set p" "r' \<in> set pc"
      with introduces_clone preservation_of_preferences Ac_def
      have "(a, b) \<in> r'"
        by auto
    }
    ultimately show ?thesis
      using Ac_def by simp
  qed
  moreover have "loose_count_code p a = Min {loose_count_code p x | x. x \<in> Ac}"
    and "loose_count_code p c = Min {loose_count_code p x | x. x \<in> Ac}"
    sorry  (* Here you need to provide the proof for this statement *)
  ultimately have "IRV_score_2 a Ac pc - loose_count_code p a = Min {IRV_score_2 x Ac pc - loose_count_code p x | x. x \<in> Ac}"
    and "IRV_score_2 c Ac pc - loose_count_code p c = Min {IRV_score_2 x Ac pc - loose_count_code p x | x. x \<in> Ac}"
    by simp_all
  then have "win_count p a - loose_count_code p a = Min {win_count p x - loose_count_code p x | x. x \<in> Ac}"
    and "win_count p c - loose_count_code p c = Min {win_count p x - loose_count_code p x | x. x \<in> Ac}"
    by (metis diff_diff_add nat_diff_split)+
  moreover have "win_count p a - loose_count_code p a < win_count p c - loose_count_code p c"
    sorry  (* Here you need to provide the proof for this statement *)
  ultimately show False by simp
qed
*)

(*
fun bulk_eliminator :: "'a Evaluation_Function \<Rightarrow> 'a Electoral_Module" where
  "bulk_eliminator e A p =
    (let
      scores = {e x A p | x. x \<in> A};
      min_score = Min scores;
      second_min_score = Min (scores - {min_score});
      losers = {x \<in> A. e x A p < second_min_score}
    in
      if losers = {} then ({}, {}, A) else ({}, losers, A - losers))"*)

(*
fun single_min_eliminator :: "'a::finite Evaluation_Function \<Rightarrow> 'a Electoral_Module" where
  "single_min_eliminator e A p =
    (if A \<noteq> {} then
       let loser = select_one_with_min_score e A p in
       ({}, {loser}, A - {loser})
     else
       ({}, {}, A))"*)

(*Para mejorar IRV*)
(*
fun select_one_loser :: "'a::finite set \<Rightarrow> 'a list \<Rightarrow> 'a" where
  "select_one_loser A p =
    (let
      loser_scores = map (\<lambda>a. (a, sum_IRV_score {a} p)) (set A);
      sorted_losers = sort_key snd loser_scores
     in
      fst (hd sorted_losers))"*)

(*
fun custom_eliminator :: "'a set \<Rightarrow> 'a Electoral_Module" where
  "custom_eliminator losers A p =
    (if (losers \<subseteq> A) then ({}, losers, A - losers)
    else ({}, {}, A))"

fun step_2_modified :: "'a::finite Electoral_Module" where
  "step_2_modified A p =
    (let max_score = max_IRV_score A p;
         losers = {a \<in> A . sum_IRV_score {a} p < max_score}
     in custom_eliminator losers A p)"
*)

(*
fun sorted_list_of_set :: "('a::{linorder}) set \<Rightarrow> 'a list" where
  "sorted_list_of_set A = sort_key (\<lambda>x. x) (sorted_list_of_set A)"*)
(*
fun lexicographic_number :: "('a::{linorder}) \<Rightarrow> 'a list \<Rightarrow> nat" where
  "lexicographic_number x sorted_list =
    (THE i. i < length sorted_list \<and> sorted_list ! i = x)"
*)
(*
fun lexicographic_IRV_score :: "'a::{linorder, finite} Evaluation_Function" where
  "lexicographic_IRV_score x A p =
    win_count p x * (card A + 1) + le"

fun sorted_list_of_set :: "('a::{linorder}) set \<Rightarrow> 'a list" where
  "sorted_list_of_set A = sort_key (\<lambda>x. x) (set A)"

fun lexicographic_number :: "('a::{linorder}) \<Rightarrow> 'a list \<Rightarrow> nat" where
  "lexicographic_number x sorted_list =
    (THE i. i < length sorted_list \<and> sorted_list ! i = x)"

fun lexicographic_IRV_score :: "'a::{linorder, finite} Evaluation_Function" where
  "lexicographic_IRV_score x A p =
     win_count p x * card A + lexicographic_tie_breaker x"

fun IRV_rule_with_lexicographic :: "'a::{linorder, finite} Electoral_Module" where
  "IRV_rule_with_lexicographic A p =
    (((absolute_max \<triangleright> single_eliminator lexicographic_IRV_score )\<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d)\<triangleright> elect_module) A p"
*)

(*
fun mid_step_2 :: "'a Electoral_Module" where
  "mid_step_2 A p= (absolute_max \<triangleright> step_2 ) A p"*)

(*
lemma mid_step_satisfies_independence_of_clones_deferred:
  shows "independence_of_clones_deferred mid_step"
proof (unfold independence_of_clones_deferred_def, clarify)
  fix A :: "'a set" and p :: "'a Profile" and a c pc
  assume defer_a: "a \<in> defer mid_step A p"
    and clone: "c \<notin> A"
    and introduces: "introduces_clone_in_candidate a c p pc"
  let ?B = "A \<union> {c}"

  have "\<exists>a'\<in>defer mid_step A p. \<exists>c. c \<notin> A \<and> introduces_clone_in_candidate a' c p pc"
    using defer_a clone introduces by blast
  then obtain a' where a'_in_defer: "a' \<in> defer mid_step A p" and c_notin_A: "c \<notin> A" and introduces_a': "introduces_clone_in_candidate a' c p pc" by auto

  have "a' \<in> defer mid_step ?B pc"
    using a'_in_defer by (simp add: defer_mid_step_def)
  moreover have "a' \<notin> defer mid_step ?B pc"
  proof
    assume "a' \<in> defer mid_step ?B pc"
    then have "a' \<in> defer mid_step A pc"
      using c_notin_A introduces_a' by (simp add: defer_mid_step_def)
    then show False
      using a'_in_defer by contradiction
  qed
  ultimately show False by simp
qed*)

(*
lemma new_winner_is_clone:
  assumes "independence_of_clones em"
      and "em A p = ({w}, d, A1)"
  shows "\<exists>w'. (let (A', p') = clone_intro A p w in em A' p' = ({w'}, {}, A')) \<and> (w' = w \<or> clones_exist_in_A {w', w} p')"
proof -
  obtain A' p' where clone: "clone_intro A p w = (A', p')" by (cases "clone_intro A p w")
  obtain e' d' A1' where A': "em A' p' = (e', d', A1')" by (cases "em A' p'")
  have "A1' = A' \<and> d' = {} \<and> (\<exists>w'. e' = {w'} \<and> (w' = w \<or> clones_exist_in_A {w', w} p'))"
    using assms clone A' unfolding independence_of_clones_def by blast
  thus ?thesis by (metis A' prod.collapse)
qed*)

(*
lemma IRV_satisfies_independence_of_clones: "independence_of_clones IRV_rule"

lemma IRV_satisfies_independence_of_clones:
  assumes "independence_of_clones IRV_rule"
  shows "\<forall>A p w. case IRV_rule A p of (e, r, A1) \<Rightarrow>
         if A1 = A \<and> r = {} \<and> e = {w} then
           let (A', p') = clone_intro A p w in
             case IRV_rule A' p' of
               (e', r', A1') \<Rightarrow>
                 if A1' = A' \<and> r' = {} then
                   \<exists>w'. e' = {w'} \<and> (w' = w \<or> clones_exist_in_A {w', w} p')
                 else False
         else False"*)
(*
theorem clone_preserves_high_score:
  assumes
    "is_winner a (step_2) A p"
    "introduces_clone_in_candidate a c p pc"
  shows
    "\<not>(score_a_pc < min_score_except_ac \<and> score_c_pc < min_score_except_ac)"
proof -
  (* Define the scores of a in p, a in pc, and c in pc *)
  let ?score_a_p = "IRV_score_2 a A p"
  let ?score_a_pc = "IRV_score_2 a (A \<union> {c}) pc"
  let ?score_c_pc = "IRV_score_2 c (A \<union> {c}) pc"

  (* Define the minimum score in pc excluding a and c *)
  let ?min_score_except_ac = "Min {IRV_score_2 x (A \<union> {c}) pc |x. x \<in> A \<union> {c} \<and> x \<noteq> a \<and> x \<noteq> c}"

  (* Step 1: Show that the score of a in the modified profile pc can't decrease significantly *)
  have score_a_preserved: "?score_a_pc \<ge> ?score_a_p - k"
  proof -

  (* Count the number of ballots where a is the winner in p *)
  let ?win_a_p = "win_count p a"
  (* Count the number of ballots where a is the winner in pc *)
  let ?win_a_pc = "win_count pc a"
  (* Count the number of ballots where a is the least preferred in p *)
  let ?loose_a_p = "loose_count p a"
  (* Count the number of ballots where a is the least preferred in pc *)
  let ?loose_a_pc = "loose_count pc a"
  let ?k1 = "win_count p a"   (* Maximum possible change in win_count is bounded by the original win_count *)
  let ?k2 = "loose_count_code p a"  (* Maximum possible change in loss_count is bounded by the original loss_count *)
 have win_count_close: "?win_a_pc \<ge> ?win_a_p - ?k1"
proof -
  let ?k1 = 1 (* Arbitrarily set k1 to 1 *)

  have win_relation: "win_count pc a = win_count p a + card {i::nat. i < length pc \<and> above (pc!i) a = {a, c}}"
    using assms(2) preservation_of_preferences by ...

  (* The additional wins should not be less than ?k1 *)
  have "card {i::nat. i < length pc \<and> above (pc!i) a = {a, c}} \<ge> ?k1" by ...

  have "?win_a_pc = win_count pc a"
    by simp
  also have "... = win_count p a + card {i::nat. i < length pc \<and> above (pc!i) a = {a, c}}"
    using win_relation
    by simp
  also have "... \<ge> ?win_a_p - ?k1"
    by simp
  finally show "?win_a_pc \<ge> ?win_a_p - ?k1" .
qed
  have loose_count_close: "?loose_a_pc \<ge> ?loose_a_p - ?k2" using assms(2) preservation_of_preferences by ...

  have "?score_a_pc = ?win_a_pc - ?loose_a_pc" by simp
  also have "... \<ge> ?win_a_p - ?k1 - (?loose_a_p - ?k2)" using win_count_close loose_count_close by simp
  also have "... = ?score_a_p - (?k1 + ?k2)" by simp
  finally show "?score_a_pc \<ge> ?score_a_p - (?k1 + ?k2)" .
qed
  (* Step 2: Show that the score of the clone c will be close to the score of a *)
  have score_c_close_to_a: "?score_c_pc \<ge> ?score_a_p - k" for some constant k ...
    using assms(2) preservation_of_preferences ...

  (* Step 3: Conclude that if score_a_p was the highest, neither score_a_pc nor score_c_pc can be the lowest in pc *)
  have "?score_a_pc \<ge> ?min_score_except_ac \<and> ?score_c_pc \<ge> ?min_score_except_ac"
    using score_a_preserved score_c_close_to_a ...

  (* This implies that neither a nor c has the lowest score in pc *)
  show "\<not>(score_a_pc < ?min_score_except_ac \<and> score_c_pc < ?min_score_except_ac)" by simp
qed*)

(*
lemma IRV_satisfies_independence_of_clones:
  shows "independence_of_clones IRV_rule"
unfolding independence_of_clones_def
proof (clarify)
  fix A :: "'a set" and p :: "'a Profile" and a c pc
  assume winner: "a \<in> elect IRV_rule A p"
  and clone: "c \<notin> A"
  and introduces: "introduces_clone_in_candidate a c p pc"
  let ?B = "A \<union> {c}"
  assume B_election: "\<exists> a \<in> elect IRV_rule A p. \<exists>c. c \<notin> A \<and> introduces_clone_in_candidate a c p pc"
  hence "a \<in> elect IRV_rule ?B pc \<or> c \<in> elect IRV_rule ?B pc"
  proof (cases "IRV_rule ?B pc")
    case (fields winners losers remaining)
    then have "a \<in> winners \<or> c \<in> winners" using introduces unfolding introduces_clone_in_candidate_def by auto
    then show ?thesis unfolding is_winner_def by blast
  qed
qed*)

(*Proof mas avanzada*)
(*
lemma IRV_satisfies_independence_of_clones:
  shows "independence_of_clones IRV_rule"
unfolding independence_of_clones_def
proof (clarify)
  fix A :: "'a set" and p :: "'a Profile" and winner :: 'a
  assume IRV_winner: "IRV_rule A p = ({winner}, A-{winner}, {})"
  let ?clone = "clone_intro A p winner"
  obtain e' r' where rule_def: "IRV_rule (fst ?clone) (snd ?clone) = (e', r', {})"
    using prod_cases3 by blast
  have "r' = {}" using rule_def by auto
  moreover have "\<exists>w'. e' = {w'} \<and> (w' = winner \<or> clones_exist_in_A {w', winner} (snd ?clone))"
  proof (cases "e' = {winner}")
    case True
    then show ?thesis by auto
  next
    case False
    then obtain new_winner where new_winner_def: "e' = {new_winner}" by fastforce
    have "new_winner = winner \<or> clones_exist_in_A {new_winner, winner} (snd ?clone)"
    proof (cases "new_winner = winner")
      case True
      then show ?thesis by simp
    next
      case False
      then have "clones_exist_in_A {new_winner, winner} (snd ?clone)"
        using new_winner_def False rule_def IRV_winner by simp
      then show ?thesis by simp
    qed
    then show ?thesis using new_winner_def by auto
  qed
  ultimately show "r' = {} \<and> (\<exists>w'. e' = {w'} \<and> (w' = winner \<or> clones_exist_in_A {w', winner} (snd ?clone)))"
    by auto
qed
*)

(*Multi_winner wrapper*)
(*
fun multi_winner_IRV :: "nat \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a Result" where
"multi_winner_IRV n A p =
  (if A = {} \<or> n > card A
   then Error
   else
    (case IRV_rule3 A p of
      Error \<Rightarrow> Error
    | OK winner \<Rightarrow>
      (case multi_winner_IRV (n - 1) (A - {winner}) p of
        Error \<Rightarrow> Error
      | OK winners \<Rightarrow> OK (insert winner winners))))"
*)

(*
fun multi_winner_IRV_rule :: "nat \<Rightarrow> 'a set \<Rightarrow> 'a Profile \<Rightarrow> 'a set \<times> 'a set \<times> 'a set" where
  "multi_winner_IRV_rule 0 A p = ({}, A, {})"
| "multi_winner_IRV_rule (Suc n) A p = (
    let (elected, rejected, deferred) = IRV_rule A p;
        (new_elected, new_rejected, new_deferred) = multi_winner_IRV_rule n (A - elected) p
    in (elected \<union> new_elected, rejected \<union> new_rejected, deferred \<union> new_deferred))"
*)
(*
fun multi_winner_IRV_rule :: "nat \<Rightarrow> 'a Electoral_Module" where
  "multi_winner_IRV_rule 0 A p = ({}, A, {})"
| "multi_winner_IRV_rule (Suc n) A p = (
    let (elected, rejected, deferred) = IRV_rule A p;
        (new_elected, new_rejected, new_deferred) = multi_winner_IRV_rule n (A - elected) p
    in (elected \<union> new_elected, rejected \<union> new_rejected, new_deferred))" *)

(*Modelo-este debería estar mal
fun multi_winner_IRV_rule :: "nat \<Rightarrow> 'a Electoral_Module" where
  "multi_winner_IRV_rule 0 A p = ({}, A, {})"
| "multi_winner_IRV_rule (Suc n) A p = (
    let (winners, not_losers, losers) = IRV_rule A p;
        (new_winners, new_not_losers, new_losers) = multi_winner_IRV_rule n (A - winners) p
    in (winners \<union> new_winners, new_not_losers, losers \<union> new_losers))" *)

(*Just for the purpose of modelling the absolute majority rule ;) *)
fun abs_rule :: "'a Electoral_Module" where
  "abs_rule A p = elector absolute_max A p"

text \<open>
  These last functions have been developed for test purposes.
  They are commented now for perfomance purposes.
\<close>

(*
fun absolute' :: "'a Electoral_Module" where
"absolute' A p =
  ((min_eliminator abs_score) \<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d) A p"

fun abs_rule' :: "'a Electoral_Module" where
  "abs_rule' A p = iterelect absolute' A p"

fun IRV_rule2 :: "'a Electoral_Module" where
  "IRV_rule2 A p= (((absolute_max \<triangleright> min_eliminator IRV_score )\<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d)) A p"

fun IRV_rule3 :: "'a Electoral_Module" where
  "IRV_rule3 A p= (((abs_rule \<triangleright> min_eliminator IRV_score )\<circlearrowleft>\<^sub>\<exists>\<^sub>!\<^sub>d)) A p"

fun mid_step:: "'a Electoral_Module" where
  "mid_step A p = (absolute_max \<triangleright> min_eliminator IRV_score) A p "
*)

end


(*  Title:      Code_Target_Integer_Bit.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Bit operations for target language integers\<close>

theory Code_Target_Integer_Bit
  imports
    "HOL-Library.Word"
    "Code_Int_Integer_Conversion"
    "../Word_Lib/Most_significant_bit"
    "../Word_Lib/Least_significant_bit"
    "../Word_Lib/Generic_set_bit"
    "../Word_Lib/Bit_Comprehension"
begin

text \<open>TODO: separate\<close>

lemmas [transfer_rule] =
  identity_quotient
  fun_quotient
  Quotient_integer[folded integer.pcr_cr_eq]

lemma undefined_transfer:
  assumes "Quotient R Abs Rep T"
  shows "T (Rep undefined) undefined"
using assms unfolding Quotient_alt_def by blast

bundle undefined_transfer = undefined_transfer[transfer_rule]

section \<open>More lemmas about @{typ integer}s\<close>

context
  includes integer.lifting
begin

lemma integer_of_nat_less_0_conv [simp]: "\<not> integer_of_nat n < 0"
  by transfer simp

lemma int_of_integer_pow: "int_of_integer (x ^ n) = int_of_integer x ^ n"
  by transfer rule

lemma sub1_lt_0_iff [simp]: "Code_Numeral.sub n num.One < 0 \<longleftrightarrow> False"
  by transfer (simp add: sub_negative)

lemma nat_of_integer_numeral [simp]: "nat_of_integer (numeral n) = numeral n"
  by transfer simp

lemma nat_of_integer_sub1_conv_pred_numeral [simp]:
  "nat_of_integer (Code_Numeral.sub n num.One) = pred_numeral n"
  by transfer (simp only: pred_numeral_def int_nat_eq numeral_One int_minus flip: int_int_eq, simp)

lemma nat_of_integer_1 [simp]: "nat_of_integer 1 = 1"
  by transfer simp

lemma dup_1 [simp]: "Code_Numeral.dup 1 = 2"
  by transfer simp

lift_definition bin_rest_integer :: "integer \<Rightarrow> integer" is \<open>\<lambda>k . k div 2\<close> .

lift_definition bin_last_integer :: "integer \<Rightarrow> bool" is odd .

lift_definition Bit_integer :: "integer \<Rightarrow> bool \<Rightarrow> integer" is \<open>\<lambda>k b. of_bool b + 2 * k\<close> .

end

section \<open>Target language implementations\<close>

text \<open>
  Unfortunately, this is not straightforward,
  because these API functions have different signatures and preconditions on the parameters:

  \begin{description}
  \item[Standard ML] Shifts in IntInf are given as word, but not IntInf.
  \item[Haskell] In the Data.Bits.Bits type class, shifts and bit indices are given as Int rather than Integer.
  \end{description}

  Additional constants take only parameters of type @{typ integer} rather than @{typ nat}
  and check the preconditions as far as possible (e.g., being non-negative) in a portable way.
  Manual implementations inside code\_printing perform the remaining range checks and convert
  these @{typ integer}s into the right type.

  For normalisation by evaluation, we derive custom code equations, because NBE
  does not know these code\_printing serialisations and would otherwise loop.
\<close>

code_printing code_module Integer_Bit \<rightharpoonup> (SML)
\<open>structure Integer_Bit : sig
  val test_bit : IntInf.int -> IntInf.int -> bool
  val set_bit : IntInf.int -> IntInf.int -> bool -> IntInf.int
  val shiftl : IntInf.int -> IntInf.int -> IntInf.int
  val shiftr : IntInf.int -> IntInf.int -> IntInf.int
end = struct

val maxWord = IntInf.pow (2, Word.wordSize);

fun test_bit x n =
  if n < maxWord then IntInf.andb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))) <> 0
  else raise (Fail ("Bit index too large: " ^ IntInf.toString n));

fun set_bit x n b =
  if n < maxWord then
    if b then IntInf.orb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n)))
    else IntInf.andb (x, IntInf.notb (IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))))
  else raise (Fail ("Bit index too large: " ^ IntInf.toString n));

fun shiftl x n =
  if n < maxWord then IntInf.<< (x, Word.fromLargeInt (IntInf.toLarge n))
  else raise (Fail ("Shift operand too large: " ^ IntInf.toString n));

fun shiftr x n =
  if n < maxWord then IntInf.~>> (x, Word.fromLargeInt (IntInf.toLarge n))
  else raise (Fail ("Shift operand too large: " ^ IntInf.toString n));

end; (*struct Integer_Bit*)\<close>
code_reserved SML Integer_Bit

code_printing code_module Integer_Bit \<rightharpoonup> (OCaml)
\<open>module Integer_Bit : sig
  val test_bit : Z.t -> Z.t -> bool
  val shiftl : Z.t -> Z.t -> Z.t
  val shiftr : Z.t -> Z.t -> Z.t
end = struct

(* We do not need an explicit range checks here,
   because Big_int.int_of_big_int raises Failure
   if the argument does not fit into an int. *)
let test_bit x n =  Z.testbit x (Z.to_int n);;

let shiftl x n = Z.shift_left x (Z.to_int n);;

let shiftr x n = Z.shift_right x (Z.to_int n);;

end;; (*struct Integer_Bit*)\<close>
code_reserved OCaml Integer_Bit

code_printing code_module Data_Bits \<rightharpoonup> (Haskell)
\<open>
module Data_Bits where {

import qualified Data.Bits;

{-
  The ...Bounded functions assume that the Integer argument for the shift
  or bit index fits into an Int, is non-negative and (for types of fixed bit width)
  less than bitSize
-}

infixl 7 .&.;
infixl 6 `xor`;
infixl 5 .|.;

(.&.) :: Data.Bits.Bits a => a -> a -> a;
(.&.) = (Data.Bits..&.);

xor :: Data.Bits.Bits a => a -> a -> a;
xor = Data.Bits.xor;

(.|.) :: Data.Bits.Bits a => a -> a -> a;
(.|.) = (Data.Bits..|.);

complement :: Data.Bits.Bits a => a -> a;
complement = Data.Bits.complement;

testBitUnbounded :: Data.Bits.Bits a => a -> Integer -> Bool;
testBitUnbounded x b
  | b <= toInteger (Prelude.maxBound :: Int) = Data.Bits.testBit x (fromInteger b)
  | otherwise = error ("Bit index too large: " ++ show b)
;

testBitBounded :: Data.Bits.Bits a => a -> Integer -> Bool;
testBitBounded x b = Data.Bits.testBit x (fromInteger b);

setBitUnbounded :: Data.Bits.Bits a => a -> Integer -> Bool -> a;
setBitUnbounded x n b
  | n <= toInteger (Prelude.maxBound :: Int) =
    if b then Data.Bits.setBit x (fromInteger n) else Data.Bits.clearBit x (fromInteger n)
  | otherwise = error ("Bit index too large: " ++ show n)
;

setBitBounded :: Data.Bits.Bits a => a -> Integer -> Bool -> a;
setBitBounded x n True = Data.Bits.setBit x (fromInteger n);
setBitBounded x n False = Data.Bits.clearBit x (fromInteger n);

shiftlUnbounded :: Data.Bits.Bits a => a -> Integer -> a;
shiftlUnbounded x n
  | n <= toInteger (Prelude.maxBound :: Int) = Data.Bits.shiftL x (fromInteger n)
  | otherwise = error ("Shift operand too large: " ++ show n)
;

shiftlBounded :: Data.Bits.Bits a => a -> Integer -> a;
shiftlBounded x n = Data.Bits.shiftL x (fromInteger n);

shiftrUnbounded :: Data.Bits.Bits a => a -> Integer -> a;
shiftrUnbounded x n
  | n <= toInteger (Prelude.maxBound :: Int) = Data.Bits.shiftR x (fromInteger n)
  | otherwise = error ("Shift operand too large: " ++ show n)
;

shiftrBounded :: (Ord a, Data.Bits.Bits a) => a -> Integer -> a;
shiftrBounded x n = Data.Bits.shiftR x (fromInteger n);

}\<close>

  and \<comment> \<open>@{theory HOL.Quickcheck_Narrowing} maps @{typ integer} to
            Haskell's Prelude.Int type instead of Integer. For compatibility
            with the Haskell target, we nevertheless provide bounded and
            unbounded functions.\<close>
  (Haskell_Quickcheck)
\<open>
module Data_Bits where {

import qualified Data.Bits;

{-
  The functions assume that the Int argument for the shift or bit index is
  non-negative and (for types of fixed bit width) less than bitSize
-}

infixl 7 .&.;
infixl 6 `xor`;
infixl 5 .|.;

(.&.) :: Data.Bits.Bits a => a -> a -> a;
(.&.) = (Data.Bits..&.);

xor :: Data.Bits.Bits a => a -> a -> a;
xor = Data.Bits.xor;

(.|.) :: Data.Bits.Bits a => a -> a -> a;
(.|.) = (Data.Bits..|.);

complement :: Data.Bits.Bits a => a -> a;
complement = Data.Bits.complement;

testBitUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool;
testBitUnbounded = Data.Bits.testBit;

testBitBounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool;
testBitBounded = Data.Bits.testBit;

setBitUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool -> a;
setBitUnbounded x n True = Data.Bits.setBit x n;
setBitUnbounded x n False = Data.Bits.clearBit x n;

setBitBounded :: Data.Bits.Bits a => a -> Prelude.Int -> Bool -> a;
setBitBounded x n True = Data.Bits.setBit x n;
setBitBounded x n False = Data.Bits.clearBit x n;

shiftlUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
shiftlUnbounded = Data.Bits.shiftL;

shiftlBounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
shiftlBounded = Data.Bits.shiftL;

shiftrUnbounded :: Data.Bits.Bits a => a -> Prelude.Int -> a;
shiftrUnbounded = Data.Bits.shiftR;

shiftrBounded :: (Ord a, Data.Bits.Bits a) => a -> Prelude.Int -> a;
shiftrBounded = Data.Bits.shiftR;

}\<close>
code_reserved Haskell Data_Bits

code_printing code_module Integer_Bit \<rightharpoonup> (Scala)
\<open>object Integer_Bit {

def testBit(x: BigInt, n: BigInt) : Boolean =
  if (n.isValidInt)
    x.testBit(n.toInt)
  else
    sys.error("Bit index too large: " + n.toString)

def setBit(x: BigInt, n: BigInt, b: Boolean) : BigInt =
  if (n.isValidInt)
    if (b)
      x.setBit(n.toInt)
    else
      x.clearBit(n.toInt)
  else
    sys.error("Bit index too large: " + n.toString)

def shiftl(x: BigInt, n: BigInt) : BigInt =
  if (n.isValidInt)
    x << n.toInt
  else
    sys.error("Shift index too large: " + n.toString)

def shiftr(x: BigInt, n: BigInt) : BigInt =
  if (n.isValidInt)
    x << n.toInt
  else
    sys.error("Shift index too large: " + n.toString)

} /* object Integer_Bit */\<close>

code_printing
  constant "Bit_Operations.and :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.andb ((_),/ (_))" and
  (OCaml) "Z.logand" and
  (Haskell) "((Data'_Bits..&.) :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "((Data'_Bits..&.) :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) infixl 3 "&"
| constant "Bit_Operations.or :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.orb ((_),/ (_))" and
  (OCaml) "Z.logor" and
  (Haskell) "((Data'_Bits..|.) :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "((Data'_Bits..|.) :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) infixl 1 "|"
| constant "Bit_Operations.xor :: integer \<Rightarrow> integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.xorb ((_),/ (_))" and
  (OCaml) "Z.logxor" and
  (Haskell) "(Data'_Bits.xor :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.xor :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) infixl 2 "^"
| constant "Bit_Operations.not :: integer \<Rightarrow> integer" \<rightharpoonup>
  (SML) "IntInf.notb" and
  (OCaml) "Z.lognot" and
  (Haskell) "(Data'_Bits.complement :: Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.complement :: Prelude.Int -> Prelude.Int)" and
  (Scala) "_.unary'_~"

code_printing constant bin_rest_integer \<rightharpoonup>
  (SML) "IntInf.div ((_), 2)" and
  (OCaml) "Z.shift'_right/ _/ 1" and
  (Haskell) "(Data'_Bits.shiftrUnbounded _ 1 :: Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.shiftrUnbounded _ 1 :: Prelude.Int)" and
  (Scala) "_ >> 1"

context
  includes integer.lifting bit_operations_syntax
begin

lemma bitNOT_integer_code [code]:
  fixes i :: integer shows
  "NOT i = - i - 1"
  by transfer (simp add: not_int_def)

lemma bin_rest_integer_code [code nbe]:
  "bin_rest_integer i = i div 2"
  by transfer rule

lemma bin_last_integer_code [code]:
  "bin_last_integer i \<longleftrightarrow> i AND 1 \<noteq> 0"
  by transfer (simp add: and_one_eq odd_iff_mod_2_eq_one)

lemma bin_last_integer_nbe [code nbe]:
  "bin_last_integer i \<longleftrightarrow> i mod 2 \<noteq> 0"
  by transfer (simp add: odd_iff_mod_2_eq_one)

lemma bitval_bin_last_integer [code_unfold]:
  "of_bool (bin_last_integer i) = i AND 1"
  by transfer (simp add: and_one_eq mod_2_eq_odd)

end

definition integer_test_bit :: "integer \<Rightarrow> integer \<Rightarrow> bool"
  where "integer_test_bit x n = (if n < 0 then undefined x n else bit x (nat_of_integer n))"

declare [[code drop: \<open>bit :: integer \<Rightarrow> nat \<Rightarrow> bool\<close>]]

lemma bit_integer_code [code]:
  "bit x n \<longleftrightarrow> integer_test_bit x (integer_of_nat n)"
  by (simp add: integer_test_bit_def)

lemma integer_test_bit_code [code]:
  "integer_test_bit x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
  "integer_test_bit 0 0 = False"
  "integer_test_bit 0 (Code_Numeral.Pos n) = False"
  "integer_test_bit (Code_Numeral.Pos num.One)      0 = True"
  "integer_test_bit (Code_Numeral.Pos (num.Bit0 n)) 0 = False"
  "integer_test_bit (Code_Numeral.Pos (num.Bit1 n)) 0 = True"
  "integer_test_bit (Code_Numeral.Pos num.One)      (Code_Numeral.Pos n') = False"
  "integer_test_bit (Code_Numeral.Pos (num.Bit0 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Pos n) (Code_Numeral.sub n' num.One)"
  "integer_test_bit (Code_Numeral.Pos (num.Bit1 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Pos n) (Code_Numeral.sub n' num.One)"
  "integer_test_bit (Code_Numeral.Neg num.One)      0 = True"
  "integer_test_bit (Code_Numeral.Neg (num.Bit0 n)) 0 = False"
  "integer_test_bit (Code_Numeral.Neg (num.Bit1 n)) 0 = True"
  "integer_test_bit (Code_Numeral.Neg num.One)      (Code_Numeral.Pos n') = True"
  "integer_test_bit (Code_Numeral.Neg (num.Bit0 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Neg n) (Code_Numeral.sub n' num.One)"
  "integer_test_bit (Code_Numeral.Neg (num.Bit1 n)) (Code_Numeral.Pos n') =
   integer_test_bit (Code_Numeral.Neg (n + num.One)) (Code_Numeral.sub n' num.One)"
  by (simp_all add: integer_test_bit_def bit_integer_def bit_0 flip: bit_not_int_iff')

code_printing constant integer_test_bit \<rightharpoonup>
  (SML) "Integer'_Bit.test'_bit" and
  (OCaml) "Integer'_Bit.test'_bit" and
  (Haskell) "(Data'_Bits.testBitUnbounded :: Integer -> Integer -> Bool)" and
  (Haskell_Quickcheck) "(Data'_Bits.testBitUnbounded :: Prelude.Int -> Prelude.Int -> Bool)" and
  (Scala) "Integer'_Bit.testBit"

context
  includes integer.lifting bit_operations_syntax
begin

lemma lsb_integer_code [code]:
  fixes x :: integer shows
  "lsb x = bit x 0"
by transfer(simp add: lsb_int_def)

definition integer_set_bit :: "integer \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> integer"
where [code del]: "integer_set_bit x n b = (if n < 0 then undefined x n b else set_bit x (nat_of_integer n) b)"

lemma set_bit_integer_code [code]:
  "set_bit x i b = integer_set_bit x (integer_of_nat i) b"
by(simp add: integer_set_bit_def)

lemma set_bit_integer_conv_masks:
  fixes x :: integer shows
  "set_bit x i b = (if b then x OR (push_bit i 1) else x AND NOT (push_bit i 1))"
  by (transfer; rule bit_eqI) (simp add: bit_simps)

end

code_printing constant integer_set_bit \<rightharpoonup>
  (SML) "Integer'_Bit.set'_bit" and
  (Haskell) "(Data'_Bits.setBitUnbounded :: Integer -> Integer -> Bool -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.setBitUnbounded :: Prelude.Int -> Prelude.Int -> Bool -> Prelude.Int)" and
  (Scala) "Integer'_Bit.setBit"

text \<open>
  OCaml.Big\_int does not have a method for changing an individual bit, so we emulate that with masks.
  We prefer an Isabelle implementation, because this then takes care of the signs for AND and OR.
\<close>

context
  includes bit_operations_syntax
begin

lemma integer_set_bit_code [code]:
  "integer_set_bit x n b =
  (if n < 0 then undefined x n b else
   if b then x OR (push_bit (nat_of_integer n) 1)
   else x AND NOT (push_bit (nat_of_integer n) 1))"
  by (auto simp add: integer_set_bit_def not_less set_bit_eq set_bit_def unset_bit_def)

end

definition integer_shiftl :: "integer \<Rightarrow> integer \<Rightarrow> integer"
where [code del]: "integer_shiftl x n = (if n < 0 then undefined x n else push_bit (nat_of_integer n) x)"

declare [[code drop: \<open>push_bit :: nat \<Rightarrow> integer \<Rightarrow> integer\<close>]]

lemma shiftl_integer_code [code]:
  fixes x :: integer shows
  "push_bit n x = integer_shiftl x (integer_of_nat n)"
by(auto simp add: integer_shiftl_def)

context
includes integer.lifting
begin

lemma shiftl_integer_conv_mult_pow2:
  fixes x :: integer shows
  "push_bit n x = x * 2 ^ n"
  by (fact push_bit_eq_mult)

lemma integer_shiftl_code [code]:
  "integer_shiftl x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
  "integer_shiftl x 0 = x"
  "integer_shiftl x (Code_Numeral.Pos n) = integer_shiftl (Code_Numeral.dup x) (Code_Numeral.sub n num.One)"
  "integer_shiftl 0 (Code_Numeral.Pos n) = 0"
     apply (simp_all add: integer_shiftl_def numeral_eq_Suc)
  apply transfer
  apply (simp add: ac_simps)
  done

end

code_printing constant integer_shiftl \<rightharpoonup>
  (SML) "Integer'_Bit.shiftl" and
  (OCaml) "Integer'_Bit.shiftl" and
  (Haskell) "(Data'_Bits.shiftlUnbounded :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.shiftlUnbounded :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) "Integer'_Bit.shiftl"

definition integer_shiftr :: "integer \<Rightarrow> integer \<Rightarrow> integer"
where [code del]: "integer_shiftr x n = (if n < 0 then undefined x n else drop_bit (nat_of_integer n) x)"

declare [[code drop: \<open>drop_bit :: nat \<Rightarrow> integer \<Rightarrow> integer\<close>]]

lemma shiftr_integer_conv_div_pow2:
  includes integer.lifting fixes x :: integer shows
  "drop_bit n x = x div 2 ^ n"
  by (fact drop_bit_eq_div)

lemma shiftr_integer_code [code]:
  fixes x :: integer shows
  "drop_bit n x = integer_shiftr x (integer_of_nat n)"
by(auto simp add: integer_shiftr_def)

code_printing constant integer_shiftr \<rightharpoonup>
  (SML) "Integer'_Bit.shiftr" and
  (OCaml) "Integer'_Bit.shiftr" and
  (Haskell) "(Data'_Bits.shiftrUnbounded :: Integer -> Integer -> Integer)" and
  (Haskell_Quickcheck) "(Data'_Bits.shiftrUnbounded :: Prelude.Int -> Prelude.Int -> Prelude.Int)" and
  (Scala) "Integer'_Bit.shiftr"

lemma integer_shiftr_code [code]:
  includes integer.lifting
  shows
  "integer_shiftr x (Code_Numeral.Neg n) = undefined x (Code_Numeral.Neg n)"
  "integer_shiftr x 0 = x"
  "integer_shiftr 0 (Code_Numeral.Pos n) = 0"
  "integer_shiftr (Code_Numeral.Pos num.One) (Code_Numeral.Pos n) = 0"
  "integer_shiftr (Code_Numeral.Pos (num.Bit0 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Pos n') (Code_Numeral.sub n num.One)"
  "integer_shiftr (Code_Numeral.Pos (num.Bit1 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Pos n') (Code_Numeral.sub n num.One)"
  "integer_shiftr (Code_Numeral.Neg num.One) (Code_Numeral.Pos n) = -1"
  "integer_shiftr (Code_Numeral.Neg (num.Bit0 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Neg n') (Code_Numeral.sub n num.One)"
  "integer_shiftr (Code_Numeral.Neg (num.Bit1 n')) (Code_Numeral.Pos n) =
   integer_shiftr (Code_Numeral.Neg (Num.inc n')) (Code_Numeral.sub n num.One)"
          apply (simp_all add: integer_shiftr_def numeral_eq_Suc drop_bit_Suc)
    apply transfer apply simp
   apply transfer apply simp
  apply transfer apply (simp add: add_One)
  done

context
includes integer.lifting
begin

lemma Bit_integer_code [code]:
  "Bit_integer i False = push_bit 1 i"
  "Bit_integer i True = push_bit 1 i + 1"
  by (transfer; simp)+

lemma msb_integer_code [code]:
  "msb (x :: integer) \<longleftrightarrow> x < 0"
  by transfer (simp add: msb_int_def)

end

context
  includes integer.lifting bit_operations_syntax
begin

lemma bitAND_integer_unfold [code]:
  "x AND y =
   (if x = 0 then 0
    else if x = - 1 then y
    else Bit_integer (bin_rest_integer x AND bin_rest_integer y) (bin_last_integer x \<and> bin_last_integer y))"
  by transfer
    (auto simp add: algebra_simps
      and_int_rec [of _ \<open>_ * 2\<close>] and_int_rec [of \<open>_ * 2\<close>] and_int_rec [of \<open>1 + _ * 2\<close>]
      elim!: evenE oddE)

lemma bitOR_integer_unfold [code]:
  "x OR y =
   (if x = 0 then y
    else if x = - 1 then - 1
    else Bit_integer (bin_rest_integer x OR bin_rest_integer y) (bin_last_integer x \<or> bin_last_integer y))"
  by transfer
    (auto simp add: algebra_simps
      or_int_rec [of _ \<open>_ * 2\<close>] or_int_rec [of _ \<open>1 + _ * 2\<close>] or_int_rec [of \<open>1 + _ * 2\<close>]
      elim!: evenE oddE)

lemma bitXOR_integer_unfold [code]:
  "x XOR y =
   (if x = 0 then y
    else if x = - 1 then NOT y
    else Bit_integer (bin_rest_integer x XOR bin_rest_integer y)
      (\<not> bin_last_integer x \<longleftrightarrow> bin_last_integer y))"
  by transfer
    (auto simp add: algebra_simps
      xor_int_rec [of _ \<open>_ * 2\<close>] xor_int_rec [of \<open>_ * 2\<close>] xor_int_rec [of \<open>1 + _ * 2\<close>]
      elim!: evenE oddE)

end

section \<open>Test code generator setup\<close>

context
  includes bit_operations_syntax
begin

definition bit_integer_test :: "bool" where
  "bit_integer_test =
  (([ -1 AND 3, 1 AND -3, 3 AND 5, -3 AND (- 5)
    , -3 OR 1, 1 OR -3, 3 OR 5, -3 OR (- 5)
    , NOT 1, NOT (- 3)
    , -1 XOR 3, 1 XOR (- 3), 3 XOR 5, -5 XOR (- 3)
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , push_bit 2 1, push_bit 3 (- 1)
    , drop_bit 3 100, drop_bit 3 (- 100)] :: integer list)
  = [ 3, 1, 1, -7
    , -3, -3, 7, -1
    , -2, 2
    , -4, -4, 6, 6
    , 21, -1, 4, -7
    , 4, -8
    , 12, -13] \<and>
    [ bit (5 :: integer) 4, bit (5 :: integer) 2, bit (-5 :: integer) 4, bit (-5 :: integer) 2
    , lsb (5 :: integer), lsb (4 :: integer), lsb (-1 :: integer), lsb (-2 :: integer),
      msb (5 :: integer), msb (0 :: integer), msb (-1 :: integer), msb (-2 :: integer)]
  = [ False, True, True, False,
      True, False, True, False,
      False, False, True, True])"

export_code bit_integer_test checking SML Haskell? Haskell_Quickcheck? OCaml? Scala

notepad begin
have bit_integer_test by eval
have bit_integer_test by normalization
have bit_integer_test by code_simp
end
ML_val \<open>val true = @{code bit_integer_test}\<close>

lemma "x AND y = x OR (y :: integer)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "(x :: integer) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
oops

lemma "(f :: integer \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

end

hide_const bit_integer_test
hide_fact bit_integer_test_def

end


(* Title:     Error_Monad
   Author:    Christian Sternagel
   Author:    René Thiemann
*)

section \<open>The Sum Type as Error Monad\<close>

theory Error_Monad
imports
  "HOL-Library.Monad_Syntax"
  Error_Syntax
begin

text \<open>Make monad syntax (including do-notation) available for the sum type.\<close>
definition bind :: "'e + 'a \<Rightarrow> ('a \<Rightarrow> 'e + 'b) \<Rightarrow> 'e + 'b"
where
  "bind m f = (case m of Inr x \<Rightarrow> f x | Inl e \<Rightarrow> Inl e)"

adhoc_overloading
  Monad_Syntax.bind bind

abbreviation (input) "return \<equiv> Inr"
abbreviation (input) "error \<equiv> Inl"
abbreviation (input) "run \<equiv> projr"

subsection \<open>Monad Laws\<close>

lemma return_bind [simp]:
  "(return x \<bind> f) = f x"
  by (simp add: bind_def)

lemma bind_return [simp]:
  "(m \<bind> return) = m"
  by (cases m) (simp_all add: bind_def)

lemma error_bind [simp]:
  "(error e \<bind> f) = error e"
  by (simp add: bind_def)

lemma bind_assoc [simp]:
  fixes m :: "'a + 'b"
  shows "((m \<bind> f) \<bind> g) = (m \<bind> (\<lambda>x. f x \<bind> g))"
  by (cases m) (simp_all add: bind_def)

definition catch_error :: "'e + 'a \<Rightarrow> ('e \<Rightarrow> 'f + 'a) \<Rightarrow> 'f + 'a"
where
  catch_def: "catch_error m f = (case m of Inl e \<Rightarrow> f e | Inr x \<Rightarrow> Inr x)"

adhoc_overloading
  Error_Syntax.catch catch_error

lemma catch_splits:
  "P (try m catch f) \<longleftrightarrow> (\<forall>e. m = Inl e \<longrightarrow> P (f e)) \<and> (\<forall>x. m = Inr x \<longrightarrow> P (Inr x))"
  "P (try m catch f) \<longleftrightarrow> (\<not> ((\<exists>e. m = Inl e \<and> \<not> P (f e)) \<or> (\<exists>x. m = Inr x \<and> \<not> P (Inr x))))"
  by (case_tac [!] m) (simp_all add: catch_def)

abbreviation update_error :: "'e + 'a \<Rightarrow> ('e \<Rightarrow> 'f) \<Rightarrow> 'f + 'a"
where
  "update_error m f \<equiv> try m catch (\<lambda>x. error (f x))"

adhoc_overloading
  Error_Syntax.update_error update_error

lemma catch_return [simp]:
  "(try return x catch f) = return x" by (simp add: catch_def)

lemma catch_error [simp]:
  "(try error e catch f) = f e" by (simp add: catch_def)

lemma update_error_return [simp]:
  "(m <+? c = return x) \<longleftrightarrow> (m = return x)"
  by (cases m) simp_all

definition "isOK m \<longleftrightarrow> (case m of Inl e \<Rightarrow> False | Inr x \<Rightarrow> True)"

lemma isOK_E [elim]:
  assumes "isOK m"
  obtains x where "m = return x"
  using assms by (cases m) (simp_all add: isOK_def)

lemma isOK_I [simp, intro]:
  "m = return x \<Longrightarrow> isOK m"
  by (cases m) (simp_all add: isOK_def)

lemma isOK_iff:
  "isOK m \<longleftrightarrow> (\<exists>x. m = return x)"
  by blast

lemma isOK_error [simp]:
  "isOK (error x) = False"
  by blast

lemma isOK_bind [simp]:
  "isOK (m \<bind> f) \<longleftrightarrow> isOK m \<and> isOK (f (run m))"
  by (cases m) simp_all

lemma isOK_update_error [simp]:
  "isOK (m <+? f) \<longleftrightarrow> isOK m"
  by (cases m) simp_all

lemma isOK_case_prod [simp]:
  "isOK (case lr of (l, r) \<Rightarrow> P l r) = (case lr of (l, r) \<Rightarrow> isOK (P l r))"
  by (rule prod.case_distrib)

lemma isOK_case_option [simp]:
  "isOK (case x of None \<Rightarrow> P | Some v \<Rightarrow> Q v) = (case x of None \<Rightarrow> isOK P | Some v \<Rightarrow> isOK (Q v))"
  by (cases x) (auto)

lemma isOK_Let [simp]:
  "isOK (Let s f) = isOK (f s)"
  by (simp add: Let_def)

lemma run_bind [simp]:
  "isOK m \<Longrightarrow> run (m \<bind> f) = run (f (run m))"
  by auto

lemma run_catch [simp]:
  "isOK m \<Longrightarrow> run (try m catch f) = run m"
  by auto

fun foldM :: "('a \<Rightarrow> 'b \<Rightarrow> 'e + 'a) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'e + 'a"
where
  "foldM f d [] = return d" |
  "foldM f d (x # xs) = do { y \<leftarrow> f d x; foldM f y xs }"

fun forallM_index_aux :: "('a \<Rightarrow> nat \<Rightarrow> 'e + unit) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> (('a \<times> nat) \<times> 'e) + unit"
where
  "forallM_index_aux P i [] = return ()" |
  "forallM_index_aux P i (x # xs) = do {
    P x i <+? Pair (x, i);
    forallM_index_aux P (Suc i) xs
  }"

lemma isOK_forallM_index_aux [simp]:
  "isOK (forallM_index_aux P n xs) = (\<forall>i < length xs. isOK (P (xs ! i) (i + n)))"
proof (induct xs arbitrary: n)
  case (Cons x xs)
  have "(\<forall>i < length (x # xs). isOK (P ((x # xs) ! i) (i + n))) \<longleftrightarrow>
    (isOK (P x n) \<and> (\<forall>i < length xs. isOK (P (xs ! i) (i + Suc n))))"
    by (auto, case_tac i) (simp_all)
  then show ?case
    unfolding Cons [of "Suc n", symmetric] by simp
qed auto

definition forallM_index :: "('a \<Rightarrow> nat \<Rightarrow> 'e + unit) \<Rightarrow> 'a list \<Rightarrow> (('a \<times> nat) \<times> 'e) + unit"
where
  "forallM_index P xs = forallM_index_aux P 0 xs"

lemma isOK_forallM_index [simp]:
  "isOK (forallM_index P xs) \<longleftrightarrow> (\<forall>i < length xs. isOK (P (xs ! i) i))"
  unfolding forallM_index_def isOK_forallM_index_aux by simp

lemma forallM_index [fundef_cong]:
  fixes c :: "'a \<Rightarrow> nat \<Rightarrow> 'e + unit"
  assumes "\<And>x i. x \<in> set xs \<Longrightarrow> c x i = d x i"
  shows "forallM_index c xs = forallM_index d xs"
proof -
  { fix n
    have "forallM_index_aux c n xs = forallM_index_aux d n xs"
      using assms by (induct xs arbitrary: n) simp_all }
  then show ?thesis by (simp add: forallM_index_def)
qed

hide_const forallM_index_aux

text \<open>
  Check whether @{term f} succeeds for all elements of a given list. In case it doesn't,
  return the first offending element together with the produced error.
\<close>
fun forallM :: "('a \<Rightarrow> 'e + unit) \<Rightarrow> 'a list \<Rightarrow> ('a * 'e) + unit"
where
  "forallM f [] = return ()" |
  "forallM f (x # xs) = f x <+? Pair x \<then> forallM f xs"

lemma isOK_forallM [simp]:
  "isOK (forallM f xs) \<longleftrightarrow> (\<forall>x \<in> set xs. isOK (f x))"
  by (induct xs) (simp_all)

text \<open>
  Check whether @{term f} succeeds for at least one element of a given list.
  In case it doesn't, return the list of produced errors.
\<close>
fun existsM :: "('a \<Rightarrow> 'e + unit) \<Rightarrow> 'a list \<Rightarrow> 'e list + unit"
where
  "existsM f [] = error []" |
  "existsM f (x # xs) = (try f x catch (\<lambda>e. existsM f xs <+? Cons e))"

lemma isOK_existsM [simp]:
  "isOK (existsM f xs) \<longleftrightarrow> (\<exists>x\<in>set xs. isOK (f x))"
proof (induct xs)
  case (Cons x xs)
  show ?case
  proof (cases "f x")
    case (Inl e)
    with Cons show ?thesis by simp
  qed (auto simp add: catch_def)
qed simp

lemma is_OK_if_return [simp]:
  "isOK (if b then return x else m) \<longleftrightarrow> b \<or> isOK m"
  "isOK (if b then m else return x) \<longleftrightarrow> \<not> b \<or> isOK m"
  by simp_all

lemma isOK_if_error [simp]:
  "isOK (if b then error e else m) \<longleftrightarrow> \<not> b \<and> isOK m"
  "isOK (if b then m else error e) \<longleftrightarrow> b \<and> isOK m"
  by simp_all

lemma isOK_if:
  "isOK (if b then x else y) \<longleftrightarrow> b \<and> isOK x \<or> \<not> b \<and> isOK y"
  by simp

fun sequence :: "('e + 'a) list \<Rightarrow> 'e + 'a list"
where
  "sequence [] = Inr []" |
  "sequence (m # ms) = do {
    x \<leftarrow> m;
    xs \<leftarrow> sequence ms;
    return (x # xs)
  }"

subsection \<open>Monadic Map for Error Monad\<close>

fun mapM :: "('a \<Rightarrow> 'e + 'b) \<Rightarrow> 'a list \<Rightarrow> 'e + 'b list"
where
  "mapM f [] = return []" |
  "mapM f (x#xs) = do {
    y \<leftarrow> f x;
    ys \<leftarrow> mapM f xs;
    Inr (y # ys)
  }"

lemma mapM_error:
  "(\<exists>e. mapM f xs = error e) \<longleftrightarrow> (\<exists>x\<in>set xs. \<exists>e. f x = error e)"
proof (induct xs)
  case (Cons x xs)
  then show ?case
    by (cases "f x", simp_all, cases "mapM f xs", simp_all)
qed simp

lemma mapM_return:
  assumes "mapM f xs = return ys"
  shows "ys = map (run \<circ> f) xs \<and> (\<forall>x\<in>set xs. \<forall>e. f x \<noteq> error e)"
using assms
proof (induct xs arbitrary: ys)
  case (Cons x xs ys)
  then show ?case
    by (cases "f x", simp, cases "mapM f xs", simp_all)
qed simp

lemma mapM_return_idx:
  assumes *: "mapM f xs = Inr ys" and "i < length xs"
  shows "\<exists>y. f (xs ! i) = Inr y \<and> ys ! i = y"
proof -
  note ** = mapM_return [OF *, unfolded set_conv_nth]
  with assms have "\<And>e. f (xs ! i) \<noteq> Inl e" by auto
  then obtain y where "f (xs ! i) = Inr y" by (cases "f (xs ! i)") auto
  then have "f (xs ! i) = Inr y \<and> ys ! i = y" unfolding ** [THEN conjunct1] using assms by auto
  then show ?thesis ..
qed

lemma mapM_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "mapM f xs = mapM g ys"
  unfolding assms(1) using assms(2) by (induct ys) auto

lemma bindE [elim]:
  assumes "(p \<bind> f) = return x"
  obtains y where "p = return y" and "f y = return x"
  using assms by (cases p) simp_all

lemma then_return_eq [simp]:
  "(p \<then> q) = return f \<longleftrightarrow> isOK p \<and> q = return f"
  by (cases p) simp_all

fun choice :: "('e + 'a) list \<Rightarrow> 'e list + 'a"
where
  "choice [] = error []" |
  "choice (x # xs) = (try x catch (\<lambda>e. choice xs <+? Cons e))"

declare choice.simps [simp del]

lemma isOK_mapM:
  assumes "isOK (mapM f xs)"
  shows "(\<forall>x. x \<in> set xs \<longrightarrow> isOK (f x)) \<and> run (mapM f xs) = map (\<lambda>x. run (f x)) xs"
  using assms mapM_return[of f xs] by (force simp: isOK_def split: sum.splits)+

fun firstM
  where
    "firstM f [] = error []"
  | "firstM f (x # xs) = (try f x \<then> return x catch (\<lambda>e. firstM f xs <+? Cons e))"

lemma firstM:
  "isOK (firstM f xs) \<longleftrightarrow> (\<exists>x\<in>set xs. isOK (f x))"
  by (induct xs) (auto simp: catch_def split: sum.splits)

lemma firstM_return:
  assumes "firstM f xs = return y"
  shows "isOK (f y) \<and> y \<in> set xs"
  using assms by (induct xs) (auto simp: catch_def split: sum.splits)

end