(*  Title: L3_Lib.thy
    Original author: Anthony Fox, University of Cambridge
    Contributions by: Kyndylan Nienhuis <kyndylan@mutlus.nl>

L3 operations.
*)

theory L3_Lib
imports "$ISABELLE_HOME/src/HOL/Word/Word"
        "$ISABELLE_HOME/src/HOL/Library/Code_Target_Numeral"
        "$ISABELLE_HOME/src/HOL/Library/Code_Char"
begin

(* basic state Monad *)

definition "return = Pair"

definition bind :: "('state \<Rightarrow> ('a \<times> 'state)) \<Rightarrow>
                    ('a \<Rightarrow> 'state \<Rightarrow> ('b \<times> 'state)) \<Rightarrow>
                    ('state \<Rightarrow> ('b \<times> 'state))" where
  "bind f g = (\<lambda>s. let (a, s') = f s in g a s')"

definition read_state :: "('state \<Rightarrow> 'a) \<Rightarrow> 'state \<Rightarrow> 'a \<times> 'state" where
  "read_state f = (\<lambda>s. (f s, s))"

definition update_state :: "('state \<Rightarrow> 'state) \<Rightarrow> 'state \<Rightarrow> unit \<times> 'state" where
  "update_state f = (\<lambda>s. ((), f s))"

definition extend_state :: "'b \<Rightarrow> ('b \<times> 'state \<Rightarrow> 'a \<times> 'b \<times> 'state) \<Rightarrow> 'state \<Rightarrow> 'a \<times> 'state" where
  "extend_state v f = (\<lambda>s. let (a, s') = f (v, s) in (a, snd s'))"

definition trim_state :: "('state \<Rightarrow> 'a \<times> 'state) \<Rightarrow> 'b \<times> 'state \<Rightarrow> 'a \<times> 'b \<times> 'state" where
  "trim_state f = (\<lambda>(s1, s2). let (a, s') = f s2 in (a, s1, s'))"

fun foreach_loop :: "'a list \<times> ('a \<Rightarrow> 'state \<Rightarrow> unit \<times> 'state) \<Rightarrow> 'state \<Rightarrow> unit \<times> 'state" where
  "foreach_loop ([], _) = return ()" |
  "foreach_loop (h # t, a) = bind (a h) (\<lambda>u. foreach_loop (t, a))"

function for_loop :: "nat \<times> nat \<times> (nat \<Rightarrow> 'state \<Rightarrow> unit \<times> 'state) \<Rightarrow> 'state \<Rightarrow> unit \<times> 'state" where
  "for_loop (i, j, a) =
   (if i = j then
      a i
    else
      bind (a i) (\<lambda>u. for_loop ((if i < j then i + 1 else i - 1), j, a)))"
  by auto
  termination by (relation "measure (\<lambda>(i, j, _). if i < j then j - i else i - j)") auto

(* Because there are no constraints on i, j and a on the left-hand side of the definition, every
occurrence of for_loop can be simplified by for_loop.simps, and since the definition is recursive
the simplifier might diverge. For this reason we remove for_loop.simps from the simp set. *)

declare for_loop.simps [simp del]

(* Monad laws *)

lemma bind_left_identity [simp]:
  shows "bind (return a) f = f a"
unfolding return_def bind_def
by auto

lemma bind_right_identity [simp]:
  shows "bind m return = m"
unfolding return_def bind_def
by auto

lemma bind_associativity:
  shows "bind (bind m f) g = bind m (\<lambda>a. bind (f a) g)"
        (is "?l = ?r")
proof
  fix s
  show "?l s = ?r s"
    unfolding return_def bind_def
    by (cases "m s") auto
qed

(* Projections *)

lemma project_return [simp]:
  shows "fst (return a s) = a"
    and "snd (return a s) = s"
unfolding return_def
by auto

lemma project_read_state [simp]:
  shows "fst (read_state f s) = f s"
    and "snd (read_state f s) = s"
unfolding read_state_def
by auto

lemma project_update_state [simp]:
  shows "fst (update_state f s) = ()"
    and "snd (update_state f s) = f s"
unfolding update_state_def
by auto

(* Other monad simplifications *)

lemma read_state_constant [simp]:
  shows "read_state (\<lambda>s. a) = return a"
unfolding read_state_def return_def
..

lemma update_state_id [simp]:
  shows "update_state (\<lambda>s. s) = return ()"
unfolding update_state_def return_def
..

lemma foreach_loop_return [simp]:
  shows "foreach_loop (l, \<lambda>_. return a) = return ()"
by (induct l) simp_all

lemma extend_state_return [simp]:
  shows "extend_state v (return a) = return a"
unfolding extend_state_def return_def
by simp

lemma extend_state_trim_state [simp]:
  shows "extend_state v (trim_state m) = m"
        (is "?l = ?r")
proof
  fix s
  show "?l s = ?r s"
    unfolding extend_state_def trim_state_def
    by (cases "m s") auto
qed

(* extra character operations *)

definition Ord :: "char \<Rightarrow> nat" where
   "Ord c = (case c of Char nh nl \<Rightarrow>
             nat_of_nibble nh * 16 + nat_of_nibble nl)"

definition Chr :: "nat \<Rightarrow> char" where
   "Chr n = Char (nibble_of_nat (n div 16)) (nibble_of_nat n)"

definition is_lower :: "char \<Rightarrow> bool" where
   "is_lower c = (Ord (CHR ''a'') \<le> Ord c \<and> Ord c \<le> Ord (CHR ''z''))"

definition is_upper :: "char \<Rightarrow> bool" where
   "is_upper c = (Ord (CHR ''A'') \<le> Ord c \<and> Ord c \<le> Ord (CHR ''Z''))"

definition is_space :: "char \<Rightarrow> bool" where
   "is_space c = (Ord (CHR '' '') = Ord c \<or> 9 \<le> Ord c \<and> Ord c \<le> 13)"

definition is_digit :: "char \<Rightarrow> bool" where
   "is_digit c = (Ord (CHR ''0'') \<le> Ord c \<and> Ord c \<le> Ord (CHR ''9''))"

definition is_hex_digit :: "char \<Rightarrow> bool" where
   "is_hex_digit c = (is_digit c \<or> Ord (CHR ''a'') \<le> Ord c \<and> Ord c \<le> Ord (CHR ''f'') \<or>
                                   Ord (CHR ''A'') \<le> Ord c \<and> Ord c \<le> Ord (CHR ''F''))"

definition is_alpha :: "char \<Rightarrow> bool" where
   "is_alpha c = (is_lower c \<or> is_upper c)"

definition is_alpha_num :: "char \<Rightarrow> bool" where
   "is_alpha_num c = (is_alpha c \<or> is_digit c)"

definition to_lower :: "char \<Rightarrow> char" where
   "to_lower c = (if is_upper c then Chr (Ord c + 32) else c)"

definition to_upper :: "char \<Rightarrow> char" where
   "to_upper c = (if is_lower c then Chr (Ord c - 32) else c)"

(* numeric strings *)

fun list_to_nat :: "nat \<Rightarrow> nat list \<Rightarrow> nat" where
  "list_to_nat _ [] = 0" |
  "list_to_nat base (h # t) = h mod base + base * list_to_nat base t"

fun nat_to_list :: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
  "nat_to_list base n =
   (if n < base \<or> base < 2 then [n mod base] else n mod base # nat_to_list base (n div base))"

(* Because there are no constraints on n on the left-hand side of the definition, every occurrence
of nat_to_list can be simplified by nat_to_list.simps, and since the definition is recursive the
simplifier might diverge. For this reason we remove nat_to_list.simps from the simp set. *)

declare nat_to_list.simps [simp del]

definition hex :: "nat \<Rightarrow> char" where
  "hex n = (if n = 0 then CHR ''0''
            else if n = 1 then CHR ''1''
            else if n = 2 then CHR ''2''
            else if n = 3 then CHR ''3''
            else if n = 4 then CHR ''4''
            else if n = 5 then CHR ''5''
            else if n = 6 then CHR ''6''
            else if n = 7 then CHR ''7''
            else if n = 8 then CHR ''8''
            else if n = 9 then CHR ''9''
            else if n = 10 then CHR ''A''
            else if n = 11 then CHR ''B''
            else if n = 12 then CHR ''C''
            else if n = 13 then CHR ''D''
            else if n = 14 then CHR ''E''
            else if n = 15 then CHR ''F''
            else undefined)"

definition unhex :: "char \<Rightarrow> nat" where
  "unhex c = (if c = CHR ''0'' then 0
              else if c = CHR ''1'' then 1
              else if c = CHR ''2'' then 2
              else if c = CHR ''3'' then 3
              else if c = CHR ''4'' then 4
              else if c = CHR ''5'' then 5
              else if c = CHR ''6'' then 6
              else if c = CHR ''7'' then 7
              else if c = CHR ''8'' then 8
              else if c = CHR ''9'' then 9
              else if c = CHR ''a'' \<or> c = CHR ''A'' then 10
              else if c = CHR ''b'' \<or> c = CHR ''B'' then 11
              else if c = CHR ''c'' \<or> c = CHR ''C'' then 12
              else if c = CHR ''d'' \<or> c = CHR ''D'' then 13
              else if c = CHR ''e'' \<or> c = CHR ''E'' then 14
              else if c = CHR ''f'' \<or> c = CHR ''F'' then 15
              else undefined)"

definition string_to_nat :: "nat \<Rightarrow> string \<Rightarrow> nat" where
  "string_to_nat base s = list_to_nat base (map unhex (rev s))"

definition nat_to_string :: "nat \<Rightarrow> nat \<Rightarrow> string" where
  "nat_to_string base n = rev (map hex (nat_to_list base n))"

definition "bin_string_to_nat \<equiv> string_to_nat 2"
definition "nat_to_bin_string \<equiv> nat_to_string 2"
definition "dec_string_to_nat \<equiv> string_to_nat 10"
definition "nat_to_dec_string \<equiv> nat_to_string 10"
definition "hex_string_to_nat \<equiv> string_to_nat 16"
definition "nat_to_hex_string \<equiv> nat_to_string 16"

definition nat_from_bin_string :: "string \<Rightarrow> nat option" where
  "nat_from_bin_string s =
   (if s \<noteq> '''' \<and> list_all (\<lambda>c. c = CHR ''0'' \<or> c = CHR ''1'') s then
      Some (bin_string_to_nat s)
    else None)"

definition nat_from_dec_string :: "string \<Rightarrow> nat option" where
  "nat_from_dec_string s =
   (if s \<noteq> '''' \<and> list_all is_digit s then Some (dec_string_to_nat s) else None)"

definition nat_from_hex_string :: "string \<Rightarrow> nat option" where
  "nat_from_hex_string s =
   (if s \<noteq> '''' \<and> list_all is_hex_digit s then Some (hex_string_to_nat s) else None)"

definition dec_string_to_int :: "string \<Rightarrow> int" where
  "dec_string_to_int r =
   (case r of []    \<Rightarrow> 0 |
              h # t \<Rightarrow> (if h = CHR ''-'' \<or> h = CHR ''~''
                        then -int (dec_string_to_nat t)
                        else  int (dec_string_to_nat r)))"

definition int_to_dec_string :: "int \<Rightarrow> string" where
  "int_to_dec_string i =
   (if i < 0 then CHR ''~'' # nat_to_dec_string (nat (-i)) else nat_to_dec_string (nat i))"

definition string_to_bool :: "string \<Rightarrow> bool" where
  "string_to_bool s = (if s = ''true'' then True
                       else if s = ''false'' then False
                       else undefined)"

definition string_to_char :: "string \<Rightarrow> char" where
  "string_to_char s = (case s of [c] \<Rightarrow> c | _ \<Rightarrow> undefined)"

(* extra Nat operation *)

fun log2 :: "nat \<Rightarrow> nat" where
  "log2 n = (if n = 0 then undefined else if n = 1 then 0 else Suc (log2 (n div 2)))"

(* Because there are no constraints on n on the left-hand side of the definition, every occurrence
of log2 can be simplified by log2.simps, and since the definition is recursive the simplifier might
diverge. For this reason we remove log2.simps from the simp set. *)

declare log2.simps [simp del]

lemma log2_bounds:
  assumes "n \<noteq> 0"
  shows   "2 ^ (log2 n) \<le> n"
    and   "n < 2 ^ (Suc (log2 n))"
proof -
  -- "The induction works better if we prove one goal instead of two goals"
  have "2 ^ (log2 n) \<le> n \<and> n < 2 ^ (Suc (log2 n))"
    using assms
    proof (induct "log2 n" arbitrary: n)
      case 0
      hence "n = 1"
        by (simp add: log2.simps) (meson nat.simps(3))
      thus ?case by (simp add: log2.simps)
    next
      case (Suc k)
      show ?case
        proof (cases "n = 1")
          case True
          thus ?thesis by (simp add: log2.simps)
        next
          case False
          hence "1 < n" using Suc(3) by simp
          hence "(n div 2) \<noteq> 0" by auto
          have log2: "log2 n = Suc (log2 (n div 2))"
            using `1 < n` by (simp add: log2.simps)
          hence "k = log2 (n div 2)" using Suc(2) by simp
          note Suc(1)[OF this `(n div 2) \<noteq> 0`]
          thus ?thesis
            using log2 by auto
        qed
    qed
  thus "2 ^ (log2 n) \<le> n" "n < 2 ^ (Suc (log2 n))" by auto
qed

lemma log2_unat_bounds:
  fixes x :: "('a :: len) word"
  assumes "x \<noteq> 0"
  shows "log2 (unat x) < len_of TYPE('a)"
proof -
  have "unat x \<noteq> 0"
    using assms
    by (simp add: unat_eq_zero)
  have "unat x < 2 ^ len_of TYPE('a)"
    by simp
  note le_less_trans[OF log2_bounds(1)[OF `unat x \<noteq> 0`] this]
  thus ?thesis by auto
qed

(* extra int operations *)

definition quot :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "quot" 70) where
  "i quot j = (if j = 0 then undefined
               else if 0 < j then if 0 \<le> i then i div j else -(-i div j)
               else if 0 \<le> i then -(i div -j)
               else -i div -j)"

definition rem :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "rem" 70) where
  "i rem j = (if j = 0 then undefined else i - i quot j * j)"

definition quot_rem :: "int * int \<Rightarrow> int * int" where
  "quot_rem p = (case p of (i, j) \<Rightarrow> (i div j, i rem j))"

(* extra option operations *)

definition is_some :: "'a option \<Rightarrow> bool" where
  "is_some x = (case x of Some _ \<Rightarrow> True | _ \<Rightarrow> False)"

lemma is_some_alt:
  shows "is_some x = (x \<noteq> None)"
unfolding is_some_def
using option.disc_eq_case(2)
by auto

lemma is_some_simps [simp]:
  shows "\<not> (is_some None)"
    and "is_some (Some x)"
unfolding is_some_def by simp_all

(* extra list operations *)

fun splitl :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list" where
  "splitl _ [] = ([], [])" |
  "splitl P (h # t) = (if P h then let (l, r) = splitl P t in (h # l, r) else ([], h # t))"

definition splitr :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<times> 'a list" where
  "splitr P x = (let (l, r) = splitl P (rev x) in (rev r, rev l))"

definition pad_left :: "'a \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "pad_left c n s = replicate (n - length s) c @ s"

definition pad_right :: "'a \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "pad_right c n s = s @ replicate (n - length s) c"

fun index_find :: "nat \<Rightarrow> 'a \<times> 'a list \<Rightarrow> nat option" where
  "index_find _ (_, []) = None" |
  "index_find i (v, h # t) = (if v = h then Some i else index_find (Suc i) (v, t))"

definition "index_of = index_find 0"

definition remove :: "'a list * 'a list \<Rightarrow> 'a list" where
  "remove p = (case p of (l1, l2) \<Rightarrow> filter (\<lambda>x. x \<notin> set l1) l2)"

definition remove_except :: "'a list * 'a list \<Rightarrow> 'a list" where
  "remove_except p = (case p of (l1, l2) \<Rightarrow> filter (\<lambda>x. x \<in> set l1) l2)"

fun remove_duplicates :: "'a list \<Rightarrow> 'a list" where
  "remove_duplicates [] = []" |
  "remove_duplicates (h # t) = (if h \<in> set t then remove_duplicates t else h # remove_duplicates t)"

lemma splitl_length:
  shows "length (fst (splitl P l)) + length (snd (splitl P l)) = length l"
by (induct l, auto simp add: case_prod_beta)

lemma splitl_fst_length [simp]:
  shows "length (fst (splitl P x)) \<le> length x"
using splitl_length
by (metis order_refl trans_le_add1)

lemma splitl_snd_length [simp]:
  shows "length (snd (splitl P x)) \<le> length x"
using splitl_length
by (metis order_refl trans_le_add2)

lemma pad_left_length [simp]:
  shows "length (pad_left e n l) = max (length l) n"
unfolding pad_left_def
by auto

lemma pad_right_length [simp]:
  shows "length (pad_right e n l) = max (length l) n"
unfolding pad_right_def
by auto

lemma pad_left_nth:
  shows "pad_left e n l ! m =
         (if m < n - List.length l
          then e
          else l ! (m - (n - List.length l)))"
unfolding pad_left_def nth_append
by simp

(* extra string operations *)

lemma fields_termination_lem [simp]:
  assumes "a \<noteq> []" and "length a \<le> length c"
  shows "length a - b < Suc (length c)"
  by (simp add: assms(2) le_imp_less_Suc less_imp_diff_less)

function (sequential) tokens :: "(char \<Rightarrow> bool) \<Rightarrow> string \<Rightarrow> string list" where
  "tokens _ '''' = []" |
  "tokens P x =
   (let (l, r) = splitl (\<lambda>e. ~P e) x in if l = [] then tokens P (tl r) else l # tokens P r)"
  by pat_completeness auto
  termination tokens
  apply (relation "measure (length o snd)")
  apply auto
  apply (case_tac "~ P v", auto simp add: case_prod_beta le_imp_less_Suc)
  apply (case_tac "~ P v", auto simp add: case_prod_beta le_imp_less_Suc)
  done

function (sequential) fields :: "(char \<Rightarrow> bool) \<Rightarrow> string \<Rightarrow> string list" where
  "fields _ '''' = [[]]" |
  "fields P x =
   (let (l, r) = splitl (\<lambda>e. ~P e) x in if l = [] then [] # fields P (tl r)
                                        else if r = [] then [l]
                                        else l # fields P (tl r))"
  by pat_completeness auto
  termination fields
  apply (relation "measure (length o snd)")
  apply auto
  apply (case_tac "~ P v", auto simp add: case_prod_beta le_imp_less_Suc)
  apply (case_tac "~ P v", auto simp add: case_prod_beta)
  done

(* bit-string operations - extends Bool_List_Representation.thy *)

definition nat_to_bitstring :: "nat \<Rightarrow> bool list" where
  "nat_to_bitstring n =
   (if n = 0 then [False] else bin_to_bl (log2 n + 1) (int n))"

definition "bitstring_to_nat = nat o bl_to_bin"

definition fixwidth :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where
  "fixwidth n v = (let l = length v in if l < n then pad_left False n v else drop (l - n) v)"

definition bitwise :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bool list \<Rightarrow> bool list \<Rightarrow> bool list" where
  "bitwise f v1 v2 =
   (let m = max (length v1) (length v2) in map (case_prod f) (zip (fixwidth m v1) (fixwidth m v2)))"

definition "bor  = bitwise (op \<or>)"
definition "band = bitwise (op \<and>)"
definition "bxor = bitwise (op \<noteq>)"

definition bitstring_shiftl :: "bool list \<Rightarrow> nat \<Rightarrow> bool list" where
  "bitstring_shiftl v m = pad_right False (length v + m) v"

definition bitstring_shiftr :: "bool list \<Rightarrow> nat \<Rightarrow> bool list" where
  "bitstring_shiftr v m = take (length v - m) v"

definition bitstring_field :: "nat \<Rightarrow> nat \<Rightarrow> bool list \<Rightarrow> bool list" where
  "bitstring_field h l v = fixwidth (Suc h - l) (bitstring_shiftr v l)"

definition bitstring_rotate :: "bool list \<Rightarrow> nat \<Rightarrow> bool list" where
  "bitstring_rotate v m =
   (let l = length v in
    let x = m mod l in
      if l = 0 \<or> x = 0 then v else bitstring_field (x - 1) 0 v @ bitstring_field (l - 1) x v)"

definition bitstring_test_bit :: "bool list \<Rightarrow> nat \<Rightarrow> bool" where
  "bitstring_test_bit v n = (bitstring_field n n v = [True])"

definition bitstring_modify ::  "(nat \<times> bool \<Rightarrow> bool) \<times> bool list \<Rightarrow> bool list" where
  "bitstring_modify p = (case p of (f, l) \<Rightarrow> map f (zip (rev (upt 0 (length l))) l))"

definition bitstring_field_insert :: "nat \<Rightarrow> nat \<Rightarrow> bool list \<Rightarrow> bool list \<Rightarrow> bool list" where
  "bitstring_field_insert h l v1 v2 =
   bitstring_modify (\<lambda>(i, b). if l \<le> i \<and> i \<le> h then bitstring_test_bit v1 (i - l) else b, v2)"

lemma nat_to_bitstring_zero [simp]:
  shows "nat_to_bitstring 0 = [False]"
unfolding nat_to_bitstring_def by simp

(* We do not add the following rule to the simp set, because n occurs twice at the right hand side,
and therefore the state might not become simpler when applying this rule. *)

lemma nat_to_bitstring_length:
  shows "length (nat_to_bitstring n) = (if n = 0 then 1 else log2 n + 1)"
unfolding nat_to_bitstring_def
by (simp del: bin_to_bl_def)

lemma fixwidth_length [simp]:
  shows "length (fixwidth n l) = n"
unfolding fixwidth_def Let_def
by auto

lemma bitwise_length [simp]:
  shows "length (bitwise f v1 v2) = max (length v1) (length v2)"
unfolding bitwise_def Let_def
by auto

(* extra word operations *)

definition unsigned_min :: "'a::len word \<times> 'a::len word \<Rightarrow> 'a::len word" where
  "unsigned_min p = (case p of (w1, w2) \<Rightarrow> (if w1 \<le> w2 then w1 else w2))"

definition unsigned_max :: "'a::len word \<times> 'a::len word \<Rightarrow> 'a::len word" where
  "unsigned_max p = (case p of (w1, w2) \<Rightarrow> (if w1 \<le> w2 then w2 else w1))"

definition word_log2 :: "'a::len word \<Rightarrow> 'a::len word" where
  "word_log2 w = of_nat (log2 (unat w))"

definition word_quot :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word" where
  "word_quot i j = of_int (sint i quot sint j)"

definition word_rem :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word" where
  "word_rem i j = of_int (sint i rem sint j)"

definition word_modify :: "(nat \<times> bool \<Rightarrow> bool) \<times> 'a::len word \<Rightarrow> 'a::len word" where
  "word_modify p = (case p of (f, w) \<Rightarrow> of_bl (bitstring_modify (f, to_bl w)))"

definition word_bit_field_insert :: "nat \<Rightarrow> nat \<Rightarrow> 'a::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word" where
  "word_bit_field_insert h l w1 w2 =
   word_modify (\<lambda>(i, b). if l \<le> i \<and> i \<le> h then test_bit w1 (i - l) else b, w2)"

definition word_bits :: "nat \<Rightarrow> nat \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word" where
  "word_bits h l w = (w >> l) AND mask (Suc h - l)"

definition word_extract :: "nat \<Rightarrow> nat \<Rightarrow> 'a::len word \<Rightarrow> 'b::len word" where
  "word_extract h l w = ucast (word_bits h l w)"

definition word_replicate :: "nat \<Rightarrow> 'a::len word \<Rightarrow> 'b::len word" where
  "word_replicate n a = word_rcat (replicate n a)"

(* floating-point stubs *)

datatype ieee_rounding =
  roundTiesToEven | roundTowardPositive | roundTowardNegative | roundTowardZero

datatype ieee_compare = LT | EQ | GT | UN

consts
  fp32_abs :: "32 word \<Rightarrow> 32 word"
  fp32_add :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_compare :: "32 word \<Rightarrow> 32 word \<Rightarrow> ieee_compare"
  fp32_div :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_equal :: "32 word \<Rightarrow> 32 word \<Rightarrow> bool"
  fp32_from_int :: "ieee_rounding \<Rightarrow> int \<Rightarrow> 32 word"
  fp32_greater :: "32 word \<Rightarrow> 32 word \<Rightarrow> bool"
  fp32_greater_equal :: "32 word \<Rightarrow> 32 word \<Rightarrow> bool"
  fp32_is_finite :: "32 word \<Rightarrow> bool"
  fp32_is_nan :: "32 word \<Rightarrow> bool"
  fp32_is_normal :: "32 word \<Rightarrow> bool"
  fp32_is_subnormal :: "32 word \<Rightarrow> bool"
  fp32_less :: "32 word \<Rightarrow> 32 word \<Rightarrow> bool"
  fp32_less_equal :: "32 word \<Rightarrow> 32 word \<Rightarrow> bool"
  fp32_mul :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_mul_add :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_mul_sub :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_neg_inf :: "32 word"
  fp32_neg_zero :: "32 word"
  fp32_negate :: "32 word \<Rightarrow> 32 word"
  fp32_pos_inf :: "32 word"
  fp32_pos_zero :: "32 word"
  fp32_sqrt :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_sub :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> 32 word \<Rightarrow> 32 word"
  fp32_to_int :: "ieee_rounding \<Rightarrow> 32 word \<Rightarrow> int option"

consts
  fp64_abs :: "64 word \<Rightarrow> 64 word"
  fp64_add :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_compare :: "64 word \<Rightarrow> 64 word \<Rightarrow> ieee_compare"
  fp64_div :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_equal :: "64 word \<Rightarrow> 64 word \<Rightarrow> bool"
  fp64_from_int :: "ieee_rounding \<Rightarrow> int \<Rightarrow> 64 word"
  fp64_greater :: "64 word \<Rightarrow> 64 word \<Rightarrow> bool"
  fp64_greater_equal :: "64 word \<Rightarrow> 64 word \<Rightarrow> bool"
  fp64_is_finite :: "64 word \<Rightarrow> bool"
  fp64_is_nan :: "64 word \<Rightarrow> bool"
  fp64_is_normal :: "64 word \<Rightarrow> bool"
  fp64_is_subnormal :: "64 word \<Rightarrow> bool"
  fp64_less :: "64 word \<Rightarrow> 64 word \<Rightarrow> bool"
  fp64_less_equal :: "64 word \<Rightarrow> 64 word \<Rightarrow> bool"
  fp64_mul :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_mul_add :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_mul_sub :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_neg_inf :: "64 word"
  fp64_neg_zero :: "64 word"
  fp64_negate :: "64 word \<Rightarrow> 64 word"
  fp64_pos_inf :: "64 word"
  fp64_pos_zero :: "64 word"
  fp64_sqrt :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_sub :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 64 word \<Rightarrow> 64 word"
  fp64_to_int :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> int option"

consts
  fp32_to_fp64 :: "32 word \<Rightarrow> 64 word"
  fp64_to_fp32 :: "ieee_rounding \<Rightarrow> 64 word \<Rightarrow> 32 word"

code_printing
    constant "fp32_abs" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_abs\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_abs\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_abs\")"
  | constant "fp32_add" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_add\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_add\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_add\")"
  | constant "fp32_compare" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_compare\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_compare\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_compare\")"
  | constant "fp32_div" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_div\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_div\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_div\")"
  | constant "fp32_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_equal\")"
  | constant "fp32_from_int" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_from'_int\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_from'_int\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_from'_int\")"
  | constant "fp32_greater" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_greater\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_greater\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_greater\")"
  | constant "fp32_greater_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_greater'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_greater'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_greater'_equal\")"
  | constant "fp32_is_finite" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_is'_finite\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_is'_finite\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_is'_finite\")"
  | constant "fp32_is_nan" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_is'_nan\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_is'_nan\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_is'_nan\")"
  | constant "fp32_is_normal" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_is'_normal\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_is'_normal\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_is'_normal\")"
  | constant "fp32_is_subnormal" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_is'_subnormal\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_is'_subnormal\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_is'_subnormal\")"
  | constant "fp32_less" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_less\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_less\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_less\")"
  | constant "fp32_less_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_less'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_less'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_less'_equal\")"
  | constant "fp32_mul" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_mul\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_mul\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_mul\")"
  | constant "fp32_mul_add" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_mul'_add\")"
      and (OCaml) "!(fun '_ '_ '_ '_ -> failwith \"fp32'_mul'_add\")"
      and (Haskell) "!(\\ '_ '_ '_ '_ -> error \"fp32'_mul'_add\")"
  | constant "fp32_mul_sub" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_mul'_sub\")"
      and (OCaml) "!(fun '_ '_ '_ '_ -> failwith \"fp32'_mul'_sub\")"
      and (Haskell) "!(\\ '_ '_ '_ '_ -> error \"fp32'_mul'_sub\")"
  | constant "fp32_neg_inf" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_neg'_inf\")"
      and (OCaml) "!(failwith \"fp32'_neg'_inf\")"
      and (Haskell) "!(error \"fp32'_neg'_inf\")"
  | constant "fp32_neg_zero" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_neg'_zero\")"
      and (OCaml) "!(failwith \"fp32'_neg'_zero\")"
      and (Haskell) "!(error \"fp32'_neg'_zero\")"
  | constant "fp32_negate" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_negate\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_negate\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_negate\")"
  | constant "fp32_pos_inf" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_pos'_inf\")"
      and (OCaml) "!(failwith \"fp32'_pos'_inf\")"
      and (Haskell) "!(error \"fp32'_pos'_inf\")"
  | constant "fp32_pos_zero" \<rightharpoonup>
      (SML) "!(raise Fail \"fp32'_pos'_zero\")"
      and (OCaml) "!(failwith \"fp32'_pos'_zero\")"
      and (Haskell) "!(error \"fp32'_pos'_zero\")"
  | constant "fp32_sqrt" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_sqrt\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_sqrt\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_sqrt\")"
  | constant "fp32_sub" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp32'_sub\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp32'_sub\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp32'_sub\")"
  | constant "fp32_to_int" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp32'_to'_int\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp32'_to'_int\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp32'_to'_int\")"
  | constant "fp64_abs" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_abs\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_abs\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_abs\")"
  | constant "fp64_add" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_add\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_add\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_add\")"
  | constant "fp64_compare" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_compare\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_compare\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_compare\")"
  | constant "fp64_div" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_div\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_div\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_div\")"
  | constant "fp64_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_equal\")"
  | constant "fp64_from_int" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_from'_int\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_from'_int\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_from'_int\")"
  | constant "fp64_greater" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_greater\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_greater\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_greater\")"
  | constant "fp64_greater_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_greater'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_greater'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_greater'_equal\")"
  | constant "fp64_is_finite" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_is'_finite\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_is'_finite\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_is'_finite\")"
  | constant "fp64_is_nan" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_is'_nan\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_is'_nan\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_is'_nan\")"
  | constant "fp64_is_normal" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_is'_normal\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_is'_normal\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_is'_normal\")"
  | constant "fp64_is_subnormal" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_is'_subnormal\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_is'_subnormal\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_is'_subnormal\")"
  | constant "fp64_less" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_less\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_less\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_less\")"
  | constant "fp64_less_equal" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_less'_equal\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_less'_equal\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_less'_equal\")"
  | constant "fp64_mul" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_mul\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_mul\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_mul\")"
  | constant "fp64_mul_add" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_mul'_add\")"
      and (OCaml) "!(fun '_ '_ '_ '_ -> failwith \"fp64'_mul'_add\")"
      and (Haskell) "!(\\ '_ '_ '_ '_ -> error \"fp64'_mul'_add\")"
  | constant "fp64_mul_sub" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_mul'_sub\")"
      and (OCaml) "!(fun '_ '_ '_ '_ -> failwith \"fp64'_mul'_sub\")"
      and (Haskell) "!(\\ '_ '_ '_ '_ -> error \"fp64'_mul'_sub\")"
  | constant "fp64_neg_inf" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_neg'_inf\")"
      and (OCaml) "!(failwith \"fp64'_neg'_inf\")"
      and (Haskell) "!(error \"fp64'_neg'_inf\")"
  | constant "fp64_neg_zero" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_neg'_zero\")"
      and (OCaml) "!(failwith \"fp64'_neg'_zero\")"
      and (Haskell) "!(error \"fp64'_neg'_zero\")"
  | constant "fp64_negate" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp64'_negate\")"
      and (OCaml) "!(fun '_ -> failwith \"fp64'_negate\")"
      and (Haskell) "!(\\ '_ -> error \"fp64'_negate\")"
  | constant "fp64_pos_inf" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_pos'_inf\")"
      and (OCaml) "!(failwith \"fp64'_pos'_inf\")"
      and (Haskell) "!(error \"fp64'_pos'_inf\")"
  | constant "fp64_pos_zero" \<rightharpoonup>
      (SML) "!(raise Fail \"fp64'_pos'_zero\")"
      and (OCaml) "!(failwith \"fp64'_pos'_zero\")"
      and (Haskell) "!(error \"fp64'_pos'_zero\")"
  | constant "fp64_sqrt" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_sqrt\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_sqrt\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_sqrt\")"
  | constant "fp64_sub" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => fn '_ => raise Fail \"fp64'_sub\")"
      and (OCaml) "!(fun '_ '_ '_ -> failwith \"fp64'_sub\")"
      and (Haskell) "!(\\ '_ '_ '_ -> error \"fp64'_sub\")"
  | constant "fp64_to_int" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_to'_int\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_to'_int\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_to'_int\")"
  | constant "fp32_to_fp64" \<rightharpoonup>
      (SML) "!(fn '_ => raise Fail \"fp32'_to'_fp64\")"
      and (OCaml) "!(fun '_ -> failwith \"fp32'_to'_fp64\")"
      and (Haskell) "!(\\ '_ -> error \"fp32'_to'_fp64\")"
  | constant "fp64_to_fp32" \<rightharpoonup>
      (SML) "!(fn '_ => fn '_ => raise Fail \"fp64'_to'_fp32\")"
      and (OCaml) "!(fun '_ '_ -> failwith \"fp64'_to'_fp32\")"
      and (Haskell) "!(\\ '_ '_ -> error \"fp64'_to'_fp32\")"

end


theory Typeclass_Hierarchy
imports Setup
begin

section \<open>Introduction\<close>

text \<open>
  The {Isabelle/HOL} type-class hierarchy entered the stage
  in a quite ancient era -- first related \<^emph>\<open>NEWS\<close> entries date
  back to release {Isabelle99-1}.  Since then, there have been
  ongoing modifications and additions, leading to ({Isabelle2016})
  more than 180 type-classes.  This sheer complexity makes access
  and understanding of that type-class hierarchy difficult and
  involved, let alone maintenance.

  The purpose of this primer is to shed some light on this,
  not only on the mere ingredients, but also on the design
  principles which have evolved and proven useful over time.
\<close>

section \<open>Foundations\<close>

subsection \<open>Locales and type classes\<close>

text \<open>
  Some familiarity with the Isabelle module system is assumed:
  defining locales and type-classes, interpreting locales and
  instantiating type-classes, adding relationships between
  locales (@{command sublocale}) and type-classes
  (@{command subclass}).  Handy introductions are the
  respective tutorials \cite{isabelle-locale}
  \cite{isabelle-classes}.
\<close>

subsection \<open>Strengths and restrictions of type classes\<close>

text \<open>
  The primary motivation for using type classes in {Isabelle/HOL}
  always have been numerical types, which form an inclusion chain:

  \begin{center}
    @{typ nat} @{text \<sqsubset>} @{typ int} @{text \<sqsubset>} @{typ rat}
      @{text \<sqsubset>} @{typ real} @{text \<sqsubset>} @{typ complex}
  \end{center}

  \noindent The inclusion @{text \<sqsubset>} means that any value of the numerical
  type to the left hand side mathematically can be transferred
  to the numerical type on the right hand side.

  How to accomplish this given the quite restrictive type system
  of {Isabelle/HOL}?  Paulson \cite{paulson-numerical} explains
  that each numerical type has some characteristic properties
  which define an characteristic algebraic structure;  @{text \<sqsubset>}
  then corresponds to specialization of the corresponding
  characteristic algebraic structures.  These algebraic structures
  are expressed using algebraic type classes and embeddings
  of numerical types into them:

  \begin{center}\begin{tabular}{lccc}
    @{term of_nat} @{text "::"}  & @{typ nat}  & @{text \<Rightarrow>} & @{typ [source] "'a::semiring_1"} \\
                                 & @{text \<sqinter>}   &            & @{text \<up>} \\
    @{term of_int} @{text "::"}  & @{typ int}  & @{text \<Rightarrow>} & @{typ [source] "'a::ring_1"} \\
                                 & @{text \<sqinter>}   &            & @{text \<up>} \\
    @{term of_rat} @{text "::"}  & @{typ rat}  & @{text \<Rightarrow>} & @{typ [source] "'a::field_char_0"} \\
                                 & @{text \<sqinter>}   &            & @{text \<up>} \\
    @{term of_real} @{text "::"} & @{typ real} & @{text \<Rightarrow>} & @{typ [source] "'a::real_algebra_1"} \\
                                 & @{text \<sqinter>} \\
                                 & @{typ complex}
  \end{tabular}\end{center}

  \noindent @{text "d \<leftarrow> c"} means that @{text c} is subclass of @{text d}.
  Hence each characteristic embedding @{text of_num} can transform
  any value of type @{text num} to any numerical type further
  up in the inclusion chain.

  This canonical example exhibits key strengths of type classes:

    \<^item> Sharing of operations and facts among different
      types, hence also sharing of notation and names: there
      is only one plus operation using infix syntax @{text "+"},
      only one zero written @{text 0}, and neutrality
      (@{thm (frugal_sorts) add_0_left [all, no_vars]} and
      @{thm (frugal_sorts) add_0_right [all, no_vars]})
      is referred to
      uniformly by names @{fact add_0_left} and @{fact add_0_right}.

    \<^item> Proof tool setups are shared implicitly:
      @{fact add_0} and @{fact add_0_right} are simplification
      rules by default.

    \<^item> Hence existing proofs about particular numerical
      types are often easy to generalize to algebraic structures,
      given that they do not depend on specific properties of
      those numerical types.

  Considerable restrictions include:

    \<^item> Type class operations are restricted to one
      type parameter; this is insufficient e.g. for expressing
      a unified power operation adequately (see \secref{sec:power}).

    \<^item> Parameters are fixed over the whole type class
      hierarchy and cannot be refined in specific situations:
      think of integral domains with a predicate @{term is_unit};
      for natural numbers, this degenerates to the much simpler
      @{term [source] "HOL.equal (1::nat)"} but facts
      refer to @{term is_unit} nonetheless.

    \<^item> Type classes are not apt for meta-theory.  There
      is no practically usable way to express that the units
      of an integral domain form a multiplicative group using
      type classes.  But see session @{text "HOL-Algebra"}
      which provides locales with an explicit carrier.
\<close>

subsection \<open>Navigating the hierarchy\<close>

text \<open>
  An indispensable tool to inspect the class hierarchy is
  @{command class_deps} which displays the graph of classes,
  optionally showing the logical content for each class also.
  Optional parameters restrict the graph to a particular segment
  which is useful to get a graspable view.  See
  the Isar reference manual \cite{isabelle-isar-ref} for details.
\<close>

section \<open>The hierarchy\<close>

subsection \<open>Syntactic type classes \label{sec:syntactic-type-class}\<close>

text \<open>
  At the top of the hierarchy there are a couple of syntactic type
  classes, ie. classes with operations but with no axioms,
  most notably:

    \<^item> @{command class} @{class plus} with @{term [source] "(a::'a::plus) + b"}

    \<^item> @{command class} @{class zero} with @{term [source] "0::'a::zero"}

    \<^item> @{command class} @{class times} with @{term [source] "(a::'a::times) * b"}

    \<^item> @{command class} @{class one} with @{term [source] "1::'a::one"}

  \noindent Before the introduction of the @{command class} statement in
  Isabelle \cite{Haftmann-Wenzel:2006:classes} it was impossible
  to define operations with associated axioms in the same class,
  hence there were always pairs of syntactic and logical type
  classes.  This restriction is lifted nowadays, but there are
  still reasons to maintain syntactic type classes:

    \<^item> Syntactic type classes allow generic notation to be used
      regardless of a particular logical interpretation; e.g.
      although multiplication @{text "*"} is usually associative,
      there are examples where it is not (e.g. octonions), and
      leaving @{text "*"} without axioms allows to re-use this
      syntax by means of type class instantiation also for such
      exotic examples.

    \<^item> Type classes might share operations but not necessarily
      axioms on them, e.g. @{term gcd} (see \secref{sec:gcd}).
      Hence their common base is a syntactic type class.

  \noindent However syntactic type classes should only be used with striking
  cause.  Otherwise there is risk for confusion if the notation
  suggests properties which do not hold without particular
  constraints.  This can be illustrated using numerals
  (see \secref{sec:numerals}):  @{lemma "2 + 2 = 4" by simp} is
  provable without further ado, and this also meets the typical
  expectation towards a numeral notation;  in more ancient releases
  numerals were purely syntactic and @{prop "2 + 2 = 4"} was
  not provable without particular type constraints.
\<close>

subsection \<open>Additive and multiplicative semigroups and monoids\<close>

text \<open>
  In common literature, notation for semigroups and monoids
  is either multiplicative @{text "(*, 1)"} or additive
  @{text "(+, 0)"} with underlying properties isomorphic.
  In {Isabelle/HOL}, this is accomplished using the following
  abstract setup:

    \<^item> A @{locale semigroup} introduces an abstract binary
      associative operation.

    \<^item> A @{locale monoid} is an extension of @{locale semigroup}
      with a neutral element.

    \<^item> Both @{locale semigroup} and @{locale monoid} provide
      dedicated syntax for their operations @{text "(\<^bold>*, \<^bold>1)"}.
      This syntax is not visible on the global theory level
      but only for abstract reasoning inside the respective
      locale.

    \<^item> Concrete global syntax is added building on existing
      syntactic type classes \secref{sec:syntactic-type-class}
      using the following classes:

        \<^item> @{command class} @{class semigroup_mult} = @{class times}

        \<^item> @{command class} @{class monoid_mult} = @{class one} + @{class semigroup_mult}

        \<^item> @{command class} @{class semigroup_add} = @{class plus}

        \<^item> @{command class} @{class monoid_add} = @{class zero} + @{class semigroup_add}

      Locales @{locale semigroup} and @{locale monoid} are
      interpreted (using @{command sublocale}) into their
      corresponding type classes, with prefixes @{text add}
      and @{text mult}; hence facts derived in @{locale semigroup}
      and @{locale monoid} are propagated simultaneously to
      \<^emph>\<open>both\<close> using a consistent naming policy, ie.

        \<^item> @{fact semigroup.assoc}: @{thm (frugal_sorts) semigroup.assoc [all, no_vars]}

        \<^item> @{fact mult.assoc}: @{thm (frugal_sorts) mult.assoc [all, no_vars]}

        \<^item> @{fact add.assoc}: @{thm (frugal_sorts) add.assoc [all, no_vars]}

        \<^item> @{fact monoid.right_neutral}: @{thm (frugal_sorts) monoid.right_neutral [all, no_vars]}

        \<^item> @{fact mult.right_neutral}: @{thm (frugal_sorts) mult.right_neutral [all, no_vars]}

        \<^item> @{fact add.right_neutral}: @{thm (frugal_sorts) add.right_neutral [all, no_vars]}

    \<^item> Note that the syntax in @{locale semigroup} and @{locale monoid}
      is bold; this avoids clashes when writing properties
      inside one of these locales in presence of that global
      concrete type class syntax.

  \noindent That hierarchy extends in a straightforward manner
  to abelian semigroups and commutative monoids\footnote{The
  designation \<^emph>\<open>abelian\<close> is quite standard concerning
  (semi)groups, but not for monoids}:

    \<^item> Locales @{locale abel_semigroup} and @{locale comm_monoid}
      add commutativity as property.

    \<^item> Concrete syntax emerges through

        \<^item> @{command class} @{class ab_semigroup_add} = @{class semigroup_add}

        \<^item> @{command class} @{class ab_semigroup_mult} = @{class semigroup_mult}

        \<^item> @{command class} @{class comm_monoid_add} = @{class zero} + @{class ab_semigroup_add}

        \<^item> @{command class} @{class comm_monoid_mult} = @{class one} + @{class ab_semigroup_mult}

      and corresponding interpretation of the locales above, yielding

        \<^item> @{fact abel_semigroup.commute}: @{thm (frugal_sorts) abel_semigroup.commute [all, no_vars]}

        \<^item> @{fact mult.commute}: @{thm (frugal_sorts) mult.commute [all, no_vars]}

        \<^item> @{fact add.commute}: @{thm (frugal_sorts) add.commute [all, no_vars]}
\<close>

paragraph \<open>Named collection of theorems\<close>

text \<open>
  Locale interpretation interacts smoothly with named collections of
  theorems as introduced by command @{command named_theorems}.  In our
  example, rules concerning associativity and commutativity are no
  simplification rules by default since they desired orientation may
  vary depending on the situation.  However, there is a collection
  @{fact ac_simps} where facts @{fact abel_semigroup.assoc},
  @{fact abel_semigroup.commute} and @{fact abel_semigroup.left_commute}
  are declared as members.  Due to interpretation, also
  @{fact mult.assoc}, @{fact mult.commute} and @{fact mult.left_commute}
  are also members of @{fact ac_simps}, as any corresponding facts
  stemming from interpretation of @{locale abel_semigroup}.
  Hence adding @{fact ac_simps} to the simplification rules for
  a single method call uses all associativity and commutativity
  rules known by means of interpretation.
\<close>

subsection \<open>Additive and multiplicative groups\<close>

text \<open>
  The hierarchy for inverse group operations takes into account
  that there are weaker algebraic structures with only a partially
  inverse operation.  E. g. the natural numbers have bounded
  subtraction @{term "m - (n::nat)"} which is only an inverse
  operation if @{term "m \<ge> (n::nat)"};  unary minus @{text "-"}
  is pointless on the natural numbers.

  Hence for both additive and multiplicative notation there
  are syntactic classes for inverse operations, both unary
  and binary:

    \<^item> @{command class} @{class minus} with @{term [source] "(a::'a::minus) - b"}

    \<^item> @{command class} @{class uminus} with @{term [source] "- a::'a::uminus"}

    \<^item> @{command class} @{class divide} with @{term [source] "(a::'a::divide) div b"}

    \<^item> @{command class} @{class inverse} = @{class divide} with @{term [source] "inverse a::'a::inverse"}
        \\ and @{term [source] "(a::'a::inverse) / b"}

  \noindent Here @{class inverse} specializes the ``partial'' syntax
  @{term [source] "a div b"} to the more specific
  @{term [source] "a / b"}.

  Semantic properties are added by

    \<^item> @{command class} @{class cancel_ab_semigroup_add} = @{class ab_semigroup_add} + @{class minus}

    \<^item> @{command class} @{class cancel_comm_monoid_add} = @{class cancel_ab_semigroup_add} + @{class comm_monoid_add}

  \noindent which specify a minimal binary partially inverse operation as

    \<^item> @{fact add_diff_cancel_left'}: @{thm (frugal_sorts) add_diff_cancel_left' [all, no_vars]}

    \<^item> @{fact diff_diff_add}: @{thm (frugal_sorts) diff_diff_add [all, no_vars]}

  \noindent which in turn allow to derive facts like

    \<^item> @{fact add_left_imp_eq}: @{thm (frugal_sorts) add_left_imp_eq [all, no_vars]}

  \noindent The total inverse operation is established as follows:

    \<^item> Locale @{locale group} extends the abstract hierarchy with
      the inverse operation.

    \<^item> The concrete additive inverse operation emerges through

      \<^item> @{command class} @{class group_add} = @{class minus} + @{class uminus} + @{class monoid_add} (in @{theory Groups}) \\

      \<^item> @{command class} @{class ab_group_add} = @{class minus} + @{class uminus} + @{class comm_monoid_add} (in @{theory Groups})

      and corresponding interpretation of locale @{locale group}, yielding e.g.

      \<^item> @{fact group.left_inverse}: @{thm (frugal_sorts) group.left_inverse [all, no_vars]}

      \<^item> @{fact add.left_inverse}: @{thm (frugal_sorts) add.left_inverse [all, no_vars]}

  \noindent There is no multiplicative counterpart.  Why?  In rings,
  the multiplicative group excludes the zero element, hence
  the inverse operation is not total.  See further \secref{sec:rings}.
\<close>

paragraph \<open>Mitigating against redundancy by default simplification rules\<close>

text \<open>
  Inverse operations imposes some redundancy on the type class
  hierarchy: in a group with a total inverse operation, the
  unary operation is simpler and more primitive than the binary
  one; but we cannot eliminate the binary one in favour of
  a mere syntactic abbreviation since the binary one is vital
  to express a partial inverse operation.

  This is mitigated by providing suitable default simplification
  rules: expression involving the unary inverse operation are
  simplified to binary inverse operation whenever appropriate.
  The rationale is that simplification is a central device in
  explorative proving, where proof obligation remaining after certain
  default proof steps including simplification are inspected
  to get an idea what is missing to finish a proof.  When
  preferable normal forms are encoded into
  default simplification rules, proof obligations after simplification
  are normalized and hence more proof-friendly.
\<close>

end


section \<open>Implementation of Heaps by Arrays\<close>
theory IICF_Impl_Heapmap
imports
  IICF_Abs_Heapmap
  "../IICF_Array"
  "../IICF_Array_List"
  "../IICF_Indexed_Array_List"
begin

  term hfref

  find_theorems INTF_OF_REL

  lemma intf_of_b_rel[synth_rules]: "INTF_OF_REL R I \<Longrightarrow> INTF_OF_REL (b_rel R P) I" by simp

  lemma b_assn_intf[intf_of_assn]: "intf_of_assn V I \<Longrightarrow> intf_of_assn (b_assn V P) I"
    by simp

  (* TODO: Move *)
  lemma mk_free_b_assn[sepref_frame_free_rules]:
    assumes "MK_FREE A f"
    shows "MK_FREE (b_assn A P) f"
  proof -
    note [vcg_rules] = assms[THEN MK_FREED]
    show ?thesis by rule vcg
  qed

  (* TODO: Move *)

  (*
  type_synonym 'a iam1 = "'a list"

  definition iam1_rel :: "nat \<Rightarrow> ('a iam1 \<times> (nat\<rightharpoonup>'a)) set"
    where "iam1_rel N \<equiv> br (\<lambda>xs i. if i<length xs then Some (xs!i) else None) (\<lambda>xs. length xs = N)"

  definition iam1_init :: "nat \<Rightarrow> 'a \<Rightarrow> 'a iam1 nres" where "iam1_init N v \<equiv> RETURN (replicate N v)"
  definition iam1_lookup :: "nat \<Rightarrow> 'a iam1 \<Rightarrow> 'a nres"
    where "iam1_lookup k m \<equiv> mop_list_get m k"

  definition iam1_update :: "nat \<Rightarrow> 'a \<Rightarrow> 'a iam1 \<Rightarrow> 'a iam1 nres"
    where "iam1_update k v m \<equiv> mop_list_set m k v"

  (*definition abs_iam_empty :: "nat \<Rightarrow> (nat \<rightharpoonup> 'a) nres"
    where "abs_iam_empty (N::nat) \<equiv> RETURN Map.empty"
  *)

  sepref_decl_op iam_init: "\<lambda>(N::nat) (v::'a). \<lambda>k. if k<N then Some v else None" :: "nat_rel \<rightarrow> V \<rightarrow> \<langle>nat_rel,V\<rangle> map_rel"
    apply (rule frefI)
    apply parametricity
    by (auto simp: map_rel_def)

  lemma iam1_empty_refine: "(uncurry iam1_init,uncurry mop_iam_init)
    \<in> [\<lambda>(N',v). N'=N]\<^sub>f nat_rel \<times>\<^sub>r Id \<rightarrow> \<langle>iam1_rel N\<rangle>nres_rel"
    unfolding iam1_init_def
    by (auto intro!: frefI nres_relI simp: iam1_rel_def in_br_conv fun_eq_iff)

  lemma iam1_lookup_refine:
    "(iam1_lookup, mop_map_the_lookup) \<in> nbn_rel N \<rightarrow> iam1_rel N \<rightarrow> \<langle>Id\<rangle>nres_rel"
    unfolding iam1_lookup_def
    apply (refine_vcg frefI)
    by (auto simp: iam1_rel_def in_br_conv)

  lemma iam1_update_refine:
    "(iam1_update, mop_map_update)
      \<in> nbn_rel N \<rightarrow>Id \<rightarrow> iam1_rel N \<rightarrow> \<langle>iam1_rel N\<rangle>nres_rel"
    unfolding iam1_update_def
    apply (refine_vcg frefI)
    by (auto simp: iam1_rel_def in_br_conv fun_eq_iff)

  context
    fixes L :: "'l::len2 itself"
    (*notes [fcomp_norm_unfold] = snatb_rel_def[symmetric]*)
  begin

    private abbreviation (input) "iam2_assn \<equiv> array_assn id_assn"

    definition "iam_assn N V \<equiv> hr_comp
      (hr_comp iam2_assn (iam1_rel N))
      (\<langle>nat_rel, the_pure V\<rangle>map_rel)"
    lemmas [fcomp_norm_unfold] = iam_assn_def[symmetric]

    lemma iam_assn_intf[intf_of_assn]: "intf_of_assn V TYPE('v) \<Longrightarrow> intf_of_assn (iam_assn N V) (TYPE((nat,'v)i_map))"
      by simp

    sepref_definition iam_init_impl is "uncurry iam1_init"
      :: "(snat_assn' TYPE('l))\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a iam2_assn"
      unfolding iam1_init_def
      apply (subst array_fold_custom_replicate)
      by sepref
    sepref_decl_impl (ismop) iam_init_impl.refine[FCOMP iam1_empty_refine] by auto

    sepref_definition iam_lookup_impl is "uncurry iam1_lookup"
      :: "(snat_assn' TYPE('l))\<^sup>k *\<^sub>a iam2_assn\<^sup>k \<rightarrow>\<^sub>a id_assn"
      unfolding iam1_lookup_def
      by sepref
    sepref_decl_impl (ismop) iam_lookup_impl.refine[FCOMP iam1_lookup_refine]
      uses mop_map_the_lookup.fref[where K=Id] .

    sepref_definition iam_update_impl is "uncurry2 iam1_update"
      :: "(snat_assn' TYPE('l))\<^sup>k *\<^sub>a id_assn\<^sup>k *\<^sub>a iam2_assn\<^sup>d \<rightarrow>\<^sub>a iam2_assn"
      unfolding iam1_update_def
      by sepref
    sepref_decl_impl (ismop) iam_update_impl.refine[FCOMP iam1_update_refine]
      uses mop_map_update.fref[where K=Id] .

  end

  *)

  type_synonym 'a iam1 = "'a list"

  definition iam1_rel :: "nat \<Rightarrow> ('a iam1 \<times> (nat\<rightharpoonup>'a)) set"
    where "iam1_rel N \<equiv> {(xs,m). length xs = N \<and> dom m \<subseteq> {0..<N} \<and> (\<forall>k v. m k = Some v \<longrightarrow> v=xs!k)}"

  definition iam1_init :: "nat \<Rightarrow> 'a::llvm_rep iam1 nres" where "iam1_init N \<equiv> RETURN (replicate N init)"
  definition iam1_lookup :: "nat \<Rightarrow> 'a iam1 \<Rightarrow> 'a nres"
    where "iam1_lookup k m \<equiv> mop_list_get m k"

  definition iam1_update :: "nat \<Rightarrow> 'a \<Rightarrow> 'a iam1 \<Rightarrow> 'a iam1 nres"
    where "iam1_update k v m \<equiv> mop_list_set m k v"

  sepref_decl_op iam_empty: "\<lambda>(N::nat). Map.empty :: nat \<rightharpoonup> _" :: "nat_rel \<rightarrow> \<langle>nat_rel,V\<rangle> map_rel" .

  lemma iam_fold_custom_empty:
    "op_map_empty = op_iam_empty N"
    "Map.empty = op_iam_empty N"
    "mop_map_empty = mop_iam_empty N"
    by auto

  lemma iam1_empty_refine: "(iam1_init,mop_iam_empty)
    \<in> [\<lambda>N'. N'=N]\<^sub>f nat_rel \<rightarrow> \<langle>iam1_rel N\<rangle>nres_rel"
    unfolding iam1_init_def
    by (auto intro!: frefI nres_relI simp: iam1_rel_def in_br_conv fun_eq_iff)

  lemma iam1_lookup_refine:
    "(iam1_lookup, mop_map_the_lookup) \<in> nbn_rel N \<rightarrow> iam1_rel N \<rightarrow> \<langle>Id\<rangle>nres_rel"
    apply (clarsimp simp: iam1_lookup_def)
    apply (refine_vcg)
    apply (auto simp: iam1_rel_def in_br_conv)
    done

  lemma iam1_update_refine:
    "(iam1_update, mop_map_update)
      \<in> nbn_rel N \<rightarrow>Id \<rightarrow> iam1_rel N \<rightarrow> \<langle>iam1_rel N\<rangle>nres_rel"
    unfolding iam1_update_def
    apply (refine_vcg frefI)
    by (auto simp: iam1_rel_def in_br_conv fun_eq_iff)

  context
    fixes L :: "'l::len2 itself"
    (*notes [fcomp_norm_unfold] = snatb_rel_def[symmetric]*)
  begin

    private abbreviation (input) "iam2_assn \<equiv> array_assn id_assn"

    definition "iam_assn N V \<equiv> hr_comp
      (hr_comp iam2_assn (iam1_rel N))
      (\<langle>nat_rel, the_pure V\<rangle>map_rel)"
    lemmas [fcomp_norm_unfold] = iam_assn_def[symmetric]

    lemma iam_assn_intf[intf_of_assn]: "intf_of_assn V TYPE('v) \<Longrightarrow> intf_of_assn (iam_assn N V) (TYPE((nat,'v)i_map))"
      by simp

    sepref_definition iam_init_impl [llvm_inline] is "iam1_init"
      :: "(snat_assn' TYPE('l))\<^sup>k \<rightarrow>\<^sub>a iam2_assn"
      unfolding iam1_init_def
      supply [sepref_import_param] = IdI[of init]
      apply (subst array_fold_custom_replicate)
      by sepref

    sepref_decl_impl (ismop,no_register) iam_empty: iam_init_impl.refine[FCOMP iam1_empty_refine] by auto

    sepref_definition iam_lookup_impl [llvm_inline] is "uncurry iam1_lookup"
      :: "(snat_assn' TYPE('l))\<^sup>k *\<^sub>a iam2_assn\<^sup>k \<rightarrow>\<^sub>a id_assn"
      unfolding iam1_lookup_def
      by sepref
    sepref_decl_impl (ismop) iam_lookup_impl.refine[FCOMP iam1_lookup_refine]
      uses mop_map_the_lookup.fref[where K=Id] .

    sepref_definition iam_update_impl [llvm_inline] is "uncurry2 iam1_update"
      :: "(snat_assn' TYPE('l))\<^sup>k *\<^sub>a id_assn\<^sup>k *\<^sub>a iam2_assn\<^sup>d \<rightarrow>\<^sub>a iam2_assn"
      unfolding iam1_update_def
      by sepref
    sepref_decl_impl (ismop) iam_update_impl.refine[FCOMP iam1_update_refine]
      uses mop_map_update.fref[where K=Id] .

  end

            find_theorems "?x[_:=_] = ?x"

  type_synonym ('v) iam = "'v ptr"

  schematic_goal [sepref_frame_free_rules]: "MK_FREE (iam_assn N V) (?fr)"
    unfolding iam_assn_def
    by sepref_dbg_side

  xxx, ctd here: Explicit parameterization on N. Use dependent relation for constructors!

  locale hm_impl = hmstruct prio for prio :: "'e \<Rightarrow> 'p::linorder" +
    fixes prio_assn :: "'p \<Rightarrow> 'pi::llvm_rep \<Rightarrow> assn"
      and elem_assn :: "'e \<Rightarrow> 'ei::llvm_rep \<Rightarrow> assn"
      and prio_impl le_prio_impl lt_prio_impl
      and ltype :: "'l::len2 itself"
    assumes prio_is_pure[safe_constraint_rules]: "is_pure prio_assn"
    assumes elem_is_pure[safe_constraint_rules]: "is_pure elem_assn"
    assumes prio_impl_refine[sepref_fr_rules]: "(prio_impl, RETURN o prio)\<in>elem_assn\<^sup>k \<rightarrow>\<^sub>a prio_assn"
    assumes le_prio_impl_refine[sepref_fr_rules]:
      "(uncurry le_prio_impl, uncurry (RETURN oo (\<le>))) \<in> prio_assn\<^sup>k *\<^sub>a prio_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
    assumes lt_prio_impl_refine[sepref_fr_rules]:
      "(uncurry lt_prio_impl, uncurry (RETURN oo (<))) \<in> prio_assn\<^sup>k *\<^sub>a prio_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"

    fixes N :: nat
    (*
    fixes N :: nat (*defines "N\<equiv>LENGTH('l)"*)
    assumes N_bound: "N<max_snat LENGTH('l)"
    assumes L_bound: "4<LENGTH('l)"
    *)
    (*assumes N_def: "N = LENGTH ('l)"*)
    (*assumes l_len[simp,arith]: "4 < LENGTH('l)"*)
  begin

    abbreviation "idx_assn \<equiv> snatb_assn' TYPE('l) N"
    abbreviation "idx1_assn \<equiv> snatb_assn' TYPE('l) (Suc N)"

    sepref_register prio

    sepref_register "(\<le>) :: 'p \<Rightarrow> 'p \<Rightarrow> bool"
    sepref_register "(<) :: 'p \<Rightarrow> 'p \<Rightarrow> bool"

    lemma l_len_bound[simp,arith]: "4<LENGTH('l) \<Longrightarrow> 16 \<le> max_snat LENGTH('l)"
      unfolding max_snat_def
    proof -
      assume "4<LENGTH('l)"
      hence "4\<le>LENGTH('l)-1" by simp
      hence "(2::nat)^4 \<le> 2^(LENGTH('l)-1)"
        by (rule power_increasing) auto
      thus "(16::nat) \<le> 2^(LENGTH('l)-1)" by auto
    qed

    lemmas [sepref_frame_free_rules] =
      mk_free_is_pure[OF prio_is_pure]
      mk_free_is_pure[OF elem_is_pure]

    definition "hm2_assn \<equiv> b_assn (ial_assn' TYPE('l) N \<times>\<^sub>a iam_assn N elem_assn) (\<lambda>_. 4<LENGTH('l) \<and> N<max_snat LENGTH('l))"

    lemma hm2_assn_rdomp_boundsI: "rdomp hm2_assn (ag, bq) \<Longrightarrow> 4<LENGTH('l) \<and> N<max_snat LENGTH('l)"
      unfolding hm2_assn_def by auto

    find_theorems iam_assn

    sepref_definition hm_append_impl is "uncurry2 hm_append_op"
      :: "hm2_assn\<^sup>d*\<^sub>aidx_assn\<^sup>k*\<^sub>aelem_assn\<^sup>k \<rightarrow>\<^sub>a hm2_assn"
      apply (rule hfref_with_rdomI)
      unfolding hm_append_op_def hm2_assn_def
      by sepref

    lemmas [sepref_fr_rules] = hm_append_impl.refine

    sepref_definition hm_length_impl is "RETURN o hm_length" :: "hm2_assn\<^sup>k \<rightarrow>\<^sub>a snatb_assn' TYPE('l) (N+1)"
      apply (rule hfref_with_rdomI)
      unfolding hm_length_def hm2_assn_def
      by sepref

    lemmas [sepref_fr_rules] = hm_length_impl.refine

    term hm2_assn
    sepref_register hm_key_of_op
    sepref_definition hm_key_of_impl is "uncurry hm_key_of_op" :: "hm2_assn\<^sup>k *\<^sub>a idx1_assn\<^sup>d \<rightarrow>\<^sub>a idx_assn"
      apply (rule hfref_with_rdomI)
      unfolding hm_key_of_op_def hm2_assn_def
      apply (annot_snat_const "TYPE('l)")
      by sepref
    lemmas [sepref_fr_rules] = hm_key_of_impl.refine

    (* Optimization *)
    definition "hm_the_lookup_op' k hm \<equiv> do {
      let (pq,ml) = hm;
      (*ASSERT (heapmap_\<alpha> (hm_impl1_\<alpha> hm) k \<noteq> None \<and> hm_impl1_invar hm);*)
      v \<leftarrow> mop_map_the_lookup k ml;
      RETURN v
    }"
    lemma hm_the_lookup_op'_refine:
      "(hm_the_lookup_op', hm_the_lookup_op) \<in> nat_rel \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding hm_the_lookup_op'_def hm_the_lookup_op_def
      apply refine_vcg
      apply (auto)
      apply (auto simp: heapmap_\<alpha>_def hmr_invar_def restrict_map_def split: if_split_asm)
      done

    sepref_definition hm_the_lookup_impl is "uncurry hm_the_lookup_op'" :: "idx_assn\<^sup>k*\<^sub>ahm2_assn\<^sup>k \<rightarrow>\<^sub>a elem_assn"
      apply (rule hfref_with_rdomI)
      unfolding hm_the_lookup_op'_def hm2_assn_def Let_def
      by sepref
    lemmas hm_the_lookup_impl_refine[sepref_fr_rules]
      = hm_the_lookup_impl.refine[FCOMP hm_the_lookup_op'_refine]

    sepref_definition hm_val_of_impl is "uncurry hm_val_of_op" :: "hm2_assn\<^sup>k*\<^sub>aidx1_assn\<^sup>k \<rightarrow>\<^sub>a elem_assn"
      unfolding hm_val_of_op_def
      by sepref
    lemmas [sepref_fr_rules] = hm_val_of_impl.refine

    sepref_register hm_prio_of_op
    sepref_definition hm_prio_of_impl is "uncurry (PR_CONST hm_prio_of_op)" :: "hm2_assn\<^sup>k*\<^sub>aidx1_assn\<^sup>k \<rightarrow>\<^sub>a prio_assn"
      unfolding hm_prio_of_op_def PR_CONST_def
      by sepref
    lemmas [sepref_fr_rules] = hm_prio_of_impl.refine

    definition "parent_valid h i \<equiv> hm_valid h (h.parent i)"
    definition "parent_valid' h i \<equiv> i>(1::nat)"

    lemma valid_parent_pat[def_pat_rules]: "hm_valid$h$(h.parent$i) \<equiv> parent_valid$h$i"
      unfolding parent_valid_def autoref_tag_defs by simp

    lemma parent_valid'_refine: "(uncurry parent_valid',uncurry parent_valid) \<in> [\<lambda>(h,i). hm_valid h i]\<^sub>f Id\<times>\<^sub>rId\<rightarrow>Id"
      apply rule
      unfolding hm_valid_def parent_valid_def parent_valid'_def hm_length_def h.parent_def
      by auto

    sepref_definition parent_valid_impl is "uncurry (RETURN oo parent_valid')" :: "hm2_assn\<^sup>k*\<^sub>aidx1_assn\<^sup>d \<rightarrow>\<^sub>a bool1_assn"
      unfolding parent_valid'_def
      apply (annot_snat_const "TYPE('l)")
      by sepref
    lemmas [sepref_fr_rules] = parent_valid_impl.refine[FCOMP parent_valid'_refine]

    sepref_definition hm_exch_impl is "uncurry2 hm_exch_op" :: "hm2_assn\<^sup>d*\<^sub>aidx1_assn\<^sup>d*\<^sub>aidx1_assn\<^sup>d \<rightarrow>\<^sub>a hm2_assn"
      apply (rule hfref_with_rdomI)
      unfolding hm_exch_op_def hm2_assn_def
      apply (annot_snat_const "TYPE('l)")
      supply [simp] = hm_valid_def
      by sepref
    lemmas [sepref_fr_rules] = hm_exch_impl.refine

    (* TODO: Move *)
    lemma hfref_bassn_resI:
      assumes "\<And>xs. \<lbrakk>rdomp (fst As) xs; C xs\<rbrakk> \<Longrightarrow> a xs \<le>\<^sub>n SPEC P"
      assumes "(c,a)\<in>[C]\<^sub>a As \<rightarrow> R"
      shows "(c,a)\<in>[C]\<^sub>a As \<rightarrow> b_assn R P"
      apply rule
      apply (rule hn_refine_preI)
      apply (rule hn_refine_cons[rotated])
      apply (rule hn_refine_augment_res)
      apply (rule assms(2)[to_hnr, unfolded hn_ctxt_def autoref_tag_defs])
      apply simp
      apply (rule assms(1))
      apply (auto simp: rdomp_def sep_algebra_simps)
      done

    sepref_definition parent_impl is "RETURN o h.parent" :: "[\<lambda>_. 4<LENGTH('l)]\<^sub>aidx1_assn\<^sup>d \<rightarrow> idx1_assn"
      unfolding h.parent_def
      apply (rule hfref_bassn_resI)
      subgoal by auto
      apply (annot_snat_const "TYPE('l)")
      by sepref

    lemmas [sepref_fr_rules] = parent_impl.refine

    find_theorems hm_swim_op
    sepref_register h.parent hm_exch_op

    (* TODO: Very specialized workaround lemma, to work around invalid-recombination
      problem for case that B is pure. DUP in IICF_Heap_Impl.thy
    *)
    lemma workaround_invalid_recombine_pure3: "is_pure B \<Longrightarrow> hn_ctxt (invalid_assn A \<times>\<^sub>a invalid_assn B) ax px \<turnstile> hn_invalid (A \<times>\<^sub>a B) ax px"
      unfolding hn_ctxt_def invalid_assn_def prod_assn_def entails_def
      by (auto split: prod.split elim!: is_pureE
        simp: sep_algebra_simps pure_part_pure_conj_eq)
      argo

    find_theorems is_pure b_assn

    sepref_register hm_swim_op
    sepref_definition hm_swim_impl is "uncurry (PR_CONST hm_swim_op)" :: "hm2_assn\<^sup>d*\<^sub>aidx1_assn\<^sup>k \<rightarrow>\<^sub>a hm2_assn"
      unfolding hm_swim_op_def PR_CONST_def
      (* TODO: Workaround/Hack *)
      supply X[sepref_frame_match_rules] = workaround_invalid_recombine_pure3[where B="snatb_assn _", simplified]
      supply [simp] = hm2_assn_rdomp_boundsI
      by sepref
    lemmas [sepref_fr_rules] = hm_swim_impl.refine

    sepref_register hm_insert_op
    sepref_definition hm_insert_impl is "uncurry2 (PR_CONST hm_insert_op)"
      :: "idx_assn\<^sup>k*\<^sub>aelem_assn\<^sup>k*\<^sub>ahm2_assn\<^sup>d \<rightarrow>\<^sub>a hm2_assn"
      unfolding hm_insert_op_def PR_CONST_def
      by sepref
    lemmas [sepref_fr_rules] = hm_insert_impl.refine

    lemma rewr_2kleN: "2*k \<le> n \<longleftrightarrow> k \<le> n div 2" for k :: nat by auto

    sepref_definition hm_has_child_impl is "uncurry (RETURN oo hm_has_child_op)" :: "hm2_assn\<^sup>k*\<^sub>aidx1_assn\<^sup>d \<rightarrow>\<^sub>a bool1_assn"
      unfolding hm_has_child_op_def
      apply (rewrite rewr_2kleN)
      supply [simp,dest] = hm2_assn_rdomp_boundsI
      apply (annot_snat_const "TYPE('l)")
      by sepref

    lemmas [sepref_fr_rules] = hm_has_child_impl.refine

    sepref_definition hm_left_child_impl is "RETURN o hm_left_child_op" :: "[\<lambda>i. 2*i\<le>N \<and> N<max_snat LENGTH('l) \<and> 4<LENGTH('l)]\<^sub>a idx1_assn\<^sup>d \<rightarrow> idx1_assn"
      unfolding hm_left_child_op_def
      apply (rule hfref_bassn_resI)
      subgoal by auto
      apply (annot_snat_const "TYPE('l)")
      by sepref
    lemmas [sepref_fr_rules] = hm_left_child_impl.refine

    lemma rewr_kp1len: "k+1 \<le> n \<longleftrightarrow> k<(n::nat)" by auto

    sepref_definition hm_has_next_child_impl is "uncurry (RETURN oo hm_has_next_child_op)" :: "hm2_assn\<^sup>k*\<^sub>aidx1_assn\<^sup>d \<rightarrow>\<^sub>a bool1_assn"
      unfolding hm_has_next_child_op_def
      apply (rewrite rewr_kp1len)
      by sepref
    lemmas [sepref_fr_rules] = hm_has_next_child_impl.refine

    sepref_definition hm_next_child_impl is "RETURN o hm_next_child_op" :: "[\<lambda>i. i<N \<and> N<max_snat LENGTH('l) \<and> 4<LENGTH('l)]\<^sub>a idx1_assn\<^sup>d \<rightarrow> idx1_assn"
      unfolding hm_next_child_op_def
      apply (rule hfref_bassn_resI)
      subgoal by auto
      apply (annot_snat_const "TYPE('l)")
      by sepref
    lemmas [sepref_fr_rules] = hm_next_child_impl.refine

    lemma sink_sepref_aux1: "\<lbrakk> a2' \<le> l div 2; (ae, l) \<in> snat_rel' TYPE('l)\<rbrakk>
       \<Longrightarrow> 2 * a2' < max_snat LENGTH('l)"
       by (simp add: le_less_trans rewr_2kleN snat_rel_imp_less_max_snat)

    (* TODO: Move *)
    lemma rdomp_ial_len: "rdomp (ial_assn N) xs \<Longrightarrow> length xs \<le> N"
      unfolding ial_assn_def
      apply (auto simp: rdomp_hrcomp_conv ial_rel1_def in_br_conv)
      by (metis (full_types) ial_invar.l_len ial_invar_def list_rel_imp_same_length)

    lemma sink_sepref_aux2: "\<lbrakk>hm_has_child_op (ag, bq) a2'; rdomp hm2_assn (ag, bq)\<rbrakk>
       \<Longrightarrow> 2 * a2' \<le> N"
      unfolding hm_has_child_op_def hm2_assn_def hm_length_def
      by (auto dest: rdomp_ial_len)

    lemma sink_sepref_aux3: "\<lbrakk>hm_has_next_child_op (ag, bq) i; rdomp hm2_assn (ag, bq)\<rbrakk> \<Longrightarrow> i<N"
      unfolding hm_has_next_child_op_def hm2_assn_def hm_length_def
      by (auto dest: rdomp_ial_len)

    sepref_register hm_sink_op
    sepref_definition hm_sink_impl is "uncurry (PR_CONST hm_sink_op)" :: "hm2_assn\<^sup>d*\<^sub>aidx1_assn\<^sup>k \<rightarrow>\<^sub>a hm2_assn"
      unfolding hm_sink_op_def PR_CONST_def
      supply [simp] = hm_length_def
      supply [simp] = snat_rel_imp_less_max_snat
        sink_sepref_aux1 sink_sepref_aux2 sink_sepref_aux3
      supply X[sepref_frame_match_rules] = workaround_invalid_recombine_pure3[where B="snatb_assn _", simplified]
      supply [simp,dest] = hm2_assn_rdomp_boundsI
      by sepref
    lemmas [sepref_fr_rules] = hm_sink_impl.refine

    sepref_register hm_repair_op
    sepref_definition hm_repair_impl is "uncurry (PR_CONST hm_repair_op)" :: "hm2_assn\<^sup>d*\<^sub>aidx1_assn\<^sup>k \<rightarrow>\<^sub>a hm2_assn"
      unfolding hm_repair_op_def PR_CONST_def
      by sepref
    lemmas [sepref_fr_rules] = hm_repair_impl.refine

    sepref_definition hm_is_empty_impl is "hm_is_empty_op" :: "hm2_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
      unfolding hm_is_empty_op_def
      apply (annot_snat_const "TYPE('l)")
      by sepref

    (* Cannot do lookup, unless we have option type!
      \<rightarrow> Do contains_key and the_lookup instead!
    sepref_definition hm_lookup_impl is "uncurry hm_lookup" :: "hm2_assn\<^sup>k*\<^sub>aidx_assn\<^sup>k \<rightarrow>\<^sub>a elem_assn"
    *)

    sepref_register hm_contains_key_op
    sepref_definition hm_contains_key_impl is "uncurry (PR_CONST hm_contains_key_op)" :: "idx_assn\<^sup>k *\<^sub>a hm2_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
      apply (rule hfref_with_rdomI)
      unfolding hm_contains_key_op_def hm2_assn_def PR_CONST_def
      by sepref
    lemmas [sepref_fr_rules] = hm_contains_key_impl.refine

    lemma hm_index_impl_aux1: "\<lbrakk>b \<in> set a1'; rdomp (ial_assn N) a1'; N<max_snat LENGTH('l)\<rbrakk>
       \<Longrightarrow> Suc (index a1' b) < max_snat LENGTH('l)"
      by (meson index_less less_trans_Suc rdomp_ial_len)

    sepref_definition hm_index_impl is "uncurry hm_index_op" :: "hm2_assn\<^sup>k*\<^sub>aidx_assn\<^sup>d\<rightarrow>\<^sub>aidx1_assn"
      unfolding hm_index_op_def hm2_assn_def
      apply (rule hfref_bassn_resI)
      subgoal
        apply (clarsimp simp: uncurry_def)
        apply refine_vcg
        by (auto simp: heapmap_\<alpha>_def restrict_map_eq rdomp_ial_len)
      supply [simp] = heapmap_\<alpha>_def restrict_map_eq hm_index_impl_aux1
      apply (rule hfref_with_rdomI)
      apply (annot_snat_const "TYPE('l)")
      by sepref
    lemmas [sepref_fr_rules] = hm_index_impl.refine

    term hm_update_op
    sepref_definition hm_update_impl is "uncurry2 hm_update_op" :: "hm2_assn\<^sup>d*\<^sub>aidx1_assn\<^sup>d*\<^sub>aelem_assn\<^sup>k \<rightarrow>\<^sub>a hm2_assn"
      unfolding hm_update_op_def hm2_assn_def
      apply (rule hfref_with_rdomI)
      supply [simp] = hm_valid_def
      apply (annot_snat_const "TYPE('l)")
      by sepref
    lemmas [sepref_fr_rules] = hm_update_impl.refine

    sepref_register hm_decrease_key_op
    sepref_definition hm_decrease_key_impl is "uncurry2 (PR_CONST hm_decrease_key_op)" :: "idx_assn\<^sup>k *\<^sub>a elem_assn\<^sup>k *\<^sub>a hm2_assn\<^sup>d \<rightarrow>\<^sub>a hm2_assn "
      unfolding hm_decrease_key_op_def PR_CONST_def
      by sepref
    lemmas [sepref_fr_rules] = hm_decrease_key_impl.refine

    sepref_register hm_increase_key_op
    sepref_definition hm_increase_key_impl is "uncurry2 (PR_CONST hm_increase_key_op)" :: "idx_assn\<^sup>k *\<^sub>a elem_assn\<^sup>k *\<^sub>a hm2_assn\<^sup>d \<rightarrow>\<^sub>a hm2_assn "
      unfolding hm_increase_key_op_def PR_CONST_def
      by sepref
    lemmas [sepref_fr_rules] = hm_increase_key_impl.refine

    sepref_register hm_change_key_op
    sepref_definition hm_change_key_impl is "uncurry2 (PR_CONST hm_change_key_op)" :: "idx_assn\<^sup>k *\<^sub>a elem_assn\<^sup>k *\<^sub>a hm2_assn\<^sup>d \<rightarrow>\<^sub>a hm2_assn "
      unfolding hm_change_key_op_def PR_CONST_def
      by sepref
    lemmas [sepref_fr_rules] = hm_change_key_impl.refine

    sepref_register hm_set_op
    sepref_definition hm_set_impl is "uncurry2 (PR_CONST hm_set_op)" :: "idx_assn\<^sup>k*\<^sub>aelem_assn\<^sup>k*\<^sub>ahm2_assn\<^sup>d \<rightarrow>\<^sub>a hm2_assn"
      unfolding hm_set_op_def PR_CONST_def
      by sepref
    lemmas [sepref_fr_rules] = hm_set_impl.refine

    lemma hm_pop_min_impl_aux1:
      "\<lbrakk>hm_valid (pq, m) (Suc 0); rdomp hm2_assn (pq, m)\<rbrakk> \<Longrightarrow> 0<N"
      by (cases pq; auto simp: hm2_assn_def hm_valid_def hm_length_def dest!: rdomp_ial_len)

    sepref_register hm_butlast_op
    sepref_definition hm_butlast_impl is "hm_butlast_op" :: "hm2_assn\<^sup>d \<rightarrow>\<^sub>a hm2_assn"
      unfolding hm_butlast_op_def hm2_assn_def
      apply (rule hfref_with_rdomI)
      apply (annot_snat_const "TYPE('l)")
      by sepref
    lemmas [sepref_fr_rules] = hm_butlast_impl.refine

    sepref_register hm_pop_min_op
    sepref_definition hm_pop_min_impl is "PR_CONST hm_pop_min_op" :: "hm2_assn\<^sup>d \<rightarrow>\<^sub>a (idx_assn \<times>\<^sub>a elem_assn) \<times>\<^sub>a hm2_assn"
      unfolding hm_pop_min_op_def PR_CONST_def
      supply [simp] = hm_pop_min_impl_aux1
      apply (annot_snat_const "TYPE('l)")
      by sepref
    lemmas [sepref_fr_rules] = hm_pop_min_impl.refine

    sepref_register hm_remove_op
    sepref_definition hm_remove_impl is "uncurry (PR_CONST hm_remove_op)" :: "idx_assn\<^sup>k *\<^sub>a hm2_assn\<^sup>d \<rightarrow>\<^sub>a hm2_assn"
      unfolding hm_remove_op_def PR_CONST_def
      (* TODO Hack/Workaround: Prevents b_assn to be degraded when comparing.
        Deeper problem to fix: Do not degrade b_assn, even if operation is on basic assn!
      *)
      apply (rewrite at "if \<hole>\<noteq>_ then _ else _" fold_COPY)
      by sepref
    lemmas [sepref_fr_rules] = hm_remove_impl.refine

    sepref_register hm_peek_min_op
    sepref_definition hm_peek_min_impl is "hm_peek_min_op" :: "hm2_assn\<^sup>k \<rightarrow>\<^sub>a idx_assn\<times>\<^sub>aelem_assn"
      unfolding hm_peek_min_op_def hm_kv_of_op_def
      supply [simp] = hm_pop_min_impl_aux1
      apply (annot_snat_const "TYPE('l)")
      by sepref
    lemmas [sepref_fr_rules] = hm_peek_min_impl.refine

    (* sepref_decl_op hm_empty: "op_map_empty" :: "\<langle>Id,Id\<rangle>map_rel" .*)

    definition [simp]: "mop_hm_empty (NN::nat) \<equiv> mop_map_empty"
    sepref_register "mop_hm_empty N" :: "('a,'b) i_map nres"

    lemma fold_custom_hm_empty:
      "RETURN Map.empty = mop_hm_empty N"
      "mop_map_empty = mop_hm_empty N"
      by auto

    context
      fixes Ni
      assumes NiREF: "(Ni,N)\<in>snat_rel' TYPE('l)"
      assumes BOUND: "4<LENGTH('l)"
      notes [[sepref_register_adhoc N]]
      notes [sepref_import_param] = NiREF
    begin
      lemma hm_empty_impl_aux: "N < max_snat LENGTH('l)"
        using NiREF
        using snat_rel_imp_less_max_snat by blast

      sepref_definition hm_empty_impl is "uncurry0 hm_empty_op" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a hm2_assn"
        unfolding hm_empty_op_def hm_empty_op_def hm2_assn_def
        apply (rule hfref_with_rdomI)
        apply (rewrite iam_fold_custom_empty[where N=N])
        apply (rewrite ial_fold_custom_empty[where N=N])
        supply [sepref_fr_rules] = iam_empty_hnr_mop[where N=N]
        supply [sepref_fr_rules] = ial_empty_hnr[where N=N]
        supply [simp] = hm_empty_impl_aux BOUND
        by sepref
    end

    lemma hm_empty_op_aref': "(hm_empty_op, PR_CONST (mop_hm_empty N))\<in>\<langle>heapmap_rel\<rangle>nres_rel"
      using hm_empty_op_aref by auto

    lemma mop_hm_empty_fref:
      "(uncurry0 (PR_CONST (mop_hm_empty N)), uncurry0 (PR_CONST (mop_hm_empty N)))\<in>unit_rel \<rightarrow>\<^sub>f \<langle>\<langle>Id,Id\<rangle>map_rel\<rangle>nres_rel"
      by (auto intro!: frefI nres_relI)

    (*
    sepref_decl_op hm_empty: "\<lambda>_::nat. op_map_empty" :: "nat_rel \<rightarrow> \<langle>Id,Id\<rangle>map_rel" .
    definition "hm_empty' (NN::nat) \<equiv> hm_empty_op"
    sepref_register hm_empty'

    lemma fold_custom_hm_empty:
      "RETURN Map.empty = mop_hm_empty N"
      "mop_map_empty = mop_hm_empty N"
      by auto

    lemma hm_empty'_aref: "(hm_empty',mop_hm_empty)\<in>nat_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
      unfolding hm_empty'_def mop_hm_empty_def
      using hm_empty_op_aref by auto

      sepref_definition hm_empty_impl is "hm_empty'" :: "[\<lambda>NN. NN=N]\<^sub>a idx_assn\<^sup>k \<rightarrow> hm2_assn"
        unfolding hm_empty'_def hm_empty_op_def hm2_assn_def
        apply (rule hfref_with_rdomI)
        apply (rewrite iam_fold_custom_empty[where N=N])
        apply (rewrite ial_fold_custom_empty[where N=N])
        supply [sepref_fr_rules] = iam_empty_hnr_mop[where N=N]
        supply [sepref_fr_rules] = ial_empty_hnr[where N=N]
        supply [[sepref_register_adhoc N]]
        by sepref

    end
    *)

    definition "hm12_assn \<equiv> hr_comp hm2_assn heapmap_rel"

    context
      notes [fcomp_norm_unfold] = hm12_assn_def[symmetric]
    begin

      lemmas hm_empty_ref12 = hm_empty_impl.refine[FCOMP hm_empty_op_aref']
      lemmas hm_insert_ref12 = hm_insert_impl.refine[unfolded PR_CONST_def, FCOMP hm_insert_op_aref]
      lemmas hm_is_empty_ref12 = hm_is_empty_impl.refine[FCOMP hm_is_empty_op_aref]
      lemmas hm_the_lookup_ref12 = hm_the_lookup_impl_refine[FCOMP hm_the_lookup_op_aref]
      lemmas hm_contains_key_ref12 = hm_contains_key_impl.refine[unfolded PR_CONST_def, FCOMP hm_contains_key_op_aref]
      lemmas hm_decrease_key_ref12 = hm_decrease_key_impl.refine[unfolded PR_CONST_def, FCOMP hm_decrease_key_op_aref]
      lemmas hm_increase_key_ref12 = hm_increase_key_impl.refine[unfolded PR_CONST_def, FCOMP hm_increase_key_op_aref]
      lemmas hm_change_key_ref12 = hm_change_key_impl.refine[unfolded PR_CONST_def, FCOMP hm_change_key_op_aref]
      lemmas hm_set_ref12 = hm_set_impl.refine[unfolded PR_CONST_def, FCOMP hm_set_op_aref]
      lemmas hm_pop_min_ref12 = hm_pop_min_impl.refine[unfolded PR_CONST_def, FCOMP hm_pop_min_op_aref]
      lemmas hm_remove_ref12 = hm_remove_impl.refine[unfolded PR_CONST_def, FCOMP hm_remove_op_aref]
      lemmas hm_peek_min_ref12 = hm_peek_min_impl.refine[FCOMP hm_peek_min_op_aref]

    end

    definition "hm_assn \<equiv> hr_comp hm12_assn (\<langle>nat_rel, Id\<rangle>map_rel)"
    context
      notes [fcomp_norm_unfold] = hm_assn_def[symmetric]
    begin
      lemmas hm_empty_hnr = hm_empty_ref12[FCOMP mop_hm_empty_fref]

      sepref_decl_impl (ismop) hm_insert_ref12 uses mop_map_update_new.fref[where K=Id and V=Id] .
      sepref_decl_impl (ismop) hm_is_empty_ref12 uses mop_map_is_empty.fref[where K=Id and V=Id] .
      sepref_decl_impl (ismop) hm_the_lookup_ref12 uses mop_map_the_lookup.fref[where K=Id and V=Id] .
      sepref_decl_impl (ismop) hm_contains_key_ref12 uses mop_map_contains_key.fref[where K=Id and V=Id] .
      sepref_decl_impl (ismop) hm_decrease_key_ref12 uses mop_pm_decrease_key.fref[where K=Id and V=Id] .
      sepref_decl_impl (ismop) hm_increase_key_ref12 uses mop_pm_increase_key.fref[where K=Id and V=Id] .
      sepref_decl_impl (ismop) hm_change_key_ref12 uses mop_map_update_ex.fref[where K=Id and V=Id] .
      sepref_decl_impl (ismop) hm_set_ref12 uses mop_map_update.fref[where K=Id and V=Id] .
      sepref_decl_impl (ismop) hm_pop_min_ref12 uses mop_pm_pop_min.fref[where K=Id and V=Id] .
      sepref_decl_impl (ismop) hm_remove_ref12 uses mop_map_delete_ex.fref[where K=Id and V=Id] .
      sepref_decl_impl (ismop) hm_peek_min_ref12 uses mop_pm_peek_min.fref[where K=Id and V=Id] .
    end

  end

  global_interpretation
    HM: hm_impl id "snat_assn' TYPE('l)" "snat_assn' TYPE('l)" return ll_icmp_sle ll_icmp_slt "TYPE('l::len2)" N for N
    defines
           hm_empty_impl = HM.hm_empty_impl
       and hm_append_impl = HM.hm_append_impl
       and hm_insert_impl = HM.hm_insert_impl
       and hm_length_impl = HM.hm_length_impl
       and hm_swim_impl = HM.hm_swim_impl
       and hm_sink_impl = HM.hm_sink_impl
       and hm_is_empty_impl = HM.hm_is_empty_impl
       and hm_the_lookup_impl = HM.hm_the_lookup_impl
       and hm_contains_key_impl = HM.hm_contains_key_impl
       and hm_decrease_key_impl = HM.hm_decrease_key_impl
       and hm_increase_key_impl = HM.hm_increase_key_impl
       and hm_change_key_impl = HM.hm_change_key_impl
       and hm_parent_impl = HM.parent_impl
       and hm_parent_valid_impl = HM.parent_valid_impl
       and hm_next_child_impl = HM.hm_next_child_impl
       and hm_has_next_child_impl = HM.hm_has_next_child_impl
       and hm_left_child_impl = HM.hm_left_child_impl
       and hm_has_child_impl = HM.hm_has_child_impl
       and hm_repair_impl = HM.hm_repair_impl
       and hm_set_impl = HM.hm_set_impl
       and hm_pop_min_impl = HM.hm_pop_min_impl
       and hm_remove_impl = HM.hm_remove_impl
       and hm_peek_min_impl = HM.hm_peek_min_impl

       and hm_exch_impl = HM.hm_exch_impl
       and hm_update_impl = HM.hm_update_impl
       and hm_index_impl = HM.hm_index_impl
       and hm_prio_of_impl = HM.hm_prio_of_impl
       and hm_val_of_impl = HM.hm_val_of_impl
       and hm_key_of_impl = HM.hm_key_of_impl
       and hm_butlast_impl = HM.hm_butlast_impl

    apply unfold_locales
    apply (rule pure_pure)
    apply sepref
    apply sepref
    apply sepref
    done

  type_synonym 'l heapmap = "'l ial \<times> 'l word iam"

  schematic_goal [sepref_frame_free_rules]: "MK_FREE (HM.hm_assn N) (?fr)"
    unfolding HM.hm_assn_def HM.hm12_assn_def HM.hm2_assn_def
    by sepref_dbg_side_keep

  concrete_definition hm_empty_impl' is HM.hm_empty_impl_def

  lemma hm_empty_hnr: "\<lbrakk>(Ni, N) \<in> snat_rel' TYPE('l); 4 < LENGTH('l::len2)\<rbrakk>
    \<Longrightarrow> (uncurry0 (hm_empty_impl' Ni), uncurry0 (PR_CONST (HM.mop_hm_empty N)))
    \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a HM.hm_assn N"
    using hm_empty_impl'.refine HM.hm_empty_hnr by metis

  lemmas [llvm_code,llvm_inline] =
    HM.hm_append_impl_def
    HM.hm_is_empty_impl_def
    HM.hm_length_impl_def
    HM.hm_the_lookup_impl_def
    HM.hm_contains_key_impl_def
    HM.parent_impl_def
    HM.parent_valid_impl_def
    HM.hm_prio_of_impl_def
    HM.hm_val_of_impl_def
    HM.hm_key_of_impl_def
    HM.hm_next_child_impl_def
    HM.hm_has_next_child_impl_def
    HM.hm_left_child_impl_def
    HM.hm_has_child_impl_def
    HM.hm_butlast_impl_def

  lemmas [llvm_code] =
    HM.hm_insert_impl_def
    HM.hm_decrease_key_impl_def
    HM.hm_increase_key_impl_def
    HM.hm_change_key_impl_def
    HM.hm_swim_impl_def
    HM.hm_sink_impl_def
    HM.hm_exch_impl_def
    HM.hm_update_impl_def
    HM.hm_index_impl_def
    HM.hm_repair_impl_def
    HM.hm_set_impl_def
    HM.hm_pop_min_impl_def
    HM.hm_remove_impl_def
    HM.hm_peek_min_impl_def
    hm_empty_impl'_def

  term HM.hm_prio_of_impl
  thm HM.hm_prio_of_impl_def

  export_llvm
    "hm_empty_impl' :: _ \<Rightarrow> 32 heapmap llM"
    "hm_append_impl:: _ \<Rightarrow> 32 word \<Rightarrow> _"
    "hm_is_empty_impl :: 32 heapmap \<Rightarrow> _"
    "hm_the_lookup_impl :: _ \<Rightarrow> 32 heapmap \<Rightarrow> _"
    "hm_contains_key_impl :: _ \<Rightarrow> 32 heapmap \<Rightarrow> _"
    "hm_decrease_key_impl :: _ \<Rightarrow> _ \<Rightarrow> 32 heapmap \<Rightarrow> _"
    "hm_increase_key_impl :: _ \<Rightarrow> _ \<Rightarrow> 32 heapmap \<Rightarrow> _"
    "hm_change_key_impl :: _ \<Rightarrow> _ \<Rightarrow> 32 heapmap \<Rightarrow> _"
    "hm_set_impl :: _ \<Rightarrow> _ \<Rightarrow> 32 heapmap \<Rightarrow> _"
    "hm_pop_min_impl :: 32 heapmap \<Rightarrow> _"
    "hm_remove_impl :: _ \<Rightarrow> 32 heapmap \<Rightarrow> _"
    "hm_peek_min_impl :: 32 heapmap \<Rightarrow> _"
    file "heapmap.ll"

  context
    fixes N Ni
    assumes NiREF: "(Ni,N)\<in>snat_rel' TYPE(32)"
    notes [sepref_import_param] = NiREF
    notes [[sepref_register_adhoc N]]
  begin

    definition "snatb (x::nat) \<equiv> x"
    lemma snatb_hnr: "(return,RETURN o snatb) \<in> [\<lambda>x. x<N]\<^sub>a snat_assn\<^sup>k \<rightarrow> snatb_assn N"
      unfolding snatb_def
      by sepref_to_hoare vcg

    definition "heapmap_test \<equiv> do {
      ASSERT (42<N);
      m \<leftarrow> HM.mop_hm_empty N;
      m \<leftarrow> mop_map_update (snatb 7)  (snatb 3) m;
      m \<leftarrow> mop_map_update (snatb 6)  (snatb 2) m;
      m \<leftarrow> mop_map_update (snatb 16) (snatb 1) m;
      (k,v) \<leftarrow> mop_pm_peek_min id m;
      RETURN k
    }"

    sepref_definition heapmap_test_impl_aux is "uncurry0 heapmap_test" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a snat_assn' TYPE(32)"
      unfolding heapmap_test_def
      supply [simp] = max_snat_def
      supply [sepref_fr_rules] = hm_empty_hnr[OF NiREF] snatb_hnr
      apply (annot_snat_const "TYPE(32)")
      by sepref

  end

  concrete_definition heapmap_test_impl is heapmap_test_impl_aux_def
  declare heapmap_test_impl_def[llvm_code]

  export_llvm heapmap_test_impl

  lemma "(heapmap_test_impl_aux, heapmap_test) \<in> snat_assn\<^sup>k \<rightarrow>\<^sub>a snat_assn"
    apply rule
    apply (rule hn_refine_preI)
    using heapmap_test_impl_aux.refine[to_hnr]
    by (simp add: pure_def pred_lift_extract_simps sep_algebra_simps)

  xxx, ctd here: Just added support for dependent result relation.

  Test this first on simple data structure, e.g., MS_Array_List!

end