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 = set pq"

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

  lemmas hmr_rel_defs = hmr_rel_def br_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"

    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
        eq_commute[of "dom _" "set _"] ran_def)
      apply force
      done

    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)"
      by (force simp: hmr_\<alpha>_def hmr_invar_def heapmap_\<alpha>_def in_multiset_in_set ran_is_image)

    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)

    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>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. ASSERT (i>0) \<then> mop_list_get pq (i - 1)"

    lemma hm_key_of_op_unfold:
      shows "hm_key_of_op hm i = ASSERT (hm_valid hm i) \<then> 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
      by (auto split: prod.splits)

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

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

    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)
      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 (vc_solve simp: hm_valid_def hm_length_def heapmap_\<alpha>_def solve: asm_rl)
      apply (auto simp add: hm_key_of_def hm_exch_def swap_def) []
      done

    lemma hm_exch_\<alpha>[simp]: "heapmap_\<alpha> (hm_exch hm i j) = (heapmap_\<alpha> hm)"
      by (auto simp: heapmap_\<alpha>_def hm_exch_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)

    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 (force simp: hm_valid_def heapmap_\<alpha>_def hmr_invar_def hm_index_def hm_length_def Suc_le_eq)

    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 (force
          simp: hm_valid_def heapmap_\<alpha>_def hmr_invar_def hm_index_def hm_length_def hm_key_of_def Suc_le_eq)

    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)
      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 (force simp: heapmap_rel_defs hmr_rel_defs hm_index_def)
      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));
        k \<leftarrow> mop_list_get pq (length pq - 1);
        pq \<leftarrow> mop_list_butlast pq;
        let m = m(k:=None);
        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)
      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 ))"
      unfolding hm_butlast_op_def
      apply refine_vcg
      apply (auto simp: heapmap_\<alpha>_def hm_key_of_def hm_length_def)
      done

    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> dom m);
        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: )
      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 hm k;
        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 heapmap_\<alpha>_def)
      done

    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 (vc_solve simp add: hm_valid_def hm_length_def)
      apply rprems
      apply (vc_solve 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);
        let len = hm_length h;
        if (2*k \<le> len) then do {
          let j = 2*k;
          pj \<leftarrow> hm_prio_of_op h j;

          j \<leftarrow> (
            if j<len then do {
              psj \<leftarrow> hm_prio_of_op h (Suc j);
              if pj>psj then RETURN (j+1) 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
      apply refine_rcg
      apply refine_dref_type

      unfolding hmr_rel_def heapmap_rel_def
      apply (clarsimp_all 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
      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 (vc_solve simp add: hm_valid_def hm_length_def) (* Takes long *)
      apply rprems
      apply (vc_solve 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> RETURN ([],Map.empty)"

    lemma hm_empty_aref: "(hm_empty_op,RETURN op_map_empty) \<in> \<langle>heapmap_rel\<rangle>nres_rel"
      unfolding hm_empty_op_def
      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
        split: prod.split)

    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
      apply (auto simp: hmr_rel_defs) []
      apply (parametricity add: hm_length_refine)
      done

    lemma hm_is_empty_op_aref: "(hm_is_empty_op, RETURN o op_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 heapmap_rel_defs hm_length_def)
      done

    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. ASSERT (heapmap_invar hm) \<then> 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

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

    definition "hm_contains_key_op \<equiv> \<lambda>k (pq,m). ASSERT (heapmap_invar (pq,m)) \<then> RETURN (k\<in>dom m)"
    lemma hm_contains_key_op_aref: "(hm_contains_key_op,RETURN oo op_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)

    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
    }"

    lemma hm_set_op_aref:
      "(hm_set_op, RETURN ooo op_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
      apply (refine_rcg
        hm_contains_key_op_aref[param_fo, unfolded o_def, THEN nres_relD]
        hm_change_key_op_aref[param_fo, THEN nres_relD]
        hm_insert_op_aref[param_fo, THEN nres_relD]
        )
      by auto

    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 hm k;
        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)
        by (metis (no_types, hide_lams) Suc_leI comp_apply diff_Suc_Suc
          diff_zero domI 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 hm k;
      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
      by (auto
        simp: hm_valid_def hm_length_def hmr_rel_defs heapmap_\<alpha>_def hm_key_of_def
        split: prod.splits)

    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


(*
    File:        dTermDef.thy
    Time-stamp:  <2016-01-03T15:09:36Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory dTermDef imports Sum Nat_ZF Nth SubOcc LVariable begin

consts
  dTerm :: i
  dTag :: i

datatype
  dTerm = dVar( "x: LVariable" )
        | dBound( "n: nat" )
        | dLam( "M: dTerm" )
        | dApp( "M: dTerm", "N: dTerm")

datatype
  dTag = TdVar( "x: LVariable" )
       | TdBound( "n: nat" )
       | TdLam
       | TdApp

definition dArity :: "i=>i" where
"dArity(T) == dTag_case(%z. 0, %z. 0, 1, 2, T)"

definition dTerm_cons :: "[i, i]=>i" where
"dTerm_cons(T, l) = dTag_case(%z. dVar(z), %z. dBound(z),
                      dLam(nth(0, l)), dApp(nth(0, l), nth(1, l)), T)"

definition dOcc :: "i=>i" where
"dOcc(M) == dTerm_rec(
            %x. Occ_cons(TdVar(x), []),
            %n. Occ_cons(TdBound(n), []),
            %N r. Occ_cons(TdLam, [r]),
            %M N rm rn. Occ_cons(TdApp, [rm, rn]), M)"

definition dOccinv :: "i=>i" where
"dOccinv(x) == THE M. M: dTerm & x = dOcc(M)"

definition dSub :: "i=>i" where
"dSub(M) == {<l, dOccinv(Occ_Subtree(l, dOcc(M)))>. <l, T>: dOcc(M)}"

definition dsubterm :: "[i, i]=>i" where
"dsubterm(M, l) == THE N. <l, N>: dSub(M)"

lemma dTerm_rec_type:
  assumes "M: dTerm"
  and "!!x. [| x: LVariable |] ==> c(x): C(dVar(x))"
  and "!!n. [| n: nat |] ==> b(n): C(dBound(n))"
  and "!!M r. [| M: dTerm;  r: C(M) |] ==>
                   h(M,r): C(dLam(M))"
  and "!!M N rm rn. [| M: dTerm;  N: dTerm;
           rm: C(M); rn: C(N) |] ==> k(M,N,rm,rn): C(dApp(M,N))"
  shows "dTerm_rec(c,b,h,k,M) : C(M)"
apply (rule assms(1) [THEN dTerm.induct])
apply (simp_all add: assms)
done

lemma dTerm_cons_eqns:
  "dTerm_cons(TdVar(x), []) = dVar(x)"
  "dTerm_cons(TdBound(n), []) = dBound(n)"
  "dTerm_cons(TdLam, [M]) = dLam(M)"
  "dTerm_cons(TdApp, [M, N]) = dApp(M, N)"
apply (simp_all add: dTerm_cons_def)
done

lemma dArity_eqns:
  "dArity(TdVar(x)) = 0"
  "dArity(TdBound(n)) = 0"
  "dArity(TdLam) = 1"
  "dArity(TdApp) = 2"
apply (simp_all add: dArity_def)
done

lemma dOcc_eqns:
  "dOcc(dVar(x)) = Occ_cons(TdVar(x), [])"
  "dOcc(dBound(n)) = Occ_cons(TdBound(n), [])"
  "dOcc(dLam(M)) = Occ_cons(TdLam, [dOcc(M)])"
  "dOcc(dApp(M, N)) = Occ_cons(TdApp, [dOcc(M), dOcc(N)])"
apply (simp_all add: dOcc_def)
done

lemma dTerm_Term_cons_intrs:
  "x: LVariable ==> dTerm_cons(TdVar(x), []): dTerm"
  "n: nat ==> dTerm_cons(TdBound(n), []): dTerm"
  "[| M: dTerm |] ==> dTerm_cons(TdLam, [M]): dTerm"
  "[| M: dTerm; N: dTerm |] ==> dTerm_cons(TdApp, [M, N]): dTerm"
apply (simp_all add: dTerm_cons_eqns)
apply (assumption | rule dTerm.intros)+
done

lemma dArity_type:
  "T: dTag ==> dArity(T): nat"
apply (erule dTag.cases)
apply (simp_all add: dArity_eqns)
done

lemma dTerm_Occ_cons_cond:
  "Occ_cons_cond(dTerm, dOcc, dTag, dArity)"
apply (rule Occ_cons_condI)
apply (elim dTag.cases)
apply (simp_all add: dArity_eqns)
apply (elim dTag.cases)
apply (simp_all add: dArity_eqns)

apply (rule bexI)
apply (rule dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (rule bexI)
apply (rule dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (elim bexE conjE)
apply (erule nth_0E)
apply assumption
apply simp
apply simp
apply (rule bexI)
apply (rule dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (elim bexE conjE)
apply (erule nth_0E)
apply assumption
apply simp
apply simp
apply (erule nth_0E)
apply assumption
apply simp
apply simp
apply (rule bexI)
apply (rule dOcc_eqns)
apply (typecheck add: dTerm.intros)
done

lemma dTerm_Occ_ind_cond:
  "Occ_ind_cond(dTerm, dOcc, dTag, dArity, dTerm_cons)"
apply (rule Occ_ind_condI)
apply (erule dTerm.induct)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] dTerm_cons_eqns [THEN subst])
apply (typecheck add: dTag.intros)
apply (simp add: dTerm_cons_eqns dArity_eqns dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] dTerm_cons_eqns [THEN subst])
apply (typecheck add: dTag.intros)
apply (simp add: dTerm_cons_eqns dArity_eqns dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] dTerm_cons_eqns [THEN subst])
apply (typecheck add: dTag.intros)
apply (simp add: dTerm_cons_eqns dArity_eqns dOcc_eqns)
apply (typecheck add: dTerm.intros)

apply (drule bspec)
apply (drule_tac [2] bspec)
apply (drule_tac [3] mp)
apply (erule_tac [4] dTerm_cons_eqns [THEN subst])
apply (typecheck add: dTag.intros)
apply (simp add: dTerm_cons_eqns dArity_eqns dOcc_eqns)
apply (typecheck add: dTerm.intros)

done

lemma dTerm_Term_cons_inj_cond:
  "Term_cons_inj_cond(dTerm, dTag, dArity, dTerm_cons)"
apply (rule Term_cons_inj_condI)
apply (rule iffI)
apply (elim dTag.cases)
prefer 17
apply (elim dTag.cases)
apply (simp_all add: dTerm_cons_def dArity_def)
done

lemmas dTerm_Term_cons_typechecks = (* nth_typechecks *)
    dTerm_Term_cons_intrs dTag.intros
    dArity_type Occ_ind_cond_Occ_domain [OF dTerm_Occ_ind_cond]
    Occ_ind_cond_Occ_in_Occ_range [OF dTerm_Occ_ind_cond]
    PowI succI1 succI2 (* consI1 *)consI2 (* nat_0I nat_succI *)

declare dTerm_Term_cons_typechecks [TC]

lemmas dTerm_Term_cons_simps = dArity_eqns (* dTerm_cons_eqns [THEN sym] *)

declare dTerm_Term_cons_simps [simp]

lemmas dTerm_cons_eqns_sym = dTerm_cons_eqns [THEN sym]

end


theory Universe
imports Main "HOL.BNF_Cardinal_Order_Relation" Misc Tools TermX_Antiquot "HOL-Library.Nat_Bijection" "HOL-Library.Rewrite" "HOL-ZF.HOLZF"
begin

(* For proving instances of types declared with
  "datatype" (not "datatype_new"), see, e.g., "char"

  For proving instances of types declared with
  "typedef", see, e.g., "ell1"
*)

(* definition "powertower t == \<forall>n. \<exists>i. inj_on i (Pow (t n)) \<and> i ` (Pow (t n)) \<subseteq> t (Suc n)" *)

lemma ZF_Pow_explode: "Pow (explode z) = explode ` explode (Power z)"
proof (rule; rule)
  fix x assume "x \<in> Pow (explode z)"
  hence "x \<subseteq> explode z" by simp

  hence "y \<in> (explode z)" if "y \<in> x" for y
    using that by blast
  hence yz: "Elem y z" if "y \<in> x" for y
    by (simp add: explode_Elem that)

  define y where "y = Replacement z (\<lambda>t. if (t \<in> x) then Some t else None)"
  have xy: "x = explode y"
    unfolding y_def explode_def Replacement
    using yz by auto
  have "Elem y (Power z)"
    unfolding y_def
    using Power xy y_def explode_Elem subset_def yz by force

  with xy show "x \<in> explode ` explode (Power z)"
    apply (subst explode_def) by auto
next
  fix x assume "x \<in> explode ` explode (Power z)"
  thus "x \<in> Pow (explode z)"
    using Power explode_Elem subset_def by auto
qed

typedef val = "{(x,n) | x n. Elem x ((Power ^^ n) Inf)}"
  apply (rule exI[of _ "(Empty,0)"])
  by (simp add: Infinity)
(*
Alternatively, val can be axiomatized as follows, which is weaker than the ZF axioms
(the axiomatization below is implied by existence of a smaller cardinal, namely beth_\<omega>)

typedecl val
axiomatization val_powertower :: "nat \<Rightarrow> val set" where
    val_powertower: "\<exists>i. inj_on i (Pow (val_powertower n)) \<and> i ` (Pow (val_powertower n)) \<subseteq> val_powertower (Suc n)"
and val_powertower_disjoint: "x \<in> val_powertower n \<Longrightarrow> x \<in> val_powertower m \<Longrightarrow> n=m"
and val_powertower_nat: "\<exists>n (i::nat\<Rightarrow>val). inj i \<and> range i \<subseteq> val_powertower n"
and val_powertower_all: "(\<Union>n. val_powertower n) = UNIV"
*)

setup_lifting type_definition_val
definition "val_powertower n = {Abs_val (x,n) | x. Elem x ((Power ^^ n) Inf)}"
lemma val_powertower: "\<exists>i. inj_on i (Pow (val_powertower n)) \<and> i ` (Pow (val_powertower n)) \<subseteq> val_powertower (Suc n)"
proof -
  define D0 where "D0 = Pow (val_powertower n)"
  define i0 where "i0 x = Rep_val ` x" for x
  have "inj_on i0 D0"
    by (metis Rep_val_inverse \<open>i0 \<equiv> (`) Rep_val\<close> inj_on_image inj_on_inverseI)
  define D1 where "D1 = i0 ` D0"
  have D1: "D1 = Pow {(x,n) | x. Elem x ((Power ^^ n) Inf)}"
    unfolding D1_def i0_def D0_def val_powertower_def
    apply (subst image_Pow_surj) apply rule
    apply (subst image_Collect)
    by (metis (no_types, hide_lams) Domainp.cases Rep_val_inverse cr_val_def val.domain_eq val.pcr_cr_eq)
  define i1 where i1_def: "i1 x = fst ` x" for x :: "(ZF*nat) set"
  have "inj_on i1 D1"
    apply (rule inj_onI) unfolding i1_def D1
    apply auto
    apply (smt \<open>i1 \<equiv> (`) fst\<close> contra_subsetD fst_conv imageI image_iff mem_Collect_eq old.prod.exhaust prod.inject)
    by (smt \<open>i1 \<equiv> (`) fst\<close> contra_subsetD fst_conv imageI image_iff mem_Collect_eq old.prod.exhaust prod.inject)

  define D2 where "D2 = i1 ` D1"
  have "D2 = Pow (explode ((Power ^^ n) Inf))"
    unfolding D2_def i1_def D1 explode_def
    apply (subst image_Pow_surj) apply rule
    apply (subst image_Collect) by auto
  hence D2: "D2 = explode ` explode ((Power ^^ Suc n) Inf)"
    unfolding ZF_Pow_explode by simp

  define i2 where "i2 = implode"
  have "inj_on i2 D2"
    apply (rule inj_onI) unfolding D2 i2_def by auto

  define D3 where "D3 = i2 ` D2"
  have D3: "D3 = explode ((Power ^^ Suc n) Inf)"
    unfolding D3_def D2 i2_def  image_comp o_def  by simp
  define i3 where "i3 z = Abs_val (z, Suc n)" for z
  have "inj_on i3 D3"
    apply (rule inj_onI)
    unfolding i3_def
    by (metis D3 Domainp.cases Rep_val_inverse cr_val_def explode_Elem prod.sel(1) val.domain_eq val.pcr_cr_eq)

  define D4 where "D4 = i3 ` D3"
  have D4: "D4 = val_powertower (Suc n)"
    unfolding val_powertower_def D4_def D3 i3_def
    by (simp add: explode_def image_Collect)

  define i where "i = i3 o i2 o i1 o i0"
  have inj_i: "inj_on i D0"
    unfolding i_def
    apply (rule comp_inj_on, fact \<open>inj_on i0 D0\<close>)
    unfolding D1_def[symmetric]
    apply (rule comp_inj_on, fact \<open>inj_on i1 D1\<close>)
    unfolding D2_def[symmetric]
    apply (rule comp_inj_on, fact \<open>inj_on i2 D2\<close>)
    unfolding D3_def[symmetric]
    by (fact \<open>inj_on i3 D3\<close>)

  have i_D0: "i ` D0 = D4"
    unfolding D4_def D3_def D2_def D1_def i_def by auto

  show ?thesis
    apply (rule exI[of _ i])
    using D0_def inj_i i_D0 D4
    by auto
qed

lemma val_powertower_disjoint: "x \<in> val_powertower n \<Longrightarrow> x \<in> val_powertower m \<Longrightarrow> n=m"
  using type_definition.Abs_inject type_definition_val val_powertower_def by fastforce

lemma val_powertower_nat: "\<exists>n (i::nat\<Rightarrow>val). inj i \<and> range i \<subseteq> val_powertower n"
proof -
  define i where "i m = Abs_val (nat2Nat m, 0)" for m
  have "inj i"
    apply (rule injI) unfolding i_def
    apply (subst (asm) Abs_val_inject)
      apply (simp add: Elem_nat2Nat_inf)
     apply (simp add: Elem_nat2Nat_inf)
    by (meson injD inj_nat2Nat old.prod.inject)

  moreover have "range i \<subseteq> val_powertower 0"
    unfolding val_powertower_def i_def by auto

  ultimately show ?thesis
    by auto
qed

lemma val_powertower_all: "(\<Union>n. val_powertower n) = UNIV"
  unfolding val_powertower_def
  apply auto
  by (smt Rep_val Rep_val_inverse mem_Collect_eq)

instantiation val :: equal begin
definition "equal_val (v::val) w = (v=w)"
instance apply intro_classes
  by (simp add: equal_val_def)
end

(* definition "small_cardinal (_::'a itself) = (\<exists>t n (i::'a\<Rightarrow>val). powertower t \<and> inj i \<and> range i \<subseteq> t n)" *)

class prog_type = default +
  fixes embedding' :: "('a \<Rightarrow> val) \<times> nat"
  assumes embedding'_range: "range (fst embedding') \<subseteq> val_powertower (snd embedding')"
  assumes inj_embedding': "inj (fst embedding')"
  (* assumes small_cardinal: "\<exists>t n. powertower t \<and> range embedding \<subseteq> t n" *)

definition embedding'_default :: "('a\<Rightarrow>val) \<times> nat" where
  "embedding'_default == (SOME fn. inj (fst fn) \<and> range (fst fn) \<subseteq> val_powertower (snd fn))"

definition "embedding = fst embedding'"
(* definition embedding :: "'a::prog_type \<Rightarrow> val" where
  "embedding == (SOME f::'a\<Rightarrow>val. inj f)" *)

lemma embedding_inv [simp]: "(embedding x = embedding y) = (x = y)"
  using inj_embedding' unfolding embedding_def inj_on_def by auto

lemma embedding_inv' [simp]: "inv embedding (embedding x) = x"
  by (metis embedding_inv f_inv_into_f range_eqI)

type_synonym 'a val_embedding = "('a\<Rightarrow>val)\<times>nat"

instantiation "nat" :: prog_type begin
definition "(embedding'::nat val_embedding) = embedding'_default"
instance proof (intro_classes, goal_cases)
case 1
  let ?e = "embedding'::nat val_embedding"
  from val_powertower_nat obtain f::"nat\<Rightarrow>val" and n where inj: "inj f" and range: "range f \<subseteq> val_powertower n" by auto
  have theses: "inj (fst ?e) \<and> range (fst ?e) \<subseteq> val_powertower (snd ?e)"
    unfolding embedding'_nat_def embedding'_default_def
    apply (rule someI[where P="\<lambda>fn. inj (fst fn) \<and> range (fst fn) \<subseteq> val_powertower (snd fn)" and x="(f,n)"])
    using inj range by auto
  thus ?case by simp
case 2 show ?case using theses by simp
qed
end

lemma prog_type_classI':
  assumes "inj (f::'a\<Rightarrow>'b::prog_type)"
  shows "range (fst (embedding'_default::'a val_embedding)) \<subseteq> val_powertower (snd (embedding'_default::'a val_embedding))" and "inj (fst (embedding'_default::'a val_embedding))"
proof -
(*   obtain n where range: "range (embedding::'b\<Rightarrow>val) \<subseteq> val_powertower n"
    using embedding_range by auto *)
  let ?e = "(\<lambda>x. fst embedding' (f x), snd (embedding'::'b val_embedding))"
  let ?e' = "embedding'_default :: 'a val_embedding"
  have theses: "inj (fst ?e) \<and> range (fst ?e) \<subseteq> val_powertower (snd ?e)"
    using assms[THEN injD] embedding'_range inj_embedding'[THEN injD] unfolding inj_on_def apply auto by blast
  have "inj (fst ?e') \<and> range (fst ?e') \<subseteq> val_powertower (snd ?e')"
    unfolding embedding'_default_def
    apply (rule someI[where P="\<lambda>f. inj (fst f) \<and> range (fst f) \<subseteq> val_powertower (snd f)"])
    by (fact theses)
  then show "range (fst ?e') \<subseteq> val_powertower (snd (embedding'_default::'a val_embedding))"
       and "inj (fst (embedding'_default::'a val_embedding))"
     by auto
qed

(* Hack to allow to state lemma prog_type_classI. Is there a cleaner way? *)
ML {*
  val consts_to_unconstrain = [@{const_name embedding'}]
  val consts_orig_constraints = map (Sign.the_const_constraint @{theory}) consts_to_unconstrain
*}
setup {*
  fold (fn c => fn thy => Sign.add_const_constraint (c,NONE) thy) consts_to_unconstrain
*}

lemma prog_type_classI:
  assumes emb: "(embedding'::'a val_embedding) = embedding'_default"
  assumes inj: "inj (f::'a\<Rightarrow>'b::prog_type)"
  shows "OFCLASS('a, prog_type_class)"
apply intro_classes using prog_type_classI'[OF inj] unfolding emb by auto

(* Recover stored type constraints *)
setup {*
  fold2 (fn c => fn T => fn thy => Sign.add_const_constraint (c,SOME (Logic.unvarifyT_global T)) thy)
      consts_to_unconstrain consts_orig_constraints
*}

definition val_powertower_level :: "val \<Rightarrow> nat" where
  "val_powertower_level x = (SOME n. x \<in> val_powertower n)"
lemma val_powertower_level: "x \<in> val_powertower (val_powertower_level x)"
  unfolding val_powertower_level_def apply (rule someI_ex)
  using val_powertower_all by auto

definition val_set_embedding :: "nat \<Rightarrow> val set \<Rightarrow> val" where
  "val_set_embedding n = (SOME f. inj_on f (Pow (val_powertower n)) \<and> f ` Pow (val_powertower n) \<subseteq> val_powertower (Suc n))"
(* definition val_set_embedding_level :: "nat \<Rightarrow> nat" where
  "val_set_embedding_level n == (SOME m. \<forall>x. x \<subseteq> val_powertower n \<longrightarrow> val_set_embedding x \<in> val_powertower m)" *)

lemma val_set_embedding_inj: "inj_on (val_set_embedding n) (Pow (val_powertower n))" (is ?thesis1)
  and val_set_embedding_range: "x \<subseteq> val_powertower n \<Longrightarrow> (val_set_embedding n) x \<in> val_powertower (Suc n)" (is "PROP ?thesis2")
proof -
  obtain f where "inj_on f (Pow (val_powertower n)) \<and> f ` Pow (val_powertower n) \<subseteq> val_powertower (Suc n)"
    apply atomize_elim using val_powertower by simp
  hence "inj_on f (Pow (val_powertower n)) \<and> f ` Pow (val_powertower n) \<subseteq> val_powertower (Suc n)"
    by auto
  hence "inj_on (val_set_embedding n) (Pow (val_powertower n)) \<and> (val_set_embedding n) ` Pow (val_powertower n) \<subseteq> val_powertower (Suc n)"
    unfolding val_set_embedding_def by (rule someI[where P="\<lambda>f. inj_on f (Pow (val_powertower n)) \<and> f ` Pow (val_powertower n) \<subseteq> val_powertower (Suc n)"])
  thus ?thesis1 and "PROP ?thesis2" by auto
qed

instantiation set :: (prog_type) prog_type begin
definition "(embedding' :: 'a set val_embedding) =
  (\<lambda>M. val_set_embedding (snd (embedding'::'a val_embedding)) (fst (embedding'::'a val_embedding) ` M),
        Suc (snd (embedding'::'a val_embedding)))"
instance proof
  let ?ea = "embedding' :: 'a val_embedding"
  let ?e = "embedding' :: 'a set val_embedding"
  show "range (fst ?e) \<subseteq> val_powertower (snd ?e)"
    unfolding embedding'_set_def apply auto
    apply (rule val_set_embedding_range[where n="snd ?ea"])
    using embedding'_range by auto
  show "inj (fst ?e)"
    unfolding embedding'_set_def
    apply simp apply (rule injI)
    apply (frule val_set_embedding_inj[THEN inj_onD])
      using embedding'_range image_subsetI apply auto[2]
    using inj_embedding'[THEN injD] by auto
qed
end

(*instantiation set :: (prog_type) prog_type begin
definition "(embedding :: 'a set \<Rightarrow> val) = embedding_default"
instance proof
  obtain n where range: "range (embedding::'a\<Rightarrow>val) \<subseteq> val_powertower n"
    using embedding_range by auto

  obtain i2::"val set\<Rightarrow>val" where i2inj: "inj_on i2 (Pow (val_powertower n))"
                                       and i2rng: "i2 ` Pow(val_powertower n) \<subseteq> val_powertower (Suc n)"
    using val_powertower by blast
  define i3 where "i3 \<equiv> \<lambda>s::'a set. i2 (embedding ` s)"
  have "inj i3"
  proof (rule injI, unfold i3_def)
    fix x y :: "'a set"
    from inj_embedding have i: "embedding ` x = embedding ` y \<Longrightarrow> x = y"
      by (metis inj_image_eq_iff)
    show "i2 (embedding ` x) = i2 (embedding ` y) \<Longrightarrow> x = y"
      apply (rule i)
      apply (subst inj_on_eq_iff[symmetric, where f=i2 and A="Pow(val_powertower n)"])
      using i2inj range by auto
  qed
  have i3rng: "range i3 \<subseteq> val_powertower (Suc n)"
  proof (unfold i3_def, auto)
    fix s :: "'a set"
    have "embedding ` s \<in> Pow (val_powertower n)" using range by auto
    hence "i2 (embedding ` s) \<in> i2 ` (Pow (val_powertower n))" by auto
    with i2rng show "i2 (embedding ` s) \<in> val_powertower (Suc n)" by auto
  qed

  let ?e = "embedding::'a set\<Rightarrow>_"
  have ex_emb: "inj i3 \<and> (\<exists>n. range i3 \<subseteq> val_powertower n)"
    using i3rng `inj i3` by auto
  have "inj ?e \<and> (\<exists>n. range ?e \<subseteq> val_powertower n)"
    unfolding embedding_set_def embedding_default_def
    apply (rule someI[where P="\<lambda>f. inj f \<and> (\<exists>n. range f \<subseteq> val_powertower n)"])
    using ex_emb by simp
  (* thus "inj (embedding::'a set \<Rightarrow> val)" by simp *)
  thus "\<exists>n. range (embedding::'a set\<Rightarrow>val) \<subseteq> val_powertower n"
   and "inj (embedding::'a set\<Rightarrow>val)"  by auto
qed
end*)

instantiation bool :: prog_type begin
definition "(embedding' :: bool val_embedding) = embedding'_default"
instance apply (rule prog_type_classI[OF embedding'_bool_def, of "\<lambda>b. if b then 0 else Suc 0"])
  apply (rule injI)
  by (case_tac x, case_tac y, auto)
end

(* TODO needed? *)
lemma ordered_cardinals: "(\<exists>i::'a\<Rightarrow>'b. inj i) \<or> (\<exists>j::'b\<Rightarrow>'a. inj j)"
proof -
  have leq: "ordLeq2 (card_of (Inl ` UNIV :: ('a+'b)set)) (card_of (Inr ` UNIV :: ('a+'b)set)) \<or>
        ordLeq2 (card_of (Inr ` UNIV :: ('a+'b)set)) (card_of (Inl ` UNIV :: ('a+'b)set))"
        by (rule ordLeq_total, rule card_of_Well_order, rule card_of_Well_order)
  show ?thesis proof (rule leq[THEN disjE], fold card_of_ordLeq)
    assume "\<exists>f::'a+'b \<Rightarrow> 'a+'b. inj_on f (range Inl) \<and> f ` range Inl \<subseteq> range Inr"
    then obtain f::"'a+'b \<Rightarrow> 'a+'b" where finj: "inj_on f (range Inl)" and frng: "f ` range Inl \<subseteq> range Inr" by auto
    define i where "i == \<lambda>x. case f (Inl x) of Inr y \<Rightarrow> y"
    have "inj i" proof (rule injI, unfold i_def)
      fix x y assume eq:"(case f (Inl x) of Inr y \<Rightarrow> y) = (case f (Inl y) of Inr y \<Rightarrow> y)"
      from frng obtain x' where x': "f (Inl x) = Inr x'" by blast
      from frng obtain y' where y': "f (Inl y) = Inr y'" by blast
      from eq have "f (Inl x) = f (Inl y)" unfolding x' y' by simp
      with finj have "Inl x = Inl y" unfolding inj_on_def by simp
      thus "x = y" by auto
    qed
    thus ?thesis by auto
  next
    assume "\<exists>f::'a+'b \<Rightarrow> 'a+'b. inj_on f (range Inr) \<and> f ` range Inr \<subseteq> range Inl"
    then obtain f::"'a+'b \<Rightarrow> 'a+'b" where finj: "inj_on f (range Inr)" and frng: "f ` range Inr \<subseteq> range Inl" by auto
    define j where "j == \<lambda>x. case f (Inr x) of Inl y \<Rightarrow> y"
    have "inj j" proof (rule injI, unfold j_def)
      fix x y assume eq:"(case f (Inr x) of Inl y \<Rightarrow> y) = (case f (Inr y) of Inl y \<Rightarrow> y)"
      from frng obtain x' where x': "f (Inr x) = Inl x'" by blast
      from frng obtain y' where y': "f (Inr y) = Inl y'" by blast
      from eq have "f (Inr x) = f (Inr y)" unfolding x' y' by simp
      with finj have "Inr x = Inr y" unfolding inj_on_def by simp
      thus "x = y" by auto
    qed
    thus ?thesis by auto
  qed
qed

function val_embed_up :: "nat \<Rightarrow> nat \<Rightarrow> val \<Rightarrow> val" where
  "val_embed_up n n x = x"
| "m > n \<Longrightarrow> val_embed_up n m x = val_set_embedding (m-1) {val_embed_up n (m-1) x}"
| "m < n \<Longrightarrow> val_embed_up n m x = undefined"
apply auto apply atomize_elim by auto
termination by lexicographic_order

lemma range_val_embed_up:
  "m\<ge>n \<Longrightarrow> x \<in> val_powertower n \<Longrightarrow> val_embed_up n m x \<in> val_powertower m"
proof (induction "m-n" arbitrary: m)
case 0 thus ?case by simp
next case (Suc m_n)
  from Suc have "m > n" by auto
  hence m: "m = Suc (m - Suc 0)" by auto
  show ?case
    apply (simp add: \<open>m > n\<close>)
    apply (subst m, rule val_set_embedding_range)
    using Suc by simp
qed

lemma inj_val_embed_up:
  "m\<ge>n \<Longrightarrow> val_embed_up n m x = val_embed_up n m y \<Longrightarrow>
       x \<in> val_powertower n \<Longrightarrow> y \<in> val_powertower n \<Longrightarrow> x = y"
proof (induction "m-n" arbitrary: m)
case 0 thus ?case by simp
next case (Suc m_n)
  from Suc have "m > n" by auto
  with Suc.prems have set: "val_set_embedding (m-1) {val_embed_up n (m-1) x} = val_set_embedding (m-1) {val_embed_up n (m-1) y}" by auto
  have "{val_embed_up n (m-1) x} = {val_embed_up n (m-1) y}"
    apply (rule val_set_embedding_inj[THEN inj_onD, of "m-1"])
      using set close
    using range_val_embed_up Suc.hyps Suc.prems by auto
  with Suc.hyps(1)[of "m-1"] show ?case apply auto
    by (metis One_nat_def Suc.hyps(2) Suc.prems(3) Suc.prems(4) Suc_diff_Suc \<open>n < m\<close> diff_Suc_1 le_add1 less_imp_Suc_add)
qed

definition val_sum_embedding :: "nat \<Rightarrow> nat \<Rightarrow> val+val \<Rightarrow> val" where
  "val_sum_embedding n m x = (let mn = prod_encode (n,m) in val_set_embedding (Suc mn) (val_set_embedding mn `
      (case x of Inl a \<Rightarrow> {{val_embed_up n mn a}} | Inr b \<Rightarrow> {{val_embed_up m mn b},{}})))"
lemma inj_val_sum_embedding: "inj_on (val_sum_embedding n m) (val_powertower n <+> val_powertower m)"
  and range_val_sum_embedding: "x \<in> val_powertower n <+> val_powertower m
              \<Longrightarrow> val_sum_embedding n m x \<in> val_powertower (prod_encode (n,m) + 2)"
proof -
  have range2: "\<And>x. x \<in> val_powertower n <+> val_powertower m \<Longrightarrow>
           (case x of Inl a \<Rightarrow> {{val_embed_up n (prod_encode(n,m)) a}} | Inr b \<Rightarrow> {{val_embed_up m (prod_encode(n,m)) b}, {}})
           \<subseteq> Pow (val_powertower (prod_encode(n,m)))"
    apply auto
     close (rule range_val_embed_up, auto intro: le_prod_encode_1)
    by (rule range_val_embed_up, auto intro: le_prod_encode_2)
  have range1: "\<And>x. x \<in> val_powertower n <+> val_powertower m \<Longrightarrow>
           val_set_embedding (prod_encode(n,m)) `
           (case x of Inl a \<Rightarrow> {{val_embed_up n (prod_encode(n,m)) a}}
                   | Inr b \<Rightarrow> {{val_embed_up m (prod_encode(n,m)) b}, {}})
           \<in> Pow (val_powertower (Suc (prod_encode(n,m))))"
    apply (simp add: image_subset_iff, rule ballI)
    apply (rule val_set_embedding_range)
    using range2 by auto
  have range2: "(case x of Inl a \<Rightarrow> {{val_embed_up n (prod_encode(n,m)) a}}
                         | Inr b \<Rightarrow> {{val_embed_up m (prod_encode(n,m)) b}, {}})
                   \<subseteq> Pow (val_powertower (prod_encode(n,m)))"
           if "x \<in> val_powertower n <+> val_powertower m" for x
    apply (cases x; simp)
     apply (rule range_val_embed_up) using le_prod_encode_1 that close 2
    apply (rule range_val_embed_up) using le_prod_encode_2 that by auto
  have inj1: "\<And>xa xb. val_embed_up n (prod_encode(n,m)) xa = val_embed_up n (prod_encode(n,m)) xb \<Longrightarrow>
             xa \<in> val_powertower n \<Longrightarrow> xb \<in> val_powertower n \<Longrightarrow> xa = xb" using inj_val_embed_up
    using le_prod_encode_1 by blast
  have inj2: "\<And>ya yb. {{val_embed_up m (prod_encode(n,m)) ya}, {}} = {{val_embed_up m (prod_encode(n,m)) yb}, {}} \<Longrightarrow>
             ya \<in> val_powertower m \<Longrightarrow> yb \<in> val_powertower m \<Longrightarrow> ya = yb"
    by (metis doubleton_eq_iff inj_val_embed_up le_prod_encode_2)
  show "val_sum_embedding n m x \<in> val_powertower (prod_encode(n,m) + 2)"
          if "x \<in> val_powertower n <+> val_powertower m"
    unfolding val_sum_embedding_def Let_def apply simp
    apply (rule val_set_embedding_range)
    apply (rule image_subset_iff[THEN iffD2, rule_format])
    apply (rule val_set_embedding_range)
    apply (cases x, auto)
     apply (rule range_val_embed_up) using le_prod_encode_1 that close 2
    apply (rule range_val_embed_up) using le_prod_encode_2 that by auto
  show "inj_on (val_sum_embedding n m) (val_powertower n <+> val_powertower m)"
    apply (rule inj_onI) unfolding val_sum_embedding_def Let_def
    apply (subst (asm) val_set_embedding_inj[THEN inj_on_eq_iff])
      close (rule range1, simp)
     close (rule range1, simp)
    apply (subst (asm) val_set_embedding_inj[THEN inj_on_image_eq_iff])
      close (rule range2, simp)
     close (rule range2, simp)
    by (auto intro: inj1 inj2)
qed

instantiation sum :: (prog_type,prog_type) prog_type begin
definition "(embedding' :: ('a+'b) val_embedding) =
  (\<lambda>x. val_sum_embedding (snd (embedding'::'a val_embedding)) (snd (embedding'::'b val_embedding))
    (map_sum (fst embedding') (fst embedding') x),
  prod_encode (snd (embedding'::'a val_embedding), snd (embedding'::'b val_embedding)) + 2)"
instance proof (intro_classes, goal_cases)
case 1
  show ?case unfolding embedding'_sum_def
    apply auto apply (rule range_val_sum_embedding[simplified])
    apply (case_tac xa) using embedding'_range by auto
case 2
  show ?case unfolding embedding'_sum_def
    apply (rule injI) apply simp
    apply (drule_tac inj_val_sum_embedding[THEN inj_onD])
    unfolding map_sum_def
      close (case_tac x; auto intro!: embedding'_range[unfolded image_subset_iff, rule_format])
     close (case_tac y; auto intro!: embedding'_range[unfolded image_subset_iff, rule_format])
    apply (case_tac x; case_tac y; simp)
    using inj_embedding'[THEN injD] by auto
qed
end

(*instantiation sum :: (prog_type,prog_type) prog_type begin
instance proof (intro_classes, cases "\<exists>i::'a\<Rightarrow>'b. inj i")
case True
  then obtain i::"'a\<Rightarrow>'b" where "inj i" by auto
  define i2 where "i2 \<equiv> \<lambda>x::'a+'b. case x of Inl a \<Rightarrow> {{i a}} | Inr b \<Rightarrow> {{b},{}}"
  have "inj i2" apply (rule injI) unfolding i2_def
    apply (case_tac x, case_tac y, auto)
    apply (metis `inj i` inj_eq)
    by (case_tac y, auto)
  hence "\<exists>f::'a+'b\<Rightarrow>'b set set. inj f"
    by (rule exI[of _ i2])
  thus "\<exists>t n (i::'a+'b\<Rightarrow>val). powertower t \<and> inj i \<and> range i \<subseteq> t n"
    by (rule prog_type_classI')
next
case False
  with ordered_cardinals obtain i::"'b\<Rightarrow>'a" where "inj i" by auto
  define i2 where "i2 \<equiv> \<lambda>x::'a+'b. case x of Inl a \<Rightarrow> {{a},{}} | Inr b \<Rightarrow> {{i b}}"
  have "inj i2" apply (rule injI) unfolding i2_def
    apply (case_tac x, case_tac y, auto)
    apply (case_tac y, auto)
    by (metis `inj i` inj_eq)
  hence "\<exists>f::'a+'b\<Rightarrow>'a set set. inj f"
    by (rule exI[of _ i2])
  thus "\<exists>t n (i::'a+'b\<Rightarrow>val). powertower t \<and> inj i \<and> range i \<subseteq> t n"
    by (rule prog_type_classI')
qed
end*)

definition val_prod_embedding' :: "nat \<Rightarrow> nat \<Rightarrow> val*val \<Rightarrow> val" where
  "val_prod_embedding' n m x = val_set_embedding (prod_encode(n,m) + 2) (val_sum_embedding n m ` {Inl (fst x), Inr (snd x)})"
lemma inj_val_prod_embedding': "inj_on (val_prod_embedding' n m) (val_powertower n \<times> val_powertower m)" (is ?inj)
  and range_val_prod_embedding': "x \<in> val_powertower n \<times> val_powertower m \<Longrightarrow> val_prod_embedding' n m x \<in> val_powertower (prod_encode(n,m) + 3)" (is "?assm \<Longrightarrow> ?range")
proof -
  have range1: "val_sum_embedding n m ` {Inl (fst x), Inr (snd x)} \<in> Pow (val_powertower (prod_encode (n, m) + 2))"
               if "x \<in> val_powertower n \<times> val_powertower m" for x
    apply auto
     apply (rule range_val_sum_embedding[simplified])
     using that close
    apply (rule range_val_sum_embedding[simplified])
    using that by auto
  have inj1: "inj_on (val_sum_embedding n m) ({Inl (fst x), Inr (snd x)} \<union> {Inl (fst y), Inr (snd y)})"
             if "x \<in> val_powertower n \<times> val_powertower m" and "y \<in> val_powertower n \<times> val_powertower m" for x y
    apply (rule inj_onI)
    apply (drule inj_val_sum_embedding[THEN inj_onD])
    using that by auto
  show ?inj
    apply (rule inj_onI)
    unfolding val_prod_embedding'_def
    apply (drule val_set_embedding_inj[THEN inj_onD])
      using range1 close 2
    apply (subst (asm) inj_on_Un_image_eq_iff[where f="val_sum_embedding n m"])
     using inj1 close
    by force
  assume ?assm
  show ?range
    unfolding val_prod_embedding'_def
    apply (rewrite at "_ + 3" to "Suc (_ + 2)" eq_reflection) close
    apply (rule val_set_embedding_range)
    using range1[OF `?assm`] by auto
qed

definition val_prod_embedding :: "val\<times>val \<Rightarrow> val" where
  "val_prod_embedding xy = val_prod_embedding' (val_powertower_level (fst xy)) (val_powertower_level (snd xy)) xy"
(* Could be made injective on all val\<times>val, by fixing a monotone nat\<Rightarrow>nat\<Rightarrow>nat: prod_encode *)
lemma inj_val_prod_embedding: "inj val_prod_embedding"
proof (rule injI)
  fix x y :: "val\<times>val"
  assume emb_eq: "val_prod_embedding x = val_prod_embedding y"

  obtain x1 x2 where x: "x=(x1,x2)" by (atomize_elim, auto)
  define n1 n2
    where "n1 == val_powertower_level x1"
      and "n2 == val_powertower_level x2"
  have "x1 \<in> val_powertower n1"
   and "x2 \<in> val_powertower n2" unfolding n1_def n2_def by (simp_all add: val_powertower_level)
  hence x_tower: "x \<in> val_powertower n1 \<times> val_powertower n2" unfolding x by auto
  hence emb_x: "val_prod_embedding' n1 n2 x \<in> val_powertower (prod_encode(n1,n2) + 3)"
    by (rule range_val_prod_embedding')

  obtain y1 y2 where y: "y=(y1,y2)" by (atomize_elim, auto)
  define m1 m2
    where "m1 == val_powertower_level y1"
      and "m2 == val_powertower_level y2"
  have "y1 \<in> val_powertower m1"
   and "y2 \<in> val_powertower m2" unfolding m1_def m2_def by (simp_all add: val_powertower_level)
  hence y_tower: "y \<in> val_powertower m1 \<times> val_powertower m2" unfolding y by auto
  hence emb_y: "val_prod_embedding' m1 m2 y \<in> val_powertower (prod_encode(m1,m2) + 3)"
    by (rule range_val_prod_embedding')

  have emb_eq': "val_prod_embedding' n1 n2 x = val_prod_embedding' m1 m2 y"
    using emb_eq unfolding val_prod_embedding_def x y n1_def n2_def m1_def m2_def
    by simp

  from emb_x emb_y have "prod_encode(n1,n2) + 3 = prod_encode(m1,m2) + 3"
    unfolding emb_eq' by (rule val_powertower_disjoint)
  hence eq1: "n1 = m1" and eq2: "n2 = m2"
    by (simp_all add: prod_encode_eq)

  show "x=y"
    apply (rule inj_val_prod_embedding'[THEN inj_onD])
    using emb_eq' eq1 eq2 x_tower y_tower by auto
qed

lemma range_val_prod_embedding:
  assumes "x \<in> val_powertower n \<times> val_powertower m"
  shows "val_prod_embedding x \<in> val_powertower (prod_encode(n,m) + 3)"
proof -
  obtain x1 x2 where x: "x=(x1,x2)" by (atomize_elim,auto)
  have n: "n = val_powertower_level x1"
    using assms unfolding x
    using val_powertower_disjoint val_powertower_level by auto
  have m: "m = val_powertower_level x2"
    using assms unfolding x
    using val_powertower_disjoint val_powertower_level by auto
  show ?thesis
    unfolding val_prod_embedding_def
    using range_val_prod_embedding'[OF assms]
    unfolding x n m by simp
qed

instantiation prod :: (prog_type,prog_type) prog_type begin
definition "(embedding' :: ('a\<times>'b) val_embedding) =
  (\<lambda>x. val_prod_embedding (map_prod (fst embedding') (fst embedding') x),
  prod_encode (snd (embedding'::'a val_embedding), snd (embedding'::'b val_embedding)) + 3)"
instance proof
  let ?e = "embedding'::('a\<times>'b)val_embedding"
  show "range (fst ?e) \<subseteq> val_powertower (snd ?e)"
    apply auto unfolding embedding'_prod_def apply simp
    apply (rule range_val_prod_embedding) apply auto
    using embedding'_range by auto
  show "inj (fst ?e)"
    apply (rule injI)
    unfolding embedding'_prod_def apply simp
    apply (frule inj_val_prod_embedding[THEN injD])
    by (auto simp: inj_embedding' inj_eq)
qed
end

(* instance apply (rule prog_type_classI)
  apply (rule exI[where x="\<lambda>(x::'a,y::'b). {Inl x,Inr y}"])
  apply (rule injI)
  by (case_tac x, case_tac y, auto)
end *)

instantiation "fun" :: (prog_type,prog_type)prog_type begin
definition "(embedding' :: ('a\<Rightarrow>'b) val_embedding) = embedding'_default"
instance apply (rule prog_type_classI[OF embedding'_fun_def, of "\<lambda>f. {(x,f x)| x. True}"])
  by (rule injI, auto)
end

instantiation list :: (prog_type) prog_type begin
definition "(embedding' :: 'a list val_embedding) = embedding'_default"
instance apply (rule prog_type_classI[OF embedding'_list_def, of "\<lambda>l. (length l, nth l)"])
  by (rule injI, metis nth_equalityI old.prod.inject)
end

local_setup {*
  Local_Theory.define ((@{binding embedding'_UNCONSTRAINED},NoSyn),((@{binding embedding'_UNCONSTRAINED_def},[]),
      Const(@{const_name embedding'},@{typ "'a val_embedding"}))) #> snd
*}

lemma OFCLASS_prog_type_typedef[unfolded embedding'_UNCONSTRAINED_def]:
  fixes Rep::"'a\<Rightarrow>'b::prog_type"
  assumes emb: "(embedding'_UNCONSTRAINED :: 'a val_embedding) \<equiv> (fst embedding' o Rep, snd (embedding'::'b val_embedding))"
  assumes inj: "\<And>x y. (Rep x = Rep y) = (x = y)"
  shows "OFCLASS('a,prog_type_class)"
proof (intro_classes, fold embedding'_UNCONSTRAINED_def)
  let ?e = "embedding'_UNCONSTRAINED :: 'a val_embedding"
  show "range (fst ?e) \<subseteq> val_powertower (snd ?e)"
    unfolding emb apply simp using embedding'_range by auto
  have "inj Rep" apply (rule injI) using inj by simp
  show "inj (fst ?e)"
    unfolding emb using inj inj_embedding' `inj Rep` by (auto intro: inj_comp)
qed

(*instantiation int::prog_type begin
instance by (fact OFCLASS_prog_type_typedef[OF Rep_int_inject]) end *)

(*
instantiation rat::prog_type begin
instance by (fact OFCLASS_prog_type_typedef[OF Rep_rat_inject]) end

instantiation real::prog_type begin
instance by (fact OFCLASS_prog_type_typedef[OF Rep_real_inject]) end
*)

subsection {* Automatically instantiate new types (defined via typedef) *}

ML {*
fun instantiate_prog_type tycon thy =
let val arity = Sign.arity_number thy tycon
    val sorts = replicate arity @{sort "prog_type"}
    val vs = Name.invent_names Name.context "'a" sorts
    val tycon_info =
      case Typedef.get_info_global thy tycon of
        [info] => info
      | [] => error (tycon^" not defined by typedef")
      | _ => error ("Typedef.get_info_global thy \""^tycon^"\" returns several items")
    val Rep_inject = #Rep_inject (snd tycon_info)
    val rep_type = #rep_type (fst tycon_info)
    val abs_type = #abs_type (fst tycon_info)
    val Rep = Const(#Rep_name (fst tycon_info), abs_type --> rep_type)
    (* val inst_type = Type(tycon,map TFree vs) *)
    val OFCLASS_prog_type_typedef = @{thm OFCLASS_prog_type_typedef} (* Global_Theory.get_thm thy "Universe.OFCLASS_prog_type_typedef" *)
    val lthy = Class.instantiation ([tycon],vs,@{sort "prog_type"}) thy

    val bind = Binding.suffix_name ("_"^(List.last (Long_Name.explode tycon))) @{binding embedding'}
    val rhs = @{termx "(fst embedding' \<circ> (?Rep::?'abs_type::prog_type\<Rightarrow>?'rep_type::prog_type), snd (embedding'::?'rep_type val_embedding))"}
    val ((_,(_,emb_thm)),lthy) = Local_Theory.define ((bind,NoSyn), ((Thm.def_binding bind,[]), rhs)) lthy
    val emb_thm_global = Proof_Context.export lthy (lthy |> Proof_Context.theory_of |> Proof_Context.init_global) [emb_thm] |> hd

    val OFCLASS_thm = OFCLASS_prog_type_typedef OF [emb_thm_global,Rep_inject]
    val thy = Class.prove_instantiation_exit (fn _ => resolve0_tac [OFCLASS_thm] 1) lthy
in
thy
end;

fun try_instantiate_prog_type tycon thy =
  instantiate_prog_type tycon thy
  handle ERROR _ => (tracing ("Did not instantiate "^tycon^" :: prog_type"); thy)
       | THM _ => (tracing ("Did not instantiate "^tycon^" :: prog_type"); thy);
*}

(* typedef 'a bla = "UNIV::'a set" by auto
(* TODO remove *)
setup {* instantiate_prog_type @{type_name "bla"} *}
 *)

setup {* Typedef.interpretation (Local_Theory.background_theory o try_instantiate_prog_type) *}

subsection {* Instantiation for types not handled by automated mechanism *}

(*instantiation option :: (prog_type)prog_type begin
instance apply (rule prog_type_classI, rule exI[where x="\<lambda>x. case x of Some x \<Rightarrow> Inl x | None \<Rightarrow> Inr ()"])
proof (rule injI) (* Sledgehammer proof *)
  fix x :: "'a option" and y :: "'a option"
  assume a1: "(case x of None \<Rightarrow> Inr () | Some f \<Rightarrow> Inl f) = (case y of None \<Rightarrow> Inr () | Some f \<Rightarrow> Inl f)"
  then obtain esk3\<^sub>1 :: "'a option \<Rightarrow> 'a" where "y = x \<or> None = x \<or> y = None" by (metis option.case(2) option.exhaust sum.sel(1))
  thus "x = y" using a1 by (metis (no_types) Inr_not_Inl option.case_eq_if)
qed
end*)

(*instantiation distr::(prog_type)prog_type begin
instance by (fact OFCLASS_prog_type_typedef[OF Rep_distr_inject]) end*)

(*instantiation nibble::prog_type begin
instance by (fact OFCLASS_prog_type_typedef[OF Rep_nibble_inject]) end*)

(*instantiation char :: prog_type begin
instance apply (rule prog_type_classI, rule exI[where x=Rep_char])
  by (metis Rep_char_inverse injI)
end*)

end


theory Safety_Certification
  imports
    Simulation_Graphs_Certification2
    Certification.Unreachability_Common
    "~/Code/Explorer/Guess_Explore"
begin

locale Unreachability_Invariant_paired_pre_defs =
  fixes E :: "'l \<times> 's \<Rightarrow> 'l \<times> 's \<Rightarrow> bool" and P :: "'l \<times> 's \<Rightarrow> bool"
    and less_eq :: "'s \<Rightarrow> 's set \<Rightarrow> bool" (infix "\<preceq>" 50)
begin

sublocale Unreachability_Invariant_pre_defs where
  less_eq = "\<lambda>(l, s) S. (\<forall>(l', s') \<in> S. l' = l) \<and> s \<preceq> R_of S" .

end

\<comment> \<open>Contains all auxiliary assumptions that will not be checked computationally.\<close>
locale Unreachability_Invariant_paired_pre =
  Unreachability_Invariant_paired_pre_defs +
  \<^cancel>\<open>assumes mono: "a \<preceq> B \<Longrightarrow> E a a' \<Longrightarrow> P a \<Longrightarrow> (\<forall>b \<in> B. P b)
    \<Longrightarrow> \<exists>B'. (\<forall>b' \<in> B'. \<exists>b \<in> B. E b b') \<and> a' \<preceq> B'"\<close>
  assumes mono:
    "s \<preceq> S \<Longrightarrow> E (l, s) (l', t) \<Longrightarrow> P (l, s) \<Longrightarrow> \<forall>s \<in> S. P (l, s)
    \<Longrightarrow> \<exists> T. t \<preceq> T \<and> (\<forall>t' \<in> T. \<exists>s' \<in> S. E (l, s') (l', t'))"
  \<^cancel>\<open>assumes P_invariant: "P a \<Longrightarrow> E a a' \<Longrightarrow> P b"\<close>
  assumes P_invariant: "P (l, s) \<Longrightarrow> E (l, s) (l', s') \<Longrightarrow> P (l', s')"
  assumes subsumes_Subsumed: "a \<preceq> A \<Longrightarrow> \<forall>s \<in> A. \<exists>T' \<subseteq> A'. s \<preceq> T' \<Longrightarrow> a \<preceq> A'"
begin

sublocale Unreachability_Invariant where
  less_eq = "\<lambda>(l, s) S. (\<forall>(l', s') \<in> S. l' = l) \<and> s \<preceq> R_of S"
  apply standard
  oops

end

definition project (infix "\<restriction>" 55) where
  "project S l = {s | s. (l, s) \<in> S}"

locale Reachability_Impl_base =
  Certification_Impl_base where E = E +
  Unreachability_Invariant_paired_pre_defs where E = E
  for E :: "'l \<times> 's \<Rightarrow> _" +
  fixes P' and F
  assumes P'_P: "\<And> l s. P' (l, s) \<Longrightarrow> P (l, s)"
  assumes F_mono:
    "\<And>a A. P a \<Longrightarrow> F a \<Longrightarrow> (\<lambda>(l, s) S. s \<preceq> S \<restriction> l) a A
    \<Longrightarrow> (\<forall> a \<in> A. P a) \<Longrightarrow> (\<exists> a \<in> A. F a)"

locale Reachability_Impl_pre =
  Reachability_Impl_base where E = E +
  Unreachability_Invariant_paired_pre where E = E +
  Paired_Graph_Set where E = E for E :: "'l \<times> 's \<Rightarrow> _"
begin

\<comment> \<open>Note that these instantiations can be restricted more,
  e.g.\ to allow subsumption checking with certificates.\<close>
sublocale Certification_Impl
  where R = "\<lambda>l s xs. s \<preceq> xs"
    and R_impl = "\<lambda>l s xs. RETURN (s \<preceq> xs)"
  by standard rule

end

locale Reachability_Impl_pre_start =
  Reachability_Impl_pre where E = E for E :: "'l \<times> 's \<Rightarrow> _" +
  fixes l\<^sub>0 :: 'l and s\<^sub>0 :: 's
begin

sublocale Certification_Impl_Start
  where R = "\<lambda>l s xs. s \<preceq> xs"
    and R_impl = "\<lambda>l s xs. RETURN (s \<preceq> xs)"
  ..

end

locale Reachability_Impl_correct =
  Reachability_Impl_pre_start where E = E +
  Unreachability_Invariant_paired_pre where E = E for E :: "'l \<times> 's \<Rightarrow> _"
begin

definition I where
  "I \<equiv> \<lambda>(l, s). l \<in> L \<and> s \<in> M l"

definition less_eq' where
  "less_eq' \<equiv> \<lambda>(l, s) S. s \<preceq> S \<restriction> l"

lemma less_eq'_pair [simp]:
  "less_eq' (l, s) S \<longleftrightarrow> s \<preceq> S \<restriction> l"
  unfolding less_eq'_def project_def from_R_def by auto

lemma project_from_R [simp]:
  "from_R l S \<restriction> l = S"
  unfolding project_def from_R_def by simp

lemma subsumes_Subsumed_lifted:
  assumes "s \<preceq> R_of A" "A \<sqsubseteq> A'" shows "s \<preceq> R_of A'"
  using assms unfolding Subsumed_def
  by (elim subsumes_Subsumed) (fastforce simp: R_of_def subset_image_iff dest: bspec)

lemma mem_project_iff:
  "s \<in> A \<restriction> l \<longleftrightarrow> (l, s) \<in> A"
  unfolding project_def by auto

lemma project_subsI:
  "A \<restriction> l \<subseteq> B \<restriction> l" if "A \<subseteq> B"
  using that unfolding project_def by auto

\<comment> \<open>Note that the second occurrence of \<^term>\<open>less_eq'\<close> can be restricted
  to only use certain subsumptions (e.g.\ from certificates).\<close>
lemma Unreachability_Invariant_pairedI[rule_format]:
  "check_all_spec \<longrightarrow> Unreachability_Invariant E P less_eq' I less_eq'"
  unfolding check_all_spec_def check_all_pre_spec_def check_invariant_spec_def
proof safe
  assume invariant:
    "\<forall>l\<in>L. \<forall>s\<in>M l. \<forall>l' s'. (l, s) \<rightarrow> (l', s') \<longrightarrow> l' \<in> L \<and> s' \<preceq> M l'" and
    wf: "\<forall>l\<in>L. \<forall>s\<in>M l. P' (l, s)" and
    \<comment> \<open>Unused:\<close>
    "l\<^sub>0 \<in> L"
    "s\<^sub>0 \<preceq> M l\<^sub>0"
    "P' (l\<^sub>0, s\<^sub>0)"
  show "Unreachability_Invariant E P less_eq' I less_eq'"
  proof standard
    fix a :: "'l \<times> 's" and B :: "('l \<times> 's) set" and a' :: "'l \<times> 's"
    assume prems:
      "less_eq' a B"
      "a \<rightarrow> a'"
      "P a"
      "\<forall>b\<in>B. P b"
    obtain l s l' s' where [simp]: "a = (l, s)" "a' = (l', s')"
      by (cases a; cases a')
    have "\<forall>s\<in>B \<restriction> l. P (l, s)" for l
      using prems(4) unfolding project_def by auto
    with prems(1-3) obtain T where "s' \<preceq> T" "\<forall>t'\<in>T. \<exists>s'\<in>B \<restriction> l. (l, s') \<rightarrow> (l', t')"
      by atomize_elim (rule mono, auto)
    then show "\<exists>B'. (\<forall>b'\<in>B'. \<exists>b\<in>B. b \<rightarrow> b') \<and> less_eq' a' B'"
      by (inst_existentials "from_R l' T") (auto simp: from_R_def project_def)
  next
    fix s :: "'l \<times> 's" and t :: "'l \<times> 's"
    assume prems: "I s" "s \<rightarrow> t"
    obtain l' s' where "t = (l', s')"
      by (cases t)
    with prems invariant show "\<exists>T. Ball T I \<and> less_eq' t T"
      by (inst_existentials "from_R l' (M l')"; clarsimp) (auto simp: from_R_def I_def)
  next
    fix s :: "'l \<times> 's" and T :: "('l \<times> 's) set"
    assume "less_eq' s T"
    then show "less_eq' s T" .
  next
    fix s :: "'l \<times> 's"
    assume "I s"
    with wf show "P s"
      by (metis (no_types, lifting) I_def P'_P case_prodE)
  next
    fix a :: "'l \<times> 's" and a' :: "'l \<times> 's"
    assume  "P a" and "a \<rightarrow> a'"
    then show "P a'"
      by - (cases a; cases a'; simp only:; rule P_invariant)
  next
    fix a :: "'l \<times> 's" and A :: "('l \<times> 's) set" and A' :: "('l \<times> 's) set"
    assume prems:
      "less_eq' a A"
      "Unreachability_Invariant_pre_defs.Subsumed less_eq' A A'"
    obtain l s where [simp]: "a = (l, s)"
      by (cases a)
    have "\<exists>T'\<subseteq>A' \<restriction> l. s \<preceq> T'" if "s \<in> A \<restriction> l" for s
    proof -
      from that prems (2) obtain T' where
        "(l, s) \<in> A" "T' \<subseteq> A'" "s \<preceq> T' \<restriction> l"
        unfolding Unreachability_Invariant_pre_defs.Subsumed_def by (auto simp: mem_project_iff)
      then show ?thesis
        by (auto dest: project_subsI)
    qed
    with prems(1) show "less_eq' a A'"
      by (auto elim: subsumes_Subsumed)
  qed
qed

lemma check_all_correct':
  "check_all \<le> SPEC (\<lambda>r. r \<longrightarrow> Unreachability_Invariant E P less_eq' I less_eq')"
  by (refine_vcg Unreachability_Invariant_pairedI check_all_correct) fast

lemma in_from_R_conv:
  "(l, s) \<in> from_R l' S \<longleftrightarrow> l = l' \<and> s \<in> S"
  unfolding from_R_def by auto

lemma F_mono':
  "P (l, s) \<Longrightarrow> F (l, s) \<Longrightarrow> s \<preceq> B \<restriction> l \<Longrightarrow> \<forall>x \<in> B. P x \<Longrightarrow> \<exists>b \<in> B. F b"
  by (drule F_mono[rotated, where A = "B"]) (auto simp: mem_project_iff)

lemma certify_unreachableI:
  "check_all_spec \<and> check_final_spec \<longrightarrow> (\<nexists>s'. E\<^sup>*\<^sup>* (l\<^sub>0, s\<^sub>0) s' \<and> F s')"
  by (rule impI Unreachability_Invariant.final_unreachable[where S\<^sub>0 = "from_R l\<^sub>0 (M l\<^sub>0)"]
        Unreachability_Invariant_pairedI)+
     (auto intro: F_mono P'_P
       simp: check_final_spec_def check_all_spec_def check_all_pre_spec_def
        Unreachability_Invariant_defs.Inv_def I_def in_from_R_conv)

lemma certify_unreachable_correct':
  "certify_unreachable \<le> SPEC (\<lambda>r. r \<longrightarrow> (\<nexists>s'. E\<^sup>*\<^sup>* (l\<^sub>0, s\<^sub>0) s' \<and> F s'))"
  by (refine_vcg certify_unreachableI[rule_format] certify_unreachable_correct; fast)

end

locale Reachability_Impl =
  Certification_Impl_imp where M = M and K = K and A = A +
  Reachability_Impl_correct where M = "\<lambda>x. case M x of None \<Rightarrow> {} | Some S \<Rightarrow> S"
    for M :: "'k \<Rightarrow> 'a set option"
    and K :: "'k \<Rightarrow> 'ki :: {hashable,heap} \<Rightarrow> assn"
    and A :: "'a \<Rightarrow> 'ai :: heap \<Rightarrow> assn" +
  \<comment> \<open>Again, as explained above, this can be replaced with a more specific subsumption.\<close>
  fixes Lei
  assumes Lei[sepref_fr_rules]:
    "(uncurry Lei,uncurry (RETURN oo PR_CONST less_eq)) \<in> A\<^sup>k *\<^sub>a (lso_assn A)\<^sup>k \<rightarrow>\<^sub>a bool_assn"

end