(*  Title:      HOL/HOLCF/One.thy
    Author:     Oscar Slotosch
*)

section \<open>The unit domain\<close>

theory One
  imports Lift
begin

type_synonym one = "unit lift"

translations
  (type) "one" \<leftharpoondown> (type) "unit lift"

definition ONE :: "one"
  where "ONE \<equiv> Def ()"

text \<open>Exhaustion and Elimination for type \<^typ>\<open>one\<close>\<close>

lemma Exh_one: "t = \<bottom> \<or> t = ONE"
  by (induct t) (simp_all add: ONE_def)

lemma oneE [case_names bottom ONE]: "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = ONE \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
  by (induct p) (simp_all add: ONE_def)

lemma one_induct [case_names bottom ONE]: "P \<bottom> \<Longrightarrow> P ONE \<Longrightarrow> P x"
  by (cases x rule: oneE) simp_all

lemma dist_below_one [simp]: "ONE \<notsqsubseteq> \<bottom>"
  by (simp add: ONE_def)

lemma below_ONE [simp]: "x \<sqsubseteq> ONE"
  by (induct x rule: one_induct) simp_all

lemma ONE_below_iff [simp]: "ONE \<sqsubseteq> x \<longleftrightarrow> x = ONE"
  by (induct x rule: one_induct) simp_all

lemma ONE_defined [simp]: "ONE \<noteq> \<bottom>"
  by (simp add: ONE_def)

lemma one_neq_iffs [simp]:
  "x \<noteq> ONE \<longleftrightarrow> x = \<bottom>"
  "ONE \<noteq> x \<longleftrightarrow> x = \<bottom>"
  "x \<noteq> \<bottom> \<longleftrightarrow> x = ONE"
  "\<bottom> \<noteq> x \<longleftrightarrow> x = ONE"
  by (induct x rule: one_induct) simp_all

lemma compact_ONE: "compact ONE"
  by (rule compact_chfin)

text \<open>Case analysis function for type \<^typ>\<open>one\<close>\<close>

definition one_case :: "'a::pcpo \<rightarrow> one \<rightarrow> 'a"
  where "one_case = (\<Lambda> a x. seq\<cdot>x\<cdot>a)"

translations
  "case x of XCONST ONE \<Rightarrow> t" \<rightleftharpoons> "CONST one_case\<cdot>t\<cdot>x"
  "case x of XCONST ONE :: 'a \<Rightarrow> t" \<rightharpoonup> "CONST one_case\<cdot>t\<cdot>x"
  "\<Lambda> (XCONST ONE). t" \<rightleftharpoons> "CONST one_case\<cdot>t"

lemma one_case1 [simp]: "(case \<bottom> of ONE \<Rightarrow> t) = \<bottom>"
  by (simp add: one_case_def)

lemma one_case2 [simp]: "(case ONE of ONE \<Rightarrow> t) = t"
  by (simp add: one_case_def)

lemma one_case3 [simp]: "(case x of ONE \<Rightarrow> ONE) = x"
  by (induct x rule: one_induct) simp_all

end


section \<open>Simple Data Structures\<close>
theory Simple_Impl
imports
  "../Structural/Rec_Impl"
  "../Structural/Tailrec_Impl"
begin

text \<open>
  We provide some very basic data structures to implement the DFS state
\<close>

subsection \<open> Stack, Pending Stack, and Visited Set \<close>
record 'v simple_state =
  ss_stack :: "('v \<times> 'v set) list"
  on_stack :: "'v set"
  visited :: "'v set"

definition [to_relAPP]: "simple_state_rel erel \<equiv> { (s,s') .
  ss_stack s = map (\<lambda>u. (u,pending s' `` {u})) (stack s') \<and>
  on_stack s = set (stack s') \<and>
  visited s = dom (discovered s') \<and>
  dom (finished s') = dom (discovered s') - set (stack s') \<and> \<comment> \<open>TODO: Hmm, this is an invariant of the abstract\<close>
  set (stack s') \<subseteq> dom (discovered s') \<and>
  (simple_state.more s, state.more s') \<in> erel
}"

lemma simple_state_relI:
  assumes
  "dom (finished s') = dom (discovered s') - set (stack s')"
  "set (stack s') \<subseteq> dom (discovered s')"
  "(m', state.more s') \<in> erel"
  shows "(\<lparr>
    ss_stack = map (\<lambda>u. (u,pending s' `` {u})) (stack s'),
    on_stack = set (stack s'),
    visited = dom (discovered s'),
    \<dots> = m'
  \<rparr>, s')\<in>\<langle>erel\<rangle>simple_state_rel"
  using assms
  unfolding simple_state_rel_def
  by auto

lemma simple_state_more_refine[param]:
  "(simple_state.more_update, state.more_update)
    \<in> (R \<rightarrow> R) \<rightarrow> \<langle>R\<rangle>simple_state_rel \<rightarrow> \<langle>R\<rangle>simple_state_rel"
  apply (clarsimp simp: simple_state_rel_def)
  apply parametricity
  done

text \<open> We outsource the definitions in a separate locale, as we want to re-use them
  for similar implementations \<close>
locale pre_simple_impl = graph_defs
begin

  definition "init_impl e
    \<equiv> RETURN \<lparr> ss_stack = [], on_stack = {}, visited = {}, \<dots> = e \<rparr>"

  definition "is_empty_stack_impl s \<equiv> (ss_stack s = [])"
  definition "is_discovered_impl u s \<equiv> (u\<in>visited s)"
  definition "is_finished_impl u s \<equiv> (u\<in>visited s - (on_stack s))"

  definition "finish_impl u s \<equiv> do {
    ASSERT (ss_stack s \<noteq> [] \<and> u\<in>on_stack s);
    let s = s\<lparr>ss_stack := tl (ss_stack s)\<rparr>;
    let s = s\<lparr>on_stack := on_stack s - {u}\<rparr>;
    RETURN s
    }"

  definition "get_pending_impl s \<equiv> do {
      ASSERT (ss_stack s \<noteq> []);
      let (u,Vs) = hd (ss_stack s);
      if Vs = {} then
        RETURN (u,None,s)
      else do {
        v \<leftarrow> SPEC (\<lambda>v. v\<in>Vs);
        let Vs = Vs - {v};
        let s = s\<lparr> ss_stack := (u,Vs) # tl (ss_stack s) \<rparr>;
        RETURN (u, Some v, s)
      }
    }"

  definition "discover_impl u v s \<equiv> do {
    ASSERT (v\<notin>on_stack s \<and> v\<notin>visited s);
    let s = s\<lparr>ss_stack := (v,E``{v}) # ss_stack s\<rparr>;
    let s = s\<lparr>on_stack := insert v (on_stack s)\<rparr>;
    let s = s\<lparr>visited := insert v (visited s)\<rparr>;
    RETURN s
    }"

  definition "new_root_impl v0 s \<equiv> do {
    ASSERT (v0\<notin>visited s);
    let s = s\<lparr>ss_stack := [(v0,E``{v0})]\<rparr>;
    let s = s\<lparr>on_stack := {v0}\<rparr>;
    let s = s\<lparr>visited := insert v0 (visited s)\<rparr>;
    RETURN s
    }"

  definition "gbs \<equiv> \<lparr>
    gbs_init = init_impl,
    gbs_is_empty_stack = is_empty_stack_impl ,
    gbs_new_root =  new_root_impl ,
    gbs_get_pending = get_pending_impl ,
    gbs_finish =  finish_impl ,
    gbs_is_discovered = is_discovered_impl ,
    gbs_is_finished = is_finished_impl ,
    gbs_back_edge = (\<lambda>u v s. RETURN s) ,
    gbs_cross_edge = (\<lambda>u v s. RETURN s) ,
    gbs_discover = discover_impl
  \<rparr>"

  lemmas gbs_simps[simp, DFS_code_unfold] = gen_basic_dfs_struct.simps[mk_record_simp, OF gbs_def]

  lemmas impl_defs[DFS_code_unfold]
  = init_impl_def is_empty_stack_impl_def new_root_impl_def
    get_pending_impl_def finish_impl_def is_discovered_impl_def
    is_finished_impl_def discover_impl_def

end

text \<open>
  Simple implementation of a DFS. This locale assumes a refinement of the
  parameters, and provides an implementation via a stack and a visited set.
\<close>
locale simple_impl_defs =
  a: param_DFS_defs G param
  + c: pre_simple_impl
  + gen_param_dfs_refine_defs
    where gbsi = c.gbs
    and gbs = a.gbs
    and upd_exti = simple_state.more_update
    and upd_ext = state.more_update
    and V0i = a.V0
    and V0 = a.V0
begin

  sublocale tailrec_impl_defs G c.gds .

  definition "get_pending s \<equiv> \<Union>(set (map (\<lambda>(u,Vs). {u}\<times>Vs) (ss_stack s)))"
  definition "get_stack s \<equiv> map fst (ss_stack s)"
  definition choose_pending
    :: "'v \<Rightarrow> 'v option \<Rightarrow> ('v,'d) simple_state_scheme \<Rightarrow> ('v,'d) simple_state_scheme nres"
    where [DFS_code_unfold]:
  "choose_pending u vo s \<equiv>
    case vo of
      None \<Rightarrow> RETURN s
    | Some v \<Rightarrow> do {
        ASSERT (ss_stack s \<noteq> []);
        let (u,Vs) = hd (ss_stack s);
        RETURN (s\<lparr> ss_stack := (u,Vs-{v})#tl (ss_stack s)\<rparr>)
      }"

  sublocale rec_impl_defs G c.gds get_pending get_stack choose_pending .
end

locale simple_impl =
  a: param_DFS
  + simple_impl_defs
  + param_refinement
    where gbsi = c.gbs
    and gbs = a.gbs
    and upd_exti = simple_state.more_update
    and upd_ext = state.more_update
    and V0i = a.V0
    and V0 = a.V0
    and V=Id
    and S = "\<langle>ES\<rangle>simple_state_rel"
begin

  lemma init_impl: "(ei, e) \<in> ES \<Longrightarrow>
    c.init_impl ei \<le>\<Down>(\<langle>ES\<rangle>simple_state_rel) (RETURN (a.empty_state e))"
    unfolding c.init_impl_def a.empty_state_def simple_state_rel_def
    by (auto)

  lemma new_root_impl:
    "\<lbrakk>a.gen_dfs.pre_new_root v0 s;
      (v0i, v0)\<in>Id; (si, s) \<in> \<langle>ES\<rangle>simple_state_rel\<rbrakk>
      \<Longrightarrow> c.new_root_impl v0 si \<le>\<Down>(\<langle>ES\<rangle>simple_state_rel) (RETURN (a.new_root v0 s))"
      unfolding simple_state_rel_def a.gen_dfs.pre_new_root_def c.new_root_impl_def
      by (auto simp add: a.pred_defs)

  lemma get_pending_impl: "
    \<lbrakk>a.gen_dfs.pre_get_pending s; (si, s) \<in> \<langle>ES\<rangle>simple_state_rel\<rbrakk>
      \<Longrightarrow> c.get_pending_impl si
          \<le> \<Down> (Id \<times>\<^sub>r Id \<times>\<^sub>r \<langle>ES\<rangle>simple_state_rel) (a.get_pending s)"
    apply (unfold a.get_pending_def c.get_pending_impl_def) []
    apply (refine_rcg bind_refine' Let_refine' IdI)
    apply (refine_dref_type)
    apply (auto
        simp: simple_state_rel_def a.gen_dfs.pre_defs a.pred_defs neq_Nil_conv
        dest: DFS_invar.stack_distinct
      )
    done

  lemma inres_get_pending_None_conv: "inres (a.get_pending s0) (v, None, s)
      \<longleftrightarrow> s=s0 \<and> v=hd (stack s0) \<and> pending s0``{hd (stack s0)} = {}"
    unfolding a.get_pending_def
    by (auto simp add: refine_pw_simps)

  lemma inres_get_pending_Some_conv: "inres (a.get_pending s0) (v,Some Vs,s)
      \<longleftrightarrow> v = hd (stack s) \<and> s = s0\<lparr>pending := pending s0 - {(hd (stack s0), Vs)}\<rparr>
       \<and> (hd (stack s0), Vs) \<in> pending s0"
    unfolding a.get_pending_def
    by (auto simp add: refine_pw_simps)

  lemma finish_impl:
    "\<lbrakk>a.gen_dfs.pre_finish v s0 s; (vi, v)\<in>Id; (si, s) \<in> \<langle>ES\<rangle>simple_state_rel\<rbrakk>
     \<Longrightarrow> c.finish_impl v si \<le>\<Down>(\<langle>ES\<rangle>simple_state_rel) (RETURN (a.finish v s))"
      unfolding simple_state_rel_def a.gen_dfs.pre_defs c.finish_impl_def

      (* Proof is fine-tuned to optimize speed *)
      apply (clarsimp simp: inres_get_pending_None_conv)
      apply (frule DFS_invar.stack_distinct)
      apply (simp add: a.pred_defs map_tl)
      apply (clarsimp simp: neq_Nil_conv)
      apply blast
      done

  lemma cross_edge_impl: "
    \<lbrakk>a.gen_dfs.pre_cross_edge u v s0 s;
      (ui, u)\<in>Id; (vi, v)\<in>Id; (si, s) \<in> \<langle>ES\<rangle>simple_state_rel\<rbrakk>
      \<Longrightarrow> (si, a.cross_edge u v s) \<in> \<langle>ES\<rangle>simple_state_rel"
    unfolding simple_state_rel_def a.gen_dfs.pre_defs
    by simp

  lemma back_edge_impl: "
    \<lbrakk>a.gen_dfs.pre_back_edge u v s0 s;
      (ui, u)\<in>Id; (vi, v)\<in>Id; (si, s) \<in> \<langle>ES\<rangle>simple_state_rel\<rbrakk>
      \<Longrightarrow> (si, a.back_edge u v s) \<in> \<langle>ES\<rangle>simple_state_rel"
    unfolding simple_state_rel_def a.gen_dfs.pre_defs
    by simp

  lemma discover_impl:
    "\<lbrakk>a.gen_dfs.pre_discover u v s0 s; (ui, u)\<in>Id; (vi, v)\<in>Id; (si, s) \<in> \<langle>ES\<rangle>simple_state_rel\<rbrakk>
     \<Longrightarrow> c.discover_impl ui vi si \<le>\<Down>(\<langle>ES\<rangle>simple_state_rel) (RETURN (a.discover u v s))"
      unfolding simple_state_rel_def a.gen_dfs.pre_defs c.discover_impl_def
      apply (rule ASSERT_leI)
      apply (clarsimp simp: inres_get_pending_Some_conv)
      apply (frule DFS_invar.stack_discovered)
      apply (auto simp: a.pred_defs) []

      apply (clarsimp simp: inres_get_pending_Some_conv)
      apply (frule DFS_invar.stack_discovered)
      apply (frule DFS_invar.pending_ssE)
      apply (clarsimp simp: a.pred_defs)
      apply blast
      done

  sublocale gen_param_dfs_refine
    where gbsi = c.gbs
    and gbs = a.gbs
    and upd_exti = simple_state.more_update
    and upd_ext = state.more_update
    and V0i = a.V0
    and V0 = a.V0
    and V = Id
    and S = "\<langle>ES\<rangle>simple_state_rel"
    apply unfold_locales
    apply (simp_all add: is_break_param) (* TODO: Strange effect,
      the is_break_param subgoal should not be visible at all!*)

    apply (auto simp: a.is_discovered_def c.is_discovered_impl_def simple_state_rel_def) []

    apply (auto simp: a.is_finished_def c.is_finished_impl_def simple_state_rel_def) []

    apply (auto simp: a.is_empty_stack_def c.is_empty_stack_impl_def simple_state_rel_def) []

    apply (refine_rcg init_impl)

    apply (refine_rcg new_root_impl, simp_all) []

    apply (refine_rcg get_pending_impl) []

    apply (refine_rcg finish_impl, simp_all) []

    apply (refine_rcg cross_edge_impl, simp_all) []

    apply (refine_rcg back_edge_impl, simp_all) []

    apply (refine_rcg discover_impl, simp_all) []
    done

  text \<open> Main outcome of this locale: The simple DFS-Algorithm, which is
    a general DFS scheme itself (and thus open to further refinements),
    and a refinement theorem that states correct refinement of the original DFS \<close>

  lemma simple_refine[refine]: "c.gen_dfs \<le> \<Down>(\<langle>ES\<rangle>simple_state_rel) a.it_dfs"
    using gen_dfs_refine
    by simp

  lemma simple_refineT[refine]: "c.gen_dfsT \<le> \<Down>(\<langle>ES\<rangle>simple_state_rel) a.it_dfsT"
    using gen_dfsT_refine
    by simp

  text \<open>Link with tail-recursive implementation\<close>

  sublocale tailrec_impl G c.gds
    apply unfold_locales
    apply (simp_all add: c.do_action_defs c.impl_defs[abs_def])
    apply (auto simp: pw_leof_iff refine_pw_simps split: prod.splits)
    done

  lemma simple_tailrec_refine[refine]: "tailrec_impl \<le> \<Down>(\<langle>ES\<rangle>simple_state_rel) a.it_dfs"
  proof -
    note tailrec_impl also note simple_refine finally show ?thesis .
  qed

  lemma simple_tailrecT_refine[refine]: "tailrec_implT \<le> \<Down>(\<langle>ES\<rangle>simple_state_rel) a.it_dfsT"
  proof -
    note tailrecT_impl also note simple_refineT finally show ?thesis .
  qed

  text \<open>Link to recursive implementation\<close>
  (* TODO: Currently, we have to prove this invar at several places.
    Maybe it's worth to share in a common locale!?
  *)
  lemma reachable_invar:
    assumes "c.gen_rwof s"
    shows "set (map fst (ss_stack s)) \<subseteq> visited s
      \<and> distinct (map fst (ss_stack s))"
    using assms
    apply (induct rule: establish_rwof_invar[rotated -1, consumes 1])
    apply (simp add: c.do_action_defs c.impl_defs[abs_def])
    apply (refine_rcg refine_vcg)
    apply simp

    unfolding c.gen_step_def c.do_action_defs c.impl_defs[abs_def] c.gds_simps c.gbs_simps
    apply (refine_rcg refine_vcg)
    apply simp_all
    apply (fastforce simp: neq_Nil_conv) []
    apply (fastforce simp: neq_Nil_conv) []
    apply (fastforce simp: neq_Nil_conv) []
    apply (fastforce simp: neq_Nil_conv) []
    done

  sublocale rec_impl G c.gds get_pending get_stack choose_pending
    apply unfold_locales
    unfolding get_pending_def get_stack_def choose_pending_def
    apply (simp_all add: c.do_action_defs c.impl_defs[abs_def])
    apply (auto simp: pw_leof_iff refine_pw_simps pw_le_iff select_def
      split: prod.split) []
    apply (auto simp: pw_leof_iff refine_pw_simps pw_le_iff select_def
      split: prod.split) []

    apply (rule le_ASSERTI)
    apply (unfold c.pre_defs, clarify) []
    apply (frule reachable_invar)

    apply (fastforce simp add: pw_leof_iff refine_pw_simps pw_le_iff neq_Nil_conv
      split: prod.split option.split) []

    apply (unfold c.pre_defs, clarify) []
    apply (frule reachable_invar)
    apply (auto simp: pw_leof_iff refine_pw_simps pw_le_iff select_def c.impl_defs neq_Nil_conv
      split: prod.split option.split) []

    apply (auto simp: pw_leof_iff refine_pw_simps pw_le_iff select_def neq_Nil_conv c.pre_defs c.impl_defs
      split: prod.split if_split_asm) []

    apply (auto simp: pw_leof_iff refine_pw_simps pw_le_iff split: prod.split) []

    apply (auto simp: pw_leof_iff refine_pw_simps pw_le_iff split: prod.split) []

    apply (auto simp: pw_leof_iff refine_pw_simps pw_le_iff split: prod.split) []
    done

  lemma simple_rec_refine[refine]: "rec_impl \<le> \<Down>(\<langle>ES\<rangle>simple_state_rel) a.it_dfs"
  proof -
    note rec_impl also note simple_refine finally show ?thesis .
  qed

end

text \<open> Autoref Setup \<close>

record ('si,'nsi)simple_state_impl =
  ss_stack_impl :: 'si
  ss_on_stack_impl :: 'nsi
  ss_visited_impl :: 'nsi

definition [to_relAPP]: "ss_impl_rel s_rel vis_rel erel \<equiv>
  {(\<lparr>ss_stack_impl = si, ss_on_stack_impl = osi, ss_visited_impl = visi, \<dots> = mi\<rparr>,
    \<lparr>ss_stack = s, on_stack = os, visited = vis, \<dots> = m\<rparr>) |
    si osi visi mi s os vis m.
    (si, s) \<in> s_rel \<and>
    (osi, os) \<in> vis_rel \<and>
    (visi, vis) \<in> vis_rel \<and>
    (mi, m) \<in> erel
  }"

consts
  i_simple_state :: "interface \<Rightarrow> interface \<Rightarrow> interface \<Rightarrow> interface"

lemmas [autoref_rel_intf] = REL_INTFI[of ss_impl_rel i_simple_state]

term simple_state_ext

subsection \<open> Simple state without on-stack \<close>
text \<open> We can further refine the simple implementation and drop the on-stack set \<close>
record ('si,'nsi)simple_state_nos_impl =
  ssnos_stack_impl :: 'si
  ssnos_visited_impl :: 'nsi

definition [to_relAPP]: "ssnos_impl_rel s_rel vis_rel erel \<equiv>
  {(\<lparr>ssnos_stack_impl = si, ssnos_visited_impl = visi, \<dots> = mi\<rparr>,
    \<lparr>ss_stack = s, on_stack = os, visited = vis, \<dots> = m\<rparr>) |
    si visi mi s os vis m.
    (si, s) \<in> s_rel \<and>
    (visi, vis) \<in> vis_rel \<and>
    (mi, m) \<in> erel
  }"

lemmas [autoref_rel_intf] = REL_INTFI[of ssnos_impl_rel i_simple_state]

definition op_nos_on_stack_update
  :: "(_ set \<Rightarrow> _ set) \<Rightarrow> (_,_)simple_state_scheme \<Rightarrow> _"
  where "op_nos_on_stack_update \<equiv> on_stack_update"

context begin interpretation autoref_syn .
lemma [autoref_op_pat_def]: "op_nos_on_stack_update f s
  \<equiv> OP (op_nos_on_stack_update f)$s" by simp

end

lemmas ssnos_unfolds \<comment> \<open>To be unfolded before autoref when using @{term ssnos_impl_rel}\<close>
  = op_nos_on_stack_update_def[symmetric]

lemma [autoref_rules, param]:
  fixes s_rel vis_rel erel
  defines "R \<equiv> \<langle>s_rel,vis_rel,erel\<rangle>ssnos_impl_rel"
  shows
  "(ssnos_stack_impl, ss_stack) \<in>  R \<rightarrow> s_rel"
  "(ssnos_visited_impl, visited) \<in> R \<rightarrow> vis_rel"
  "(simple_state_nos_impl.more, simple_state.more) \<in> R \<rightarrow> erel"
  "(ssnos_stack_impl_update, ss_stack_update) \<in> (s_rel \<rightarrow> s_rel) \<rightarrow> R \<rightarrow> R"
  "(\<lambda>x. x, op_nos_on_stack_update f) \<in> R \<rightarrow> R"
  "(ssnos_visited_impl_update, visited_update) \<in> (vis_rel \<rightarrow> vis_rel) \<rightarrow> R \<rightarrow> R"
  "(simple_state_nos_impl.more_update, simple_state.more_update) \<in> (erel \<rightarrow> erel) \<rightarrow> R \<rightarrow> R"
  "(\<lambda>ns _ ps vs. simple_state_nos_impl_ext ns ps vs, simple_state_ext)
    \<in> s_rel \<rightarrow> ANY_rel \<rightarrow> vis_rel \<rightarrow> erel \<rightarrow> R"
  unfolding ssnos_impl_rel_def R_def op_nos_on_stack_update_def
  apply auto
  apply parametricity+
  done

subsection \<open>Simple state without stack and on-stack\<close>
text \<open>Even further refinement yields an implementation without a stack.
  Note that this only works for structural implementations that provide their own
  stack (e.g., recursive)!\<close>
record ('si,'nsi)simple_state_ns_impl =
  ssns_visited_impl :: 'nsi

definition [to_relAPP]: "ssns_impl_rel (R::('a\<times>'b) set) vis_rel erel \<equiv>
  {(\<lparr>ssns_visited_impl = visi, \<dots> = mi\<rparr>,
    \<lparr>ss_stack = s, on_stack = os, visited = vis, \<dots> = m\<rparr>) |
    visi mi s os vis m.
    (visi, vis) \<in> vis_rel \<and>
    (mi, m) \<in> erel
  }"

lemmas [autoref_rel_intf] = REL_INTFI[of ssns_impl_rel i_simple_state]

definition op_ns_on_stack_update
  :: "(_ set \<Rightarrow> _ set) \<Rightarrow> (_,_)simple_state_scheme \<Rightarrow> _"
  where "op_ns_on_stack_update \<equiv> on_stack_update"

definition op_ns_stack_update
  :: "(_ list \<Rightarrow> _ list) \<Rightarrow> (_,_)simple_state_scheme \<Rightarrow> _"
  where "op_ns_stack_update \<equiv> ss_stack_update"

context begin interpretation autoref_syn .
lemma [autoref_op_pat_def]: "op_ns_on_stack_update f s
  \<equiv> OP (op_ns_on_stack_update f)$s" by simp

lemma [autoref_op_pat_def]: "op_ns_stack_update f s
  \<equiv> OP (op_ns_stack_update f)$s" by simp

end

context simple_impl_defs begin
  thm choose_pending_def[unfolded op_ns_stack_update_def[symmetric], no_vars]

  lemma choose_pending_ns_unfold: "choose_pending u vo s = (
    case vo of None \<Rightarrow> RETURN s
    | Some v \<Rightarrow> do {
          _ \<leftarrow> ASSERT (ss_stack s \<noteq> []);
          RETURN
           (op_ns_stack_update
             ( let
                 (u, Vs) = hd (ss_stack s)
               in (\<lambda>_. (u, Vs - {v}) # tl (ss_stack s))
             )
             s
           )
        })"
    unfolding choose_pending_def op_ns_stack_update_def
    by (auto split: option.split prod.split)

  lemmas ssns_unfolds \<comment> \<open>To be unfolded before autoref when using @{term ssns_impl_rel}.
    Attention: This lemma conflicts with the standard unfolding lemma in
    @{text DFS_code_unfold}, so has to be placed first in an unfold-statement!\<close>
  = op_ns_on_stack_update_def[symmetric] op_ns_stack_update_def[symmetric]
    choose_pending_ns_unfold

end

lemma [autoref_rules, param]:
  fixes s_rel vis_rel erel ANY_rel
  defines "R \<equiv> \<langle>ANY_rel,vis_rel,erel\<rangle>ssns_impl_rel"
  shows
  "(ssns_visited_impl, visited) \<in> R \<rightarrow> vis_rel"
  "(simple_state_ns_impl.more, simple_state.more) \<in> R \<rightarrow> erel"
  "\<And>f. (\<lambda>x. x, op_ns_stack_update f) \<in> R \<rightarrow> R"
  "\<And>f. (\<lambda>x. x, op_ns_on_stack_update f) \<in> R \<rightarrow> R"
  "(ssns_visited_impl_update, visited_update) \<in> (vis_rel \<rightarrow> vis_rel) \<rightarrow> R \<rightarrow> R"
  "(simple_state_ns_impl.more_update, simple_state.more_update) \<in> (erel \<rightarrow> erel) \<rightarrow> R \<rightarrow> R"
  "(\<lambda>_ _ ps vs. simple_state_ns_impl_ext ps vs, simple_state_ext)
    \<in> ANY1_rel \<rightarrow> ANY2_rel \<rightarrow> vis_rel \<rightarrow> erel \<rightarrow> R"
  unfolding ssns_impl_rel_def R_def op_ns_on_stack_update_def op_ns_stack_update_def
  apply auto
  apply parametricity+
  done

lemma [refine_transfer_post_simp]:
  "\<And>a m. a\<lparr>simple_state_nos_impl.more := m::unit\<rparr> = a"
  "\<And>a m. a\<lparr>simple_state_impl.more := m::unit\<rparr> = a"
  "\<And>a m. a\<lparr>simple_state_ns_impl.more := m::unit\<rparr> = a"
  by auto

end


theory Exam imports SeCaV begin

(* S184235 *)

lemma  \<open>\<tturnstile>
  [
    Dis (Neg (Pre 0 []))  (Pre 0 [])
  ]
  \<close>
proof -
   from AlphaDis have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 []),
      Pre 0 []
    ]
    \<close>
     using that by simp
 with Ext have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [],
      Neg (Pre 0 [])

    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

lemma   \<open>\<tturnstile>
  [
    Imp (Neg(Uni (Pre 0 [Var 0]))) (Exi(Neg (Pre 0 [Var 0])))
  ]
  \<close>
proof -
     from AlphaImp have ?thesis if \<open>\<tturnstile>
    [
      Neg (Neg(Uni (Pre 0 [Var 0]))),
      (Exi(Neg (Pre 0 [Var 0])))
    ]
    \<close>
       using that by simp
  with Neg have ?thesis if \<open>\<tturnstile>
    [
      Uni (Pre 0 [Var 0]),
      Exi(Neg (Pre 0 [Var 0]))

    ]
    \<close>
    using that by simp
  with DeltaUni have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [Fun 0[]],
      Exi(Neg (Pre 0 [Var 0]))
    ]
    \<close>
    using that by simp

 with Ext have ?thesis if \<open>\<tturnstile>
    [
      Exi(Neg (Pre 0 [Var 0])),
      Pre 0 [Fun 0[]]
    ]
    \<close>
   using that by simp
  with GammaExi[where t=\<open>Fun 0 []\<close>] have ?thesis if \<open>\<tturnstile>
    [
      Neg (Pre 0 [Fun 0 []]),
      Pre 0 [Fun 0[]]
    ]
    \<close>
    using that by simp
 with Ext have ?thesis if \<open>\<tturnstile>
    [
      Pre 0 [Fun 0[]],
      Neg (Pre 0 [Fun 0 []])
    ]
    \<close>
    using that by simp
  with Basic show ?thesis
    by simp
qed

end


(*  Title:       Interuptible Fold
    Author:      Thomas Tuerk <tuerk@in.tum.de>
*)
header {* Interuptible Fold *}
theory Foldi
imports Main
begin

subsection {* Left folding *}

primrec foldli where
   "foldli [] c f \<sigma> = \<sigma>"
 | "foldli (x#xs) c f \<sigma> =
    (if c \<sigma> then foldli xs c f (f x \<sigma>) else \<sigma>)"

lemma foldli_not_cond [simp] :
   "\<not>(c \<sigma>) \<Longrightarrow>foldli xs c f \<sigma> = \<sigma>"
by (cases xs, simp_all)

lemma foldli_cong [fundef_cong]:
  assumes "l = l'" "\<sigma> = \<sigma>'" "c = c'"
  and ff': "\<And>\<sigma> x. \<lbrakk> x \<in> set l'; c' \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> = f' x \<sigma>"
  shows "foldli l c f \<sigma> = foldli l' c' f' \<sigma>'"
unfolding assms using ff'
by(induct l' arbitrary: \<sigma>') auto

text {* Notice that @{term foldli} is a generalisation of folding that respects the abortion condition. *}
lemma foldli_foldl :
  "foldli xs (\<lambda>_. True) f \<sigma> = foldl (\<lambda>\<sigma> x. f x \<sigma>) \<sigma> xs"
by (induct xs arbitrary: \<sigma>) simp_all

lemma foldli_append :
   "foldli (xs1 @ xs2) c f \<sigma> =
    foldli xs2 c f (foldli xs1 c f \<sigma>)"
by (induct xs1 arbitrary: \<sigma>, simp_all)

lemma foldli_concat :
   "foldli (concat xs) c f \<sigma> =
    foldli xs c (\<lambda>x. foldli x c f) \<sigma>"
by (induct xs arbitrary: \<sigma>, simp_all add: foldli_append)

lemma foldli_map :
  "foldli (map f1 xs) c f2 \<sigma> =
   foldli xs c (f2 \<circ> f1) \<sigma>"
by (induct xs arbitrary: \<sigma>, simp_all)

lemma foldli_snoc :
   "foldli (xs @ [x]) c f \<sigma> =
    (if c (foldli xs c f \<sigma>) then
     f x (foldli xs c f \<sigma>) else (foldli xs c f \<sigma>))"
by (induct xs arbitrary: \<sigma>, simp_all)

lemma foldli_snoc_id[simp]: "foldli l (\<lambda>_. True) (\<lambda>x l. l@[x]) l0 = l0@l"
  by (induct l arbitrary: l0) (auto)

subsection {* Right folding *}

definition foldri :: "'x list \<Rightarrow> ('\<sigma> \<Rightarrow> bool) \<Rightarrow> ('x \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"  where
  "foldri l = foldli (rev l)"

lemma foldri_simp[simp] :
  "foldri [] c f \<sigma> = \<sigma>"
  "foldri (l@[x]) c f \<sigma> = (if c \<sigma> then foldri l c f (f x \<sigma>) else \<sigma>)"
  unfolding foldri_def by simp_all

lemma foldri_simp_Cons[simp] :
  "foldri (x # l) c f \<sigma> = (if (c (foldri l c f \<sigma>)) then  f x (foldri l c f \<sigma>) else (foldri l c f \<sigma>))"
  unfolding foldri_def by (simp add: foldli_append)

lemma foldri_code[code] :
  "foldri [] c f \<sigma> = \<sigma>"
  "foldri (x # l) c f \<sigma> = (let \<sigma>' = foldri l c f \<sigma> in if c \<sigma>' then  f x \<sigma>' else \<sigma>')"
  by simp_all

lemma foldri_not_cond [simp] :
   "\<not>(c \<sigma>) \<Longrightarrow>foldri xs c f \<sigma> = \<sigma>"
unfolding foldri_def by simp

lemma foldri_cong [fundef_cong]:
  assumes "l = l'" "\<sigma> = \<sigma>'" "c = c'"
  and ff': "\<And>\<sigma> x. \<lbrakk> x \<in> set l'; c' \<sigma> \<rbrakk> \<Longrightarrow> f x \<sigma> = f' x \<sigma>"
  shows "foldri l c f \<sigma> = foldri l' c' f' \<sigma>'"
unfolding assms using ff'
by(induct l' arbitrary: \<sigma>') auto

text {* Notice that @{term foldli} is a generalisation of folding that respects the abortion condition. *}
lemma foldri_foldr :
  "foldri xs (\<lambda>_. True) f \<sigma> = foldr (\<lambda>x \<sigma>. f x \<sigma>) xs \<sigma>"
by (induct xs arbitrary: \<sigma>) simp_all

lemma foldri_append :
   "foldri (xs1 @ xs2) c f \<sigma> =
    foldri xs1 c f (foldri xs2 c f \<sigma>)"
unfolding foldri_def
by (simp add: foldli_append)

lemma foldri_concat :
   "foldri (concat xs) c f \<sigma> =
    foldri xs c (\<lambda>x. foldri x c f) \<sigma>"
unfolding foldri_def
by (simp add: rev_concat foldli_concat foldli_map o_def)

lemma foldri_map :
  "foldri (map f1 xs) c f2 \<sigma> =
   foldri xs c (f2 \<circ> f1) \<sigma>"
unfolding foldri_def
by (simp add: rev_map foldli_map)

lemma foldri_cons_id[simp]: "foldri l (\<lambda>_. True) (\<lambda>x l. x#l) [] = l"
  by (induct l) (auto)

end


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

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

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

theory SDS_Automation
  imports
    Preference_Profile_Cmd
    QSOpt_Exact
    "../Social_Decision_Schemes"
keywords
  "derive_orbit_equations"
  "derive_support_conditions"
  "derive_ex_post_conditions"
  "find_inefficient_supports"
  "prove_inefficient_supports"
  "derive_strategyproofness_conditions" :: thy_goal
begin

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

\<close>

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

context preorder_on
begin

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

end

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

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

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

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

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

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

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

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

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

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

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

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

ML_file \<open>randomised_social_choice.ML\<close>
ML_file \<open>sds_automation.ML\<close>

end


section \<open>Preliminaries\<close>

subsection \<open>Status functions\<close>

text \<open>A status function assigns to each n-ary symbol a list of indices between 0 and n-1.
These functions are encapsulated into a separate type, so that recursion on the i-th subterm
does not have to perform out-of-bounds checks (e.g., to ensure termination).\<close>

theory Status
  imports
    First_Order_Terms.Term
begin

typedef 'f status = "{ (\<sigma> :: 'f \<times> nat \<Rightarrow> nat list). (\<forall> f k. set (\<sigma> (f, k)) \<subseteq> {0 ..< k})}"
  morphisms status Abs_status
  by (rule exI[of _ "\<lambda> _. []"]) auto

setup_lifting type_definition_status

lemma status: "set (status \<sigma> (f, n)) \<subseteq> {0 ..< n}"
  by (transfer) auto

lemma status_aux[termination_simp]: "i \<in> set (status \<sigma> (f, length ss)) \<Longrightarrow> ss ! i \<in> set ss"
  using status[of \<sigma> f "length ss"] unfolding set_conv_nth by force

lemma status_termination_simps[termination_simp]:
  assumes i1: "i < length (status \<sigma> (f, length xs))"
  shows "size (xs ! (status \<sigma> (f, length xs) ! i)) < Suc (size_list size xs)" (is "?a < ?c")
proof -
  from i1 have "status \<sigma> (f, length xs) ! i \<in> set (status \<sigma> (f, length xs))" by auto
  from status_aux[OF this] have "?a \<le> size_list size xs" by (auto simp: termination_simp)
  then show ?thesis by auto
qed

lemma status_ne:
  "status \<sigma> (f, n) \<noteq> [] \<Longrightarrow> \<exists>i < n. i \<in> set (status \<sigma> (f, n))"
  using status [of \<sigma> f n]
  by (meson atLeastLessThan_iff set_empty subsetCE subsetI subset_empty)

lemma set_status_nth:
  "length xs = n \<Longrightarrow> i \<in> set (status \<sigma> (f, n)) \<Longrightarrow> i < length xs \<and> xs ! i \<in> set xs"
  using status [of \<sigma> f n] by force

lift_definition full_status :: "'f status" is "\<lambda> (f, n). [0 ..< n]" by auto

lemma full_status[simp]: "status full_status (f, n) = [0 ..< n]"
  by transfer auto

text \<open>An argument position i is simple wrt. some term relation, if the i-th subterm is in relation to the
  full term.\<close>

definition simple_arg_pos :: "('f, 'v) term rel \<Rightarrow> 'f \<times> nat \<Rightarrow> nat \<Rightarrow> bool" where
  "simple_arg_pos rel f i \<equiv> \<forall> ts. i < snd f \<longrightarrow> length ts = snd f \<longrightarrow> (Fun (fst f) ts, ts ! i) \<in> rel"

lemma simple_arg_posI: "\<lbrakk>\<And> ts. length ts = n \<Longrightarrow> i < n \<Longrightarrow> (Fun f ts, ts ! i) \<in> rel\<rbrakk> \<Longrightarrow> simple_arg_pos rel (f, n) i"
  unfolding simple_arg_pos_def by auto

end


theory HeapMemory
  imports "../08FlatCode/ByteCode" Heap
begin

datatype hclosure =
  HConst nat
  | HLam "ptr list" nat

datatype heap_state =
  HS "hclosure heap" "ptr list" "(ptr list \<times> nat) list"

inductive evalh :: "byte_code list \<Rightarrow> heap_state \<Rightarrow> heap_state \<Rightarrow> bool" (infix "\<tturnstile> _ \<leadsto>\<^sub>h" 50) where
  evh_lookup [simp]: "lookup cd pc = Some (BLookup x) \<Longrightarrow> lookup env x = Some v \<Longrightarrow>
    cd \<tturnstile> HS h vs ((env, Suc pc) # sfs) \<leadsto>\<^sub>h HS h (v # vs) ((env, pc) # sfs)"
| evh_pushcon [simp]: "lookup cd pc = Some (BPushCon k) \<Longrightarrow> halloc h (HConst k) = (h', v) \<Longrightarrow>
    cd \<tturnstile> HS h vs ((env, Suc pc) # sfs) \<leadsto>\<^sub>h HS h' (v # vs) ((env, pc) # sfs)"
| evh_pushlam [simp]: "lookup cd pc = Some (BPushLam pc') \<Longrightarrow> halloc h (HLam env pc') = (h', v) \<Longrightarrow>
    cd \<tturnstile> HS h vs ((env, Suc pc) # sfs) \<leadsto>\<^sub>h HS h' (v # vs) ((env, pc) # sfs)"
| evh_apply [simp]: "lookup cd pc = Some BApply \<Longrightarrow> hlookup h v2 = HLam env' pc' \<Longrightarrow>
    cd \<tturnstile> HS h (v1 # v2 # vs) ((env, Suc pc) # sfs) \<leadsto>\<^sub>h
      HS h vs ((v1 # env', pc') # (env, pc) # sfs)"
| evh_return [simp]: "lookup cd pc = Some BReturn \<Longrightarrow>
    cd \<tturnstile> HS h vs ((env, Suc pc) # sfs) \<leadsto>\<^sub>h HS h vs sfs"
| evh_jump [simp]: "lookup cd pc = Some BJump \<Longrightarrow> hlookup h v2 = HLam env' pc' \<Longrightarrow>
    cd \<tturnstile> HS h (v1 # v2 # vs) ((env, Suc pc) # sfs) \<leadsto>\<^sub>h HS h vs ((v1 # env', pc') # sfs)"

theorem determinismh: "cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>h \<Sigma>' \<Longrightarrow> cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>h \<Sigma>'' \<Longrightarrow> \<Sigma>' = \<Sigma>''"
proof (induction cd \<Sigma> \<Sigma>' rule: evalh.induct)
  case (evh_lookup cd pc x env v h vs sfs)
  from evh_lookup(3, 1, 2) show ?case
    by (induction cd "HS h vs ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalh.induct) simp_all
next
  case (evh_pushcon cd pc k h h' v vs env sfs)
  from evh_pushcon(3, 1, 2) show ?case
    by (induction cd "HS h vs ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalh.induct) simp_all
next
  case (evh_pushlam cd pc pc' h env h' v vs sfs)
  from evh_pushlam(3, 1, 2) show ?case
    by (induction cd "HS h vs ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalh.induct) simp_all
next
  case (evh_apply cd pc h v2 env' pc' v1 vs env sfs)
  from evh_apply(3, 1, 2) show ?case
    by (induction cd "HS h (v1 # v2 # vs) ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalh.induct)
       simp_all
next
  case (evh_return cd pc h vs env sfs)
  from evh_return(2, 1) show ?case
    by (induction cd "HS h vs ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalh.induct) simp_all
next
  case (evh_jump cd pc h v2 env' pc' v1 vs env sfs)
  from evh_jump(3, 1, 2) show ?case
    by (induction cd "HS h (v1 # v2 # vs) ((env, Suc pc) # sfs)" \<Sigma>'' rule: evalh.induct)
       simp_all
qed

end


theory ML_Term
  imports Main
begin

ML \<open>
  local
    structure Data = Generic_Data
    (
      type T = term
      val empty : T = @{term True}
      val extend = I;
      fun merge (t1,_) = t1
    );

    val get_term = Data.get

    fun ml_term (ctx:Proof.context) (source:Symbol_Pos.T list) =
      let val range = Symbol_Pos.range source
          val str = Symbol_Pos.implode source
          val source' = Input.source true str range
          val ctx' =
            ML_Context.expression range
              "term" "term"
              "fn ctx => set_term term ctx"
            (ML_Lex.read_source false source')
              (Context.Proof ctx)
          val term = get_term ctx'
       in
        term
      end
  in
    val set_term = Data.put
    fun ml_term_tr content (ctx:Proof.context) args =
      let fun err () = raise TERM ("string_tr", args) in
        (case args of
          [(c as Const (@{syntax_const "_constrain"}, _)) $ Free (s, _) $ p] =>
            (case Term_Position.decode_position p of
              SOME (pos, _) => c $ ml_term ctx (content (s, pos)) $ p
            | NONE => err ())
        | _ => err ())
      end;
  end;
\<close>

syntax "_ml_term" :: "cartouche_position \<Rightarrow> term" ("@_")
syntax "_ml_term" :: "cartouche_position \<Rightarrow> prop" ("PROP @_")
parse_translation \<open>[(@{syntax_const "_ml_term"},
    ml_term_tr (Symbol_Pos.cartouche_content o Symbol_Pos.explode))]\<close>

(* Testing *)
ML {* val test_goal = @{prop "1=2"} *}
lemma "a@bv==c"  oops
lemma "PROP @\<open>test_goal\<close>" oops

end


(*  Title:       Proving the Correctness of Disk Paxos

    Author:      Mauro J. Jaskelioff, Stephan Merz, 2005
    Maintainer:  Mauro J. Jaskelioff <mauro at fceia.unr.edu.ar>
*)

header "Disk Paxos Algorithm Specification"

theory DiskPaxos_Model imports Main begin

text{* This is the specification of the Disk Synod algorithm. *}

typedecl InputsOrNi
typedecl Disk
typedecl Proc

axiomatization
  Inputs :: "InputsOrNi set" and
  NotAnInput :: "InputsOrNi" and
  Ballot :: "Proc \<Rightarrow> nat set" and
  IsMajority :: "Disk set \<Rightarrow> bool"
where
  NotAnInput: "NotAnInput \<notin> Inputs" and
  InputsOrNi: "(UNIV :: InputsOrNi set) = Inputs \<union> {NotAnInput}" and
  Ballot_nzero: "\<forall>p. 0 \<notin> Ballot p" and
  Ballot_disj: "\<forall>p q. p \<noteq> q \<longrightarrow> (Ballot p) \<inter> (Ballot q) = {}" and
  Disk_isMajority: "IsMajority(UNIV)" and
  majorities_intersect:
    "\<forall>S T. IsMajority(S) \<and> IsMajority(T) \<longrightarrow> S \<inter> T \<noteq> {}"

lemma ballots_not_zero [simp]:
  "b \<in> Ballot p \<Longrightarrow> 0 < b"
proof (rule ccontr)
  assume b: "b \<in> Ballot p"
  and contr: "\<not> (0 < b)"
  from Ballot_nzero
  have "0 \<notin> Ballot p" ..
  with b contr
  show "False"
    by auto
qed

lemma majority_nonempty [simp]: "IsMajority(S) \<Longrightarrow> S \<noteq> {}"
proof(auto)
  from majorities_intersect
  have "IsMajority({}) \<and> IsMajority({}) \<longrightarrow> {} \<inter> {} \<noteq> {}"
    by auto
  thus "IsMajority {} \<Longrightarrow> False"
    by auto
qed

definition AllBallots :: "nat set"
  where "AllBallots = (UN p. Ballot p)"

record
  DiskBlock =
    mbal:: nat
    bal :: nat
    inp :: InputsOrNi

definition InitDB :: DiskBlock
  where "InitDB = \<lparr> mbal = 0, bal = 0, inp = NotAnInput \<rparr>"

record
  BlockProc =
    block :: DiskBlock
    proc  :: Proc

record
  state =
    inpt :: "Proc \<Rightarrow> InputsOrNi"
    outpt :: "Proc \<Rightarrow> InputsOrNi"
    disk :: "Disk \<Rightarrow> Proc \<Rightarrow> DiskBlock"
    dblock :: "Proc \<Rightarrow> DiskBlock"
    phase :: "Proc \<Rightarrow> nat"
    disksWritten :: "Proc \<Rightarrow> Disk set"
    blocksRead :: "Proc \<Rightarrow> Disk \<Rightarrow> BlockProc set"
  (* History Variables *)
    allInput  :: "InputsOrNi set"
    chosen    :: "InputsOrNi"

definition hasRead :: "state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool"
  where "hasRead s p d q = (\<exists> br \<in> blocksRead s p d. proc br = q)"

definition allRdBlks :: "state \<Rightarrow> Proc \<Rightarrow> BlockProc set"
  where "allRdBlks s p = (UN d. blocksRead s p d)"

definition allBlocksRead :: "state \<Rightarrow> Proc \<Rightarrow> DiskBlock set"
  where "allBlocksRead s p = block ` (allRdBlks s p)"

definition Init :: "state \<Rightarrow> bool"
  where
    "Init s =
      (range (inpt s) \<subseteq> Inputs
     & outpt s = (\<lambda>p. NotAnInput)
     & disk s = (\<lambda>d p. InitDB)
     & phase s = (\<lambda>p. 0)
     & dblock s = (\<lambda>p. InitDB)
     & disksWritten s = (\<lambda>p. {})
     & blocksRead s = (\<lambda>p d. {}))"

definition InitializePhase :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
  where
  "InitializePhase s s' p =
    (disksWritten s' = (disksWritten s)(p := {})
   & blocksRead s' = (blocksRead s)(p := (\<lambda>d. {})))"

definition StartBallot :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "StartBallot s s' p =
    (phase s p \<in> {1,2}
   & phase s' = (phase s)(p := 1)
   & (\<exists>b \<in> Ballot p.
         mbal (dblock s p) < b
       & dblock s' = (dblock s)(p := (dblock s p)\<lparr> mbal := b \<rparr>))
   & InitializePhase s s' p
   & inpt s' = inpt s & outpt s' = outpt s & disk s' = disk s)"

definition Phase1or2Write :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "Phase1or2Write s s' p d =
    (phase s p \<in> {1, 2}
   \<and> disk s' = (disk s) (d := (disk s d) (p := dblock s p))
   \<and> disksWritten s' = (disksWritten s) (p:= (disksWritten s p) \<union> {d})
   \<and> inpt s' = inpt s \<and> outpt s'= outpt s
   \<and> phase s' = phase s \<and> dblock s' = dblock s
   \<and> blocksRead s'= blocksRead s)"

definition Phase1or2ReadThen :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool"
where
  "Phase1or2ReadThen s s' p d q =
    (d \<in> disksWritten s p
   & mbal(disk s d q) < mbal(dblock s p)
   & blocksRead s' = (blocksRead s)(p := (blocksRead s p)(d :=
                       (blocksRead s p d) \<union> {\<lparr> block = disk s d q,
                                               proc = q \<rparr>}))
   & inpt s' = inpt s & outpt s' = outpt s
   & disk s' = disk s & phase s' = phase s
   & dblock s' = dblock s & disksWritten s' = disksWritten s)"

definition Phase1or2ReadElse :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool"
where
  "Phase1or2ReadElse s s' p d q =
    (d \<in> disksWritten s p
   \<and> StartBallot s s' p)"

definition Phase1or2Read :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool"
where
  "Phase1or2Read s s' p d q =
     (Phase1or2ReadThen s s' p d q
    \<or> Phase1or2ReadElse s s' p d q)"

definition blocksSeen :: "state \<Rightarrow> Proc \<Rightarrow> DiskBlock set"
  where "blocksSeen s p = allBlocksRead s p \<union> {dblock s p}"

definition nonInitBlks :: "state \<Rightarrow> Proc \<Rightarrow> DiskBlock set"
  where"nonInitBlks s p = {bs . bs \<in> blocksSeen s p \<and> inp bs \<in> Inputs}"

definition maxBlk :: "state \<Rightarrow> Proc \<Rightarrow> DiskBlock"
where
  "maxBlk s p =
     (SOME b. b \<in> nonInitBlks s p \<and> (\<forall>c \<in> nonInitBlks s p. bal c \<le> bal b))"

definition EndPhase1 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "EndPhase1 s s' p =
    (IsMajority {d . d \<in> disksWritten s p
                     \<and> (\<forall>q \<in> UNIV - {p}. hasRead s p d q)}
   \<and> phase s p = 1
   \<and> dblock s' = (dblock s) (p := dblock s p
           \<lparr> bal := mbal(dblock s p),
             inp :=
              (if nonInitBlks s p = {}
               then inpt s p
               else inp (maxBlk s p))
           \<rparr> )
   \<and> outpt s' = outpt s
   \<and> phase s' = (phase s) (p := phase s p + 1)
   \<and> InitializePhase s s' p
   \<and> inpt s' = inpt s \<and> disk s' = disk s)"

definition EndPhase2 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "EndPhase2 s s' p =
    (IsMajority {d . d \<in> disksWritten s p
                     \<and> (\<forall>q \<in> UNIV - {p}. hasRead s p d q)}
   \<and> phase s p = 2
   \<and> outpt s' = (outpt s) (p:= inp (dblock s p))
   \<and> dblock s' = dblock s
   \<and> phase s' = (phase s) (p := phase s p + 1)
   \<and> InitializePhase s s' p
   \<and> inpt s' = inpt s \<and> disk s' = disk s)"

definition EndPhase1or2 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
  where "EndPhase1or2 s s' p = (EndPhase1 s s' p \<or> EndPhase2 s s' p)"

definition Fail :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "Fail s s' p =
    (\<exists>ip \<in> Inputs. inpt s' = (inpt s) (p := ip)
   \<and> phase s' = (phase s) (p := 0)
   \<and> dblock s'= (dblock s) (p := InitDB)
   \<and> outpt s' = (outpt s) (p := NotAnInput)
   \<and> InitializePhase s s' p
   \<and> disk s'= disk s)"

definition Phase0Read :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool"
where
  "Phase0Read s s' p d =
    (phase s p = 0
   \<and> blocksRead s' = (blocksRead s) (p := (blocksRead s p) (d := blocksRead s p d \<union> {\<lparr> block = disk s d p, proc = p \<rparr>}))
   \<and> inpt s' = inpt s & outpt s' = outpt s
   \<and> disk s' = disk s & phase s' = phase s
   \<and> dblock s' = dblock s & disksWritten s' = disksWritten s)"

definition EndPhase0 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool"
where
  "EndPhase0 s s' p =
    (phase s p = 0
   \<and> IsMajority ({d. hasRead s p d p})
   \<and> (\<exists>b \<in> Ballot p.
       (\<forall>r \<in> allBlocksRead s p. mbal r < b)
     \<and> dblock s' = (dblock s) ( p:=
                    (SOME r.   r \<in> allBlocksRead s p
                            \<and> (\<forall>s \<in> allBlocksRead s p. bal s \<le>  bal r)) \<lparr> mbal := b \<rparr> ))
   \<and> InitializePhase s s' p
   \<and> phase s' = (phase s) (p:= 1)
   \<and> inpt s' = inpt s \<and> outpt s' = outpt s \<and> disk s' = disk s)"

definition Next :: "state \<Rightarrow> state \<Rightarrow> bool"
where
  "Next s s' = (\<exists>p.
                  StartBallot s s' p
                \<or> (\<exists>d.   Phase0Read s s' p d
                       \<or> Phase1or2Write s s' p d
                       \<or> (\<exists>q. q \<noteq> p \<and> Phase1or2Read s s' p d q))
                \<or> EndPhase1or2 s s' p
                \<or> Fail s s' p
                \<or> EndPhase0 s s' p)"

text {*
  In the following, for each action or state {\em name} we name
  {\em Hname} the corresponding action that includes
  the history part of the HNext action or state predicate that includes
  history variables.
*}

definition HInit :: "state \<Rightarrow> bool"
where
  "HInit s =
    (Init s
   & chosen s = NotAnInput
   & allInput s = range (inpt s))"

text {* HNextPart is the part of the Next action
        that is concerned with history variables.
*}

definition HNextPart :: "state \<Rightarrow> state => bool"
where
  "HNextPart s s' =
    (chosen s' =
       (if chosen s \<noteq> NotAnInput \<or> (\<forall>p. outpt s' p = NotAnInput )
            then chosen s
            else outpt s' (SOME p. outpt s' p \<noteq> NotAnInput))
   \<and> allInput s' = allInput s \<union> (range (inpt s')))"

definition HNext :: "state \<Rightarrow> state \<Rightarrow> bool"
where
  "HNext s s' =
     (Next s s'
   \<and> HNextPart s s')"

text {*
  We add HNextPart to every action (rather than proving that Next
  maintains the HInv invariant) to make proofs easier.
*}

definition
  HPhase1or2ReadThen :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool" where
  "HPhase1or2ReadThen s s' p d q = (Phase1or2ReadThen s s' p d q \<and> HNextPart s s')"

definition
  HEndPhase1 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool" where
  "HEndPhase1 s s' p = (EndPhase1 s s' p \<and> HNextPart s s')"

definition
  HStartBallot :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool" where
  "HStartBallot s s' p = (StartBallot s s' p \<and> HNextPart s s')"

definition
  HPhase1or2Write :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool" where
  "HPhase1or2Write s s' p d = (Phase1or2Write s s' p d \<and> HNextPart s s')"

definition
  HPhase1or2ReadElse :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> Proc \<Rightarrow> bool" where
  "HPhase1or2ReadElse s s' p d q = (Phase1or2ReadElse s s' p d q \<and> HNextPart s s')"

definition
  HEndPhase2 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool" where
  "HEndPhase2 s s' p = (EndPhase2 s s' p \<and> HNextPart s s')"

definition
  HFail :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool" where
  "HFail s s' p = (Fail s s' p  \<and> HNextPart s s')"

definition
  HPhase0Read :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> Disk \<Rightarrow> bool" where
  "HPhase0Read s s' p d = (Phase0Read s s' p d \<and> HNextPart s s')"

definition
  HEndPhase0 :: "state \<Rightarrow> state \<Rightarrow> Proc \<Rightarrow> bool" where
  "HEndPhase0 s s' p = (EndPhase0 s s' p \<and> HNextPart s s')"

text {*
  Since these definitions are the conjunction of two other definitions
  declaring them as simplification rules should be harmless.
*}

declare HPhase1or2ReadThen_def [simp]
declare HPhase1or2ReadElse_def [simp]
declare HEndPhase1_def  [simp]
declare HStartBallot_def  [simp]
declare HPhase1or2Write_def [simp]
declare HEndPhase2_def [simp]
declare HFail_def [simp]
declare HPhase0Read_def [simp]
declare HEndPhase0_def [simp]

end


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

  Project: Refining Authenticated Key Agreement with Strong Adversaries

  Module:  Infra.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Infra.thy 132861 2016-12-21 10:34:41Z csprenge $
  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Infrastructure for refinement proofs (attributes, prover tuning etc)

  Copyright (c) 2009-2016 Christoph Sprenger
  Licence: LGPL

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

section \<open>Proving infrastructure\<close>

theory Infra imports Main
begin

(******************************************************************************)
subsection \<open>Prover configuration\<close>
(******************************************************************************)

declare if_split_asm [split]

(******************************************************************************)
subsection \<open>Forward reasoning ("attributes")\<close>
(******************************************************************************)

text \<open>The following lemmas are used to produce intro/elim rules from
set definitions and relation definitions.\<close>

lemmas set_def_to_intro = meta_eq_to_obj_eq [THEN eqset_imp_iff, THEN iffD2]
lemmas set_def_to_dest = meta_eq_to_obj_eq [THEN eqset_imp_iff, THEN iffD1]
lemmas set_def_to_elim = set_def_to_dest [elim_format]

lemmas setc_def_to_intro =
  set_def_to_intro [where B="{x. P x}" for P, to_pred]

lemmas setc_def_to_dest =
  set_def_to_dest [where B="{x. P x}" for P, to_pred]

lemmas setc_def_to_elim = setc_def_to_dest [elim_format]

lemmas rel_def_to_intro = setc_def_to_intro [where x="(s, t)" for s t]
lemmas rel_def_to_dest = setc_def_to_dest [where x="(s, t)" for s t]
lemmas rel_def_to_elim = rel_def_to_dest [elim_format]

(******************************************************************************)
subsection \<open>General results\<close>
(******************************************************************************)

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

text \<open>We usually remove @{term"domIff"} from the simpset and clasets due
to annoying behavior. Sometimes the lemmas below are more well-behaved than
@{term "domIff"}. Usually to be used as "dest: dom\_lemmas". However, adding
them as permanent dest rules slows down proofs too much, so we refrain from
doing this.\<close>

lemma map_definedness:
  "f x = Some y \<Longrightarrow> x \<in> dom f"
by (simp add: domIff)

lemma map_definedness_contra:
  "\<lbrakk> f x = Some y; z \<notin> dom f \<rbrakk> \<Longrightarrow> x \<noteq> z"
by (auto simp add: domIff)

lemmas dom_lemmas = map_definedness map_definedness_contra

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

lemma vimage_image_subset: "A \<subseteq> f-`(f`A)"
by (auto simp add: image_def vimage_def)

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

lemma Image_compose [simp]:
  "(R1 O R2)``A  = R2``(R1``A)"
by (auto)

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

\<comment> \<open>Do NOT add the following equation to the simpset! (looping)\<close>
lemma map_comp: "map (g o f) = map g o map f"
by (simp)

declare map_comp_map [simp del]

lemma take_prefix: "\<lbrakk> take n l = xs \<rbrakk> \<Longrightarrow> \<exists>xs'. l = xs @ xs'"
by (induct l arbitrary: n xs, auto)
   (rename_tac n, case_tac n, auto)

subsubsection \<open>Finite sets\<close>
(******************************************************************************)

text \<open>Cardinality.\<close>

declare arg_cong [where f=card, intro]

lemma finite_positive_cardI [intro!]:
  "\<lbrakk> A \<noteq> {}; finite A \<rbrakk> \<Longrightarrow> 0 < card A"
by (auto)

lemma finite_positive_cardD [dest!]:
  "\<lbrakk> 0 < card A; finite A \<rbrakk> \<Longrightarrow> A \<noteq> {}"
by (auto)

lemma finite_zero_cardI [intro!]:
  "\<lbrakk> A = {}; finite A \<rbrakk> \<Longrightarrow> card A = 0"
by (auto)

lemma finite_zero_cardD [dest!]:
  "\<lbrakk> card A = 0; finite A \<rbrakk> \<Longrightarrow> A = {}"
by (auto)

end


(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section \<open>\isaheader{Implementation of a trie with explicit invariants}\<close>
theory Trie_Impl imports
  "../../Lib/Assoc_List"
  Trie
begin

subsection \<open>Interuptible iterator\<close>

fun iteratei_postfixed :: "'key list \<Rightarrow> ('key, 'val) trie \<Rightarrow>
    ('key list \<times> 'val, '\<sigma>) set_iterator"
where
  "iteratei_postfixed ks (Trie vo ts) c f \<sigma> =
   (if c \<sigma>
    then foldli ts c (\<lambda>(k, t) \<sigma>. iteratei_postfixed (k # ks) t c f \<sigma>)
           (case vo of None \<Rightarrow> \<sigma> | Some v \<Rightarrow> f (ks, v) \<sigma>)
    else \<sigma>)"

definition iteratei :: "('key, 'val) trie \<Rightarrow> ('key list \<times> 'val, '\<sigma>) set_iterator"
where "iteratei t c f \<sigma> = iteratei_postfixed [] t c f \<sigma>"

lemma iteratei_postfixed_interrupt:
  "\<not> c \<sigma> \<Longrightarrow> iteratei_postfixed ks t c f \<sigma> = \<sigma>"
by(cases t) simp

lemma iteratei_interrupt:
  "\<not> c \<sigma> \<Longrightarrow> iteratei t c f \<sigma> = \<sigma>"
unfolding iteratei_def by (simp add: iteratei_postfixed_interrupt)

lemma iteratei_postfixed_alt_def :
  "iteratei_postfixed ks ((Trie vo ts)::('key, 'val) trie) =
   (set_iterator_union
     (case_option set_iterator_emp (\<lambda>v. set_iterator_sng (ks, v)) vo)
     (set_iterator_image snd
     (set_iterator_product (foldli ts)
        (\<lambda>(k, t'). iteratei_postfixed (k # ks) t'))
     ))"
proof -
  have aux: "\<And>c f. (\<lambda>(k, t). iteratei_postfixed (k # ks) t c f) =
              (\<lambda>a. iteratei_postfixed (fst a # ks) (snd a) c f)"
    by auto

  show ?thesis
    apply (rule ext)+ apply (rename_tac c f \<sigma>)
    apply (simp add: set_iterator_product_def set_iterator_image_filter_def
                     set_iterator_union_def set_iterator_sng_def set_iterator_image_alt_def
                     case_prod_beta set_iterator_emp_def
            split: option.splits)
    apply (simp add: aux)
  done
qed

lemma iteratei_postfixed_correct :
  assumes invar: "invar_trie (t :: ('key, 'val) trie)"
  shows "set_iterator ((iteratei_postfixed ks0 t)::('key list \<times> 'val, '\<sigma>) set_iterator)
           ((\<lambda>ksv. (rev (fst ksv) @ ks0, (snd ksv))) ` (map_to_set (lookup_trie t)))"
using invar
proof (induct t arbitrary: ks0)
  case (Trie vo kvs)
  note ind_hyp = Trie(1)
  note invar = Trie(2)

  from invar
  have dist_fst_kvs : "distinct (map fst kvs)"
   and dist_kvs: "distinct kvs"
   and invar_child: "\<And>k t. (k, t) \<in> set kvs \<Longrightarrow> invar_trie t"
  by (simp_all add: Ball_def distinct_map)

  \<comment> \<open>root iterator\<close>
  define it_vo :: "('key list \<times> 'val, '\<sigma>) set_iterator"
    where "it_vo =
      (case vo of None \<Rightarrow> set_iterator_emp
       | Some v \<Rightarrow> set_iterator_sng (ks0, v))"
  define vo_S where "vo_S = (case vo of None \<Rightarrow> {} | Some v \<Rightarrow> {(ks0, v)})"
  have it_vo_OK: "set_iterator it_vo vo_S"
    unfolding it_vo_def vo_S_def
    by (simp split: option.split
             add: set_iterator_emp_correct set_iterator_sng_correct)

  \<comment> \<open>children iterator\<close>
  define it_prod :: "(('key \<times> ('key, 'val) trie) \<times> 'key list \<times> 'val, '\<sigma>) set_iterator"
    where "it_prod = set_iterator_product (foldli kvs) (\<lambda>(k, y). iteratei_postfixed (k # ks0) y)"

  define it_prod_S where "it_prod_S = (SIGMA kt:set kvs.
       (\<lambda>ksv. (rev (fst ksv) @ ((fst kt) # ks0), snd ksv)) `
       map_to_set (lookup_trie (snd kt)))"

  have it_prod_OK: "set_iterator it_prod it_prod_S"
  proof -
    from set_iterator_foldli_correct[OF dist_kvs]
    have it_foldli: "set_iterator (foldli kvs) (set kvs)" .

    { fix kt
      assume kt_in: "kt \<in> set kvs"
      hence k_t_in: "(fst kt, snd kt) \<in> set kvs" by simp

      note ind_hyp [OF k_t_in, OF invar_child[OF k_t_in], of "fst kt # ks0"]
    } note it_child = this

    show ?thesis
      unfolding it_prod_def it_prod_S_def
      apply (rule set_iterator_product_correct [OF it_foldli])
      apply (insert it_child)
      apply (simp add: case_prod_beta)
    done
  qed

  have it_image_OK : "set_iterator (set_iterator_image snd it_prod) (snd ` it_prod_S)"
  proof (rule set_iterator_image_correct[OF it_prod_OK])
    from dist_fst_kvs
    have "\<And>k v1 v2. (k, v1) \<in> set kvs \<Longrightarrow> (k, v2) \<in> set kvs \<Longrightarrow> v1 = v2"
       by (induct kvs) (auto simp add: image_iff)
    thus "inj_on snd it_prod_S"
      unfolding inj_on_def it_prod_S_def
      apply (simp add: image_iff Ball_def map_to_set_def)
      apply auto
    done
  qed auto

  \<comment> \<open>overall iterator\<close>
  have it_all_OK: "set_iterator
      ((iteratei_postfixed ks0 (Trie vo kvs)):: ('key list \<times> 'val, '\<sigma>) set_iterator)
     (vo_S \<union> snd ` it_prod_S)"
    unfolding iteratei_postfixed_alt_def
       it_vo_def[symmetric]
       it_prod_def[symmetric]
  proof (rule set_iterator_union_correct [OF it_vo_OK it_image_OK])
    show "vo_S \<inter> snd ` it_prod_S = {}"
      unfolding vo_S_def it_prod_S_def
      by (simp split: option.split add: set_eq_iff image_iff)
  qed

  \<comment> \<open>rewrite result set\<close>
  have it_set_rewr: "((\<lambda>ksv. (rev (fst ksv) @ ks0, snd ksv)) `
      map_to_set (lookup_trie (Trie vo kvs))) = (vo_S \<union> snd ` it_prod_S)"
    (is "?ls = ?rs")
    apply (simp add: map_to_set_def lookup_eq_Some_iff[OF invar]
                     set_eq_iff image_iff vo_S_def it_prod_S_def Ball_def Bex_def)
    apply (simp split: option.split del: ex_simps add: ex_simps[symmetric])
    apply (intro allI impI iffI)
    apply auto[]
    apply (metis append_Cons append_Nil append_assoc rev.simps)
  done

  \<comment> \<open>done\<close>
  show ?case
    unfolding it_set_rewr using it_all_OK by fast
qed

definition trie_reverse_key where
  "trie_reverse_key ksv = (rev (fst ksv), (snd ksv))"

lemma trie_reverse_key_alt_def[code] :
  "trie_reverse_key (ks, v) = (rev ks, v)"
unfolding trie_reverse_key_def by auto

lemma trie_reverse_key_reverse[simp] :
  "trie_reverse_key (trie_reverse_key ksv) = ksv"
by (simp add: trie_reverse_key_def)

lemma trie_iteratei_correct:
  assumes invar: "invar_trie (t :: ('key, 'val) trie)"
  shows "set_iterator ((iteratei t)::('key list \<times> 'val, '\<sigma>) set_iterator)
           (trie_reverse_key ` (map_to_set (lookup_trie t)))"
unfolding trie_reverse_key_def[abs_def] iteratei_def[abs_def]
using iteratei_postfixed_correct [OF invar, of "[]"]
by simp

hide_const (open) iteratei
hide_type (open) trie

end


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

lemma monoAux: "A \<subseteq> B \<Longrightarrow> P \<leadsto>[A] Q \<longrightarrow> P \<leadsto>[B] Q"
by(auto intro: Strong_Late_Sim.monotonic)

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

abbreviation
  strongBisimJudge (infixr "\<sim>" 65) where "P \<sim> Q \<equiv> (P, Q) \<in> bisim"

lemma monotonic': "mono(\<lambda>S. {(P, Q) |P Q. P \<leadsto>[S] Q \<and> Q \<leadsto>[S] P})"
apply(rule monoI)
by(auto dest: monoAux)

lemma bisimCoinduct[case_names cSim cSym , consumes 1]:
  assumes p: "(P, Q) \<in> X"
  and     rSim: "\<And>R S. (R, S) \<in> X \<Longrightarrow> R \<leadsto>[(X \<union> bisim)] S"
  and     rSym: "\<And>R S. (R, S) \<in> X \<Longrightarrow> (S, R) \<in> X"

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

  from p show ?thesis
    apply(coinduct, auto)
    apply(fastforce dest: rSim simp add: aux)
    by(fastforce dest: rSym)
qed

lemma bisimE:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim> Q"

  shows "P \<leadsto>[bisim] Q"
using assms
by(auto intro: bisim.cases)

lemma bisimI:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<leadsto>[bisim] Q"
  and     "Q \<sim> P"

  shows "P \<sim> Q"
using assms
by(rule bisim.intros)

definition old_bisim :: "(pi \<times> pi) set \<Rightarrow> bool" where
  "old_bisim Rel \<equiv> \<forall>(P, Q) \<in> Rel. P \<leadsto>[Rel] Q \<and> (Q, P) \<in> Rel"

lemma oldBisimBisimEq:
  shows "(\<Union>{Rel. (old_bisim Rel)}) = bisim"  (is "?LHS = ?RHS")
proof
  show "?LHS \<subseteq> ?RHS"
  proof auto
    fix P Q Rel
    assume "(P, Q) \<in> Rel" and "old_bisim Rel"
    thus "P \<sim> Q"
    proof(coinduct rule: bisimCoinduct)
      case(cSim P Q)
      with `old_bisim Rel` show ?case
        by(fastforce simp add: old_bisim_def intro: Strong_Late_Sim.monotonic)
    next
      case(cSym P Q)
      with `old_bisim Rel` show ?case
        by(auto simp add: old_bisim_def)
    qed
  qed
next
  show "?RHS \<subseteq> ?LHS"
  proof auto
    fix P Q
    assume "P \<sim> Q"
    moreover hence "old_bisim bisim"
      by(auto simp add: old_bisim_def dest: bisim.cases)
    ultimately show "\<exists>Rel. old_bisim Rel \<and> (P, Q) \<in> Rel"
      by blast
  qed
qed

lemma reflexive:
  fixes P :: pi

  shows "P \<sim> P"
proof -
  have "(P, P) \<in> Id" by simp
  thus ?thesis
    by(coinduct rule: bisimCoinduct, auto intro: Strong_Late_Sim.reflexive)
qed

  shows "Q \<sim> P"
using assms
by(auto dest: bisim.cases)

lemma bisimClosed:
  fixes P :: pi
  and   Q :: pi
  and   p :: "name prm"

  assumes "P \<sim> Q"

  shows "(p \<bullet> P) \<sim> (p \<bullet> Q)"
proof -
  let ?X = "{(p \<bullet> P, p \<bullet> Q) | P Q (p::name prm). P \<sim> Q}"
  from `P \<sim> Q` have  "(p \<bullet> P, p \<bullet> Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim pP pQ)
    from `(pP, pQ) \<in> ?X` obtain P Q p where "P \<sim> Q" and "pP = (p::name prm) \<bullet> P" and "pQ = p \<bullet> Q"
      by auto
    from `P \<sim> Q` have "P \<leadsto>[bisim] Q" by(rule bisimE)
    moreover have "bisim \<subseteq> ?X"
    proof
      fix x
      assume "x \<in> bisim"
      moreover have "x = (([]::name prm) \<bullet> x)" by auto
      ultimately show "x \<in> ?X"
        apply(case_tac x)
        by(clarify, simp only: eqvts) metis
    qed
    moreover have "eqvt ?X"
    proof(auto simp add: eqvt_def)
      fix P Q
      fix perm1::"name prm"
      fix perm2::"name prm"

      assume "P \<sim> 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'. (\<exists>(perm::name prm). perm1 \<bullet> perm2 \<bullet> P = perm \<bullet> P' \<and>
                                                   perm1 \<bullet> perm2 \<bullet> Q = perm \<bullet> Q') \<and> P' \<sim> Q'"
        by blast
    qed
    ultimately have "(p \<bullet> P) \<leadsto>[?X] (p \<bullet> Q)"
      by(rule Strong_Late_Sim.eqvtI)
    with `pP = p \<bullet> P` `pQ = p \<bullet> Q` show ?case
      by(force intro: Strong_Late_Sim.monotonic)
  next
    case(cSym P Q)
    thus ?case by(auto intro: symmetric)
  qed
qed

lemma bisimEqvt[simp]:
  shows "eqvt bisim"
by(auto simp add: eqvt_def bisimClosed)

  assumes "P \<sim> Q"
  and     "Q \<sim> R"

  shows "P \<sim> R"
proof -
  let ?X = "bisim O bisim"
  from assms have "(P, R) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim P R)
    thus ?case
      by(fastforce intro: Strong_Late_Sim.transitive dest: bisimE simp add: eqvtTrans)
  next
    case(cSym P R)
    thus ?case
      by(auto dest: symmetric)
  qed
qed

  shows "P \<sim> Q"
proof -
  let ?X = "bisim O (X \<union> bisim) O bisim"
  from `(P, Q) \<in> X`  have "(P, Q) \<in> ?X" by(auto intro: reflexive)
  thus ?thesis
  proof(coinduct rule: bisimCoinduct)
    case(cSim P Q)
    {
      fix P P' Q' Q

      assume "P \<sim> P'" and "(P', Q') \<in> X \<union> bisim" and "Q' \<sim> Q"
      have "P \<leadsto>[(?X \<union> bisim)] Q"
      proof(cases "(P', Q') \<in> X")
        case True
        from `P \<sim> P'` have "P \<leadsto>[bisim] P'" by(rule bisimE)
        moreover from `(P', Q') \<in> X` have "P' \<leadsto>[(?X)] Q'" by(rule rSim)
        moreover from `eqvt X` bisimEqvt have "eqvt(?X \<union> bisim)" by blast
        moreover have "bisim O ?X \<subseteq> ?X \<union> bisim" by(auto dest: transitive)
        ultimately have "P \<leadsto>[(?X \<union> bisim)] Q'" by(rule Strong_Late_Sim.transitive)
        moreover from `Q' \<sim> Q` have "Q' \<leadsto>[bisim] Q" by(rule bisimE)
        moreover note `eqvt(?X \<union> bisim)`
        moreover have "(?X \<union> bisim) O bisim \<subseteq> ?X \<union> bisim"
          by auto (blast dest: transitive)+
        ultimately show ?thesis by(rule Strong_Late_Sim.transitive)
      next
        case False
        from `(P', Q') \<notin> X` `(P', Q') \<in> X \<union> bisim` have "P' \<sim> Q'" by simp
        with `P \<sim> P'` `Q' \<sim> Q` have "P \<sim> Q" by(blast dest: transitive)
        hence "P \<leadsto>[bisim] Q" by(rule bisimE)
        moreover have "bisim \<subseteq> ?X \<union> bisim" by auto
        ultimately show ?thesis by(rule Strong_Late_Sim.monotonic)
      qed
    }
    with `(P, Q) \<in> ?X` show ?case by auto
    case(cSym P Q)
    {
      fix P P' Q' Q

      assume "P \<sim> P'" and "(P', Q') \<in> X \<union> bisim" and "Q' \<sim> Q"
      have "(Q, P) \<in> bisim O (X \<union> bisim) O bisim"
      proof(cases "(P', Q') \<in> X")
        case True
        from `(P', Q') \<in> X` have "(Q', P') \<in> ?X" by(rule rSym)
        then obtain Q'' P'' where "Q' \<sim> Q''" and "(Q'', P'') \<in> X \<union> bisim" and "P'' \<sim> P'"
          by auto
        from `Q' \<sim> Q` `Q' \<sim> Q''` have "Q \<sim> Q''" by(metis transitive symmetric)
        moreover from `P \<sim> P'` `P'' \<sim> P'` have "P'' \<sim> P" by(metis transitive symmetric)
        ultimately show ?thesis using `(Q'', P'') \<in> X \<union> bisim` by blast
      next
        case False
        from `(P', Q') \<notin> X` `(P', Q') \<in> X \<union> bisim` have "P' \<sim> Q'" by simp
        with `P \<sim> P'` `Q' \<sim> Q` have "Q \<sim> P" by(metis transitive symmetric)
        thus ?thesis by(blast intro: reflexive)
      qed
    }
    with `(P, Q) \<in> ?X` show ?case by blast
  qed
qed

end