theory javabip
  imports Main "/Volumes/Setup/Isabelle/Isabelle-Code/August/libs_functions"
begin

(*
value "concat (mk_pair_4 test_synchron)"
value "(mk_pair_4 (make_betaSet_3 test_triggers))"
value "(mk_pair_4 test_synchron)"
value "concat (mk_pair_4 test_synchron)"

value "(mk_pair_4 test_triggers)"
value "(mk_pair_4_no_product test_triggers)"
value "(mk_Trigger_list (mk_pair_4_no_product test_triggers))"
value "(mk_Trigger_list (mk_pair_4_no_product test_synchron))"
value "List.product (mk_Trigger_list (mk_pair_4 test_synchron)) (mk_Trigger_list (mk_pair_4_no_product test_triggers))"

value "mk_pair_4_no_product test_synchron"
value "List.product (mk_Trigger_list (mk_pair_4_no_product test_synchron)) (mk_Trigger_list (mk_pair_4_no_product test_triggers))"
value "List.product ((mk_pair_4_no_product test_synchron)) (mk_Trigger_list (mk_pair_4_no_product test_triggers))"

definition JavaBIP_Connector :: "((string \<times> string) list list \<times> (string \<times> string) list list) list"
  where
"JavaBIP_Connector = List.product (mk_Trigger_list (mk_pair_4_no_product test_synchron)) (mk_Trigger_list (mk_pair_4_no_product test_triggers))"
*)
value "List.product ((mk_pair_4_no_product test_synchron)) (mk_Trigger_list (mk_pair_4 test_triggers))"

definition JavaBIP_Connector_1 :: "((string \<times> string) list list \<times> (string \<times> string) list list) list"
  where
"JavaBIP_Connector_1 = List.product ((mk_pair_4_no_product test_synchron)) (mk_Trigger_list (mk_pair_4_no_product test_triggers))"

value "(mk_pair_4_no_product test_synchron)"
value "(mk_Trigger_list (mk_pair_4_no_product test_triggers))"

(*JavaBIP connector 2*)
fun mk_jvb :: "'a list \<Rightarrow> 'b \<Rightarrow> ('a \<times> 'b) list" where
"mk_jvb [] y = []"|
"mk_jvb (x#xs) y = [(Pair x) y] @ mk_jvb xs y"

value "mk_jvb (mk_pair_4_no_product test_synchron) (mk_Trigger_list (mk_pair_4_no_product test_triggers))"

definition JavaBIP_Connector_2 :: "((string \<times> string) list list \<times> (string \<times> string) list list list) list"
  where
"JavaBIP_Connector_2 = mk_jvb (mk_pair_4_no_product test_synchron) (mk_Trigger_list (mk_pair_4_no_product test_triggers))"

value "JavaBIP_Connector_2"

value "mk_Trigger_list (mk_pair_4_no_product test_triggers)"

value "product_lists (mk_Trigger_list (mk_pair_4_no_product test_triggers))"
(*
value "JavaBIP_Connector"
value "\<exists>connector \<in>set JavaBIP_Connector.\<forall>sync\<in>set (fst connector).\<forall>s_elm\<in>set(sync).(P (fst s_elm) (snd s_elm) \<longrightarrow> (\<exists>trig\<in>set(snd connector).\<forall>t_elm\<in>set(trig). Q (fst t_elm) (snd t_elm) \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q (fst t_elm) h)
\<and> (\<forall>s_elm_1\<in>set(sync)-{s_elm}. P (fst s_elm_1) (snd s_elm_1)
    \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P (fst s_elm_1) l))
)
)"

value "\<exists>connector \<in>set JavaBIP_Connector.\<forall>sync\<in>set (fst connector).\<exists>s_elm\<in>set(sync).(P (fst s_elm) (snd s_elm) \<longrightarrow> (\<exists>trig\<in>set(snd connector).\<forall>t_elm\<in>set(trig). Q (fst t_elm) (snd t_elm)
  \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q (fst t_elm) h)
  \<and> (
    (\<forall>s_elm_1\<in>set(sync)-{s_elm}. P (fst s_elm_1) (snd s_elm_1)
    \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P (fst s_elm_1) l))

    )
)
)"
*)
(*---- JavaBIP Connector 3*)
value "mk_jvb (mk_pair_4_no_product test_synchron) (product_lists (mk_Trigger_list (mk_pair_4_no_product test_triggers)))"
definition JavaBIP_Connector_3 :: "((string \<times> string) list list \<times> (string \<times> string) list list list) list"
  where
"JavaBIP_Connector_3 = mk_jvb (mk_pair_4_no_product test_synchron) (product_lists (mk_Trigger_list (mk_pair_4_no_product test_triggers)))"

value "JavaBIP_Connector_3"

(*----------*)
value "JavaBIP_Connector_1"

(*REQUIRE*)
value "\<exists>connector\<in>set JavaBIP_Connector_1.\<forall>sync\<in>set (fst connector).\<forall>s_elm\<in>set sync. (
P (fst s_elm) (snd s_elm) \<longrightarrow>
    ((\<exists>trig\<in>set(snd connector).\<forall>t_elm\<in>set trig. (
      Q (fst t_elm) (snd t_elm)
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q (fst t_elm) h)))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync}.\<exists>s_elm_1\<in>set(sync_1). P (fst s_elm_1) (snd s_elm_1)
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P (fst s_elm_1) l))
    )
)"

(*Accepts*)
value "(\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t) l1)
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1)"

(*JavaBIP*)
value "((\<exists>connector\<in>set JavaBIP_Connector_1.\<exists>sync\<in>set (fst connector).\<forall>s_elm\<in>set sync. (
P (fst s_elm) (snd s_elm) \<longrightarrow>
    ((\<exists>trig\<in>set(snd connector).\<forall>t_elm\<in>set trig. (
      Q (fst t_elm) (snd t_elm)
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q (fst t_elm) h)))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync}.\<exists>s_elm_1\<in>set(sync_1). P (fst s_elm_1) (snd s_elm_1)
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P (fst s_elm_1) l))
    )
))
\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t) l1)
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))"

(*----- JavaBIP_Connector_2 -----*)
value "JavaBIP_Connector_2"
value "(\<forall>connector\<in>set JavaBIP_Connector_2.\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q (fst t_elm) (snd t_elm)
\<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q (fst t_elm) h)))"
(*Requires*)
value "\<forall>connector\<in>set JavaBIP_Connector_2.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P (fst sync) (snd sync) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q (fst t_elm) (snd t_elm)
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q (fst t_elm) h)))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P (fst s_elm_1) (snd s_elm_1)
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P (fst s_elm_1) l))
    )
)"

(*JavaBIP*)
value "((\<forall>connector\<in>set JavaBIP_Connector_2.\<forall>sync_list\<in>set (fst connector).\<forall>sync\<in>set sync_list. (P (fst sync) (snd sync) \<longrightarrow>
      ((\<exists>trig_list\<in>set(snd connector).\<exists>trig\<in>set trig_list. \<forall>t_elm\<in>set trig. (Q (fst t_elm) (snd t_elm)
      \<and> (\<forall>h \<in> set (lookup_3 (fst t_elm) test_triggers) - {snd t_elm}. \<not>Q (fst t_elm) h)))
      \<and> (\<forall>sync_1\<in>set(fst connector)-{sync_list}.\<exists>s_elm_1\<in>set(sync_1). P (fst s_elm_1) (snd s_elm_1)
      \<and> (\<forall>l \<in> set (lookup_3 (fst s_elm_1) test_synchron) - {snd s_elm_1}. \<not>P (fst s_elm_1) l))
    )
))
\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P (fst t) l \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. \<not>P (fst t) l1)))
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q (fst k) h \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q (fst k) h1))))
"

(*Accepts*)
value "\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P (fst t) l \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. P (fst t) l1))"
value "(\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t) l1)"
value "\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}.(P (fst t) l \<longrightarrow> \<not>P (fst t) l1)"
value "(\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<forall>h \<in> set (snd k).(Q (fst k) h \<longrightarrow> (\<forall>h1 \<in> set (snd k) - {h}. \<not>Q (fst k) h1)))"

lemma test_accepts_0: "
\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P (fst t) l \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. P (fst t) l1)) \<Longrightarrow>
(\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t) l1)
"

lemma test_accepts: "((\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t) l1))
\<Longrightarrow>
(\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<forall>l \<in> set (snd t).(P (fst t) l \<longrightarrow> (\<forall>l1 \<in> set (snd t) - {l}. P (fst t) l1)))
"

end
(*----old------*)
(*
value "List.product [[(''3b1'', ''1'')]] [[(''3b2'', ''1''), (''3b2'', ''2'')]]"
fun make_javaBIP :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a * 'b list) list"
  where
"make_javaBIP [] _ = []" |
"make_javaBIP (x#xs) ys = [(Pair x) ys] @ make_javaBIP xs ys"

value "make_javaBIP (concat (mk_pair_4 test_synchron)) (mk_pair_4 (make_betaSet_3 test_triggers))"

definition JavaBIP_Connector :: "((string \<times> string) list \<times> (string \<times> string) list list list) list" where
"JavaBIP_Connector = make_javaBIP (concat (mk_pair_4 test_synchron)) (mk_pair_4 (make_betaSet_3 test_triggers))"

definition BIP_Connector :: "((string \<times> string) list \<times> (string \<times> string) list list) list" where
"BIP_Connector = List.product (concat (mk_pair_4 test_synchron)) (mk_pair_4 (make_betaSet_3 test_triggers))"

value "(Pair [(''4'', ''1'')]) (mk_pair_4 (make_betaSet_3 test_triggers))"
value "JavaBIP_Connector"

(*require code*)
value "\<forall>connector\<in>set JavaBIP_Connector.\<forall>sync\<in> set (fst connector). (P (fst sync) (snd sync) \<longrightarrow>
  (\<exists>bet \<in> set (snd connector).
    (\<exists>bet1\<in> set bet.\<forall>elm \<in> set (bet1).(Q (fst elm) (snd elm) \<and> (\<forall>h \<in> set (lookup_3 (fst elm) test_triggers) - {snd elm}. \<not>Q (fst elm) h)))
    \<and> (\<forall>sync1\<in> set (fst connector) - {sync}. P (fst sync1) (snd sync1) \<and> (\<forall>l \<in> set (lookup_3 (fst sync1) test_synchron)-{snd sync1}.\<not>P (fst sync1) l))
  )
)"

(*accept code*)
value "(\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t) l1)
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1)"

(*JavaBIP code*)
value "((\<forall>connector\<in>set JavaBIP_Connector.\<forall>sync\<in> set (fst connector). (P (fst sync) (snd sync) \<longrightarrow>
  (\<exists>bet \<in> set (snd connector).
    (\<exists>bet1\<in> set bet.\<forall>elm \<in> set (bet1).(Q (fst elm) (snd elm) \<and> (\<forall>h \<in> set (lookup_3 (fst elm) test_triggers) - {snd elm}. \<not>Q (fst elm) h)))
    \<and> (\<forall>sync1\<in> set (fst connector) - {sync}. P (fst sync1) (snd sync1) \<and> (\<forall>l \<in> set (lookup_3 (fst sync1) test_synchron)-{snd sync1}.\<not>P (fst sync1) l))
  )
))
\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t) l1)
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1))
"

lemma compare: "((\<forall>connector\<in>set JavaBIP_Connector.\<forall>sync\<in> set (fst connector). (P (fst sync) (snd sync) \<longrightarrow>
  (\<exists>bet \<in> set (snd connector).
    (\<exists>bet1\<in> set bet.\<forall>elm \<in> set (bet1).(Q (fst elm) (snd elm) \<and> (\<forall>h \<in> set (lookup_3 (fst elm) test_triggers) - {snd elm}. \<not>Q (fst elm) h)))
    \<and> (\<forall>sync1\<in> set (fst connector) - {sync}. P (fst sync1) (snd sync1) \<and> (\<forall>l \<in> set (lookup_3 (fst sync1) test_synchron)-{snd sync1}.\<not>P (fst sync1) l))
  )
))
\<and> (\<forall>j \<in> set test_synchron. \<forall>u \<in> set j. \<forall>t \<in> set u. \<exists>l \<in> set (snd t).\<forall>l1 \<in> set (snd t) - {l}. \<not> P (fst t) l1)
\<and> (\<forall>i \<in> set test_triggers. \<forall>v \<in> set i. \<forall>k \<in> set v. \<exists>h \<in> set (snd k).\<forall>h1 \<in> set (snd k) - {h}. \<not> Q (fst k) h1)) \<Longrightarrow>
(\<exists>connector\<in>set BIP_Connector.\<exists>sync\<in>set (fst connector).(P (fst sync) (snd sync) \<longrightarrow> (\<exists>trig\<in>set (snd connector).\<forall>elm\<in>set trig. Q (fst elm) (snd elm))
  \<and> (\<forall>sync1\<in>set (fst connector) - {sync}. P (fst sync1) (snd sync1))
  \<and> (\<forall>rs \<in> remaining_pairs (all_pairs test_synchron) (fst connector). \<not>P (fst rs) (snd rs))
  \<and> (\<forall>rt \<in> remaining_pairs (all_pairs test_triggers) (concat (snd connector)). \<not>Q (fst rt) (snd rt))
))
"
  sledgehammer
*)
end


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

  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"

  begin

    context
      fixes N :: nat
    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"

    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 amt_assn elem_assn N) (\<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 amt_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;
      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

    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_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 sepref_bounds

    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 sepref_bounds

    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] = 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)"
      apply sepref_bounds
      by (meson index_less less_trans_Suc)

    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
        apply sepref_bounds
        by (auto simp: heapmap_\<alpha>_def restrict_map_eq)
      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

    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

    lemma hm_pop_min_impl_aux1:
      "\<lbrakk>hm_valid (pq, m) (Suc 0); rdomp hm2_assn (pq, m)\<rbrakk> \<Longrightarrow> 0<N"
      unfolding hm2_assn_def hm_valid_def hm_length_def
      by (cases pq; sepref_bounds)

    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

    end

    sepref_decl_op hm_empty: "\<lambda>_::nat. op_map_empty" :: "nat_rel \<rightarrow> \<langle>K,V\<rangle>map_rel" .

    context fixes N :: nat begin
      sepref_decl_op hm_empty_fixed: "op_hm_empty N" :: "\<langle>K,V\<rangle>map_rel" .
    end

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

    lemma fold_custom_hm_empty_fixed:
      "Map.empty = op_hm_empty_fixed N"
      "RETURN Map.empty = mop_hm_empty_fixed N"
      "mop_map_empty = mop_hm_empty_fixed N"
      by auto

    term hm_empty_op

    definition "hm_empty_op' N \<equiv> do { m\<leftarrow>mop_amt_empty N; RETURN (op_ial_empty N,m) }"

    lemma hm_empty_op_N: "hm_empty_op' N = hm_empty_op"
      by (auto simp: hm_empty_op_def hm_empty_op'_def)

    lemma hm_empty_op'_aref: "(hm_empty_op', mop_hm_empty) \<in> nat_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
      using hm_empty_op_aref by (auto simp: hm_empty_op_N)

    sepref_definition hm_empty_impl is "hm_empty_op'" :: "[\<lambda>_. 4<LENGTH('l)]\<^sub>a\<^sub>d (snat_assn' TYPE('l))\<^sup>k \<rightarrow> (\<lambda>N _. hm2_assn N)"
      unfolding hm_empty_op_def hm_empty_op'_def hm2_assn_def
      apply (rule hfref_with_rdomI)
      by sepref

    definition "hm12_assn N \<equiv> hrr_comp nat_rel (\<lambda>N _. hm2_assn N) (\<lambda>_. heapmap_rel) N ()"

    lemma hm12_assn_fold': "hr_comp (hm2_assn N) heapmap_rel = hm12_assn N"
      unfolding hm12_assn_def
      by auto

    lemma hm12_assn_fold'': "hrr_comp nat_rel (\<lambda>N _. hm2_assn N) (\<lambda>_. heapmap_rel) = (\<lambda>N _. hm12_assn N)"
      unfolding hm12_assn_def
      by auto

    context
      notes [fcomp_norm_unfold] = hm12_assn_def[symmetric] hm12_assn_fold' hm12_assn_fold''
    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 N \<equiv> hr_comp (hm12_assn N) (\<langle>nat_rel, Id\<rangle>map_rel)"

    lemma hm_assn_fold': "hrr_comp nat_rel (\<lambda>N _. hm12_assn N) (\<lambda>x. \<langle>nat_rel, Id\<rangle>map_rel) = (\<lambda>N _. hm_assn N)"
      by (auto simp: hm_assn_def fun_eq_iff)

    context
      notes [fcomp_norm_unfold] = hm_assn_def[symmetric] hm_assn_fold'
    begin
      (*lemmas hm_empty_hnr = hm_empty_ref12[FCOMP mop_hm_empty_fref]*)

      sepref_decl_impl (ismop) hm_empty_ref12
        uses mop_hm_empty.fref[where K=Id and V=Id] fixes 'l by parametricity simp

      context
        fixes N :: nat and Ni :: "'l word"
        assumes Ni_ref: "(Ni,N)\<in>snat_rel' TYPE('l)"
      begin
        lemma hm_empty_fixed_ref:
          "(uncurry0 (hm_empty_impl Ni), uncurry0 (PR_CONST (mop_hm_empty_fixed N))) \<in> [\<lambda>_. 4 < LENGTH('l)]\<^sub>a unit_assn\<^sup>k \<rightarrow> hm12_assn N"
          apply rule
          apply (drule hfrefD[OF hm_empty_ref12, of N Ni])
          using Ni_ref
          by (simp add: pure_def)

        sepref_decl_impl (ismop,no_register) hm_empty_fixed: hm_empty_fixed_ref
          uses mop_hm_empty_fixed.fref[where K=Id and V=Id] fixes 'l by parametricity simp

      end

      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)"
    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 amt"

  abbreviation hm_assn' where "hm_assn' TYPE('l::len2) \<equiv> HM.hm_assn :: _ \<Rightarrow> _ \<Rightarrow> 'l heapmap \<Rightarrow> _"

  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

  term  HM.hm_assn

  lemma hm_assn_intf[intf_of_assn]:
    "intf_of_assn (HM.hm_assn N) (TYPE((nat,nat)i_map))"
    by simp

  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.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_fr_rules] = HM.hm_empty_fixed_hnr_mop[OF NiREF]

    (*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_fixed 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 [sepref_fr_rules] = 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)

end


chapter \<open>Reasoning Processes in IDE-CP - Part I\<close>

text \<open>The part includes small process that can be built without infrastructure of
  IDE-CP, and declarations of other large process.\<close>

theory IDE_CP_Reasoning1
  imports Spec_Framework
begin

section \<open>Annotations Guiding the Reasoning\<close>

subsection \<open>General Tags\<close>

consts SOURCE :: mode
       TARGET :: mode
       ABNORMAL :: mode

subsection \<open>Small Annotations\<close>

subsubsection \<open>Matches\<close>

definition Assertion_Matches :: \<open>'a set \<Rightarrow> 'a set \<Rightarrow> 'a set\<close> (infixl "<matches>" 18)
  where \<open>(S <matches> pattern) = S\<close>

text \<open>The annotation marking on a target \<^term>\<open>Y <matches> A\<close> in a ToA or a view shift
  restricts that the source have to first match pattern \<open>A\<close>.\<close>

lemma [\<phi>reason 2000]:
  \<open>Matches X A \<Longrightarrow> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> Y \<a>\<n>\<d> P \<Longrightarrow> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> (Y <matches> A) \<a>\<n>\<d> P\<close>
  unfolding Assertion_Matches_def .

lemma [\<phi>reason 2000]:
  \<open>Matches X A \<Longrightarrow> X \<s>\<h>\<i>\<f>\<t>\<s> Y \<a>\<n>\<d> P \<Longrightarrow> X \<s>\<h>\<i>\<f>\<t>\<s> (Y <matches> A) \<a>\<n>\<d> P\<close>
  unfolding Assertion_Matches_def .

subsubsection \<open>Useless Tag\<close>

definition USELESS :: \<open>bool \<Rightarrow> bool\<close> where \<open>USELESS x = x\<close>

text \<open>Simplification plays an important role in the programming in IDE_CP.
  We use it to simplify the specification and evaluate the abstract state.

  It is powerful as a transformation preserving all information,
  but sometimes we expect the transformation is weaker and unequal by disposing
  some useless information that we do not need.
  For example, we want to rewrite \<^term>\<open>x \<Ztypecolon> T\<close> to \<^term>\<open>y \<Ztypecolon> U\<close> but the rewrite may be held
  only with an additional proposition \<^term>\<open>Useless\<close> which is useless for us,
  \[ \<^prop>\<open>x \<Ztypecolon> T \<equiv> y \<Ztypecolon> U \<s>\<u>\<b>\<j> Useless\<close> \]
  In cases like this, we can wrap the useless proposition by tag \<open>\<open>USELESS\<close>\<close>,
  as \<^prop>\<open>x \<Ztypecolon> T \<equiv> y \<Ztypecolon> U \<s>\<u>\<b>\<j> USELESS Useless\<close>. The equality is still held because
  \<^prop>\<open>USELESS P \<equiv> P\<close>, but IDE-CP is configured to drop the \<^prop>\<open>Useless\<close>
  so the work space will not be polluted by helpless propositions.
\<close>

subsubsection \<open>Structural Morphism\<close>

(*TODO: explain*)

definition SMorphism :: \<open>'a \<Rightarrow> 'a\<close> ("SMORPH _" [17] 16)
  where [iff]: \<open>SMorphism X = X\<close>

definition Morphism :: \<open>mode \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool\<close>
  where \<open>Morphism _ R Q = (R \<longrightarrow> Q)\<close>

consts morphism_mode :: mode

abbreviation Automatic_Morphism :: \<open>bool \<Rightarrow> bool \<Rightarrow> bool\<close> where \<open>Automatic_Morphism \<equiv> Morphism MODE_AUTO\<close>

text \<open>
Note, the argument here means any \<phi>-Type in the pre-condition, not necessary argument value.

  If in a procedure or an implication rule or a view shift rule,
  there is an argument where the procedure or the rule retains its structure,
  this argument can be marked by \<^term>\<open>SMORPH arg\<close>.

  Recall when applying the procedure or the rule, the reasoner extracts \<^term>\<open>arg\<close> from the
    current \<phi>-BI specification \<^term>\<open>X\<close> of the current sequent.
  This extraction may break \<^term>\<open>X\<close> especially when the \<^term>\<open>arg\<close> to be extracted is
    scattered and embedded in multiple \<phi>-Types in \<^term>\<open>X\<close>.
  For example, extract \<^term>\<open>(x1, y2) \<Ztypecolon> (A1 * B2)\<close> from
    \<^term>\<open>((x1, x2) \<Ztypecolon> (A1 * A2)) * ((y1, (y2, y3)) \<Ztypecolon> (B1 * (B2 * B3)))\<close>.
  After the application, the following sequent will have broken structures because
    the original structure of \<^term>\<open>X\<close> is destroyed in order to extract \<^term>\<open>arg\<close>.
  However, the structure of the new \<^term>\<open>arg'\<close> may not changes.
  If so, by reversing the extraction, it is possible to recovery the original structure of \<^term>\<open>X\<close>,
    only with changed value of the corresponding part of \<^term>\<open>arg\<close> in \<^term>\<open>X\<close>.

  The system supports multiple arguments to be marked by \<^term>\<open>SMORPH arg\<close>.
  And the system applies the reverse morphism in the correct order.
  A requirement is,
  those structural-retained argument should locate at the end of the procedure's or the rule's
    argument list. Or else, because the reasoner does not record the extraction morphism of
    arguments not marked by \<^term>\<open>SMORPH arg\<close>, those arguments which occur after the
    structural-retained arguments change the \<phi>-BI specification by their extraction
    causing the recorded morphism of previous \<^term>\<open>SMORPH arg\<close> mismatch the current
    \<phi>-BI specification and so possibly not able to be applied any more.
\<close>

declare [[\<phi>reason_default_pattern
      \<open>?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> ?Y \<a>\<n>\<d> Automatic_Morphism _ _ \<and> _\<close> \<Rightarrow>
      \<open>?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> ?Y \<a>\<n>\<d> Automatic_Morphism _ _ \<and> _\<close>    (110)
  and \<open>?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> _ *  \<blangle> ?Y \<brangle> \<a>\<n>\<d> Automatic_Morphism _ _ \<and> _\<close> \<Rightarrow>
      \<open>?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> _ *  \<blangle> ?Y \<brangle> \<a>\<n>\<d> Automatic_Morphism _ _ \<and> _\<close>    (120)
]]

section \<open>Normalization of Assertions\<close>

consts assertion_simps :: \<open>mode \<Rightarrow> mode\<close>

ML \<open>
structure Assertion_SS = Simpset (
  val initial_ss = Simpset_Configure.Minimal_SS
  val binding = \<^binding>\<open>assertion_simps\<close>
  val comment = "Simplification rules normalizing an assertion. \
                       \It is applied before ToSA process."
)

structure Assertion_SS_Source = Simpset (
  val initial_ss = Simpset_Configure.Empty_SS
  val binding = \<^binding>\<open>assertion_simps_source\<close>
  val comment = "Simp rules normalizing particularly source part of an assertion."
)

structure Assertion_SS_Target = Simpset (
  val initial_ss = Simpset_Configure.Empty_SS
  val binding = \<^binding>\<open>assertion_simps_target\<close>
  val comment = "Simp rules normalizing particularly target part of an assertion."
)

structure Assertion_SS_Abnormal = Simpset (
  val initial_ss = Simpset_Configure.Empty_SS
  val binding = \<^binding>\<open>assertion_simps_abnormal\<close>
  val comment = "Simp rules normalizing particularly the abnormal spec of a triple."
)
\<close>

\<phi>reasoner_ML assertion_simp_source 1300
  (\<open>Simplify (assertion_simps SOURCE) ?X' ?X\<close>)
  = \<open>PLPR_Simplifier.simplifier_by_ss' NONE (fn ctxt =>
      Raw_Simplifier.merge_ss (Assertion_SS.get' ctxt, Assertion_SS_Source.get' ctxt))\<close>

\<phi>reasoner_ML assertion_simp_target 1300
  (\<open>Simplify (assertion_simps TARGET) ?X' ?X\<close>)
  = \<open>PLPR_Simplifier.simplifier_by_ss' NONE (fn ctxt =>
      Raw_Simplifier.merge_ss (Assertion_SS.get' ctxt, Assertion_SS_Target.get' ctxt))\<close>

\<phi>reasoner_ML assertion_simp_abnormal 1300
  (\<open>Simplify (assertion_simps ABNORMAL) ?X' ?X\<close>)
  = \<open>PLPR_Simplifier.simplifier_by_ss' NONE (fn ctxt =>
      Raw_Simplifier.merge_ss (Assertion_SS.get' ctxt, Assertion_SS_Abnormal.get' ctxt))\<close>

\<phi>reasoner_ML assertion_simp 1200
  (\<open>Premise (assertion_simps _) _\<close> | \<open>Simplify (assertion_simps ?ANY) ?X' ?X\<close>
     )
  = \<open>PLPR_Simplifier.simplifier_by_ss' NONE Assertion_SS.get'\<close>

lemmas [assertion_simps] =
  mult_zero_right[where 'a=\<open>'a::sep_magma set\<close>] mult_zero_left[where 'a=\<open>'a::sep_magma set\<close>]
  mult_1_right[where 'a=\<open>'a::sep_magma_1 set\<close>]
  mult_1_left[where 'a=\<open>'a::sep_magma_1 set\<close>]
  add_0_right[where 'a=\<open>'a::sep_magma set\<close>] add_0_left[where 'a=\<open>'a::sep_magma set\<close>]
  zero_fun[where 'a=\<open>'a::sep_magma set\<close>] zero_fun_def[symmetric, where 'b=\<open>'a::sep_magma set\<close>]
  plus_fun[where 'a=\<open>'a::sep_magma set\<close>]
  Subjection_Zero ExSet_simps distrib_right[where 'a=\<open>'a::sep_semigroup set\<close>]
  mult.assoc[symmetric, where 'a=\<open>'a::sep_semigroup set\<close>]
  \<phi>V_simps

lemmas [assertion_simps_source] = ExSet_times_left ExSet_times_right

section \<open>Small Reasoning Process\<close>

subsubsection \<open>Semantic Expansion of \<phi>-Types\<close>

consts MODE_\<phi>EXPN :: mode \<comment> \<open>relating to named_theorems \<open>\<phi>expn\<close>\<close>

abbreviation \<phi>expn_Premise ("<\<phi>expn> _" [26] 26) where \<open>\<phi>expn_Premise \<equiv> Premise MODE_\<phi>EXPN\<close>

\<phi>reasoner \<phi>expn_Premise 10 (\<open><\<phi>expn> ?P\<close>)
  = (rule Premise_I; simp add: \<phi>expns)

text \<open>Antecedent \<^prop>\<open><\<phi>expn> P\<close> indicates the reasoner solving the premise \<^prop>\<open>P\<close> using
  simplification rules of \<open>\<phi>expns\<close>.\<close>

subsubsection \<open>Name tag by type\<close>

(*TODO: elaborate this*)

datatype ('x, 'name) named (infix "<named>" 30) = tag 'x

syntax "__named__" :: \<open>logic \<Rightarrow> tuple_args \<Rightarrow> logic\<close> (infix "<<named>>" 25)

ML_file \<open>library/syntax/name_by_type.ML\<close>

text \<open>It is a tool to annotate names on a term, e.g. \<^term>\<open>x <<named>> a, b\<close>.
  The name tag is useful in lambda abstraction (including quantification) because the
  name of an abstraction variable is not preserved in many transformation especially
  simplifications. The name can be useful in the deductive programming, e.g. universally
  quantified variables in a sub-procedure like
  \[ \<open>\<forall>x y. proc f \<lbrace> VAL x \<Ztypecolon> T\<heavy_comma> VAL y \<Ztypecolon> U \<longmapsto> any \<rbrace> \<Longrightarrow> any'\<close> \]
  When starting to write the sub-procedure f by command \<open>\<medium_left_bracket>\<close>, \<phi>-system fixes variables x and y
    with the name of x and y. The name of x and y then are significant for programming.
  To preserve the name, we use \<^typ>\<open>'any <named> '\<phi>name_x \<times> '\<phi>name_y\<close>,
    \<^prop>\<open>\<forall>(x :: 'any <named> '\<phi>name_x). sth\<close>.
  We use free type variable to annotate it because it is most stable. No transformation
    changes the name of a free type variable.

  This feature is mostly used in \<^emph>\<open>Expansion of Quantification\<close> given in the immediate subsection.
  Therefore we put this part in the subsection of reasoning jobs, though itself is not related to
  any reasoning work.
\<close>

lemma named_forall: "All P \<longleftrightarrow> (\<forall>x. P (tag x))" by (metis named.exhaust)
lemma named_exists: "Ex P \<longleftrightarrow> (\<exists>x. P (tag x))" by (metis named.exhaust)
lemma [simp]: "tag (case x of tag x \<Rightarrow> x) = x" by (cases x) simp
lemma named_All: "(\<And>x. PROP P x) \<equiv> (\<And>x. PROP P (tag x))"
proof fix x assume "(\<And>x. PROP P x)" then show "PROP P (tag x)" .
next fix x :: "'a <named> 'b" assume "(\<And>x. PROP P (tag x))" from \<open>PROP P (tag (case x of tag x \<Rightarrow> x))\<close> show "PROP P x" by simp
qed

lemma named_ExSet: "(ExSet T) = (\<exists>*c. T (tag c) )" by (auto simp add: named_exists \<phi>expns)

subsubsection \<open>Expansion of Quantification\<close>

definition \<open>eoq__fst = fst\<close>
definition \<open>eoq__snd = snd\<close>

named_theorems named_expansion \<open>Rewriting rules expanding named quantification.\<close>

lemma eoq__fst[unfolded atomize_eq[symmetric], named_expansion]:
        \<open>eoq__fst (x,y) = x\<close> unfolding eoq__fst_def by simp
lemma eoq__snd[unfolded atomize_eq[symmetric], named_expansion]:
        \<open>eoq__snd (x,y) = y\<close> unfolding eoq__snd_def by simp

lemmas [unfolded atomize_eq[symmetric], named_expansion] =
  Product_Type.prod.case named.case id_apply

ML_file  "./library/tools/quant_expansion.ML"

hide_fact  eoq__fst eoq__snd
hide_const eoq__fst eoq__snd

simproc_setup named_forall_expansion ("All (P :: 'a <named> 'names \<Rightarrow> bool)") =
  \<open>K (QuantExpansion.simproc_of
          (fn Type(\<^type_name>\<open>\<phi>arg\<close>, _) => QuantExpansion.forall_expansion_arg_encoding
            | _ => QuantExpansion.forall_expansion))\<close>

simproc_setup named_ex_expansion ("Ex (P :: 'a <named> 'names \<Rightarrow> bool)") =
  \<open>K (QuantExpansion.simproc_of
          (fn Type(\<^type_name>\<open>\<phi>arg\<close>, _) => QuantExpansion.exists_expansion_arg_encoding
            | _ => QuantExpansion.exists_expansion))\<close>

simproc_setup named_exSet_expansion ("ExSet (P :: 'a <named> 'names \<Rightarrow> 'b set)") =
  \<open>K (QuantExpansion.simproc_of (K QuantExpansion.ExNu_expansion))\<close>

simproc_setup named_metaAll_expansion ("Pure.all (P :: 'a <named> 'names \<Rightarrow> prop)") =
  \<open>K (QuantExpansion.simproc_of
          (fn Type(\<^type_name>\<open>\<phi>arg\<close>, _) => QuantExpansion.meta_All_expansion_arg_encoding
            | _ => QuantExpansion.meta_All_expansion))\<close>

(*TODO: merge to procedure 1*)
ML_file "./library/syntax/procedure3.ML"

subsubsection \<open>Rename \<lambda>-Abstraction\<close>

definition rename_abstraction :: \<open>'\<phi>name_name itself \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>
  where \<open>rename_abstraction name origin_abs named_abs \<longleftrightarrow> (origin_abs = named_abs)\<close>

lemma rename_abstraction:
  \<open>rename_abstraction name X X\<close>
  unfolding rename_abstraction_def ..

\<phi>reasoner_ML rename_abstraction 1100 (\<open>rename_abstraction TYPE(?'name) ?Y ?Y'\<close>) =
\<open>fn (ctxt, sequent) =>
  case Thm.major_prem_of sequent
    of \<^const>\<open>Trueprop\<close> $ (Const (\<^const_name>\<open>rename_abstraction\<close>, _)
                $ (Const (\<^const_name>\<open>Pure.type\<close>, Type(\<^type_name>\<open>itself\<close>, [name'])))
                $ Abs(_,ty,body)
                $ Var Y'') =>
      let
        val name = case Phi_Syntax.dest_name_tylabels name'
                     of [x] => x
                      | _ => raise TYPE ("only one name is expected", [name'], [])
        val Y' = Abs(name, ty, body) |> Thm.cterm_of ctxt
        val sequent = @{thm rename_abstraction} RS Thm.instantiate (TVars.empty, Vars.make [(Y'',Y')]) sequent
      in
        Seq.single (ctxt, sequent)
      end
     | term => raise THM ("Bad shape of rename_abstraction antecedent", 0, [sequent])
\<close>

subsubsection \<open>\<lambda>-Abstraction Tag\<close>

definition "lambda_abstraction" :: " 'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool "
  where "lambda_abstraction x Y Y' \<longleftrightarrow> Y' x = Y"

lemma lambda_abstraction: "lambda_abstraction x (Y' x) Y'"
  unfolding lambda_abstraction_def ..

lemma [\<phi>reason 1200 for \<open>lambda_abstraction (?x,?y) ?fx ?f\<close>]:
  \<open> lambda_abstraction y fx f1
\<Longrightarrow> lambda_abstraction x f1 f2
\<Longrightarrow> lambda_abstraction (x,y) fx (case_prod f2)\<close>
  unfolding lambda_abstraction_def by simp

\<phi>reasoner_ML lambda_abstraction 1100 ("lambda_abstraction ?x ?Y ?Y'") = \<open>fn (ctxt, sequent) =>
  let
    val (Vs, _, \<^const>\<open>Trueprop\<close> $ (Const (\<^const_name>\<open>lambda_abstraction\<close>, _) $ x $ Y $ _))
      = Phi_Help.leading_antecedent (Thm.prop_of sequent)
    val Y' = Abs("", fastype_of x, abstract_over (x, Y))
    val idx = Thm.maxidx_of sequent
    val vars = map Var (List.tabulate (length Vs, (fn i => ("v", i+idx))) ~~ map snd Vs)
    fun subst X = Term.subst_bounds (vars, X)
    val rule = Drule.infer_instantiate ctxt
                  (map (apsnd (Thm.cterm_of ctxt)) [(("x",0), subst x), (("Y'",0),subst Y')])
                  @{thm lambda_abstraction}
  in
    Seq.single (ctxt, rule RS sequent)
  end
\<close>

lemma [\<phi>reason 1200 for \<open>lambda_abstraction (tag ?x) ?fx ?f\<close>]:
  \<open> lambda_abstraction x fx f
\<Longrightarrow> rename_abstraction TYPE('name) f f'
\<Longrightarrow> lambda_abstraction (tag x :: 'any <named> 'name) fx (case_named f')\<close>
  unfolding lambda_abstraction_def rename_abstraction_def by simp

subsubsection \<open>Introduce Frame Variable\<close>

named_theorems frame_var_rewrs \<open>Rewriting rules to normalize after inserting the frame variable\<close>

declare mult.assoc[symmetric, frame_var_rewrs]
  Subjection_times[frame_var_rewrs]
  ExSet_times_right[frame_var_rewrs]

consts frame_var_rewrs :: mode

\<phi>reasoner_ML Subty_Simplify 2000 (\<open>Simplify frame_var_rewrs ?x ?y\<close>)
  = \<open>PLPR_Simplifier.simplifier_only NONE (fn ctxt =>
          Named_Theorems.get ctxt \<^named_theorems>\<open>frame_var_rewrs\<close>)\<close>

definition \<phi>IntroFrameVar :: "'a::sep_magma_1 set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool"
  where "\<phi>IntroFrameVar R S' S T' T \<longleftrightarrow> S' = (R * S) \<and> T' = R * T "

definition \<phi>IntroFrameVar' ::
  "assn \<Rightarrow> assn \<Rightarrow> assn \<Rightarrow> ('ret \<Rightarrow> assn) \<Rightarrow> ('ret \<Rightarrow> assn) \<Rightarrow> ('ex \<Rightarrow> assn) \<Rightarrow> ('ex \<Rightarrow> assn) \<Rightarrow> bool"
  where "\<phi>IntroFrameVar' R S' S T' T E' E \<longleftrightarrow> S' = (R * S) \<and> T' = (\<lambda>ret. R * T ret) \<and> E' = (\<lambda>ex. R * E ex) "

definition TAIL :: \<open>assn \<Rightarrow> assn\<close> where \<open>TAIL S = S\<close>

text \<open>Antecedent \<^schematic_prop>\<open>\<phi>IntroFrameVar ?R ?S' S ?T' T\<close> appends a frame variable
  \<^schematic_term>\<open>?R\<close> to the source MTF \<^term>\<open>S\<close> if the items in \<^term>\<open>S\<close> do not have an ending
  frame variable already nor the ending item is not tagged by \<open>TAIL\<close>.
  If so, the reasoner returns \<open>?S' := ?R * S\<close> for a schematic \<open>?R\<close>,
  or else, the \<open>S\<close> is returned unchanged \<open>?S' := ?S\<close>.
  \<open>\<phi>IntroFrameVar'\<close> is similar.

  Tag \<open>TAIL\<close> is meaningful only when it tags the last item of a \<open>\<^emph>\<close>-sequence.
  It has a meaning of `the remaining everything' like, the target (RHS) item tagged by this
  means the item matches the whole remaining part of the source (LHS) part.
  \<open>TAIL\<close> also means, the tagged item is at the end and has a sense of ending, so no further
  padding is required (e.g. padding-of-void during ToSA reasoning).
\<close>

lemma \<phi>IntroFrameVar_No:
  "\<phi>IntroFrameVar 1 S S T T"
  unfolding \<phi>IntroFrameVar_def by simp

lemma \<phi>IntroFrameVar'_No:
  "\<phi>IntroFrameVar' 1 S S T T E E"
  unfolding \<phi>IntroFrameVar'_def by simp

lemma \<phi>IntroFrameVar_Yes:
  "\<phi>IntroFrameVar R (R * \<blangle> S \<brangle>) S (R * T) T"
  unfolding \<phi>IntroFrameVar_def FOCUS_TAG_def by blast

lemma \<phi>IntroFrameVar'_Yes:
  " \<phi>IntroFrameVar' R (R * \<blangle> S \<brangle>) S (\<lambda>ret. R * T ret) T (\<lambda>ex. R * E ex) E"
  unfolding \<phi>IntroFrameVar'_def FOCUS_TAG_def by blast

(*TODO*)
\<phi>reasoner_ML \<phi>IntroFrameVar 1000 ("\<phi>IntroFrameVar ?R ?S' ?S ?T' ?T") =
\<open>fn (ctxt, sequent) =>
  let
    val (Const (\<^const_name>\<open>\<phi>IntroFrameVar\<close>, _) $ _ $ _ $ S $ _ $ _) =
        Thm.major_prem_of sequent |> HOLogic.dest_Trueprop
    val tail = hd (Phi_Syntax.strip_separations S)
    fun suppressed (Var _) = true
      | suppressed (\<^const>\<open>TAIL\<close> $ _) = true
      | suppressed _ = false
  in
    if suppressed tail (* andalso fastype_of tail = \<^typ>\<open>assn\<close> *)
    then Seq.single (ctxt, @{thm \<phi>IntroFrameVar_No}  RS sequent)
    else Seq.single (ctxt, @{thm \<phi>IntroFrameVar_Yes} RS sequent)
  end\<close>

\<phi>reasoner_ML \<phi>IntroFrameVar' 1000 ("\<phi>IntroFrameVar' ?R ?S' ?S ?T' ?T ?E' ?E") =
\<open>fn (ctxt, sequent) =>
  let
    val (Const (\<^const_name>\<open>\<phi>IntroFrameVar'\<close>, _) $ _ $ _ $ S $ _ $ _ $ _ $ _) =
        Thm.major_prem_of sequent |> HOLogic.dest_Trueprop
    val tail = hd (Phi_Syntax.strip_separations S)
    fun suppressed (Var _) = true
      | suppressed (\<^const>\<open>TAIL\<close> $ _) = true
      | suppressed _ = false
  in
    if suppressed tail andalso fastype_of tail = \<^typ>\<open>assn\<close>
    then Seq.single (ctxt, @{thm \<phi>IntroFrameVar'_No}  RS sequent)
    else Seq.single (ctxt, @{thm \<phi>IntroFrameVar'_Yes} RS sequent)
  end\<close>

subsection \<open>Embedded Reasoning\<close>

definition Embedded_Reasoning :: \<open>bool \<Rightarrow> bool\<close> where \<open>Embedded_Reasoning X \<longleftrightarrow> X\<close>

text \<open>Annotate a boolean assertion in a proof obligation is actually an embedded reasoning
antecedent.\<close>

subsubsection \<open>Implementation\<close>

definition Pass_Embedded_Reasoning :: \<open>bool \<Rightarrow> bool\<close>
  where \<open>Pass_Embedded_Reasoning X \<longleftrightarrow> X\<close>

definition Pass_Embedded_Reasoning' :: \<open>bool \<Rightarrow> bool \<Rightarrow> bool\<close>
  where \<open>Pass_Embedded_Reasoning' IN OUT \<longleftrightarrow> (OUT \<longleftrightarrow> IN)\<close>

declare [[\<phi>reason_default_pattern
      \<open>Pass_Embedded_Reasoning' ?X _\<close> \<Rightarrow> \<open>Pass_Embedded_Reasoning' ?X _\<close> (100)
]]

lemma [\<phi>reason 1000]:
  \<open> Pass_Embedded_Reasoning' X Y
\<Longrightarrow> \<p>\<r>\<e>\<m>\<i>\<s>\<e> Y
\<Longrightarrow> Pass_Embedded_Reasoning X\<close>
  unfolding Pass_Embedded_Reasoning_def Pass_Embedded_Reasoning'_def Premise_def
  by blast

lemma [\<phi>reason 1110]:
  \<open> R
\<Longrightarrow> Pass_Embedded_Reasoning' X Y
\<Longrightarrow> Pass_Embedded_Reasoning' (Embedded_Reasoning R \<and> X) Y\<close>
  unfolding Pass_Embedded_Reasoning'_def Embedded_Reasoning_def by blast

lemma [\<phi>reason 1100]:
  \<open> Pass_Embedded_Reasoning' X Y
\<Longrightarrow> Pass_Embedded_Reasoning' (P \<and> X) (P \<and> Y)\<close>
  unfolding Pass_Embedded_Reasoning'_def by blast

lemma [\<phi>reason 1010]:
  \<open> R
\<Longrightarrow> Pass_Embedded_Reasoning' (Embedded_Reasoning R) True \<close>
  unfolding Pass_Embedded_Reasoning'_def Embedded_Reasoning_def by blast

lemma [\<phi>reason 1000]:
  \<open> Pass_Embedded_Reasoning' P P \<close>
  unfolding Pass_Embedded_Reasoning'_def by blast

subsection \<open>Semantic Type of Multiple Values\<close>

lemma [\<phi>reason 1200 for \<open>\<phi>_Have_Types (\<lambda>vs. ?R vs\<heavy_comma> ?x \<Ztypecolon> \<v>\<a>\<l>[\<phi>V_fst vs] ?T) _\<close>]:
  \<open> \<phi>SemType (x \<Ztypecolon> T) TY
\<Longrightarrow> \<phi>_Have_Types (\<lambda>vs. R vs) TYs
\<Longrightarrow> \<phi>_Have_Types (\<lambda>vs. R (\<phi>V_snd vs)\<heavy_comma> x \<Ztypecolon> \<v>\<a>\<l>[\<phi>V_fst vs] T) (TY#TYs)\<close>
  unfolding \<phi>_Have_Types_def Well_Typed_Vals_def \<phi>arg_forall \<phi>SemType_def subset_iff
  by (clarsimp simp add: to_vals_prod_def to_vals_VAL_def Val_inhabited_rewr)

lemma [\<phi>reason 1200]:
  \<open> \<phi>SemType (x \<Ztypecolon> T) TY
\<Longrightarrow> \<phi>_Have_Types (\<lambda>vs. R\<heavy_comma> x \<Ztypecolon> \<v>\<a>\<l>[vs] T) [TY]\<close>
  unfolding \<phi>_Have_Types_def Well_Typed_Vals_def \<phi>arg_forall \<phi>SemType_def subset_iff
  by (clarsimp simp add: to_vals_prod_def to_vals_VAL_def Val_inhabited_rewr)

lemma [\<phi>reason 1200]:
  \<open> \<phi>_Have_Types R TYs
\<Longrightarrow> \<phi>_Have_Types (\<lambda>vs. R vs\<heavy_comma> S) TYs\<close>
  unfolding \<phi>_Have_Types_def Well_Typed_Vals_def by clarsimp

lemma [\<phi>reason 2000]:
  \<open> \<phi>_Have_Types (\<lambda>_::unit \<phi>arg. Void) []\<close>
  unfolding \<phi>_Have_Types_def Well_Typed_Vals_def to_vals_unit_def by clarsimp

lemma [\<phi>reason 1020 except \<open>\<phi>_Have_Types (\<lambda>vs. ?A vs\<heavy_comma> ?B vs) _\<close>]:
  \<open> \<phi>_Have_Types (\<lambda>vs. Void\<heavy_comma> R vs) TYs
\<Longrightarrow> \<phi>_Have_Types R TYs\<close>
  unfolding \<phi>_Have_Types_def Well_Typed_Vals_def by clarsimp

lemma [\<phi>reason 1000]:
  \<open> FAIL TEXT(\<open>Fail to infer the semantic type of\<close> R)
\<Longrightarrow> \<phi>_Have_Types R TYs\<close>
  unfolding \<phi>_Have_Types_def Well_Typed_Vals_def by clarsimp

section \<open>Declaration of Large Processes\<close>

subsection \<open>Transformation of State Abstraction (ToSA)\<close>

text \<open>
  Supporting implication \<open>X \<i>\<m>\<p>\<l>\<i>\<e>\<s> Y @action ToSA\<close> only,
  ToSA is a reasoning process of Transformation of Abstraction (ToA) for
  assertions of (fictional) computation state.
\<close>

consts ToSA' :: \<open>bool \<comment> \<open>whether to reason deeper transformation for each desired \<phi>-type
                          by invoking more time-consuming reasoning process,
                          or just apply unification to match the desired.\<close>
              \<Rightarrow> mode\<close>

text \<open>The boolean flag indicates whether to reason the transformation of \<phi>-types in depth.
For \<open>X\<^sub>1 * \<cdots> * X\<^sub>n \<i>\<m>\<p>\<l>\<i>\<e>\<s> Y\<^sub>1 * \<cdots> * Y\<^sub>m @action ToSA' ?flag\<close>,

\<^item> If the flag is turned on, for every desired \<phi>-Type \<^term>\<open>Y\<^sub>i\<close>, the reasoner
  infers in depth whether some source \<phi>-Type \<^term>\<open>X\<^sub>j\<close> can be transformed into \<^term>\<open>Y\<^sub>i\<close>,
  by invoking any configured reasoning rules bound on the type of \<^term>\<open>Y\<^sub>i\<close>.

\<^item> If the flag is turned off, such in-depth inference is not applied, so the
  reasoning succeeds only if for every desired \<phi>-Type \<^term>\<open>Y\<^sub>i\<close> there is another
  \<^term>\<open>X\<^sub>j\<close> that unifies \<^term>\<open>Y\<^sub>i\<close>.

The the flag is turned off, obviously the performance can be improved a lot though
the reasoning is weaker.
\<close>

abbreviation \<open>ToSA \<equiv> ToSA' True\<close>

lemma [\<phi>reason 3000 for \<open>?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> ?X' \<a>\<n>\<d> ?P @action ToSA' ?mode\<close>]:
  \<open>X \<i>\<m>\<p>\<l>\<i>\<e>\<s> X @action ToSA' mode\<close>
  unfolding Action_Tag_def using implies_refl .

subsection \<open>Removing Values\<close>

definition \<open>Remove_Values (Input::assn) (Output::assn) \<longleftrightarrow> (Input \<i>\<m>\<p>\<l>\<i>\<e>\<s> Output)\<close>

text \<open>The process \<^prop>\<open>Remove_Values Input Output\<close> removes value assertions \<open>x \<Ztypecolon> \<v>\<a>\<l> T\<close>
  from the assertion \<open>Input\<close>. Bounded values such the return value of a procedure are not removed.\<close>

subsection \<open>Collects all Values in an Assertion / from the State Sequent\<close>

consts collect_clean_value :: \<open>bool \<Rightarrow> action\<close>

lemma apply_collect_clean_value:
  \<open> S \<i>\<m>\<p>\<l>\<i>\<e>\<s> S' \<a>\<n>\<d> V @action collect_clean_value WHETHER_CLEAN
\<Longrightarrow> S \<i>\<m>\<p>\<l>\<i>\<e>\<s> S' \<a>\<n>\<d> V\<close>
  unfolding Action_Tag_def .

lemma [\<phi>reason 1200 for \<open>?S \<heavy_comma> ?x \<Ztypecolon> \<v>\<a>\<l>[?v] ?T \<i>\<m>\<p>\<l>\<i>\<e>\<s> ?S' \<a>\<n>\<d> ?V @action collect_clean_value True\<close>]:
  \<open> S \<i>\<m>\<p>\<l>\<i>\<e>\<s> S' \<a>\<n>\<d> V @action collect_clean_value True
\<Longrightarrow> S \<heavy_comma> x \<Ztypecolon> \<v>\<a>\<l>[v] T \<i>\<m>\<p>\<l>\<i>\<e>\<s> S' \<a>\<n>\<d> \<phi>arg.dest v \<in> (x \<Ztypecolon> T) \<and> V @action collect_clean_value True\<close>
  unfolding Action_Tag_def Imply_def by (clarsimp simp add: \<phi>expns)

lemma [\<phi>reason 1200 for \<open>?S \<heavy_comma> ?x \<Ztypecolon> \<v>\<a>\<l>[?v] ?T \<i>\<m>\<p>\<l>\<i>\<e>\<s> ?S' \<a>\<n>\<d> ?V @action collect_clean_value False\<close>]:
  \<open> S \<i>\<m>\<p>\<l>\<i>\<e>\<s> S' \<a>\<n>\<d> V @action collect_clean_value False
\<Longrightarrow> S \<heavy_comma> x \<Ztypecolon> \<v>\<a>\<l>[v] T \<i>\<m>\<p>\<l>\<i>\<e>\<s> S' \<heavy_comma> x \<Ztypecolon> \<v>\<a>\<l>[v] T \<a>\<n>\<d> \<phi>arg.dest v \<in> (x \<Ztypecolon> T) \<and> V
    @action collect_clean_value False\<close>
  unfolding Action_Tag_def Imply_def by (clarsimp simp add: \<phi>expns)

lemma [\<phi>reason 1100 for \<open>?S\<heavy_comma> ?X \<i>\<m>\<p>\<l>\<i>\<e>\<s> ?S' \<a>\<n>\<d> ?V @action collect_clean_value ?CLEAN\<close>]:
  \<open> S \<i>\<m>\<p>\<l>\<i>\<e>\<s> S' \<a>\<n>\<d> V @action collect_clean_value CLEAN
\<Longrightarrow> S\<heavy_comma> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> S'\<heavy_comma> X \<a>\<n>\<d> V @action collect_clean_value CLEAN\<close>
  unfolding Action_Tag_def using implies_right_prod .

lemma [\<phi>reason 1050 for \<open>?x \<Ztypecolon> \<v>\<a>\<l>[?v] ?T \<i>\<m>\<p>\<l>\<i>\<e>\<s> ?S' \<a>\<n>\<d> ?V @action collect_clean_value True\<close>]:
  \<open> x \<Ztypecolon> \<v>\<a>\<l>[v] T \<i>\<m>\<p>\<l>\<i>\<e>\<s> Void \<a>\<n>\<d> \<phi>arg.dest v \<in> (x \<Ztypecolon> T) \<and> True
    @action collect_clean_value True\<close>
  unfolding Action_Tag_def Imply_def by (clarsimp simp add: \<phi>expns)

lemma [\<phi>reason 1050 for \<open>?x \<Ztypecolon> \<v>\<a>\<l>[?v] ?T \<i>\<m>\<p>\<l>\<i>\<e>\<s> ?S' \<a>\<n>\<d> ?V @action collect_clean_value False\<close>]:
  \<open> x \<Ztypecolon> \<v>\<a>\<l>[v] T \<i>\<m>\<p>\<l>\<i>\<e>\<s> x \<Ztypecolon> \<v>\<a>\<l>[v] T \<a>\<n>\<d> \<phi>arg.dest v \<in> (x \<Ztypecolon> T) \<and> True
    @action collect_clean_value False\<close>
  unfolding Action_Tag_def Imply_def by (clarsimp simp add: \<phi>expns)

lemma [\<phi>reason 1000 for \<open>?S \<i>\<m>\<p>\<l>\<i>\<e>\<s> ?S' \<a>\<n>\<d> ?V @action collect_clean_value ?clean\<close>]:
  \<open> X \<i>\<m>\<p>\<l>\<i>\<e>\<s> X \<a>\<n>\<d> True @action collect_clean_value clean\<close>
  unfolding Action_Tag_def using implies_refl .

end


theory tp89
imports Main "~~/src/HOL/Library/Code_Target_Nat"
begin

(*
transid
c identifie un client
m identifie un marchand
i numéro de transaction entre c et m

am transaction montant retenu pour la transaction

Client \<longrightarrow> Marchand
Pay (c,m,i) am \<longrightarrow> c accepte de payer le montant am à m pour la transaction id

Marchand \<longrightarrow> Client
Ack (c,m,i) am \<longrightarrow> m demande un montant am au client c pour la transaction id
Cancel (c,m,i) \<longrightarrow> m annule toutes les transactions pour transaction id

le marchand doit diminuer am
le client doit augmenter am
*)
type_synonym transid= "nat*nat*nat"

datatype message=
  Pay transid nat
| Ack transid nat
| Cancel transid

datatype etatTrans=
  Encours
| Ok
| Abort

datatype SomeTrans =
  None
| Integer nat

datatype SomeEtat =
  Nothing
| Etat  etatTrans
type_synonym transaction= "transid * nat"

(* transid * am marchand * am client * etat  *)

type_synonym ligneBdd = "(transid * SomeTrans *SomeTrans * etatTrans )"

type_synonym transBdd ="ligneBdd list"

(* select dans la bdd, l'etat de la transi*)
fun selectEtat ::"transid \<Rightarrow> transBdd \<Rightarrow> SomeEtat "
where
 "selectEtat _ [] = Nothing"
|"selectEtat id1 ((id2::transid,sm2,sc2,etat2)#xs) =( if(id1=id2) then (Etat etat2)  else selectEtat id1 xs )"

(* select dans la bdd de la proposition du marchand*)
fun selectMarch ::"transid \<Rightarrow> transBdd \<Rightarrow> SomeTrans "
where
 "selectMarch _ [] = None"
|"selectMarch id1 ((id2::transid,sm2,sc2,etat2)#xs) =( if(id1=id2) then sm2  else selectMarch id1 xs )"

(* select dans la bdd de la proposition du client*)
fun selectClient ::"transid \<Rightarrow> transBdd \<Rightarrow> SomeTrans"
where
 "selectClient _ [] = None"
|"selectClient id1 ((id2::transid,sm2,sc2,etat2)#xs) =( if(id1=id2) then sc2  else selectClient id1 xs )"

fun updateLignePay :: "  nat \<Rightarrow> ligneBdd \<Rightarrow>  ligneBdd"
where
 "updateLignePay _ ((x2::transid),m2,c2,Abort) =  ((x2::transid),m2,c2,Abort)"
|"updateLignePay v1 ((x2::transid),Integer m2,None,Encours) = (if (v1\<ge>m2) then  ((x2::transid),Integer m2, Integer v1,Ok) else  ((x2::transid),Integer m2,Integer v1,Encours) )"
|"updateLignePay v1 ((x2::transid),Integer m2,Integer v2,Encours) = (if (v1>v2) then  (if(v1\<ge>m2) then  ((x2::transid),Integer m2,Integer v1,Ok)  else  ((x2::transid),Integer m2,Integer v1,Encours)) else ( ((x2::transid),Integer m2,Integer v2,Encours)))"
|"updateLignePay _ ((x2::transid),m2,c2,Ok) = ((x2::transid),m2,c2,Ok)"
|"updateLignePay v1 (v,None, None, Encours) =  (v,None, Integer v1, Encours)"
|"updateLignePay v1 (v,None, Integer v2, Encours) = (if (v1>v2) then (v,None, Integer v1, Encours)  else (v,None, Integer v2, Encours)) "

fun updatePay:: "(transid * nat) \<Rightarrow> transBdd \<Rightarrow>  transBdd"
where
 "updatePay ((x1::transid),c1) [] = [((x1::transid),None,Integer c1,Encours)] "
|"updatePay ((x1::transid),c1) (((x2::transid),m2,c2,e2)#xs)= (if (x2=x1) then (updateLignePay  (c1) ((x2::transid),m2,c2,e2)  )#xs  else (((x2::transid),m2,c2,e2)#(updatePay ((x1::transid),c1) xs ))  )"

fun updateLigneAck :: "nat \<Rightarrow> ligneBdd \<Rightarrow>  ligneBdd"
where
 "updateLigneAck _ ((x2::transid),m2,c2,Abort) =  ((x2::transid),m2,c2,Abort)"
|"updateLigneAck m1 ((x2::transid),Integer m2,None,Encours) = (if (m1\<le>m2) then  ((x2::transid),Integer m1, None,Encours) else  ((x2::transid),Integer m2,None,Encours) )"
|"updateLigneAck m1 ((x2::transid),Integer m2,Integer v2,Encours) = (if (m1\<le>m2) then  (if(m1\<le>v2) then  ((x2::transid),Integer m1,Integer v2,Ok)  else  ((x2::transid),Integer m1,Integer v2,Encours)) else ( ((x2::transid),Integer m2,Integer v2,Encours)))"
|"updateLigneAck _ ((x2::transid),m2,c2,Ok) = ((x2::transid),m2,c2,Ok)"
|"updateLigneAck m1 (v,None, None, Encours) =  (v,Integer m1,None, Encours)"
|"updateLigneAck m1 (v,None, Integer v2, Encours) = (if (m1\<le>v2) then (v,Integer m1, Integer v2, Ok)  else (v, Integer m1,Integer v2, Encours)) "

fun updateAck:: "(transid * nat) \<Rightarrow> transBdd \<Rightarrow>  transBdd"
where
 "updateAck ((x1::transid),c1) [] = [((x1::transid),Integer c1,None,Encours)] "
|"updateAck ((x1::transid),c1) (((x2::transid),m2,c2,e2)#xs)= (if (x2=x1) then (updateLigneAck  (c1) ((x2::transid),m2,c2,e2)  )#xs  else (((x2::transid),m2,c2,e2)#(updateAck ((x1::transid),c1) xs ))  )"

fun updateLigneCancel :: " ligneBdd \<Rightarrow>  ligneBdd"
where
 "updateLigneCancel  ((x2::transid),m2,c2,e2) =  ((x2::transid),m2,c2,Abort)"

fun updateCancel:: "transid \<Rightarrow> transBdd \<Rightarrow>  transBdd"
where
 "updateCancel (x1::transid) [] = [((x1::transid),None,None,Abort)] "
|"updateCancel (x1::transid) (((x2::transid),m2,c2,e2)#xs)= (if (x2=x1) then (updateLigneCancel  ((x2::transid),m2,c2,e2)  )#xs  else (((x2::transid),m2,c2,e2)#(updateCancel ((x1::transid)) xs ))  )"

fun traiterMessage ::"message \<Rightarrow> transBdd \<Rightarrow> transBdd "
where
 "traiterMessage ( Pay transid am) tb = (if(am>0) then updatePay (transid, am) tb else tb)"
|"traiterMessage ( Ack transid am) tb = (if(am\<ge>0) then  updateAck (transid, am) tb else tb)"
|"traiterMessage ( Cancel transid) tb = updateCancel transid tb "

fun export:: "transBdd \<Rightarrow> transaction list"
where
 "export [] = []"
|"export  (((x2::transid),m2,Integer c2,e2)#xs) = (if (e2=Ok) then (x2,c2)#(export xs ) else(export xs ) )"
|"export  (((x2::transid),m2,c2,e2)#xs) = (export xs )"

fun traiMessList:: "message list \<Rightarrow> transBdd \<Rightarrow> transBdd"
where
 "traiMessList [] tb = tb"
|"traiMessList (v # va) tb =traiMessList va (traiterMessage v tb) "

fun traiterMessageList:: "message list \<Rightarrow> transBdd"
where
 "traiterMessageList ml = traiMessList ml []"

lemma lem1:"( (List.member  (export  (traiterMessageList lm)) (a,b)) \<longrightarrow> (b>0))"
apply (induct lm)
apply auto
apply (simp add: member_rec(2))
oops

oops

lemma lem3:"(selectEtat a  (traiterMessage (Cancel  a) (traiterMessageList lm))) = Etat Abort"

apply (induct lm)
apply auto

oops

lemma lem4:"(List.member (export (traiterMessage (Cancel  a) (traiterMessageList lm))) (a,b)) = False"
apply (induct lm)
apply auto
apply (simp add: member_rec(2))

oops

lemma lem5:"pc\<ge>pm \<and> pc>0 \<and>  \<not>(List.member  lm (Cancel a )) \<longrightarrow> (\<exists> pc. List.member (export (traiterMessage (Pay a pc)  (traiterMessage (Ack  a pm) (traiterMessageList lm)))) (a,pc))"
apply (induct lm)
apply auto
apply (metis gr_implies_not0 member_rec(1))
apply (simp add: member_rec(1))

oops

lemma lem6:"(selectEtat a (traiterMessageList lm) = Etat Ok) \<longrightarrow>(\<exists> pc pm.(List.member lm (Ack a pm)) \<and> (List.member lm (Pay a pc)) \<and> pc \<ge> pm) "
apply (induct lm)
apply auto

oops

lemma lem71:"( selectClient a  (traiterMessageList lm)) = Integer pm \<and> pm> mo \<longrightarrow> ( selectClient a (traiterMessage (Pay  a mo)  (traiterMessageList lm))) = Integer pm "

oops

lemma lem72:"( selectMarch a  (traiterMessageList lm)) = Integer pm \<and> pm < mo \<longrightarrow> ( selectMarch a (traiterMessage (Ack  a mo) (traiterMessageList lm))) = Integer pm "

oops

lemma lem81:"(selectEtat a (traiterMessageList lm) = Etat Ok) \<and> (selectClient a (traiterMessage (Pay  a pm) (traiterMessageList lm)) = Integer pm) \<longrightarrow> (selectClient a (traiterMessage (Pay  a autre) (traiterMessageList lm)) = Integer pm)"

oops

lemma lem82:"(selectEtat a (traiterMessageList lm) = Etat Ok) \<and> (selectMarch a (traiterMessageList lm) = Integer pm) \<longrightarrow> (selectMarch a  (traiterMessage (Ack  a autre) (traiterMessageList lm)) = Integer pm)"

oops

lemma lem9:"(selectEtat a (traiterMessageList lm) = Etat Ok) \<and> (selectMarch a (traiterMessageList lm) = Integer pm) \<and>  (selectClient a  (traiterMessageList lm) = Integer pc) \<longrightarrow> (List.member (export (traiterMessageList lm)) (a,pc)) "
oops

(* ----- Exportation en Scala (Isabelle 2014) -------*)

(* Directive d'exportation *)
export_code export traiterMessage in Scala

end