section \<open>Priority Maps implemented with List and Map\<close>
theory IICF_Abs_Heapmap
imports IICF_Abs_Heap "HOL-Library.Rewrite" "../../Intf/IICF_Prio_Map"
begin

  type_synonym ('k,'v) ahm = "'k list \<times> ('k \<rightharpoonup> 'v)"

  subsection \<open>Basic Setup\<close>

  text \<open>First, we define a mapping to list-based heaps\<close>
  definition hmr_\<alpha> :: "('k,'v) ahm \<Rightarrow> 'v heap" where
    "hmr_\<alpha> \<equiv> \<lambda>(pq,m). map (the o m) pq"

  definition "hmr_invar \<equiv> \<lambda>(pq,m). distinct pq \<and> dom m \<supseteq> set pq"

  definition "hmr_rel \<equiv> br hmr_\<alpha> hmr_invar"

  lemmas hmr_rel_defs = hmr_rel_def hmr_\<alpha>_def hmr_invar_def

  lemma hmr_empty_invar[simp]: "hmr_invar ([],Map.empty)"
    by (auto simp: hmr_invar_def)

  locale hmstruct = h: heapstruct prio for prio :: "'v \<Rightarrow> 'b::linorder"
  begin

    text \<open>Next, we define a mapping to priority maps.\<close>

    definition heapmap_\<alpha> :: "('k,'v) ahm \<Rightarrow> ('k \<rightharpoonup> 'v)" where
      "heapmap_\<alpha> \<equiv> \<lambda>(pq,m). m |` set pq"

    definition heapmap_invar :: "('k,'v) ahm \<Rightarrow> bool" where
      "heapmap_invar \<equiv> \<lambda>hm. hmr_invar hm \<and> h.heap_invar (hmr_\<alpha> hm)"

    definition "heapmap_rel \<equiv> br heapmap_\<alpha> heapmap_invar"

    lemmas heapmap_rel_defs = heapmap_rel_def br_def heapmap_\<alpha>_def heapmap_invar_def

    lemma [refine_dref_RELATES]: "RELATES hmr_rel" by (simp add: RELATES_def)

    lemma h_heap_invarI[simp]: "heapmap_invar hm \<Longrightarrow> h.heap_invar (hmr_\<alpha> hm)"
      by (simp add: heapmap_invar_def)

    lemma hmr_invarI[simp]: "heapmap_invar hm \<Longrightarrow> hmr_invar hm"
      unfolding heapmap_invar_def by blast

    lemma set_hmr_\<alpha>[simp]: "hmr_invar hm \<Longrightarrow> set (hmr_\<alpha> hm) = ran (heapmap_\<alpha> hm)"
      apply (clarsimp simp: hmr_\<alpha>_def hmr_invar_def heapmap_\<alpha>_def)
      by (smt Int_absorb1 comp_apply dom_restrict image_cong ran_is_image restrict_in)

    lemma in_h_hmr_\<alpha>_conv[simp]: "hmr_invar hm \<Longrightarrow> x \<in># h.\<alpha> (hmr_\<alpha> hm) \<longleftrightarrow> x \<in> ran (heapmap_\<alpha> hm)"
      apply (clarsimp simp: hmr_\<alpha>_def hmr_invar_def heapmap_\<alpha>_def in_multiset_in_set ran_is_image)
      by (smt Int_absorb1 comp_apply image_cong restrict_in)

    subsection \<open>Basic Operations\<close>
    (* length, val_of_op, update, butlast, append, empty *)

    text \<open>In this section, we define the basic operations on heapmaps,
      and their relations to heaps and maps.\<close>

    subsubsection \<open>Length\<close>
    text \<open>Length of the list that represents the heap\<close>
    definition hm_length :: "('k,'v) ahm \<Rightarrow> nat" where
      "hm_length \<equiv> \<lambda>(pq,_). length pq"

    lemma hm_length_refine: "(hm_length, length) \<in> hmr_rel \<rightarrow> nat_rel"
      apply (intro fun_relI)
      unfolding hm_length_def
      by (auto simp: hmr_rel_defs in_br_conv)

    lemma hm_length_hmr_\<alpha>[simp]: "length (hmr_\<alpha> hm) = hm_length hm"
      by (auto simp: hm_length_def hmr_\<alpha>_def split: prod.splits)

    lemmas [refine] = hm_length_refine[param_fo]

    subsubsection \<open>Valid\<close>
    text \<open>Check whether index is valid\<close>
    definition "hm_valid hm i \<equiv> i>0 \<and> i\<le> hm_length hm"

    lemma hm_valid_refine: "(hm_valid,h.valid)\<in>hmr_rel \<rightarrow> nat_rel \<rightarrow> bool_rel"
      apply (intro fun_relI)
      unfolding hm_valid_def h.valid_def
      by (parametricity add: hm_length_refine)

    lemma hm_valid_hmr_\<alpha>[simp]: "h.valid (hmr_\<alpha> hm) = hm_valid hm"
      by (intro ext) (auto simp: h.valid_def hm_valid_def)

    subsubsection \<open>Has-Child\<close>
    definition "hm_has_child_op hm k \<longleftrightarrow> 2*k \<le> hm_length hm"
    definition "hm_left_child_op (k::nat) \<equiv> 2*k"
    definition "hm_next_child_op (k::nat) \<equiv> k+1"
    definition "hm_has_next_child_op hm k \<equiv> k+1 \<le> hm_length hm"

    subsubsection \<open>Key-Of\<close>
    definition hm_key_of :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> 'k" where
      "hm_key_of \<equiv> \<lambda>(pq,m) i. pq!(i - 1)"

    definition hm_key_of_op :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> 'k nres" where
      "hm_key_of_op \<equiv> \<lambda>(pq,m) i. doN {ASSERT (i>0); mop_list_get pq (i - 1)}"

    lemma hm_key_of_op_unfold:
      shows "hm_key_of_op hm i = doN {ASSERT (hm_valid hm i); RETURN (hm_key_of hm i)}"
      unfolding hm_valid_def hm_length_def hm_key_of_op_def hm_key_of_def
      by (auto split: prod.splits simp: pw_eq_iff refine_pw_simps)

    lemma val_of_hmr_\<alpha>[simp]: "hm_valid hm i \<Longrightarrow> h.val_of (hmr_\<alpha> hm) i
      = the (heapmap_\<alpha> hm (hm_key_of hm i))"
      by (auto
        simp: hmr_\<alpha>_def h.val_of_def heapmap_\<alpha>_def hm_key_of_def hm_valid_def hm_length_def
        split: prod.splits)

    lemma hm_\<alpha>_key_ex[simp]:
      "\<lbrakk>hmr_invar hm; hm_valid hm i\<rbrakk> \<Longrightarrow> (heapmap_\<alpha> hm (hm_key_of hm i) \<noteq> None)"
      unfolding heapmap_invar_def hmr_invar_def hm_valid_def heapmap_\<alpha>_def
        hm_key_of_def hm_length_def
      apply (clarsimp split: prod.splits)
      by (meson domD in_set_conv_nth nz_le_conv_less subset_code(1))

    subsubsection \<open>Lookup\<close>
    abbreviation (input) hm_lookup where "hm_lookup \<equiv> heapmap_\<alpha>"

    definition "hm_the_lookup_op k hm \<equiv> doN {
      ASSERT (heapmap_\<alpha> hm k \<noteq> None \<and> hmr_invar hm);
      RETURN (the (heapmap_\<alpha> hm k))}"

    (*definition "hm_the_lookup_op' hm k \<equiv> do {
      let (pq,ml) = hm;
      (*ASSERT (heapmap_\<alpha> (hm_impl1_\<alpha> hm) k \<noteq> None \<and> hm_impl1_invar hm);*)
      v \<leftarrow> mop_map_lookup ml k;
      RETURN v
    }"

    lemma hm_the_lookup_op'_refine:
      "(hm_the_lookup_op', hm_the_lookup_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>Id\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_the_lookup_op'_def hm_the_lookup_op_def
      apply refine_vcg
      apply (auto)
      apply (auto simp: hm_impl1_rel_defs heapmap_\<alpha>_def hmr_invar_def split: if_split_asm)
      done
    *)

    subsubsection \<open>Exchange\<close>
    text \<open>Exchange two indices\<close>

    definition "hm_exch_op \<equiv> \<lambda>(pq,m) i j. do {
      ASSERT (hm_valid (pq,m) i);
      ASSERT (hm_valid (pq,m) j);
      ASSERT (hmr_invar (pq,m));
      pq \<leftarrow> mop_list_swap pq (i - 1) (j - 1);
      RETURN (pq,m)
    }"

    lemma hm_exch_op_invar: "hm_exch_op hm i j \<le>\<^sub>n SPEC hmr_invar"
      unfolding hm_exch_op_def h.exch_op_def h.val_of_op_def h.update_op_def
      apply simp
      apply refine_vcg
      apply (auto simp: hm_valid_def map_swap hm_length_def hmr_rel_defs)
      done

    lemma hm_exch_op_refine: "(hm_exch_op,h.exch_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_exch_op_def h.exch_op_def h.val_of_op_def h.update_op_def
      apply simp
      apply refine_vcg
      apply (auto simp: hm_valid_def map_swap hm_length_def hmr_rel_defs in_br_conv)
      done

    lemmas hm_exch_op_refine'[refine] = hm_exch_op_refine[param_fo, THEN nres_relD]

    definition hm_exch :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('k,'v) ahm"
      where "hm_exch \<equiv> \<lambda>(pq,m) i j. (swap pq (i-1) (j-1),m)"

    lemma hm_exch_op_\<alpha>_correct: "hm_exch_op hm i j \<le>\<^sub>n SPEC (\<lambda>hm'.
      hm_valid hm i \<and> hm_valid hm j \<and> hm'=hm_exch hm i j
      )"
      unfolding hm_exch_op_def
      apply refine_vcg
      apply (auto simp add: hm_key_of_def hm_exch_def swap_def)
      done

    lemma hm_exch_\<alpha>[simp]: "\<lbrakk>hm_valid hm i; hm_valid hm j\<rbrakk>
      \<Longrightarrow> heapmap_\<alpha> (hm_exch hm i j) = (heapmap_\<alpha> hm)"
      by (auto simp: heapmap_\<alpha>_def hm_exch_def hm_valid_def hm_length_def split: prod.splits)

    lemma hm_exch_valid[simp]: "hm_valid (hm_exch hm i j) = hm_valid hm"
      by (intro ext) (auto simp: hm_valid_def hm_length_def hm_exch_def split: prod.splits)
    lemma hm_exch_length[simp]: "hm_length (hm_exch hm i j) = hm_length hm"
      by (auto simp: hm_length_def hm_exch_def split: prod.splits)

    lemma hm_exch_same[simp]: "hm_exch hm i i = hm"
      by (auto simp: hm_exch_def split: prod.splits)

    lemma hm_key_of_exch_conv[simp]:
      "\<lbrakk>hm_valid hm i; hm_valid hm j; hm_valid hm k\<rbrakk> \<Longrightarrow>
        hm_key_of (hm_exch hm i j) k = (
          if k=i then hm_key_of hm j
          else if k=j then hm_key_of hm i
          else hm_key_of hm k
          )"
      unfolding hm_exch_def hm_valid_def hm_length_def hm_key_of_def
      by (auto split: prod.splits simp: swap_nth)

    lemma hm_key_of_exch_matching[simp]:
      "\<lbrakk>hm_valid hm i; hm_valid hm j\<rbrakk> \<Longrightarrow> hm_key_of (hm_exch hm i j) i = hm_key_of hm j"
      "\<lbrakk>hm_valid hm i; hm_valid hm j\<rbrakk> \<Longrightarrow> hm_key_of (hm_exch hm i j) j = hm_key_of hm i"
      by simp_all

    subsubsection \<open>Index\<close>
    text \<open>Obtaining the index of a key\<close>
    definition "hm_index \<equiv> \<lambda>(pq,m) k. index pq k + 1"

    lemma hm_index_valid[simp]: "\<lbrakk>hmr_invar hm; heapmap_\<alpha> hm k \<noteq> None\<rbrakk> \<Longrightarrow> hm_valid hm (hm_index hm k)"
      by (auto
        simp: hm_valid_def heapmap_\<alpha>_def hmr_invar_def hm_index_def hm_length_def Suc_le_eq
        simp: restrict_map_def split: if_splits)

    lemma hm_index_key_of[simp]: "\<lbrakk>hmr_invar hm; heapmap_\<alpha> hm k \<noteq> None\<rbrakk> \<Longrightarrow> hm_key_of hm (hm_index hm k) = k"
      by (auto
        simp: hm_valid_def heapmap_\<alpha>_def hmr_invar_def hm_index_def hm_length_def hm_key_of_def Suc_le_eq
        simp: restrict_map_def split: if_splits)

    definition "hm_index_op \<equiv> \<lambda>(pq,m) k.
      do {
        ASSERT (hmr_invar (pq,m) \<and> heapmap_\<alpha> (pq,m) k \<noteq> None);
        i \<leftarrow> mop_list_index pq k;
        RETURN (i+1)
      }"

    lemma hm_index_op_correct:
      assumes "hmr_invar hm"
      assumes "heapmap_\<alpha> hm k \<noteq> None"
      shows "hm_index_op hm k \<le> SPEC (\<lambda>r. r= hm_index hm k)"
      using assms unfolding hm_index_op_def
      apply refine_vcg
      apply (auto simp: heapmap_\<alpha>_def hmr_invar_def hm_index_def index_nth_id)
      done
    lemmas [refine_vcg] = hm_index_op_correct

    subsubsection \<open>Update\<close>
    text \<open>Updating the heap at an index\<close>
    definition hm_update_op :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> 'v \<Rightarrow> ('k,'v) ahm nres" where
      "hm_update_op \<equiv> \<lambda>(pq,m) i v. do {
        ASSERT (hm_valid (pq,m) i \<and> hmr_invar (pq,m));
        k \<leftarrow> mop_list_get pq (i - 1);
        RETURN (pq, m(k \<mapsto> v))
      }"

    lemma hm_update_op_invar: "hm_update_op hm k v \<le>\<^sub>n SPEC hmr_invar"
      unfolding hm_update_op_def h.update_op_def
      apply refine_vcg
      by (auto simp: hmr_rel_defs map_distinct_upd_conv hm_valid_def hm_length_def)

    lemma hm_update_op_refine: "(hm_update_op, h.update_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> Id \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_update_op_def h.update_op_def mop_list_get_alt mop_list_set_alt
      apply refine_vcg
      apply (auto simp: hmr_rel_defs map_distinct_upd_conv hm_valid_def hm_length_def in_br_conv)
      done

    lemmas [refine] = hm_update_op_refine[param_fo, THEN nres_relD]

    lemma hm_update_op_\<alpha>_correct:
      assumes "hmr_invar hm"
      assumes "heapmap_\<alpha> hm k \<noteq> None"
      shows "hm_update_op hm (hm_index hm k) v \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = (heapmap_\<alpha> hm)(k\<mapsto>v))"
      using assms
      unfolding hm_update_op_def
      apply refine_vcg
      apply (auto simp: heapmap_rel_defs hmr_rel_defs hm_index_def restrict_map_def split: if_splits)
      done

    subsubsection \<open>Butlast\<close>
    text \<open>Remove last element\<close>
    definition hm_butlast_op :: "('k,'v) ahm \<Rightarrow> ('k,'v) ahm nres" where
      "hm_butlast_op \<equiv> \<lambda>(pq,m). do {
        ASSERT (hmr_invar (pq,m));
        ASSERT (pq\<noteq>[]);
        k \<leftarrow> mop_list_get pq (length pq - 1);
        pq \<leftarrow> mop_list_butlast pq;
        RETURN (pq,m)
      }"

    lemma hm_butlast_op_refine: "(hm_butlast_op, h.butlast_op) \<in> hmr_rel \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
      supply [simp del] = map_upd_eq_restrict
      apply (intro fun_relI nres_relI)
      unfolding hm_butlast_op_def h.butlast_op_def
      apply simp
      apply refine_vcg
      apply (clarsimp_all simp: hmr_rel_defs map_butlast distinct_butlast in_br_conv)
      apply (auto simp: neq_Nil_rev_conv) []
      done

    lemmas [refine] = hm_butlast_op_refine[param_fo, THEN nres_relD]

    lemma hm_butlast_op_\<alpha>_correct: "hm_butlast_op hm \<le>\<^sub>n SPEC (
      \<lambda>hm'. heapmap_\<alpha> hm' = (heapmap_\<alpha> hm)( hm_key_of hm (hm_length hm) := None ))"
    proof -
      have AUX: "xs\<noteq>[]
        \<Longrightarrow> set (butlast xs) = (if xs!(length xs - 1) \<in> set (butlast xs) then set xs else set xs - {xs!(length xs - 1)})"
        for xs :: "'a list"
        apply (cases xs rule: rev_cases)
        apply auto
        done

      have AUX: "\<lbrakk> distinct xs; xs\<noteq>[] \<rbrakk> \<Longrightarrow> set (butlast xs) = set xs - {xs!(length xs - 1)}"
        for xs :: "'a list"
        apply (cases xs rule: rev_cases)
        by auto

      show ?thesis
        unfolding hm_butlast_op_def
        apply refine_vcg
        by (auto simp: heapmap_\<alpha>_def hm_key_of_def hm_length_def hmr_invar_def AUX)
    qed

    subsubsection \<open>Append\<close>
    text \<open>Append new element at end of heap\<close>

    definition hm_append_op :: "('k,'v) ahm \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> ('k,'v) ahm nres"
      where "hm_append_op \<equiv> \<lambda>(pq,m) k v. do {
        ASSERT (k \<notin> set pq);
        ASSERT (hmr_invar (pq,m));
        pq \<leftarrow> mop_list_append pq k;
        let m = m (k \<mapsto> v);
        RETURN (pq,m)
      }"

    lemma hm_append_op_invar: "hm_append_op hm k v \<le>\<^sub>n SPEC hmr_invar"
      unfolding hm_append_op_def h.append_op_def
      apply refine_vcg
      unfolding heapmap_\<alpha>_def hmr_rel_defs
      apply (auto simp: )
      done

    lemma hm_append_op_refine: "\<lbrakk> heapmap_\<alpha> hm k = None; (hm,h)\<in>hmr_rel \<rbrakk>
      \<Longrightarrow> (hm_append_op hm k v, h.append_op h v) \<in> \<langle>hmr_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_append_op_def h.append_op_def
      apply refine_vcg
      unfolding heapmap_\<alpha>_def hmr_rel_defs
      apply (auto simp: in_br_conv)
      done

    lemmas hm_append_op_refine'[refine] = hm_append_op_refine[param_fo, THEN nres_relD]

    lemma hm_append_op_\<alpha>_correct:
      "hm_append_op hm k v \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = (heapmap_\<alpha> hm) (k \<mapsto> v))"
      unfolding hm_append_op_def
      apply refine_vcg
      by (auto simp: heapmap_\<alpha>_def)

    subsection \<open>Auxiliary Operations\<close>
    text \<open>Auxiliary operations on heapmaps, which are derived
      from the basic operations, but do not correspond to
      operations of the priority map interface\<close>

    text \<open>We start with some setup\<close>

    lemma heapmap_hmr_relI: "(hm,h)\<in>heapmap_rel \<Longrightarrow> (hm,hmr_\<alpha> hm) \<in> hmr_rel"
      by (auto simp: heapmap_rel_defs hmr_rel_defs)

    lemma heapmap_hmr_relI': "heapmap_invar hm \<Longrightarrow> (hm,hmr_\<alpha> hm) \<in> hmr_rel"
      by (auto simp: heapmap_rel_defs hmr_rel_defs)

    text \<open>The basic principle how we prove correctness of our operations:
      Invariant preservation is shown by relating the operations to
      operations on heaps. Then, only correctness on the abstraction
      remains to be shown, assuming the operation does not fail.
      \<close>
    lemma heapmap_nres_relI':
      assumes "hm \<le> \<Down>hmr_rel h'"
      assumes "h' \<le> SPEC (h.heap_invar)"
      assumes "hm \<le>\<^sub>n SPEC (\<lambda>hm'. RETURN (heapmap_\<alpha> hm') \<le> h)"
      shows "hm \<le> \<Down>heapmap_rel h"
      using assms
      unfolding heapmap_rel_defs hmr_rel_def
      by (auto simp: pw_le_iff pw_leof_iff refine_pw_simps)

    lemma heapmap_nres_relI'':
      assumes "hm \<le> \<Down>hmr_rel h'"
      assumes "h' \<le> SPEC \<Phi>"
      assumes "\<And>h'. \<Phi> h' \<Longrightarrow> h.heap_invar h'"
      assumes "hm \<le>\<^sub>n SPEC (\<lambda>hm'. RETURN (heapmap_\<alpha> hm') \<le> h)"
      shows "hm \<le> \<Down>heapmap_rel h"
      apply (rule heapmap_nres_relI')
      apply fact
      apply (rule order_trans, fact)
      apply (clarsimp; fact)
      apply fact
      done

    subsubsection \<open>Val-of\<close>
    text \<open>Indexing into the heap\<close>
    definition hm_val_of_op :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> 'v nres" where
      "hm_val_of_op \<equiv> \<lambda>hm i. do {
        k \<leftarrow> hm_key_of_op hm i;
        v \<leftarrow> hm_the_lookup_op k hm;
        RETURN v
      }"

    lemma hm_val_of_op_refine: "(hm_val_of_op,h.val_of_op) \<in> (hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>Id\<rangle>nres_rel)"
      apply (intro fun_relI nres_relI)
      unfolding hm_val_of_op_def h.val_of_op_def
        hm_key_of_op_def hm_key_of_def hm_valid_def hm_length_def
        hm_the_lookup_op_def
      apply clarsimp
      apply (rule refine_IdD)
      apply refine_vcg
      apply (auto simp: hmr_rel_defs in_br_conv heapmap_\<alpha>_def)
      by (meson domD nth_mem subsetCE)

    lemmas [refine] = hm_val_of_op_refine[param_fo, THEN nres_relD]

    subsubsection \<open>Prio-of\<close>
    text \<open>Priority of key\<close>
    definition "hm_prio_of_op h i \<equiv> do {v \<leftarrow> hm_val_of_op h i; RETURN (prio v)}"

    lemma hm_prio_of_op_refine: "(hm_prio_of_op, h.prio_of_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>Id\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_prio_of_op_def h.prio_of_op_def
      apply refine_rcg
      by auto

    lemmas hm_prio_of_op_refine'[refine] = hm_prio_of_op_refine[param_fo, THEN nres_relD]

    subsubsection \<open>Swim\<close>

    definition hm_swim_op :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> ('k,'v) ahm nres" where
      "hm_swim_op h i \<equiv> do {
        RECT (\<lambda>swim (h,i). do {
          ASSERT (hm_valid h i \<and> h.swim_invar (hmr_\<alpha> h) i);
          if hm_valid h (h.parent i) then do {
            ppi \<leftarrow> hm_prio_of_op h (h.parent i);
            pi \<leftarrow> hm_prio_of_op h i;
            if (\<not>ppi \<le> pi) then do {
              h \<leftarrow> hm_exch_op h i (h.parent i);
              swim (h, h.parent i)
            } else
              RETURN h
          } else
            RETURN h
        }) (h,i)
      }"

    lemma hm_swim_op_refine: "(hm_swim_op, h.swim_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_swim_op_def h.swim_op_def
      apply refine_rcg
      apply refine_dref_type
      apply (clarsimp_all simp: hm_valid_refine[param_fo, THEN IdD])
      apply (simp add: hmr_rel_def in_br_conv)
      done

    lemmas hm_swim_op_refine'[refine] = hm_swim_op_refine[param_fo, THEN nres_relD]

    lemma hm_swim_op_nofail_imp_valid:
      "nofail (hm_swim_op hm i) \<Longrightarrow> hm_valid hm i \<and> h.swim_invar (hmr_\<alpha> hm) i"
      unfolding hm_swim_op_def
      apply (subst (asm) RECT_unfold, refine_mono)
      by (auto simp: refine_pw_simps)

    lemma hm_swim_op_\<alpha>_correct: "hm_swim_op hm i \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm)"
      apply (rule leof_add_nofailI)
      apply (drule hm_swim_op_nofail_imp_valid)
      unfolding hm_swim_op_def
      apply (rule RECT_rule_leof[where
            pre="\<lambda>(hm',i). hm_valid hm' i \<and> heapmap_\<alpha> hm' = heapmap_\<alpha> hm"
            and V = "inv_image less_than snd"
            ])
      apply simp
      apply simp

      unfolding hm_prio_of_op_def hm_val_of_op_def
        hm_exch_op_def hm_key_of_op_def hm_the_lookup_op_def
      apply (refine_vcg)
      apply (clarsimp_all simp add: hm_valid_def hm_length_def)
      apply rprems
      apply (auto simp: heapmap_\<alpha>_def h.parent_def)
      done

    subsubsection \<open>Sink\<close>
    definition hm_sink_op
    where
      "hm_sink_op h k \<equiv> RECT (\<lambda>D (h,k). do {
        ASSERT (k>0 \<and> k\<le>hm_length h);
        if hm_has_child_op h k then do {
          let j = hm_left_child_op k;
          pj \<leftarrow> hm_prio_of_op h j;

          j \<leftarrow> (
            if hm_has_next_child_op h j then do {
              let j' = hm_next_child_op j;
              psj \<leftarrow> hm_prio_of_op h j';
              if pj>psj then RETURN j' else RETURN j
            } else RETURN j);

          pj \<leftarrow> hm_prio_of_op h j;
          pk \<leftarrow> hm_prio_of_op h k;
          if (pk > pj) then do {
            h \<leftarrow> hm_exch_op h k j;
            D (h,j)
          } else
            RETURN h
        } else RETURN h
      }) (h,k)"

    lemma hm_sink_op_refine: "(hm_sink_op, h.sink_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_sink_op_def h.sink_op_opt_eq[symmetric] h.sink_op_opt_def
      unfolding hm_has_child_op_def hm_has_next_child_op_def
        hm_left_child_op_def hm_next_child_op_def
      apply (rewrite at "let _ = length _ in _" Let_def)
      apply (rewrite at "let _ = _ + 1 in _" Let_def)
      apply refine_rcg
      apply refine_dref_type

      unfolding hmr_rel_def heapmap_rel_def
      apply (auto simp: in_br_conv)
      done

    lemmas hm_sink_op_refine'[refine] = hm_sink_op_refine[param_fo, THEN nres_relD]

    lemma hm_sink_op_nofail_imp_valid: "nofail (hm_sink_op hm i) \<Longrightarrow> hm_valid hm i"
      unfolding hm_sink_op_def
      apply (subst (asm) RECT_unfold, refine_mono)
      by (auto simp: refine_pw_simps hm_valid_def)

    lemma hm_sink_op_\<alpha>_correct: "hm_sink_op hm i \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm)"
      apply (rule leof_add_nofailI)
      apply (drule hm_sink_op_nofail_imp_valid)
      unfolding hm_sink_op_def
      unfolding hm_left_child_op_def hm_has_child_op_def hm_has_next_child_op_def hm_next_child_op_def
      apply (rule RECT_rule_leof[where
            pre="\<lambda>(hm',i). hm_valid hm' i \<and> heapmap_\<alpha> hm' = heapmap_\<alpha> hm \<and> hm_length hm' = hm_length hm"
            and V = "measure (\<lambda>(hm',i). hm_length hm' - i)"
            ])
      apply simp
      apply simp

      unfolding hm_prio_of_op_def hm_val_of_op_def hm_exch_op_def
        hm_key_of_op_def hm_the_lookup_op_def
      apply (refine_vcg)
      apply (clarsimp_all simp add: hm_valid_def hm_length_def) (* Takes long *)
      apply rprems
      apply (clarsimp_all simp: heapmap_\<alpha>_def h.parent_def split: prod.splits)
      apply (auto)
      done

    subsubsection \<open>Repair\<close>
    definition "hm_repair_op hm i \<equiv> do {
      hm \<leftarrow> hm_sink_op hm i;
      hm \<leftarrow> hm_swim_op hm i;
      RETURN hm
    }"

    lemma hm_repair_op_refine: "(hm_repair_op, h.repair_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_repair_op_def h.repair_op_def
      by refine_rcg

    lemmas hm_repair_op_refine'[refine] = hm_repair_op_refine[param_fo, THEN nres_relD]

    lemma hm_repair_op_\<alpha>_correct: "hm_repair_op hm i \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm)"
      unfolding hm_repair_op_def
      apply (refine_vcg
        hm_swim_op_\<alpha>_correct[THEN leof_trans]
        hm_sink_op_\<alpha>_correct[THEN leof_trans])
      by auto

    subsection \<open>Operations\<close>
    text \<open>In this section, we define the operations that implement the priority-map interface\<close>

    subsubsection \<open>Empty\<close>
    definition hm_empty_op :: "('k,'v) ahm nres"
      where "hm_empty_op \<equiv> do { m\<leftarrow>mop_map_empty; RETURN ([],m) }"

    lemma hm_empty_op_aref: "(hm_empty_op,mop_map_empty) \<in> \<langle>heapmap_rel\<rangle>nres_rel"
      unfolding hm_empty_op_def
      apply refine_vcg
      by (auto simp: heapmap_rel_defs hmr_rel_defs intro: nres_relI)

    subsubsection \<open>Insert\<close>
    definition hm_insert_op :: "'k \<Rightarrow> 'v \<Rightarrow> ('k,'v) ahm \<Rightarrow> ('k,'v) ahm nres" where
      "hm_insert_op \<equiv> \<lambda>k v h. do {
        ASSERT (h.heap_invar (hmr_\<alpha> h));
        h \<leftarrow> hm_append_op h k v;
        let l = hm_length h;
        h \<leftarrow> hm_swim_op h l;
        RETURN h
      }"

    lemma hm_insert_op_refine[refine]: "\<lbrakk> heapmap_\<alpha> hm k = None; (hm,h)\<in>hmr_rel \<rbrakk> \<Longrightarrow>
      hm_insert_op k v hm \<le> \<Down>hmr_rel (h.insert_op v h)"
      unfolding hm_insert_op_def h.insert_op_def
      apply refine_rcg
      by (auto simp: hmr_rel_def br_def)

    lemma hm_insert_op_aref:
      "(hm_insert_op,mop_map_update_new) \<in> Id \<rightarrow> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding mop_map_update_new_alt
      apply (rule ASSERT_refine_right)
      apply (rule heapmap_nres_relI''[OF hm_insert_op_refine h.insert_op_correct])
      apply (unfold heapmap_rel_def in_br_conv; clarsimp)
      apply (erule heapmap_hmr_relI)
      apply (unfold heapmap_rel_def in_br_conv; clarsimp)
      apply (unfold heapmap_rel_def in_br_conv; clarsimp)
      unfolding hm_insert_op_def
      apply (refine_vcg
        hm_append_op_\<alpha>_correct[THEN leof_trans]
        hm_swim_op_\<alpha>_correct[THEN leof_trans])
      apply (unfold heapmap_rel_def in_br_conv; clarsimp)
      done

    subsubsection \<open>Is-Empty\<close>

    lemma hmr_\<alpha>_empty_iff[simp]:
      "hmr_invar hm \<Longrightarrow> hmr_\<alpha> hm = [] \<longleftrightarrow> heapmap_\<alpha> hm = Map.empty"
      by (auto
        simp: hmr_\<alpha>_def heapmap_invar_def heapmap_\<alpha>_def hmr_invar_def restrict_map_def fun_eq_iff
        split: prod.split if_splits)

    definition hm_is_empty_op :: "('k,'v) ahm \<Rightarrow> bool nres" where
      "hm_is_empty_op \<equiv> \<lambda>hm. do {
        ASSERT (hmr_invar hm);
        let l = hm_length hm;
        RETURN (l=0)
      }"

    lemma hm_is_empty_op_refine: "(hm_is_empty_op, h.is_empty_op) \<in> hmr_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_is_empty_op_def h.is_empty_op_def
      apply refine_rcg
      subgoal by (auto simp: hmr_rel_defs in_br_conv)
      subgoal by (parametricity add: hm_length_refine)
      done

    lemma hm_is_empty_op_aref: "(hm_is_empty_op, mop_map_is_empty) \<in> heapmap_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_is_empty_op_def
      apply refine_vcg
      apply (auto simp: hmr_rel_defs in_br_conv heapmap_rel_defs hm_length_def)
      by (metis Int_absorb1 dom_restrict length_greater_0_conv ndomIff nth_mem)

    subsubsection \<open>Lookup\<close>

    definition hm_lookup_op :: "'k \<Rightarrow> ('k,'v) ahm \<Rightarrow> 'v option nres"
      where "hm_lookup_op \<equiv> \<lambda>k hm. doN {ASSERT (heapmap_invar hm); RETURN (hm_lookup hm k)}"

    lemma hm_lookup_op_aref: "(hm_lookup_op,RETURN oo op_map_lookup) \<in> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>\<langle>Id\<rangle>option_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_lookup_op_def heapmap_rel_def in_br_conv
      apply refine_vcg
      apply simp_all
      done

    lemma hm_the_lookup_op_aref: "(hm_the_lookup_op,mop_map_the_lookup) \<in> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>Id\<rangle>nres_rel"
      unfolding hm_the_lookup_op_def
      by (auto intro!: nres_relI simp: pw_eq_iff refine_pw_simps heapmap_rel_def in_br_conv)

    subsubsection \<open>Contains-Key\<close>

    definition "hm_contains_key_op \<equiv> \<lambda>k (pq,m). doN {ASSERT (heapmap_invar (pq,m)); mop_list_contains k pq}"
    lemma hm_contains_key_op_aref: "(hm_contains_key_op,mop_map_contains_key) \<in> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_contains_key_op_def heapmap_rel_defs
      apply refine_vcg
      by (auto simp: hmr_invar_def)

    subsubsection \<open>Decrease-Key\<close>

    definition "hm_decrease_key_op \<equiv> \<lambda>k v hm. do {
      ASSERT (heapmap_invar hm);
      ASSERT (heapmap_\<alpha> hm k \<noteq> None \<and> prio v \<le> prio (the (heapmap_\<alpha> hm k)));
      i \<leftarrow> hm_index_op hm k;
      hm \<leftarrow> hm_update_op hm i v;
      hm_swim_op hm i
    }"

    definition (in heapstruct) "decrease_key_op i v h \<equiv> do {
      ASSERT (valid h i \<and> prio v \<le> prio_of h i);
      h \<leftarrow> update_op h i v;
      swim_op h i
    }"

    lemma (in heapstruct) decrease_key_op_invar:
      "\<lbrakk>heap_invar h; valid h i; prio v \<le> prio_of h i\<rbrakk> \<Longrightarrow> decrease_key_op i v h \<le> SPEC heap_invar"
      unfolding decrease_key_op_def
      apply refine_vcg
      by (auto simp: swim_invar_decr)

    lemma index_op_inline_refine:
      assumes "heapmap_invar hm"
      assumes "heapmap_\<alpha> hm k \<noteq> None"
      assumes "f (hm_index hm k) \<le> m"
      shows "do {i \<leftarrow> hm_index_op hm k; f i} \<le> m"
      using hm_index_op_correct[of hm k] assms
      by (auto simp: pw_le_iff refine_pw_simps)

    lemma hm_decrease_key_op_refine:
      "\<lbrakk>(hm,h)\<in>hmr_rel; (hm,m)\<in>heapmap_rel; m k = Some v'\<rbrakk>
        \<Longrightarrow> hm_decrease_key_op k v hm \<le>\<Down>hmr_rel (h.decrease_key_op (hm_index hm k) v h)"
      unfolding hm_decrease_key_op_def h.decrease_key_op_def
      (*apply (rewrite at "Let (hm_index hm k) _" Let_def)*)
      apply (refine_rcg index_op_inline_refine)
      unfolding hmr_rel_def heapmap_rel_def in_br_conv
      apply (clarsimp_all)
      done

    lemma hm_index_op_inline_leof:
      assumes "f (hm_index hm k) \<le>\<^sub>n m"
      shows "do {i \<leftarrow> hm_index_op hm k; f i} \<le>\<^sub>n m"
      using hm_index_op_correct[of hm k] assms unfolding hm_index_op_def
      by (auto simp: pw_le_iff pw_leof_iff refine_pw_simps split: prod.splits)

    lemma hm_decrease_key_op_\<alpha>_correct:
      "heapmap_invar hm \<Longrightarrow> hm_decrease_key_op k v hm \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm(k\<mapsto>v))"
      unfolding hm_decrease_key_op_def
      apply (refine_vcg
        hm_update_op_\<alpha>_correct[THEN leof_trans]
        hm_swim_op_\<alpha>_correct[THEN leof_trans]
        hm_index_op_inline_leof
        )
      apply simp_all
      done

    lemma hm_decrease_key_op_aref:
      "(hm_decrease_key_op, PR_CONST (mop_pm_decrease_key prio)) \<in> Id \<rightarrow> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
      unfolding PR_CONST_def
      apply (intro fun_relI nres_relI)
      apply (frule heapmap_hmr_relI)
      unfolding mop_pm_decrease_key_alt
      apply (rule ASSERT_refine_right; clarsimp)
      apply (rule heapmap_nres_relI')
      apply (rule hm_decrease_key_op_refine; assumption)
      unfolding heapmap_rel_def hmr_rel_def in_br_conv
      apply (rule h.decrease_key_op_invar; simp; fail )
      apply (refine_vcg hm_decrease_key_op_\<alpha>_correct[THEN leof_trans]; simp; fail)
      done

    subsubsection \<open>Increase-Key\<close>

    definition "hm_increase_key_op \<equiv> \<lambda>k v hm. do {
      ASSERT (heapmap_invar hm);
      ASSERT (heapmap_\<alpha> hm k \<noteq> None \<and> prio v \<ge> prio (the (heapmap_\<alpha> hm k)));
      i \<leftarrow> hm_index_op hm k;
      hm \<leftarrow> hm_update_op hm i v;
      hm_sink_op hm i
    }"

    definition (in heapstruct) "increase_key_op i v h \<equiv> do {
      ASSERT (valid h i \<and> prio v \<ge> prio_of h i);
      h \<leftarrow> update_op h i v;
      sink_op h i
    }"

    lemma (in heapstruct) increase_key_op_invar:
      "\<lbrakk>heap_invar h; valid h i; prio v \<ge> prio_of h i\<rbrakk> \<Longrightarrow> increase_key_op i v h \<le> SPEC heap_invar"
      unfolding increase_key_op_def
      apply refine_vcg
      by (auto simp: sink_invar_incr)

    lemma hm_increase_key_op_refine:
      "\<lbrakk>(hm,h)\<in>hmr_rel; (hm,m)\<in>heapmap_rel; m k = Some v'\<rbrakk>
        \<Longrightarrow> hm_increase_key_op k v hm \<le>\<Down>hmr_rel (h.increase_key_op (hm_index hm k) v h)"
      unfolding hm_increase_key_op_def h.increase_key_op_def
      (*apply (rewrite at "Let (hm_index hm k) _" Let_def)*)
      apply (refine_rcg index_op_inline_refine)
      unfolding hmr_rel_def heapmap_rel_def in_br_conv
      apply (clarsimp_all)
      done

    lemma hm_increase_key_op_\<alpha>_correct:
      "heapmap_invar hm \<Longrightarrow> hm_increase_key_op k v hm \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm(k\<mapsto>v))"
      unfolding hm_increase_key_op_def
      apply (refine_vcg
        hm_update_op_\<alpha>_correct[THEN leof_trans]
        hm_sink_op_\<alpha>_correct[THEN leof_trans]
        hm_index_op_inline_leof)
      apply simp_all
      done

    lemma hm_increase_key_op_aref:
      "(hm_increase_key_op, PR_CONST (mop_pm_increase_key prio)) \<in> Id \<rightarrow> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
      unfolding PR_CONST_def
      apply (intro fun_relI nres_relI)
      apply (frule heapmap_hmr_relI)
      unfolding mop_pm_increase_key_alt
      apply (rule ASSERT_refine_right; clarsimp)
      apply (rule heapmap_nres_relI')
      apply (rule hm_increase_key_op_refine; assumption)
      unfolding heapmap_rel_def hmr_rel_def in_br_conv
      apply (rule h.increase_key_op_invar; simp; fail )
      apply (refine_vcg hm_increase_key_op_\<alpha>_correct[THEN leof_trans]; simp)
      done

    subsubsection \<open>Change-Key\<close>

    definition "hm_change_key_op \<equiv> \<lambda>k v hm. do {
      ASSERT (heapmap_invar hm);
      ASSERT (heapmap_\<alpha> hm k \<noteq> None);
      i \<leftarrow> hm_index_op hm k;
      hm \<leftarrow> hm_update_op hm i v;
      hm_repair_op hm i
    }"

    definition (in heapstruct) "change_key_op i v h \<equiv> do {
      ASSERT (valid h i);
      h \<leftarrow> update_op h i v;
      repair_op h i
    }"

    lemma (in heapstruct) change_key_op_invar:
      "\<lbrakk>heap_invar h; valid h i\<rbrakk> \<Longrightarrow> change_key_op i v h \<le> SPEC heap_invar"
      unfolding change_key_op_def
      apply (refine_vcg)
      apply hypsubst
      apply refine_vcg
      by (auto simp: sink_invar_incr)

    lemma hm_change_key_op_refine:
      "\<lbrakk>(hm,h)\<in>hmr_rel; (hm,m)\<in>heapmap_rel; m k = Some v'\<rbrakk>
        \<Longrightarrow> hm_change_key_op k v hm \<le>\<Down>hmr_rel (h.change_key_op (hm_index hm k) v h)"
      unfolding hm_change_key_op_def h.change_key_op_def
      (*apply (rewrite at "Let (hm_index hm k) _" Let_def)*)
      apply (refine_rcg index_op_inline_refine)
      unfolding hmr_rel_def heapmap_rel_def in_br_conv
      apply (clarsimp_all)
      done

    lemma hm_change_key_op_\<alpha>_correct:
      "heapmap_invar hm \<Longrightarrow> hm_change_key_op k v hm \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm(k\<mapsto>v))"
      unfolding hm_change_key_op_def
      apply (refine_vcg
        hm_update_op_\<alpha>_correct[THEN leof_trans]
        hm_repair_op_\<alpha>_correct[THEN leof_trans]
        hm_index_op_inline_leof)
      unfolding heapmap_rel_def in_br_conv
      apply simp
      apply simp
      done

    lemma hm_change_key_op_aref:
      "(hm_change_key_op, mop_map_update_ex) \<in> Id \<rightarrow> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      apply (frule heapmap_hmr_relI)
      unfolding mop_map_update_ex_alt
      apply (rule ASSERT_refine_right; clarsimp)
      apply (rule heapmap_nres_relI')
      apply (rule hm_change_key_op_refine; assumption)
      unfolding heapmap_rel_def hmr_rel_def in_br_conv
      apply (rule h.change_key_op_invar; simp; fail )
      apply ((refine_vcg hm_change_key_op_\<alpha>_correct[THEN leof_trans]; simp))
      done

    subsubsection \<open>Set\<close>

    text \<open>Realized as generic algorithm!\<close> (* TODO: Implement as such! *)
    lemma (in -) op_pm_set_gen_impl: "RETURN ooo op_map_update = (\<lambda>k v m. do {
      c \<leftarrow> RETURN (op_map_contains_key k m);
      if c then
        mop_map_update_ex k v m
      else
        mop_map_update_new k v m
    })"
      apply (intro ext)
      unfolding op_map_contains_key_def mop_map_update_ex_def mop_map_update_new_def
      by simp

    definition "hm_set_op k v hm \<equiv> do {
      c \<leftarrow> hm_contains_key_op k hm;
      if c then
        hm_change_key_op k v hm
      else
        hm_insert_op k v hm
    }"

    (* TODO: Move. Near RETURN_to_SPEC_rule *)
    thm RETURN_to_SPEC_rule
    lemma SPEC_to_RETURN_rule: "m \<le> RETURN x \<Longrightarrow> m \<le> SPEC ((=) x)"
      by (auto simp: pw_le_iff)

    lemma hm_set_op_aref:
      "(hm_set_op, mop_map_update) \<in> Id \<rightarrow> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
      unfolding op_pm_set_gen_impl
      apply (intro fun_relI nres_relI)
      unfolding hm_set_op_def o_def
      using hm_contains_key_op_aref[param_fo]
      using hm_change_key_op_aref[param_fo]
      using hm_insert_op_aref[param_fo]
      by (fastforce simp: pw_le_iff pw_nres_rel_iff refine_pw_simps) (** Takes long *)

    subsubsection \<open>Pop-Min\<close>

    definition hm_pop_min_op :: "('k,'v) ahm \<Rightarrow> (('k\<times>'v) \<times> ('k,'v) ahm) nres" where
      "hm_pop_min_op hm \<equiv> do {
        ASSERT (heapmap_invar hm);
        ASSERT (hm_valid hm 1);
        k \<leftarrow> hm_key_of_op hm 1;
        v \<leftarrow> hm_the_lookup_op k hm;
        let l = hm_length hm;
        hm \<leftarrow> hm_exch_op hm 1 l;
        hm \<leftarrow> hm_butlast_op hm;

        if (l\<noteq>1) then do {
          hm \<leftarrow> hm_sink_op hm 1;
          RETURN ((k,v),hm)
        } else RETURN ((k,v),hm)
      }"

    lemma hm_pop_min_op_refine:
      "(hm_pop_min_op, h.pop_min_op) \<in> hmr_rel \<rightarrow> \<langle>UNIV \<times>\<^sub>r hmr_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_pop_min_op_def h.pop_min_op_def
      (* Project away stuff of second component *)
      unfolding ignore_snd_refine_conv hm_the_lookup_op_def hm_key_of_op_unfold
      apply (simp cong: if_cong add: Let_def)
      apply (simp add: unused_bind_conv h.val_of_op_def refine_pw_simps)

      (* Prove refinement *)
      apply refine_rcg
      unfolding hmr_rel_def in_br_conv
      apply (unfold heapmap_invar_def;simp)
      apply (auto simp: in_br_conv)
      done

    text \<open>We demonstrate two different approaches for proving correctness
      here.
      The first approach uses the relation to plain heaps only to establish
      the invariant.

      The second approach also uses the relation to heaps to establish
      correctness of the result.

      The first approach seems to be more robust against badly set
      up simpsets, which may be the case in early stages of development.

      Assuming a working simpset, the second approach may be less work,
      and the proof may look more elegant.
      \<close>

    text_raw \<open>\paragraph{First approach}\<close>
    text \<open>Transfer heapmin-property to heapmap-domain\<close>
    lemma heapmap_min_prop:
      assumes INV: "heapmap_invar hm"
      assumes V': "heapmap_\<alpha> hm k = Some v'"
      assumes NE: "hm_valid hm (Suc 0)"
      shows "prio (the (heapmap_\<alpha> hm (hm_key_of hm (Suc 0)))) \<le> prio v'"
    proof -
      \<comment> \<open>Transform into the domain of heaps\<close>
      obtain pq m where [simp]: "hm=(pq,m)" by (cases hm)

      from NE have [simp]: "pq\<noteq>[]" by (auto simp: hm_valid_def hm_length_def)

      have CNV_LHS: "prio (the (heapmap_\<alpha> hm (hm_key_of hm (Suc 0))))
        = h.prio_of (hmr_\<alpha> hm) (Suc 0)"
        by (auto simp: heapmap_\<alpha>_def hm_key_of_def hmr_\<alpha>_def h.val_of_def)

      from INV have INV': "h.heap_invar (hmr_\<alpha> hm)"
        unfolding heapmap_invar_def by auto

      from V' INV obtain i where IDX: "h.valid (hmr_\<alpha> hm) i"
        and CNV_RHS: "prio v' = h.prio_of (hmr_\<alpha> hm) i"
        apply (clarsimp simp: heapmap_\<alpha>_def heapmap_invar_def hmr_invar_def hmr_\<alpha>_def
          h.valid_def h.val_of_def restrict_map_eq)
        by (metis (no_types, hide_lams) Suc_leI comp_apply diff_Suc_Suc
          diff_zero index_less_size_conv neq0_conv nth_index nth_map
          old.nat.distinct(2) option.sel)

      from h.heap_min_prop[OF INV' IDX] show ?thesis
        unfolding CNV_LHS CNV_RHS .
    qed

    text \<open>With the above lemma, the correctness proof is straightforward\<close>

    lemma heapmap_nres_rel_prodI:
      assumes "hmx \<le> \<Down>(UNIV \<times>\<^sub>r hmr_rel) h'x"
      assumes "h'x \<le> SPEC (\<lambda>(_,h'). h.heap_invar h')"
      assumes "hmx \<le>\<^sub>n SPEC (\<lambda>(r,hm'). RETURN (r,heapmap_\<alpha> hm') \<le> \<Down>(R\<times>\<^sub>rId) hx)"
      shows "hmx \<le> \<Down>(R\<times>\<^sub>rheapmap_rel) hx"
      using assms
      unfolding heapmap_rel_def hmr_rel_def br_def heapmap_invar_def
      apply (auto simp: pw_le_iff pw_leof_iff refine_pw_simps; blast)
      done

    lemma hm_pop_min_op_aref: "(hm_pop_min_op, PR_CONST (mop_pm_pop_min prio)) \<in> heapmap_rel \<rightarrow> \<langle>(Id\<times>\<^sub>rId)\<times>\<^sub>rheapmap_rel\<rangle>nres_rel"
      unfolding PR_CONST_def
      apply (intro fun_relI nres_relI)
      apply (frule heapmap_hmr_relI)
      unfolding mop_pm_pop_min_alt
      apply (intro ASSERT_refine_right)
      apply (rule heapmap_nres_rel_prodI)
      apply (rule hm_pop_min_op_refine[param_fo, THEN nres_relD]; assumption)
      unfolding heapmap_rel_def hmr_rel_def in_br_conv
      apply (refine_vcg; simp)
      apply (refine_vcg hm_pop_min_\<alpha>_correct[THEN leof_trans]; simp split: prod.splits)
      done

    text_raw \<open>\paragraph{Second approach}\<close>

    (* Alternative approach: Also use knowledge about result
      in multiset domain. Obtaining property seems infeasible at first attempt! *)

    definition "hm_kv_of_op hm i \<equiv> do {
      ASSERT (hm_valid hm i \<and> hmr_invar hm);
      k \<leftarrow> hm_key_of_op hm i;
      v \<leftarrow> hm_the_lookup_op k hm;
      RETURN (k, v)
    }"

    definition "kvi_rel hm i \<equiv> {((k,v),v) | k v. hm_key_of hm i = k}"

    lemma hm_kv_op_refine[refine]:
      assumes "(hm,h)\<in>hmr_rel"
      shows "hm_kv_of_op hm i \<le> \<Down>(kvi_rel hm i) (h.val_of_op h i)"
      unfolding hm_kv_of_op_def h.val_of_op_def kvi_rel_def
        hm_key_of_op_unfold hm_the_lookup_op_def
      apply simp
      apply refine_vcg
      using assms
      apply (auto
        simp: hm_valid_def hm_length_def hmr_rel_defs in_br_conv heapmap_\<alpha>_def hm_key_of_def
        split: prod.splits)
      by (meson contra_subsetD domIff not_None_eq nth_mem)

    definition hm_pop_min_op' :: "('k,'v) ahm \<Rightarrow> (('k\<times>'v) \<times> ('k,'v) ahm) nres" where
      "hm_pop_min_op' hm \<equiv> do {
        ASSERT (heapmap_invar hm);
        ASSERT (hm_valid hm 1);
        kv \<leftarrow> hm_kv_of_op hm 1;
        let l = hm_length hm;
        hm \<leftarrow> hm_exch_op hm 1 l;
        hm \<leftarrow> hm_butlast_op hm;

        if (l\<noteq>1) then do {
          hm \<leftarrow> hm_sink_op hm 1;
          RETURN (kv,hm)
        } else RETURN (kv,hm)
      }"

    lemma hm_pop_min_op_refine':
      "\<lbrakk> (hm,h)\<in>hmr_rel \<rbrakk> \<Longrightarrow> hm_pop_min_op' hm \<le> \<Down>(kvi_rel hm 1 \<times>\<^sub>r hmr_rel) (h.pop_min_op h)"
      unfolding hm_pop_min_op'_def h.pop_min_op_def
      (* Project away stuff of second component *)
      unfolding ignore_snd_refine_conv
      (* Prove refinement *)
      apply refine_rcg
      unfolding hmr_rel_def heapmap_rel_def
      apply (unfold heapmap_invar_def; simp add: in_br_conv)
      apply (simp_all add: in_br_conv)
      done

    lemma heapmap_nres_rel_prodI':
      assumes "hmx \<le> \<Down>(S \<times>\<^sub>r hmr_rel) h'x"
      assumes "h'x \<le> SPEC \<Phi>"
      assumes "\<And>h' r. \<Phi> (r,h') \<Longrightarrow> h.heap_invar h'"
      assumes "hmx \<le>\<^sub>n SPEC (\<lambda>(r,hm'). (\<exists>r'. (r,r')\<in>S \<and> \<Phi> (r',hmr_\<alpha> hm')) \<and> hmr_invar hm' \<longrightarrow> RETURN (r,heapmap_\<alpha> hm') \<le> \<Down>(R\<times>\<^sub>rId) hx)"
      shows "hmx \<le> \<Down>(R\<times>\<^sub>rheapmap_rel) hx"
      using assms
      unfolding heapmap_rel_def hmr_rel_def heapmap_invar_def
      apply (auto
        simp: pw_le_iff pw_leof_iff refine_pw_simps in_br_conv
        )
      by meson

    lemma ex_in_kvi_rel_conv:
      "(\<exists>r'. (r,r')\<in>kvi_rel hm i \<and> \<Phi> r') \<longleftrightarrow> (fst r = hm_key_of hm i \<and> \<Phi> (snd r))"
      unfolding kvi_rel_def
      apply (cases r)
      apply auto
      done

    lemma hm_pop_min_aref': "(hm_pop_min_op', mop_pm_pop_min prio) \<in> heapmap_rel \<rightarrow> \<langle>(Id\<times>\<^sub>rId) \<times>\<^sub>r heapmap_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      apply (frule heapmap_hmr_relI)
      unfolding mop_pm_pop_min_alt
      apply (intro ASSERT_refine_right)
      apply (rule heapmap_nres_rel_prodI')
        apply (erule hm_pop_min_op_refine')

        apply (unfold heapmap_rel_def hmr_rel_def in_br_conv) []
        apply (rule h.pop_min_op_correct)
        apply simp
        apply simp

        apply simp

        apply (clarsimp simp: ex_in_kvi_rel_conv split: prod.splits)
        unfolding hm_pop_min_op'_def hm_kv_of_op_def hm_key_of_op_unfold
          hm_the_lookup_op_def
        apply (refine_vcg
          hm_exch_op_\<alpha>_correct[THEN leof_trans]
          hm_butlast_op_\<alpha>_correct[THEN leof_trans]
          hm_sink_op_\<alpha>_correct[THEN leof_trans]
          )
        unfolding heapmap_rel_def hmr_rel_def in_br_conv
        apply (auto intro: ranI)
      done

    subsubsection \<open>Remove\<close>

    definition "hm_remove_op k hm \<equiv> do {
      ASSERT (heapmap_invar hm);
      ASSERT (k \<in> dom (heapmap_\<alpha> hm));
      i \<leftarrow> hm_index_op hm k;
      let l = hm_length hm;
      hm \<leftarrow> hm_exch_op hm i l;
      hm \<leftarrow> hm_butlast_op hm;
      if i \<noteq> l then
        hm_repair_op hm i
      else
        RETURN hm
    }"

    definition (in heapstruct) "remove_op i h \<equiv> do {
      ASSERT (heap_invar h);
      ASSERT (valid h i);
      let l = length h;
      h \<leftarrow> exch_op h i l;
      h \<leftarrow> butlast_op h;
      if i \<noteq> l then
        repair_op h i
      else
        RETURN h
    }"

    lemma (in -) swap_empty_iff[iff]: "swap l i j = [] \<longleftrightarrow> l=[]"
      by (auto simp: swap_def)

    lemma (in heapstruct)
      butlast_exch_last: "butlast (exch h i (length h)) = update (butlast h) i (last h)"
      unfolding exch_def update_def
      apply (cases h rule: rev_cases)
      apply (auto simp: swap_def butlast_list_update)
      done

    lemma (in heapstruct) remove_op_invar:
      "\<lbrakk> heap_invar h; valid h i \<rbrakk> \<Longrightarrow> remove_op i h \<le> SPEC heap_invar"
      unfolding remove_op_def
      apply refine_vcg
      apply (auto simp: valid_def) []
      apply (auto simp: valid_def exch_def) []
      apply (simp add: butlast_exch_last)
      apply refine_vcg
      apply auto []
      apply auto []
      apply (auto simp: valid_def) []
      apply auto []
      apply auto []
      done

    lemma hm_remove_op_refine[refine]:
      "\<lbrakk> (hm,m)\<in>heapmap_rel; (hm,h)\<in>hmr_rel; heapmap_\<alpha> hm k \<noteq> None\<rbrakk> \<Longrightarrow>
        hm_remove_op k hm \<le> \<Down>hmr_rel (h.remove_op (hm_index hm k) h)"
      unfolding hm_remove_op_def h.remove_op_def heapmap_rel_def
      (*apply (rewrite at "Let (hm_index hm k) _" Let_def)*)
      apply (refine_rcg index_op_inline_refine)
      unfolding hmr_rel_def
      apply (auto simp: in_br_conv)
      done

    lemma hm_remove_op_aref:
      "(hm_remove_op,mop_map_delete_ex) \<in> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding mop_map_delete_ex_alt
      apply (rule ASSERT_refine_right)
      apply (frule heapmap_hmr_relI)
      apply (rule heapmap_nres_relI')
      apply (rule hm_remove_op_refine; assumption?)
      apply (unfold heapmap_rel_def in_br_conv; auto)

      unfolding heapmap_rel_def hmr_rel_def in_br_conv
      apply (refine_vcg h.remove_op_invar; clarsimp; fail)
      apply (refine_vcg hm_remove_op_\<alpha>_correct[THEN leof_trans]; simp; fail)
      done

    subsubsection \<open>Peek-Min\<close>

    definition hm_peek_min_op :: "('k,'v) ahm \<Rightarrow> ('k\<times>'v) nres" where
      "hm_peek_min_op hm \<equiv> hm_kv_of_op hm 1"

    lemma hm_peek_min_op_aref:
      "(hm_peek_min_op, PR_CONST (mop_pm_peek_min prio)) \<in> heapmap_rel \<rightarrow> \<langle>Id\<times>\<^sub>rId\<rangle>nres_rel"
      unfolding PR_CONST_def
      apply (intro fun_relI nres_relI)
    proof -
      fix hm and m :: "'k \<rightharpoonup> 'v"
      assume A: "(hm,m)\<in>heapmap_rel"

      from A have [simp]: "h.heap_invar (hmr_\<alpha> hm)" "hmr_invar hm" "m=heapmap_\<alpha> hm"
        unfolding heapmap_rel_def in_br_conv heapmap_invar_def
        by simp_all

      have "hm_peek_min_op hm \<le> \<Down> (kvi_rel hm 1) (h.peek_min_op (hmr_\<alpha> hm))"
        unfolding hm_peek_min_op_def  h.peek_min_op_def
        apply (refine_rcg hm_kv_op_refine)
        using A
        apply (simp add: heapmap_hmr_relI)
        done
      also have "\<lbrakk>hmr_\<alpha> hm \<noteq> []\<rbrakk> \<Longrightarrow> (h.peek_min_op (hmr_\<alpha> hm))
        \<le> SPEC (\<lambda>v. v\<in>ran (heapmap_\<alpha> hm) \<and> (\<forall>v'\<in>ran (heapmap_\<alpha> hm). prio v \<le> prio v'))"
        apply refine_vcg
        by simp_all
      finally show "hm_peek_min_op hm \<le> \<Down> (Id \<times>\<^sub>r Id) (mop_pm_peek_min prio m)"
        unfolding mop_pm_peek_min_alt
        apply (simp add: pw_le_iff refine_pw_simps hm_peek_min_op_def hm_kv_of_op_def
            hm_key_of_op_unfold hm_the_lookup_op_def)
        apply (fastforce simp: kvi_rel_def ran_def)
        done

    qed

  end

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Strong_Sim_Pres
  imports Strong_Sim
begin

lemma actPres:
  fixes P    :: ccs
  and   Q    :: ccs
  and   Rel  :: "(ccs \<times> ccs) set"
  and   a    :: name
  and   Rel' :: "(ccs \<times> ccs) set"

  assumes "(P, Q) \<in> Rel"

  shows "\<alpha>.(P) \<leadsto>[Rel] \<alpha>.(Q)"
using assms
by(fastforce simp add: simulation_def elim: actCases intro: Action)

lemma sumPres:
  fixes P   :: ccs
  and   Q   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"

  assumes "P \<leadsto>[Rel] Q"
  and     "Rel \<subseteq> Rel'"
  and     "Id \<subseteq> Rel'"

  shows "P \<oplus> R \<leadsto>[Rel'] Q \<oplus> R"
using assms
by(force simp add: simulation_def elim: sumCases intro: Sum1 Sum2)

lemma parPresAux:
  fixes P   :: ccs
  and   Q   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"

  assumes "P \<leadsto>[Rel] Q"
  and     "(P, Q) \<in> Rel"
  and     "R \<leadsto>[Rel'] T"
  and     "(R, T) \<in> Rel'"
  and     C1: "\<And>P' Q' R' T'. \<lbrakk>(P', Q') \<in> Rel; (R', T') \<in> Rel'\<rbrakk> \<Longrightarrow> (P' \<parallel> R', Q' \<parallel> T') \<in> Rel''"

  shows "P \<parallel> R \<leadsto>[Rel''] Q \<parallel> T"
proof(induct rule: simI)
  case(Sim a QT)
  from \<open>Q \<parallel> T \<longmapsto>a \<prec> QT\<close>
  show ?case
  proof(induct rule: parCases)
    case(cPar1 Q')
    from \<open>P \<leadsto>[Rel] Q\<close> \<open>Q \<longmapsto>a \<prec> Q'\<close> obtain P' where "P \<longmapsto>a \<prec> P'" and "(P', Q') \<in> Rel"
      by(rule simE)
    from \<open>P \<longmapsto>a \<prec> P'\<close> have "P \<parallel> R \<longmapsto>a \<prec> P' \<parallel> R" by(rule Par1)
    moreover from \<open>(P', Q') \<in> Rel\<close> \<open>(R, T) \<in> Rel'\<close> have "(P' \<parallel> R, Q' \<parallel> T) \<in> Rel''" by(rule C1)
    ultimately show ?case by blast
  next
    case(cPar2 T')
    from \<open>R \<leadsto>[Rel'] T\<close> \<open>T \<longmapsto>a \<prec> T'\<close> obtain R' where "R \<longmapsto>a \<prec> R'" and "(R', T') \<in> Rel'"
      by(rule simE)
    from \<open>R \<longmapsto>a \<prec> R'\<close> have "P \<parallel> R \<longmapsto>a \<prec> P \<parallel> R'" by(rule Par2)
    moreover from \<open>(P, Q) \<in> Rel\<close> \<open>(R', T') \<in> Rel'\<close> have "(P \<parallel> R', Q \<parallel> T') \<in> Rel''" by(rule C1)
    ultimately show ?case by blast
  next
    case(cComm Q' T' a)
    from \<open>P \<leadsto>[Rel] Q\<close> \<open>Q \<longmapsto>a \<prec> Q'\<close> obtain P' where "P \<longmapsto>a \<prec> P'" and "(P', Q') \<in> Rel"
      by(rule simE)
    from \<open>R \<leadsto>[Rel'] T\<close> \<open>T \<longmapsto>(coAction a) \<prec> T'\<close> obtain R' where "R \<longmapsto>(coAction a) \<prec> R'" and "(R', T') \<in> Rel'"
      by(rule simE)
    from \<open>P \<longmapsto>a \<prec> P'\<close> \<open>R \<longmapsto>(coAction a) \<prec> R'\<close> \<open>a \<noteq> \<tau>\<close> have "P \<parallel> R \<longmapsto>\<tau> \<prec> P' \<parallel> R'" by(rule Comm)
    moreover from \<open>(P', Q') \<in> Rel\<close> \<open>(R', T') \<in> Rel'\<close> have "(P' \<parallel> R', Q' \<parallel> T') \<in> Rel''" by(rule C1)
    ultimately show ?case by blast
  qed
qed

lemma parPres:
  fixes P   :: ccs
  and   Q   :: ccs
  and   Rel :: "(ccs \<times> ccs) set"

  assumes "P \<leadsto>[Rel] Q"
  and     "(P, Q) \<in> Rel"
  and     C1: "\<And>S T U. (S, T) \<in> Rel \<Longrightarrow> (S \<parallel> U, T \<parallel> U) \<in> Rel'"

  shows "P \<parallel> R \<leadsto>[Rel'] Q \<parallel> R"
using assms
by(rule_tac parPresAux[where Rel''=Rel' and Rel'=Id]) (auto intro: reflexive)

  assumes "P \<leadsto>[Rel] Q"
  and     "\<And>R S y. (R, S) \<in> Rel \<Longrightarrow> (\<lparr>\<nu>y\<rparr>R, \<lparr>\<nu>y\<rparr>S) \<in> Rel'"

  shows "\<lparr>\<nu>x\<rparr>P \<leadsto>[Rel'] \<lparr>\<nu>x\<rparr>Q"
using assms
by(fastforce simp add: simulation_def elim: resCases intro: Res)

  assumes "(P, Q) \<in> Rel"
  and     C1: "\<And>R S. (R, S) \<in> Rel \<Longrightarrow> R \<leadsto>[Rel] S"

  shows "!P \<leadsto>[bangRel Rel] !Q"
proof(induct rule: simI)
  case(Sim \<alpha> Q')
  {
    fix Pa \<alpha> Q'
    assume "!Q \<longmapsto>\<alpha> \<prec> Q'" and "(Pa, !Q) \<in> bangRel Rel"
    hence "\<exists>P'. Pa \<longmapsto>\<alpha> \<prec> P' \<and> (P', Q') \<in> bangRel Rel"
    proof(nominal_induct arbitrary: Pa rule: bangInduct)
      case(cPar1 \<alpha> Q')
      from \<open>(Pa, Q \<parallel> !Q) \<in> bangRel Rel\<close>
      show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        from \<open>(P, Q) \<in> Rel\<close> have "P \<leadsto>[Rel] Q" by(rule C1)
        with \<open>Q \<longmapsto>\<alpha> \<prec> Q'\<close> obtain P' where "P \<longmapsto>\<alpha> \<prec> P'" and "(P', Q') \<in> Rel"
          by(blast dest: simE)
        from \<open>P \<longmapsto>\<alpha> \<prec> P'\<close> have "P \<parallel> R \<longmapsto>\<alpha> \<prec> P' \<parallel> R" by(rule Par1)
        moreover from \<open>(P', Q') \<in> Rel\<close> \<open>(R, !Q) \<in> bangRel Rel\<close> have "(P' \<parallel> R, Q' \<parallel> !Q) \<in> bangRel Rel"
          by(rule bangRel.BRPar)
        ultimately show ?case by blast
      qed
    next
      case(cPar2 \<alpha> Q')
      from \<open>(Pa, Q \<parallel> !Q) \<in> bangRel Rel\<close>
      show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        from \<open>(R, !Q) \<in> bangRel Rel\<close> obtain R' where "R \<longmapsto>\<alpha> \<prec> R'" and "(R', Q') \<in> bangRel Rel" using cPar2
          by blast
        from \<open>R \<longmapsto>\<alpha> \<prec> R'\<close> have "P \<parallel> R \<longmapsto>\<alpha> \<prec> P \<parallel> R'" by(rule Par2)
        moreover from \<open>(P, Q) \<in> Rel\<close> \<open>(R', Q') \<in> bangRel Rel\<close> have "(P \<parallel> R', Q \<parallel> Q') \<in> bangRel Rel" by(rule bangRel.BRPar)
        ultimately show ?case by blast
      qed
    next
      case(cComm a Q' Q'' Pa)
      from \<open>(Pa, Q \<parallel> !Q) \<in> bangRel Rel\<close>
      show ?case
      proof(induct rule: BRParCases)
        case(BRPar P R)
        from \<open>(P, Q) \<in> Rel\<close> have "P \<leadsto>[Rel] Q" by(rule C1)
        with \<open>Q \<longmapsto>a \<prec> Q'\<close> obtain P' where "P \<longmapsto>a \<prec> P'" and "(P', Q') \<in> Rel"
          by(blast dest: simE)
        from \<open>(R, !Q) \<in> bangRel Rel\<close> obtain R' where "R \<longmapsto>(coAction a) \<prec> R'" and "(R', Q'') \<in> bangRel Rel" using cComm
          by blast
        from \<open>P \<longmapsto>a \<prec> P'\<close> \<open>R \<longmapsto>(coAction a) \<prec> R'\<close> \<open>a \<noteq> \<tau>\<close> have "P \<parallel> R \<longmapsto>\<tau> \<prec> P' \<parallel> R'" by(rule Comm)
        moreover from \<open>(P', Q') \<in> Rel\<close> \<open>(R', Q'') \<in> bangRel Rel\<close> have "(P' \<parallel> R', Q' \<parallel> Q'') \<in> bangRel Rel" by(rule bangRel.BRPar)
        ultimately show ?case by blast
      qed
    next
      case(cBang \<alpha> Q' Pa)
      from \<open>(Pa, !Q) \<in> bangRel Rel\<close>
      show ?case
      proof(induct rule: BRBangCases)
        case(BRBang P)
        from \<open>(P, Q) \<in> Rel\<close> have "(!P, !Q) \<in> bangRel Rel" by(rule bangRel.BRBang)
        with \<open>(P, Q) \<in> Rel\<close> have "(P \<parallel> !P, Q \<parallel> !Q) \<in> bangRel Rel" by(rule bangRel.BRPar)
        then obtain P' where "P \<parallel> !P \<longmapsto>\<alpha> \<prec> P'" and "(P', Q') \<in> bangRel Rel" using cBang
          by blast
        from \<open>P \<parallel> !P \<longmapsto>\<alpha> \<prec> P'\<close> have "!P \<longmapsto>\<alpha> \<prec> P'" by(rule Bang)
        thus ?case using \<open>(P', Q') \<in> bangRel Rel\<close> by blast
      qed
    qed
  }

  moreover from \<open>(P, Q) \<in> Rel\<close> have "(!P, !Q) \<in> bangRel Rel" by(rule BRBang)
  ultimately show ?case using \<open>!Q \<longmapsto> \<alpha> \<prec> Q'\<close> by blast
qed

end


(*  Title:      HOL/Auth/Public.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Theory of Public Keys (common to all public-key protocols)

Private and public keys; initial states of agents
*)

theory Public
imports Event
begin

lemma invKey_K: "K \<in> symKeys \<Longrightarrow> invKey K = K"
by (simp add: symKeys_def)

subsection\<open>Asymmetric Keys\<close>

datatype keymode = Signature | Encryption

consts
  publicKey :: "[keymode,agent] \<Rightarrow> key"

abbreviation
  pubEK :: "agent \<Rightarrow> key" where
  "pubEK == publicKey Encryption"

abbreviation
  pubSK :: "agent \<Rightarrow> key" where
  "pubSK == publicKey Signature"

abbreviation
  privateKey :: "[keymode, agent] \<Rightarrow> key" where
  "privateKey b A == invKey (publicKey b A)"

abbreviation
  (*BEWARE!! priEK, priSK DON'T WORK with inj, range, image, etc.*)
  priEK :: "agent \<Rightarrow> key" where
  "priEK A == privateKey Encryption A"

abbreviation
  priSK :: "agent \<Rightarrow> key" where
  "priSK A == privateKey Signature A"

text\<open>These abbreviations give backward compatibility.  They represent the
simple situation where the signature and encryption keys are the same.\<close>

abbreviation
  pubK :: "agent \<Rightarrow> key" where
  "pubK A == pubEK A"

abbreviation
  priK :: "agent \<Rightarrow> key" where
  "priK A == invKey (pubEK A)"

text\<open>By freeness of agents, no two agents have the same key.  Since
  \<^term>\<open>True\<noteq>False\<close>, no agent has identical signing and encryption keys\<close>
specification (publicKey)
  injective_publicKey:
    "publicKey b A = publicKey c A' \<Longrightarrow> b=c \<and> A=A'"
   apply (rule exI [of _
       "\<lambda>b A. 2 * case_agent 0 (\<lambda>n. n + 2) 1 A + case_keymode 0 1 b"])
   apply (auto simp add: inj_on_def split: agent.split keymode.split)
   apply presburger
   apply presburger
   done

axiomatization where
  (*No private key equals any public key (essential to ensure that private
    keys are private!) *)
  privateKey_neq_publicKey [iff]: "privateKey b A \<noteq> publicKey c A'"

lemmas publicKey_neq_privateKey = privateKey_neq_publicKey [THEN not_sym]
declare publicKey_neq_privateKey [iff]

subsection\<open>Basic properties of \<^term>\<open>pubK\<close> and \<^term>\<open>priK\<close>\<close>

lemma publicKey_inject [iff]: "(publicKey b A = publicKey c A') = (b=c \<and> A=A')"
by (blast dest!: injective_publicKey)

lemma not_symKeys_pubK [iff]: "publicKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma not_symKeys_priK [iff]: "privateKey b A \<notin> symKeys"
by (simp add: symKeys_def)

lemma symKey_neq_priEK: "K \<in> symKeys \<Longrightarrow> K \<noteq> priEK A"
by auto

lemma symKeys_neq_imp_neq: "(K \<in> symKeys) \<noteq> (K' \<in> symKeys) \<Longrightarrow> K \<noteq> K'"
by blast

lemma symKeys_invKey_iff [iff]: "(invKey K \<in> symKeys) = (K \<in> symKeys)"
  unfolding symKeys_def by auto

lemma analz_symKeys_Decrypt:
     "\<lbrakk>Crypt K X \<in> analz H;  K \<in> symKeys;  Key K \<in> analz H\<rbrakk>
      \<Longrightarrow> X \<in> analz H"
by (auto simp add: symKeys_def)

subsection\<open>"Image" equations that hold for injective functions\<close>

lemma invKey_image_eq [simp]: "(invKey x \<in> invKey`A) = (x \<in> A)"
by auto

(*holds because invKey is injective*)
lemma publicKey_image_eq [simp]:
     "(publicKey b x \<in> publicKey c ` AA) = (b=c \<and> x \<in> AA)"
by auto

lemma privateKey_notin_image_publicKey [simp]: "privateKey b x \<notin> publicKey c ` AA"
by auto

lemma privateKey_image_eq [simp]:
     "(privateKey b A \<in> invKey ` publicKey c ` AS) = (b=c \<and> A\<in>AS)"
by auto

lemma publicKey_notin_image_privateKey [simp]: "publicKey b A \<notin> invKey ` publicKey c ` AS"
by auto

subsection\<open>Symmetric Keys\<close>

text\<open>For some protocols, it is convenient to equip agents with symmetric as
well as asymmetric keys.  The theory \<open>Shared\<close> assumes that all keys
are symmetric.\<close>

consts
  shrK    :: "agent => key"    \<comment> \<open>long-term shared keys\<close>

specification (shrK)
  inj_shrK: "inj shrK"
  \<comment> \<open>No two agents have the same long-term key\<close>
   apply (rule exI [of _ "case_agent 0 (\<lambda>n. n + 2) 1"])
   apply (simp add: inj_on_def split: agent.split)
   done

axiomatization where
  sym_shrK [iff]: "shrK X \<in> symKeys" \<comment> \<open>All shared keys are symmetric\<close>

text\<open>Injectiveness: Agents' long-term keys are distinct.\<close>
lemmas shrK_injective = inj_shrK [THEN inj_eq]
declare shrK_injective [iff]

lemma invKey_shrK [simp]: "invKey (shrK A) = shrK A"
by (simp add: invKey_K)

lemma analz_shrK_Decrypt:
     "\<lbrakk>Crypt (shrK A) X \<in> analz H; Key(shrK A) \<in> analz H\<rbrakk> \<Longrightarrow> X \<in> analz H"
by auto

lemma analz_Decrypt':
     "\<lbrakk>Crypt K X \<in> analz H; K \<in> symKeys; Key K \<in> analz H\<rbrakk> \<Longrightarrow> X \<in> analz H"
by (auto simp add: invKey_K)

lemma priK_neq_shrK [iff]: "shrK A \<noteq> privateKey b C"
by (simp add: symKeys_neq_imp_neq)

lemmas shrK_neq_priK = priK_neq_shrK [THEN not_sym]
declare shrK_neq_priK [simp]

lemma pubK_neq_shrK [iff]: "shrK A \<noteq> publicKey b C"
by (simp add: symKeys_neq_imp_neq)

lemmas shrK_neq_pubK = pubK_neq_shrK [THEN not_sym]
declare shrK_neq_pubK [simp]

lemma priEK_noteq_shrK [simp]: "priEK A \<noteq> shrK B"
by auto

lemma publicKey_notin_image_shrK [simp]: "publicKey b x \<notin> shrK ` AA"
by auto

lemma privateKey_notin_image_shrK [simp]: "privateKey b x \<notin> shrK ` AA"
by auto

lemma shrK_notin_image_publicKey [simp]: "shrK x \<notin> publicKey b ` AA"
by auto

lemma shrK_notin_image_privateKey [simp]: "shrK x \<notin> invKey ` publicKey b ` AA"
by auto

lemma shrK_image_eq [simp]: "(shrK x \<in> shrK ` AA) = (x \<in> AA)"
by auto

text\<open>For some reason, moving this up can make some proofs loop!\<close>
declare invKey_K [simp]

subsection\<open>Initial States of Agents\<close>

text\<open>Note: for all practical purposes, all that matters is the initial
knowledge of the Spy.  All other agents are automata, merely following the
protocol.\<close>

overloading
  initState \<equiv> initState
begin

primrec initState where
        (*Agents know their private key and all public keys*)
  initState_Server:
    "initState Server     =
       {Key (priEK Server), Key (priSK Server)} \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK) \<union> (Key ` range shrK)"

| initState_Friend:
    "initState (Friend i) =
       {Key (priEK(Friend i)), Key (priSK(Friend i)), Key (shrK(Friend i))} \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK)"

| initState_Spy:
    "initState Spy        =
       (Key ` invKey ` pubEK ` bad) \<union> (Key ` invKey ` pubSK ` bad) \<union>
       (Key ` shrK ` bad) \<union>
       (Key ` range pubEK) \<union> (Key ` range pubSK)"

end

text\<open>These lemmas allow reasoning about \<^term>\<open>used evs\<close> rather than
   \<^term>\<open>knows Spy evs\<close>, which is useful when there are private Notes.
   Because they depend upon the definition of \<^term>\<open>initState\<close>, they cannot
   be moved up.\<close>

lemma used_parts_subset_parts [rule_format]:
     "\<forall>X \<in> used evs. parts {X} \<subseteq> used evs"
apply (induct evs)
 prefer 2
 apply (simp add: used_Cons split: event.split)
 apply (metis Un_iff empty_subsetI insert_subset le_supI1 le_supI2 parts_subset_iff)
txt\<open>Base case\<close>
apply (auto dest!: parts_cut simp add: used_Nil)
done

lemma MPair_used_D: "\<lbrace>X,Y\<rbrace> \<in> used H \<Longrightarrow> X \<in> used H \<and> Y \<in> used H"
by (drule used_parts_subset_parts, simp, blast)

text\<open>There was a similar theorem in Event.thy, so perhaps this one can
  be moved up if proved directly by induction.\<close>
lemma MPair_used [elim!]:
     "\<lbrakk>\<lbrace>X,Y\<rbrace> \<in> used H;
         \<lbrakk>X \<in> used H; Y \<in> used H\<rbrakk> \<Longrightarrow> P\<rbrakk>
      \<Longrightarrow> P"
by (blast dest: MPair_used_D)

text\<open>Rewrites should not refer to  \<^term>\<open>initState(Friend i)\<close> because
  that expression is not in normal form.\<close>

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
unfolding keysFor_def
apply (induct_tac "C")
apply (auto intro: range_eqI)
done

lemma Crypt_notin_initState: "Crypt K X \<notin> parts (initState B)"
by (induct B, auto)

lemma Crypt_notin_used_empty [simp]: "Crypt K X \<notin> used []"
by (simp add: Crypt_notin_initState used_Nil)

(*** Basic properties of shrK ***)

(*Agents see their own shared keys!*)
lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState A"
by (induct_tac "A", auto)

lemma shrK_in_knows [iff]: "Key (shrK A) \<in> knows A evs"
by (simp add: initState_subset_knows [THEN subsetD])

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
by (rule initState_into_used, blast)

(** Fresh keys never clash with long-term shared keys **)

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range shrK"
by blast

lemma shrK_neq: "Key K \<notin> used evs \<Longrightarrow> shrK B \<noteq> K"
by blast

lemmas neq_shrK = shrK_neq [THEN not_sym]
declare neq_shrK [simp]

subsection\<open>Function \<^term>\<open>spies\<close>\<close>

lemma not_SignatureE [elim!]: "b \<noteq> Signature \<Longrightarrow> b = Encryption"
  by (cases b, auto)

text\<open>Agents see their own private keys!\<close>
lemma priK_in_initState [iff]: "Key (privateKey b A) \<in> initState A"
  by (cases A, auto)

text\<open>Agents see all public keys!\<close>
lemma publicKey_in_initState [iff]: "Key (publicKey b A) \<in> initState B"
  by (cases B, auto)

text\<open>All public keys are visible\<close>
lemma spies_pubK [iff]: "Key (publicKey b A) \<in> spies evs"
apply (induct_tac "evs")
apply (auto simp add: imageI knows_Cons split: event.split)
done

lemmas analz_spies_pubK = spies_pubK [THEN analz.Inj]
declare analz_spies_pubK [iff]

text\<open>Spy sees private keys of bad agents!\<close>
lemma Spy_spies_bad_privateKey [intro!]:
     "A \<in> bad \<Longrightarrow> Key (privateKey b A) \<in> spies evs"
apply (induct_tac "evs")
apply (auto simp add: imageI knows_Cons split: event.split)
done

text\<open>Spy sees long-term shared keys of bad agents!\<close>
lemma Spy_spies_bad_shrK [intro!]:
     "A \<in> bad \<Longrightarrow> Key (shrK A) \<in> spies evs"
apply (induct_tac "evs")
apply (simp_all add: imageI knows_Cons split: event.split)
done

lemma publicKey_into_used [iff] :"Key (publicKey b A) \<in> used evs"
apply (rule initState_into_used)
apply (rule publicKey_in_initState [THEN parts.Inj])
done

lemma privateKey_into_used [iff]: "Key (privateKey b A) \<in> used evs"
apply(rule initState_into_used)
apply(rule priK_in_initState [THEN parts.Inj])
done

(*For case analysis on whether or not an agent is compromised*)
lemma Crypt_Spy_analz_bad:
     "\<lbrakk>Crypt (shrK A) X \<in> analz (knows Spy evs);  A \<in> bad\<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
by force

subsection\<open>Fresh Nonces\<close>

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState B)"
by (induct_tac "B", auto)

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
by (simp add: used_Nil)

subsection\<open>Supply fresh nonces for possibility theorems\<close>

text\<open>In any trace, there is an upper bound N on the greatest nonce in use\<close>
lemma Nonce_supply_lemma: "\<exists>N. \<forall>n. N\<le>n \<longrightarrow> Nonce n \<notin> used evs"
apply (induct_tac "evs")
apply (rule_tac x = 0 in exI)
apply (simp_all (no_asm_simp) add: used_Cons split: event.split)
apply safe
apply (rule msg_Nonce_supply [THEN exE], blast elim!: add_leE)+
done

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
by (rule Nonce_supply_lemma [THEN exE], blast)

lemma Nonce_supply: "Nonce (SOME N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule Nonce_supply_lemma [THEN exE])
apply (rule someI, fast)
done

subsection\<open>Specialized Rewriting for Theorems About \<^term>\<open>analz\<close> and Image\<close>

lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key ` (insert K KK) \<union> C"
by blast

lemma Crypt_imp_keysFor :"\<lbrakk>Crypt K X \<in> H; K \<in> symKeys\<rbrakk> \<Longrightarrow> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

text\<open>Lemma for the trivial direction of the if-and-only-if of the
Session Key Compromise Theorem\<close>
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) \<longrightarrow> (K \<in> nE | Key K \<in> analz H)  \<Longrightarrow>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

lemmas analz_image_freshK_simps =
       simp_thms mem_simps \<comment> \<open>these two allow its use with \<open>only:\<close>\<close>
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN subsetD]
       insert_Key_singleton
       Key_not_used insert_Key_image Un_assoc [THEN sym]

ML \<open>
structure Public =
struct

val analz_image_freshK_ss =
  simpset_of
   (\<^context> delsimps [image_insert, image_Un]
    delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
    addsimps @{thms analz_image_freshK_simps})

(*Tactic for possibility theorems*)
fun possibility_tac ctxt =
    REPEAT (*omit used_Says so that Nonces start from different traces!*)
    (ALLGOALS (simp_tac (ctxt setSolver safe_solver delsimps [@{thm used_Says}]))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}]))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac ctxt [refl, conjI]))

end
\<close>

method_setup analz_freshK = \<open>
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac ctxt [allI, ballI, impI]),
          REPEAT_FIRST (resolve_tac ctxt @{thms analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Public.analz_image_freshK_ss ctxt))])))\<close>
    "for proving the Session Key Compromise theorem"

subsection\<open>Specialized Methods for Possibility Theorems\<close>

method_setup possibility = \<open>
    Scan.succeed (SIMPLE_METHOD o Public.possibility_tac)\<close>
    "for proving possibility theorems"

method_setup basic_possibility = \<open>
    Scan.succeed (SIMPLE_METHOD o Public.basic_possibility_tac)\<close>
    "for proving possibility theorems"

end


(*  Title:      FMap.thy
    Author:     Ludovic Henrio and Florian Kammuller, 2006

Finite maps for Sigma-calculus
Idea use axiomatic type classes to preserve
usability of datatype afterwards, i.e. definition
of an object as a finite map of labels to fields in
a datatype.
*)

header {* Finite maps with axclasses *}

theory FMap imports ListPre begin

type_synonym ('a, 'b) fmap = "('a :: finite) ~=> 'b" (infixl "-~>" 50)

class inftype =
assumes infinite: "\<not>finite UNIV"

theorem fset_induct:
  "P {} \<Longrightarrow> (\<And>x (F::('a::finite)set). x \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert x F)) \<Longrightarrow> P F"
proof (rule_tac P=P and F=F in finite_induct)
  from finite_subset[OF subset_UNIV] show "finite F" by auto
next
  assume "P {}" thus "P {}" by simp
next
  fix x F
  assume "\<And>x F. \<lbrakk> x \<notin> F; P F \<rbrakk> \<Longrightarrow> P (insert x F)" and "x \<notin> F" and "P F"
  thus "P (insert x F)" by simp
qed

theorem fmap_unique: "x = y \<Longrightarrow> (f::('a,'b)fmap) x = f y"
  by (erule ssubst, rule refl)

(* define the witness as a constant function so it may be used in the proof of
the induction scheme below *)
definition
  set_fmap :: "'a -~> 'b \<Rightarrow> ('a * 'b)set" where
  "set_fmap F = {(x, y). x \<in> dom F \<and> F x = Some y}"

definition
  pred_set_fmap :: "(('a -~> 'b) \<Rightarrow> bool) \<Rightarrow> (('a * 'b)set) \<Rightarrow> bool" where
  "pred_set_fmap P = (\<lambda>S. P (\<lambda>x. if x \<in> fst ` S
                                  then (THE y. (\<exists>z. y = Some z \<and> (x, z) \<in> S))
                                  else None))"

definition
  fmap_minus_direct :: "[('a -~> 'b), ('a * 'b)] \<Rightarrow> ('a -~> 'b)" (infixl "--" 50) where
  "F -- x = (\<lambda>z. if (fst x = z \<and> ((F (fst x)) = Some (snd x)))
                   then None
                   else (F z))"

lemma insert_lem : "insert x A = B \<Longrightarrow> x \<in> B"
  by auto

lemma fmap_minus_fmap:
  fixes F x a b
  assumes "(F -- x) a = Some b"
  shows "F a = Some b"
proof (rule ccontr, cases "F a")
  case None hence "a \<notin> dom F" by auto
  hence "(F -- x) a = None"
    unfolding fmap_minus_direct_def by auto
  with `(F -- x) a = Some b` show False by simp
next
  assume "F a \<noteq> Some b"
  case (Some y) thus False
  proof (cases "fst x = a")
    case True thus False
    proof (cases "snd x = y")
      case True with `F a = Some y` `fst x = a`
      have "(F -- x) a = None" unfolding fmap_minus_direct_def by auto
      with `(F -- x) a = Some b` show False by simp
    next
      case False with `F a = Some y` `fst x = a`
      have "F (fst x) \<noteq> Some (snd x)" by auto
      with `(F -- x) a = Some b` have "F a = Some b"
        unfolding fmap_minus_direct_def by auto
      with `F a \<noteq> Some b` show False by simp
    qed
  next
    case False with `(F -- x) a = Some b`
    have "F a = Some b" unfolding fmap_minus_direct_def by auto
    with `F a \<noteq> Some b` show False by simp
  qed
qed

lemma set_fmap_minus_iff:
  "set_fmap ((F::(('a::finite) -~> 'b)) -- x) = set_fmap F - {x}"
  unfolding set_fmap_def
proof (auto)
  fix a b assume "(F -- x) a = Some b" from fmap_minus_fmap[OF this]
  show "\<exists>y. F a = Some y" by blast
next
  fix a b assume "(F -- x) a = Some b" from fmap_minus_fmap[OF this]
  show "F a = Some b" by assumption
next
  fix a b assume "(F -- (a, b)) a = Some b"
  with fmap_minus_fmap[OF this] show False
    unfolding fmap_minus_direct_def by auto
next
  fix a b assume "(a,b) \<noteq> x" and "F a = Some b"
  hence "fst x \<noteq> a \<or> F (fst x) \<noteq> Some (snd x)" by auto
  with `F a = Some b` show "\<exists>y. (F -- x) a = Some y"
    unfolding fmap_minus_direct_def by (rule_tac x = b in exI, simp)
next
  fix a b assume "(a,b) \<noteq> x" and "F a = Some b"
  hence "fst x \<noteq> a \<or> F (fst x) \<noteq> Some (snd x)" by auto
  with `F a = Some b` show "(F -- x) a = Some b"
    unfolding fmap_minus_direct_def by simp
qed

lemma set_fmap_minus_insert:
  fixes F :: "('a::finite * 'b)set" and  F':: "('a::finite) -~> 'b" and x
  assumes "x \<notin> F" and "insert x F = set_fmap F'"
  shows "F = set_fmap (F' -- x)"
proof -
  from `x \<notin> F` sym[OF `insert x F = set_fmap F'`] set_fmap_minus_iff[of F' x]
  show ?thesis by simp
qed

lemma notin_fmap_minus: "x \<notin> set_fmap ((F::(('a::finite) -~> 'b)) -- x)"
  by (auto simp: set_fmap_minus_iff)

lemma fst_notin_fmap_minus_dom:
  fixes F x and F' :: "('a::finite) -~> 'b"
  assumes "insert x F = set_fmap F'"
  shows "fst x \<notin> dom (F' -- x)"
proof (rule ccontr, auto)
  fix y assume "(F' -- x) (fst x) = Some y"
  with notin_fmap_minus[of x F']
  have "y \<noteq> snd x"
    unfolding set_fmap_def by auto
  moreover
  from insert_lem[OF `insert x F = set_fmap F'`]
  have "F' (fst x) = Some (snd x)"
    unfolding set_fmap_def by auto
  ultimately show False
    using fmap_minus_fmap[OF `(F' -- x) (fst x) = Some y`]
    by simp
qed

lemma  set_fmap_pair:
  "x \<in> set_fmap F \<Longrightarrow> (fst x \<in> dom F \<and> snd x = the (F (fst x)))"
  by (simp add: set_fmap_def, auto)

lemma  set_fmap_inv1:
  "\<lbrakk> fst x \<in> dom F; snd x = the (F (fst x)) \<rbrakk> \<Longrightarrow> (F -- x)(fst x \<mapsto> snd x) = F"
proof (rule ext)
  fix xa assume "fst x \<in> dom F" and "snd x = the (F (fst x))"
  thus "((F -- x)(fst x \<mapsto> snd x)) xa = F xa"
    unfolding fmap_minus_direct_def
    by (case_tac "xa = fst x", auto)
qed

lemma set_fmap_inv2:
  "fst x \<notin> dom F \<Longrightarrow> insert x (set_fmap F) = set_fmap (F(fst x \<mapsto> snd x))"
  unfolding set_fmap_def
proof
  assume "fst x \<notin> dom F"
  thus
    "insert x {(x, y). x \<in> dom F \<and> F x = Some y} \<subseteq>
    {(xa, y). xa \<in> dom (F(fst x \<mapsto> snd x)) \<and> (F(fst x \<mapsto> snd x)) xa = Some y}"
    by force
next
  have
    "\<And>z. z \<in> {(xa, y). xa \<in> dom (F(fst x \<mapsto> snd x))
                     \<and> (F(fst x \<mapsto> snd x)) xa = Some y}
    \<Longrightarrow> z \<in> insert x {(x, y). x \<in> dom F \<and> F x = Some y}"
    proof -
      fix z
      assume
        z: "z \<in> {(xa, y). xa \<in> dom (F(fst x \<mapsto> snd x))
                     \<and> (F(fst x \<mapsto> snd x)) xa = Some y}"
      hence "z = x \<or> ((fst z) \<in> dom F \<and> F (fst z) = Some (snd z))"
      proof (cases "fst x = fst z")
        case True thus ?thesis using z by auto
      next
        case False thus ?thesis using z by auto
      qed
      thus "z \<in> insert x {(x, y). x \<in> dom F \<and> F x = Some y}" by fastforce
    qed
  thus
    "{(xa, y). xa \<in> dom (F(fst x \<mapsto> snd x)) \<and> (F(fst x \<mapsto> snd x)) xa = Some y} \<subseteq>
    insert x {(x, y). x \<in> dom F \<and> F x = Some y}" by auto
qed

lemma rep_fmap_base: "P (F::('a  -~> 'b)) = (pred_set_fmap P)(set_fmap F)"
  unfolding pred_set_fmap_def set_fmap_def
proof (rule_tac f = P in arg_cong)
  have
    "\<And>x. F x =
         (\<lambda>x. if x \<in> fst ` {(x, y). x \<in> dom F \<and> F x = Some y}
               then THE y. \<exists>z. y = Some z
                             \<and> (x, z) \<in> {(x, y). x \<in> dom F \<and> F x = Some y}
               else None) x"
  proof auto
    fix a b
    assume "F a = Some b"
    hence "\<exists>!x. x = Some b \<and> a \<in> dom F"
    proof (rule_tac a = "F a" in ex1I)
      assume "F a = Some b"
      thus "F a = Some b \<and> a \<in> dom F"
        by (simp add: dom_def)
    next
      fix x assume "F a = Some b" and "x = Some b \<and> a \<in> dom F"
      thus "x = F a" by simp
    qed
    hence "(THE y. y = Some b \<and> a \<in> dom F) = Some b \<and> a \<in> dom F"
      by (rule theI')
    thus "Some b = (THE y. y = Some b \<and> a \<in> dom F)"
      by simp
  next
    fix x assume nin_x: "x \<notin> fst ` {(x, y). x \<in> dom F \<and> F x = Some y}"
    thus "F x = None"
    proof (cases "F x")
      case None thus ?thesis by assumption
    next
      case (Some a)
      hence "x \<in> fst ` {(x, y). x \<in> dom F \<and> F x = Some y}"
        by (simp add: image_def dom_def)
      with nin_x show ?thesis by simp
    qed
  qed
  thus
    "F = (\<lambda>x. if x \<in> fst ` {(x, y). x \<in> dom F \<and> F x = Some y}
               then THE y. \<exists>z. y = Some z
                             \<and> (x, z) \<in> {(x, y). x \<in> dom F \<and> F x = Some y}
               else None)"
    by (rule ext)
qed

lemma rep_fmap:
  "\<exists>(Fp ::('a * 'b)set) (P'::('a * 'b)set \<Rightarrow> bool). P (F::('a -~> 'b)) = P' Fp"
proof -
  from rep_fmap_base show ?thesis by blast
qed

theorem finite_fsets: "finite (F::('a::finite)set)"
proof -
  from finite_subset[OF subset_UNIV] show "finite F" by auto
qed

lemma finite_dom_fmap: "finite (dom (F::('a -~> 'b))::('a::finite)set)"
  by (rule finite_fsets)

lemma finite_fmap_ran: "finite (ran (F::(('a::finite) -~> 'b)))"
  unfolding ran_def
proof -
  from finite_dom_fmap finite_imageI
  have "finite ((\<lambda>x. the (F x)) ` (dom F))"
    by blast
  moreover
  have "{b. \<exists>a. F a = Some b} = (\<lambda>x. the (F x)) ` (dom F)"
    unfolding image_def dom_def by force
  ultimately
  show "finite {b. \<exists>a. F a = Some b}"  by simp
qed

lemma finite_fset_map: "finite (set_fmap (F::(('a::finite) -~> 'b)))"
proof -
  from finite_cartesian_product[OF finite_dom_fmap finite_fmap_ran]
  have "finite (dom F \<times> ran F)" .
  moreover
  have "set_fmap F \<subseteq> dom F \<times> ran F"
    unfolding set_fmap_def dom_def ran_def by fastforce
  ultimately
  show ?thesis using finite_subset by auto
qed

lemma rep_fmap_imp:
  "\<forall>F x z. x \<notin> dom (F::('a -~> 'b)) \<longrightarrow> P F \<longrightarrow> P (F(x \<mapsto> z))
  \<Longrightarrow> (\<forall>F x z. x \<notin> fst ` (set_fmap F) \<longrightarrow> (pred_set_fmap P)(set_fmap F)
        \<longrightarrow> (pred_set_fmap P) (insert (x,z) (set_fmap F)))"
proof (clarify)
  fix P F x z
  assume
    "\<forall>F x z. x \<notin> dom (F::('a -~> 'b)) \<longrightarrow> P F \<longrightarrow> P (F(x \<mapsto> z))" and
    "x \<notin> fst ` set_fmap F" and "(pred_set_fmap P)(set_fmap F)"
  hence notin: "x \<notin> dom F"
    unfolding set_fmap_def image_def dom_def by simp
  moreover
  from `pred_set_fmap P (set_fmap F)` have "P F" by (simp add: rep_fmap_base)
  ultimately
  have "P (F(x \<mapsto> z))" using `\<forall>F x z. x \<notin> dom F \<longrightarrow> P F \<longrightarrow> P (F(x \<mapsto> z))`
    by blast
  hence "(pred_set_fmap P) (set_fmap (F(x \<mapsto> z)))"
    by (simp add: rep_fmap_base)
  moreover
  from notin
  have "(insert (x,z) (set_fmap F)) = (set_fmap (F(fst (x,z) \<mapsto> snd (x,z))))"
    by (simp add: set_fmap_inv2)
  ultimately
  show "(pred_set_fmap P) (insert (x,z) (set_fmap F))" by simp
qed

theorem fmap_induct[rule_format, case_names empty insert]:
  fixes  P  :: "(('a :: finite) -~> 'b) \<Rightarrow> bool" and  F' :: "('a  -~> 'b)"
  assumes
  "P empty" and
  "\<forall>(F::('a -~> 'b)) x z. x \<notin> dom F \<longrightarrow> P F \<longrightarrow> P (F(x \<mapsto> z))"
  shows "P F'"
proof -
  {
    fix F :: "('a \<times> 'b) set" assume "finite F"
    hence "\<forall>F'. F = set_fmap F' \<longrightarrow> pred_set_fmap P (set_fmap F')"
    proof (induct F)
      case empty thus ?case
      proof (intro strip)
        fix F' :: "'a -~> 'b" assume "{} = set_fmap F'"
        hence "\<And>a. F' a = None" unfolding set_fmap_def by auto
        hence "F' = empty" by (rule ext)
        with `P empty` rep_fmap_base[of P empty]
        show "pred_set_fmap P (set_fmap F')" by simp
      qed
    next
      case (insert x Fa) thus ?case
      proof (intro strip)
        fix Fb :: "'a -~> 'b"
        assume "insert x Fa = set_fmap Fb"
        from
          set_fmap_minus_insert[OF `x \<notin> Fa` this]
          `\<forall>F'. Fa = set_fmap F' \<longrightarrow> pred_set_fmap P (set_fmap F')`
          rep_fmap_base[of P "Fb -- x"]
        have "P (Fb -- x)" by blast
        with
          `\<forall>F x z. x \<notin> dom F \<longrightarrow> P F \<longrightarrow> P (F(x \<mapsto> z))`
          fst_notin_fmap_minus_dom[OF `insert x Fa = set_fmap Fb`]
        have "P ((Fb -- x)(fst x \<mapsto> snd x))" by blast
        moreover
        from
          insert_absorb[OF insert_lem[OF `insert x Fa = set_fmap Fb`]]
          set_fmap_minus_iff[of Fb x]
          set_fmap_inv2[OF
           fst_notin_fmap_minus_dom[OF `insert x Fa = set_fmap Fb`]]
        have "set_fmap Fb = set_fmap ((Fb -- x)(fst x \<mapsto> snd x))"
          by simp
        ultimately
        show "pred_set_fmap P (set_fmap Fb)"
          using rep_fmap_base[of P "(Fb -- x)(fst x \<mapsto> snd x)"]
          by simp
      qed
    qed
  }
  from this[OF finite_fset_map[of F']]
       rep_fmap_base[of P F']
  show "P F'" by blast
qed

lemma fmap_induct3[consumes 2, case_names empty insert]:
  "\<And>(F2::('a::finite) -~> 'b) (F3::('a -~> 'b)).
   \<lbrakk> dom (F1::('a -~> 'b)) = dom F2; dom F3 = dom F1;
     P empty empty empty;
     \<And>x a b c (F1::('a -~> 'b)) (F2::('a -~> 'b)) (F3::('a -~> 'b)).
     \<lbrakk> P F1 F2 F3; dom F1 = dom F2; dom F3 = dom F1; x \<notin> dom F1 \<rbrakk>
     \<Longrightarrow> P (F1(x \<mapsto> a)) (F2(x \<mapsto> b)) (F3(x \<mapsto> c)) \<rbrakk>
  \<Longrightarrow> P F1 F2 F3"
proof (induct F1 rule: fmap_induct)
  case empty
  from `dom empty = dom F2` have "F2 = empty" by (simp add: empty_dom)
  moreover
  from `dom F3 = dom empty` have "F3 = empty" by (simp add: empty_dom)
  ultimately
  show ?case using `P empty empty empty` by simp
next
  case (insert F x y) thus ?case
  proof (cases "F2 = empty")
    case True with `dom (F(x \<mapsto> y)) = dom F2`
    have "dom (F(x \<mapsto> y)) = {}" by auto
    thus ?thesis by auto
  next
    case False thus ?thesis
    proof (cases "F3 = empty")
      case True with `dom F3 = dom (F(x \<mapsto> y))`
      have "dom (F(x \<mapsto> y)) = {}" by simp
      thus ?thesis by simp
    next
      case False thus ?thesis
      proof -
        from `F2 \<noteq> Map.empty`
        have "\<forall>l\<in>dom F2. \<exists>f'. F2 = f'(l \<mapsto> the (F2 l)) \<and> l \<notin> dom f'"
          by (simp add: one_more_dom)
        moreover
        from `dom (F(x \<mapsto> y)) = dom F2` have "x \<in> dom F2" by force
        ultimately have "\<exists>f'. F2 = f'(x \<mapsto> the (F2 x)) \<and> x \<notin> dom f'" by blast
        then obtain F2' where "F2 = F2'(x \<mapsto> the (F2 x))" and "x \<notin> dom F2'"
          by auto

        from `F3 \<noteq> Map.empty`
        have "\<forall>l\<in>dom F3. \<exists>f'. F3 = f'(l \<mapsto> the (F3 l)) \<and> l \<notin> dom f'"
          by (simp add: one_more_dom)
        moreover from `dom F3 = dom (F(x \<mapsto> y))` have "x \<in> dom F3" by force
        ultimately have "\<exists>f'. F3 = f'(x \<mapsto> the (F3 x)) \<and> x \<notin> dom f'" by blast
        then obtain F3' where "F3 = F3'(x \<mapsto> the (F3 x))" and "x \<notin> dom F3'"
          by auto

        show ?thesis
        proof -
          from `dom (F(x \<mapsto> y)) = dom F2` `F2 = F2'(x \<mapsto> the (F2 x))`
          have "dom (F(x \<mapsto> y)) = dom (F2'(x \<mapsto> the (F2 x)))" by simp
          with `x \<notin> dom F` `x \<notin> dom F2'` have "dom F = dom F2'" by auto

          moreover
          from `dom F3 = dom (F(x \<mapsto> y))` `F3 = F3'(x \<mapsto> the (F3 x))`
          have "dom (F(x \<mapsto> y)) = dom (F3'(x \<mapsto> the (F3 x)))" by simp
          with `x \<notin> dom F` `x \<notin> dom F3'` have "dom F3' = dom F" by auto

          ultimately have "P F F2' F3'" using insert by simp

          with
            `\<And>F1 F2 F3 x a b c.
              \<lbrakk> P F1 F2 F3; dom F1 = dom F2; dom F3 = dom F1; x \<notin> dom F1 \<rbrakk>
              \<Longrightarrow> P (F1(x \<mapsto> a)) (F2(x \<mapsto> b)) (F3(x \<mapsto> c))`
            `dom F = dom F2'`
            `dom F3' = dom F`
            `x \<notin> dom F`
          have "P (F(x \<mapsto> y)) (F2'(x \<mapsto> the (F2 x))) (F3'(x \<mapsto> the (F3 x)))"
            by simp
          with `F2 = F2'(x \<mapsto> the (F2 x))` `F3 = F3'(x \<mapsto> the (F3 x))`
          show "P (F(x \<mapsto> y)) F2 F3" by simp
        qed
      qed
    qed
  qed
qed

lemma fmap_ex_cof2:
  "\<And>(P::'c \<Rightarrow> 'c \<Rightarrow> 'b option \<Rightarrow> 'b option \<Rightarrow> 'a \<Rightarrow> bool)
     (f'::('a::finite) -~> 'b).
  \<lbrakk> dom f' = dom (f::('a -~> 'b));
    \<forall>l\<in>dom f. (\<exists>L. finite L
                  \<and> (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p
                      \<longrightarrow> P s p (f l) (f' l) l)) \<rbrakk>
  \<Longrightarrow> \<exists>L. finite L \<and> (\<forall>l\<in>dom f. (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p
                                   \<longrightarrow> P s p (f l) (f' l) l))"
proof (induct f rule: fmap_induct)
  case empty thus ?case by blast
next
  case (insert f l t P f') note imp = this(2) and pred = this(4)
  def pred_cof \<equiv> "\<lambda>L b b' l. \<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p \<longrightarrow> P s p b b' l"
  from
    map_upd_nonempty[of f l t] `dom f' = dom (f(l \<mapsto> t))`
    one_more_dom[of l f']
  obtain f'a where
    "f' = f'a(l \<mapsto> the(f' l))" and "l \<notin> dom f'a" and
    "dom (f'a(l \<mapsto> the(f' l))) = dom (f(l \<mapsto> t))"
    by auto
  from `l \<notin> dom f`
  have
    fla: "\<forall>la\<in>dom f. f la = (f(l \<mapsto> t)) la" and
    "\<forall>la\<in>dom f. f'a la = (f'a(l \<mapsto> the(f' l))) la"
    by auto
  with `f' = f'a(l \<mapsto> the(f' l))`
  have f'ala: "\<forall>la\<in>dom f. f'a la = f' la" by simp
  have "\<exists>L. finite L \<and> (\<forall>la\<in>dom f. pred_cof L (f la) (f'a la) la)"
    unfolding pred_cof_def
  proof
    (intro imp[OF insert_dom_less_eq[OF `l \<notin> dom f'a` `l \<notin> dom f`
                                        `dom (f'a(l \<mapsto> the(f' l))) = dom (f(l \<mapsto> t))`]],
      intro strip)
    fix la assume "la \<in> dom f"
    with fla f'ala
    have
      "la \<in> dom (f(l \<mapsto> t))" and
      "f la = (f(l \<mapsto> t)) la" and "f'a la = f' la"
      by auto
    with pred
    show "\<exists>L. finite L \<and> (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p \<longrightarrow> P s p (f la) (f'a la) la)"
      by (elim ssubst, blast)
  qed
  with fla f'ala obtain L where
    "finite L" and predf: "\<forall>la\<in>dom f. pred_cof L ((f(l \<mapsto> t)) la) (f' la) la"
    by auto
  moreover
  have "l \<in> dom (f(l \<mapsto> t))" by simp
  with pred obtain L' where
    "finite L'" and predfl: "pred_cof L' ((f(l \<mapsto> t)) l) (f' l) l"
    unfolding pred_cof_def
    by blast
  ultimately show ?case
  proof (rule_tac x = "L \<union> L'" in exI,
      intro conjI, simp, intro strip)
    fix s p la assume
      sp: "s \<notin> L \<union> L' \<and> p \<notin> L \<union> L' \<and> s \<noteq> p" and indom: "la \<in> dom (f(l \<mapsto> t))"
    show "P s p ((f(l \<mapsto> t)) la) (f' la) la"
    proof (cases "la = l")
      case True with sp predfl show ?thesis
        unfolding pred_cof_def
        by simp
    next
      case False with indom sp predf show ?thesis
        unfolding pred_cof_def
        by force
    qed
  qed
qed

lemma fmap_ex_cof:
  fixes
  P :: "'c \<Rightarrow> 'c \<Rightarrow> 'b option \<Rightarrow> ('a::finite) \<Rightarrow> bool"
  assumes
  "\<forall>l\<in>dom (f::('a -~> 'b)).
  (\<exists>L. finite L \<and> (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p \<longrightarrow> P s p (f l) l))"
  shows
  "\<exists>L. finite L \<and> (\<forall>l\<in>dom f. (\<forall>s p. s \<notin> L \<and> p \<notin> L \<and> s \<noteq> p \<longrightarrow> P s p (f l) l))"
  using assms fmap_ex_cof2[of f f  "\<lambda>s p b b' l. P s p b l"] by auto

lemma fmap_ball_all2:
  fixes
  Px :: "'c \<Rightarrow> 'd \<Rightarrow> bool" and
  P :: "'c \<Rightarrow> 'd \<Rightarrow> 'b option \<Rightarrow> bool"
  assumes
  "\<forall>l\<in>dom (f::('a::finite) -~> 'b). \<forall>(x::'c) (y::'d). Px x y \<longrightarrow> P x y (f l)"
  shows
  "\<forall>x y. Px x y \<longrightarrow> (\<forall>l\<in>dom f. P x y (f l))"
proof (intro strip)
  fix x y l assume "Px x y" and "l \<in> dom f"
  with assms show "P x y (f l)" by blast
qed

lemma fmap_ball_all2':
  fixes
  Px :: "'c \<Rightarrow> 'd \<Rightarrow> bool" and
  P :: "'c \<Rightarrow> 'd \<Rightarrow> 'b option \<Rightarrow> ('a::finite) \<Rightarrow> bool"
  assumes
  "\<forall>l\<in>dom (f::('a -~> 'b)). \<forall>(x::'c) (y::'d). Px x y \<longrightarrow> P x y (f l) l"
  shows
  "\<forall>x y. Px x y \<longrightarrow> (\<forall>l\<in>dom f. P x y (f l) l)"
proof (intro strip)
  fix x y l assume "Px x y" and "l \<in> dom f"
  with assms show "P x y (f l) l" by blast
qed

lemma fmap_ball_all3:
  fixes
  Px :: "'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> bool" and
  P :: "'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'b option \<Rightarrow> 'b option \<Rightarrow> bool" and
  f :: "('a::finite) -~> 'b" and f' :: "'a -~> 'b"
  assumes
  "dom f' = dom f" and
  "\<forall>l\<in>dom f.
     \<forall>(x::'c) (y::'d) (z::'e). Px x y z \<longrightarrow> P x y z (f l) (f' l)"
  shows
  "\<forall>x y z. Px x y z \<longrightarrow> (\<forall>l\<in>dom f. P x y z (f l) (f' l))"
proof (intro strip)
  fix x y z l assume "Px x y z" and "l \<in> dom f"
  with assms show "P x y z (f l) (f' l)" by blast
qed

lemma fmap_ball_all4':
  fixes
  Px :: "'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'f \<Rightarrow> bool" and
  P :: "'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'f \<Rightarrow> 'b option \<Rightarrow> ('a::finite) \<Rightarrow> bool"
  assumes
  "\<forall>l\<in>dom (f::('a -~> 'b)).
    \<forall>(x::'c) (y::'d) (z::'e) (a::'f). Px x y z a \<longrightarrow> P x y z a (f l) l"
  shows
  "\<forall>x y z a. Px x y z a \<longrightarrow> (\<forall>l\<in>dom f. P x y z a (f l) l)"
proof (intro strip)
  fix x y z a l assume "Px x y z a" and "l \<in> dom f"
  with assms show "P x y z a (f l) l" by blast
qed

end