(*  Title:      HOL/MicroJava/BV/Correct.thy
    Author:     Cornelia Pusch, Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section {* BV Type Safety Invariant *}

theory Correct
imports BVSpec "../JVM/JVMExec"
begin

definition approx_val :: "[jvm_prog,aheap,val,ty err] \<Rightarrow> bool" where
  "approx_val G h v any == case any of Err \<Rightarrow> True | OK T \<Rightarrow> G,h\<turnstile>v::\<preceq>T"

definition approx_loc :: "[jvm_prog,aheap,val list,locvars_type] \<Rightarrow> bool" where
  "approx_loc G hp loc LT == list_all2 (approx_val G hp) loc LT"

definition approx_stk :: "[jvm_prog,aheap,opstack,opstack_type] \<Rightarrow> bool" where
  "approx_stk G hp stk ST == approx_loc G hp stk (map OK ST)"

definition correct_frame  :: "[jvm_prog,aheap,state_type,nat,bytecode] \<Rightarrow> frame \<Rightarrow> bool" where
  "correct_frame G hp == \<lambda>(ST,LT) maxl ins (stk,loc,C,sig,pc).
                         approx_stk G hp stk ST  \<and> approx_loc G hp loc LT \<and>
                         pc < length ins \<and> length loc=length(snd sig)+maxl+1"

primrec correct_frames  :: "[jvm_prog,aheap,prog_type,ty,sig,frame list] \<Rightarrow> bool" where
  "correct_frames G hp phi rT0 sig0 [] = True"
| "correct_frames G hp phi rT0 sig0 (f#frs) =
    (let (stk,loc,C,sig,pc) = f in
    (\<exists>ST LT rT maxs maxl ins et.
      phi C sig ! pc = Some (ST,LT) \<and> is_class G C \<and>
      method (G,C) sig = Some(C,rT,(maxs,maxl,ins,et)) \<and>
    (\<exists>C' mn pTs. ins!pc = (Invoke C' mn pTs) \<and>
           (mn,pTs) = sig0 \<and>
           (\<exists>apTs D ST' LT'.
           (phi C sig)!pc = Some ((rev apTs) @ (Class D) # ST', LT') \<and>
           length apTs = length pTs \<and>
           (\<exists>D' rT' maxs' maxl' ins' et'.
             method (G,D) sig0 = Some(D',rT',(maxs',maxl',ins',et')) \<and>
             G \<turnstile> rT0 \<preceq> rT') \<and>
     correct_frame G hp (ST, LT) maxl ins f \<and>
     correct_frames G hp phi rT sig frs))))"

definition correct_state :: "[jvm_prog,prog_type,jvm_state] \<Rightarrow> bool"
                  ("_,_ |-JVM _ [ok]"  [51,51] 50) where
"correct_state G phi == \<lambda>(xp,hp,frs).
   case xp of
     None \<Rightarrow> (case frs of
             [] \<Rightarrow> True
             | (f#fs) \<Rightarrow> G\<turnstile>h hp\<surd> \<and> preallocated hp \<and>
      (let (stk,loc,C,sig,pc) = f
             in
                         \<exists>rT maxs maxl ins et s.
                         is_class G C \<and>
                         method (G,C) sig = Some(C,rT,(maxs,maxl,ins,et)) \<and>
                         phi C sig ! pc = Some s \<and>
       correct_frame G hp s maxl ins f \<and>
             correct_frames G hp phi rT sig fs))
   | Some x \<Rightarrow> frs = []"

notation (xsymbols)
 correct_state  ("_,_ \<turnstile>JVM _ \<surd>"  [51,51] 50)

lemma sup_ty_opt_OK:
  "(G \<turnstile> X <=o (OK T')) = (\<exists>T. X = OK T \<and> G \<turnstile> T \<preceq> T')"
  by (cases X) auto

subsection {* approx-val *}

lemma approx_val_Err [simp,intro!]:
  "approx_val G hp x Err"
  by (simp add: approx_val_def)

lemma approx_val_OK [iff]:
  "approx_val G hp x (OK T) = (G,hp \<turnstile> x ::\<preceq> T)"
  by (simp add: approx_val_def)

lemma approx_val_Null [simp,intro!]:
  "approx_val G hp Null (OK (RefT x))"
  by (auto simp add: approx_val_def)

lemma approx_val_sup_heap:
  "\<lbrakk> approx_val G hp v T; hp \<le>| hp' \<rbrakk> \<Longrightarrow> approx_val G hp' v T"
  by (cases T) (blast intro: conf_hext)+

lemma approx_val_heap_update:
  "\<lbrakk> hp a = Some obj'; G,hp\<turnstile> v::\<preceq>T; obj_ty obj = obj_ty obj'\<rbrakk>
  \<Longrightarrow> G,hp(a\<mapsto>obj)\<turnstile> v::\<preceq>T"
  by (cases v) (auto simp add: obj_ty_def conf_def)

lemma approx_val_widen:
  "\<lbrakk> approx_val G hp v T; G \<turnstile> T <=o T'; wf_prog wt G \<rbrakk>
  \<Longrightarrow> approx_val G hp v T'"
  by (cases T') (auto simp add: sup_ty_opt_OK intro: conf_widen)

subsection {* approx-loc *}

lemma approx_loc_Nil [simp,intro!]:
  "approx_loc G hp [] []"
  by (simp add: approx_loc_def)

lemma approx_loc_Cons [iff]:
  "approx_loc G hp (l#ls) (L#LT) =
  (approx_val G hp l L \<and> approx_loc G hp ls LT)"
by (simp add: approx_loc_def)

lemma approx_loc_nth:
  "\<lbrakk> approx_loc G hp loc LT; n < length LT \<rbrakk>
  \<Longrightarrow> approx_val G hp (loc!n) (LT!n)"
  by (simp add: approx_loc_def list_all2_conv_all_nth)

lemma approx_loc_imp_approx_val_sup:
  "\<lbrakk>approx_loc G hp loc LT; n < length LT; LT ! n = OK T; G \<turnstile> T \<preceq> T'; wf_prog wt G\<rbrakk>
  \<Longrightarrow> G,hp \<turnstile> (loc!n) ::\<preceq> T'"
  apply (drule approx_loc_nth, assumption)
  apply simp
  apply (erule conf_widen, assumption+)
  done

lemma approx_loc_conv_all_nth:
  "approx_loc G hp loc LT =
  (length loc = length LT \<and> (\<forall>n < length loc. approx_val G hp (loc!n) (LT!n)))"
  by (simp add: approx_loc_def list_all2_conv_all_nth)

lemma approx_loc_sup_heap:
  "\<lbrakk> approx_loc G hp loc LT; hp \<le>| hp' \<rbrakk>
  \<Longrightarrow> approx_loc G hp' loc LT"
  apply (clarsimp simp add: approx_loc_conv_all_nth)
  apply (blast intro: approx_val_sup_heap)
  done

lemma approx_loc_widen:
  "\<lbrakk> approx_loc G hp loc LT; G \<turnstile> LT <=l LT'; wf_prog wt G \<rbrakk>
  \<Longrightarrow> approx_loc G hp loc LT'"
apply (unfold Listn.le_def lesub_def sup_loc_def)
apply (simp (no_asm_use) only: list_all2_conv_all_nth approx_loc_conv_all_nth)
apply (simp (no_asm_simp))
apply clarify
apply (erule allE, erule impE)
 apply simp
apply (erule approx_val_widen)
 apply simp
apply assumption
done

lemma loc_widen_Err [dest]:
  "\<And>XT. G \<turnstile> replicate n Err <=l XT \<Longrightarrow> XT = replicate n Err"
  by (induct n) auto

lemma approx_loc_Err [iff]:
  "approx_loc G hp (replicate n v) (replicate n Err)"
  by (induct n) auto

lemma approx_loc_subst:
  "\<lbrakk> approx_loc G hp loc LT; approx_val G hp x X \<rbrakk>
  \<Longrightarrow> approx_loc G hp (loc[idx:=x]) (LT[idx:=X])"
apply (unfold approx_loc_def list_all2_iff)
apply (auto dest: subsetD [OF set_update_subset_insert] simp add: zip_update)
done

lemma approx_loc_append:
  "length l1=length L1 \<Longrightarrow>
  approx_loc G hp (l1@l2) (L1@L2) =
  (approx_loc G hp l1 L1 \<and> approx_loc G hp l2 L2)"
  apply (unfold approx_loc_def list_all2_iff)
  apply (simp cong: conj_cong)
  apply blast
  done

subsection {* approx-stk *}

lemma approx_stk_rev_lem:
  "approx_stk G hp (rev s) (rev t) = approx_stk G hp s t"
  apply (unfold approx_stk_def approx_loc_def)
  apply (simp add: rev_map [THEN sym])
  done

lemma approx_stk_rev:
  "approx_stk G hp (rev s) t = approx_stk G hp s (rev t)"
  by (auto intro: subst [OF approx_stk_rev_lem])

lemma approx_stk_sup_heap:
  "\<lbrakk> approx_stk G hp stk ST; hp \<le>| hp' \<rbrakk> \<Longrightarrow> approx_stk G hp' stk ST"
  by (auto intro: approx_loc_sup_heap simp add: approx_stk_def)

lemma approx_stk_widen:
  "\<lbrakk> approx_stk G hp stk ST; G \<turnstile> map OK ST <=l map OK ST'; wf_prog wt G \<rbrakk>
  \<Longrightarrow> approx_stk G hp stk ST'"
  by (auto elim: approx_loc_widen simp add: approx_stk_def)

lemma approx_stk_Nil [iff]:
  "approx_stk G hp [] []"
  by (simp add: approx_stk_def)

lemma approx_stk_Cons [iff]:
  "approx_stk G hp (x#stk) (S#ST) =
  (approx_val G hp x (OK S) \<and> approx_stk G hp stk ST)"
  by (simp add: approx_stk_def)

lemma approx_stk_Cons_

lemma approx_stk_append:
  "approx_stk G hp stk (S@S') \<Longrightarrow>
  (\<exists>s stk'. stk = s@stk' \<and> length s = length S \<and> length stk' = length S' \<and>
            approx_stk G hp s S \<and> approx_stk G hp stk' S')"
  by (simp add: list_all2_append2 approx_stk_def approx_loc_def)

lemma approx_stk_all_widen:
  "\<lbrakk> approx_stk G hp stk ST; \<forall>(x, y) \<in> set (zip ST ST'). G \<turnstile> x \<preceq> y; length ST = length ST'; wf_prog wt G \<rbrakk>
  \<Longrightarrow> approx_stk G hp stk ST'"
apply (unfold approx_stk_def)
apply (clarsimp simp add: approx_loc_conv_all_nth all_set_conv_all_nth)
apply (erule allE, erule impE, assumption)
apply (erule allE, erule impE, assumption)
apply (erule conf_widen, assumption+)
done

subsection {* oconf *}

lemma oconf_field_update:
  "\<lbrakk>map_of (fields (G, oT)) FD = Some T; G,hp\<turnstile>v::\<preceq>T; G,hp\<turnstile>(oT,fs)\<surd> \<rbrakk>
  \<Longrightarrow> G,hp\<turnstile>(oT, fs(FD\<mapsto>v))\<surd>"
  by (simp add: oconf_def lconf_def)

lemma oconf_newref:
  "\<lbrakk>hp oref = None; G,hp \<turnstile> obj \<surd>; G,hp \<turnstile> obj' \<surd>\<rbrakk> \<Longrightarrow> G,hp(oref\<mapsto>obj') \<turnstile> obj \<surd>"
  apply (unfold oconf_def lconf_def)
  apply simp
  apply (blast intro: conf_hext hext_new)
  done

lemma oconf_heap_update:
  "\<lbrakk> hp a = Some obj'; obj_ty obj' = obj_ty obj''; G,hp\<turnstile>obj\<surd> \<rbrakk>
  \<Longrightarrow> G,hp(a\<mapsto>obj'')\<turnstile>obj\<surd>"
  apply (unfold oconf_def lconf_def)
  apply (fastforce intro: approx_val_heap_update)
  done

subsection {* hconf *}

lemma hconf_newref:
  "\<lbrakk> hp oref = None; G\<turnstile>h hp\<surd>; G,hp\<turnstile>obj\<surd> \<rbrakk> \<Longrightarrow> G\<turnstile>h hp(oref\<mapsto>obj)\<surd>"
  apply (simp add: hconf_def)
  apply (fast intro: oconf_newref)
  done

lemma hconf_field_update:
  "\<lbrakk> map_of (fields (G, oT)) X = Some T; hp a = Some(oT,fs);
     G,hp\<turnstile>v::\<preceq>T; G\<turnstile>h hp\<surd> \<rbrakk>
  \<Longrightarrow> G\<turnstile>h hp(a \<mapsto> (oT, fs(X\<mapsto>v)))\<surd>"
  apply (simp add: hconf_def)
  apply (fastforce intro: oconf_heap_update oconf_field_update
                  simp add: obj_ty_def)
  done

subsection {* preallocated *}

lemma preallocated_field_update:
  "\<lbrakk> map_of (fields (G, oT)) X = Some T; hp a = Some(oT,fs);
     G\<turnstile>h hp\<surd>; preallocated hp \<rbrakk>
  \<Longrightarrow> preallocated (hp(a \<mapsto> (oT, fs(X\<mapsto>v))))"
  apply (unfold preallocated_def)
  apply (rule allI)
  apply (erule_tac x=x in allE)
  apply simp
  apply (rule ccontr)
  apply (unfold hconf_def)
  apply (erule allE, erule allE, erule impE, assumption)
  apply (unfold oconf_def lconf_def)
  apply (simp del: split_paired_All)
  done

lemma
  assumes none: "hp oref = None" and alloc: "preallocated hp"
  shows preallocated_newref: "preallocated (hp(oref\<mapsto>obj))"
proof (cases oref)
  case (XcptRef x)
  with none alloc have False by (auto elim: preallocatedE [of _ x])
  thus ?thesis ..
next
  case (Loc l)
  with alloc show ?thesis by (simp add: preallocated_def)
qed

subsection {* correct-frames *}

lemmas [simp del] = fun_upd_apply

lemma correct_frames_field_update [rule_format]:
  "\<forall>rT C sig.
  correct_frames G hp phi rT sig frs \<longrightarrow>
  hp a = Some (C,fs) \<longrightarrow>
  map_of (fields (G, C)) fl = Some fd \<longrightarrow>
  G,hp\<turnstile>v::\<preceq>fd
  \<longrightarrow> correct_frames G (hp(a \<mapsto> (C, fs(fl\<mapsto>v)))) phi rT sig frs"
apply (induct frs)
 apply simp
apply clarify
apply (simp (no_asm_use))
apply clarify
apply (unfold correct_frame_def)
apply (simp (no_asm_use))
apply clarify
apply (intro exI conjI)
    apply assumption+
   apply (erule approx_stk_sup_heap)
   apply (erule hext_upd_obj)
  apply (erule approx_loc_sup_heap)
  apply (erule hext_upd_obj)
 apply assumption+
apply blast
done

lemma correct_frames_newref [rule_format]:
  "\<forall>rT C sig.
  hp x = None \<longrightarrow>
  correct_frames G hp phi rT sig frs \<longrightarrow>
  correct_frames G (hp(x \<mapsto> obj)) phi rT sig frs"
apply (induct frs)
 apply simp
apply clarify
apply (simp (no_asm_use))
apply clarify
apply (unfold correct_frame_def)
apply (simp (no_asm_use))
apply clarify
apply (intro exI conjI)
    apply assumption+
   apply (erule approx_stk_sup_heap)
   apply (erule hext_new)
  apply (erule approx_loc_sup_heap)
  apply (erule hext_new)
 apply assumption+
apply blast
done

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Words of Length 8"

theory Word_8
imports
  More_Word
  Enumeration_Word
  Even_More_List
  Signed_Words
  Word_Lemmas
begin

context
  includes bit_operations_syntax
begin

lemma len8: "len_of (x :: 8 itself) = 8" by simp

lemma word8_and_max_simp:
  \<open>x AND 0xFF = x\<close> for x :: \<open>8 word\<close>
  using word_and_full_mask_simp [of x]
  by (simp add: numeral_eq_Suc mask_Suc_exp)

lemma enum_word8_eq:
  \<open>enum = [0 :: 8 word, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
                            20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
                            37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53,
                            54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,
                            71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87,
                            88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103,
                            104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117,
                            118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131,
                            132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145,
                            146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159,
                            160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173,
                            174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187,
                            188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201,
                            202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215,
                            216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229,
                            230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243,
                            244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255]\<close> (is \<open>?lhs = ?rhs\<close>)
proof -
  have \<open>map unat ?lhs = [0..<256]\<close>
    by (simp add: enum_word_def comp_def take_bit_nat_eq_self map_idem_upt_eq unsigned_of_nat)
  also have \<open>\<dots> = map unat ?rhs\<close>
    by (simp add: upt_zero_numeral_unfold)
  finally show ?thesis
    using unat_inj by (rule map_injective)
qed

lemma set_enum_word8_def:
  "(set enum :: 8 word set) = {0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
                            20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36,
                            37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53,
                            54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70,
                            71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87,
                            88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103,
                            104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117,
                            118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, 129, 130, 131,
                            132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145,
                            146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159,
                            160, 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, 171, 172, 173,
                            174, 175, 176, 177, 178, 179, 180, 181, 182, 183, 184, 185, 186, 187,
                            188, 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, 201,
                            202, 203, 204, 205, 206, 207, 208, 209, 210, 211, 212, 213, 214, 215,
                            216, 217, 218, 219, 220, 221, 222, 223, 224, 225, 226, 227, 228, 229,
                            230, 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, 241, 242, 243,
                            244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255}"
  by (simp add: enum_word8_eq)

lemma set_strip_insert: "\<lbrakk> x \<in> insert a S; x \<noteq> a \<rbrakk> \<Longrightarrow> x \<in> S"
  by simp

lemma word8_exhaust:
  fixes x :: \<open>8 word\<close>
  shows "\<lbrakk>x \<noteq> 0; x \<noteq> 1; x \<noteq> 2; x \<noteq> 3; x \<noteq> 4; x \<noteq> 5; x \<noteq> 6; x \<noteq> 7; x \<noteq> 8; x \<noteq> 9; x \<noteq> 10; x \<noteq> 11; x \<noteq>
          12; x \<noteq> 13; x \<noteq> 14; x \<noteq> 15; x \<noteq> 16; x \<noteq> 17; x \<noteq> 18; x \<noteq> 19; x \<noteq> 20; x \<noteq> 21; x \<noteq> 22; x \<noteq>
          23; x \<noteq> 24; x \<noteq> 25; x \<noteq> 26; x \<noteq> 27; x \<noteq> 28; x \<noteq> 29; x \<noteq> 30; x \<noteq> 31; x \<noteq> 32; x \<noteq> 33; x \<noteq>
          34; x \<noteq> 35; x \<noteq> 36; x \<noteq> 37; x \<noteq> 38; x \<noteq> 39; x \<noteq> 40; x \<noteq> 41; x \<noteq> 42; x \<noteq> 43; x \<noteq> 44; x \<noteq>
          45; x \<noteq> 46; x \<noteq> 47; x \<noteq> 48; x \<noteq> 49; x \<noteq> 50; x \<noteq> 51; x \<noteq> 52; x \<noteq> 53; x \<noteq> 54; x \<noteq> 55; x \<noteq>
          56; x \<noteq> 57; x \<noteq> 58; x \<noteq> 59; x \<noteq> 60; x \<noteq> 61; x \<noteq> 62; x \<noteq> 63; x \<noteq> 64; x \<noteq> 65; x \<noteq> 66; x \<noteq>
          67; x \<noteq> 68; x \<noteq> 69; x \<noteq> 70; x \<noteq> 71; x \<noteq> 72; x \<noteq> 73; x \<noteq> 74; x \<noteq> 75; x \<noteq> 76; x \<noteq> 77; x \<noteq>
          78; x \<noteq> 79; x \<noteq> 80; x \<noteq> 81; x \<noteq> 82; x \<noteq> 83; x \<noteq> 84; x \<noteq> 85; x \<noteq> 86; x \<noteq> 87; x \<noteq> 88; x \<noteq>
          89; x \<noteq> 90; x \<noteq> 91; x \<noteq> 92; x \<noteq> 93; x \<noteq> 94; x \<noteq> 95; x \<noteq> 96; x \<noteq> 97; x \<noteq> 98; x \<noteq> 99; x \<noteq>
          100; x \<noteq> 101; x \<noteq> 102; x \<noteq> 103; x \<noteq> 104; x \<noteq> 105; x \<noteq> 106; x \<noteq> 107; x \<noteq> 108; x \<noteq> 109; x \<noteq>
          110; x \<noteq> 111; x \<noteq> 112; x \<noteq> 113; x \<noteq> 114; x \<noteq> 115; x \<noteq> 116; x \<noteq> 117; x \<noteq> 118; x \<noteq> 119; x \<noteq>
          120; x \<noteq> 121; x \<noteq> 122; x \<noteq> 123; x \<noteq> 124; x \<noteq> 125; x \<noteq> 126; x \<noteq> 127; x \<noteq> 128; x \<noteq> 129; x \<noteq>
          130; x \<noteq> 131; x \<noteq> 132; x \<noteq> 133; x \<noteq> 134; x \<noteq> 135; x \<noteq> 136; x \<noteq> 137; x \<noteq> 138; x \<noteq> 139; x \<noteq>
          140; x \<noteq> 141; x \<noteq> 142; x \<noteq> 143; x \<noteq> 144; x \<noteq> 145; x \<noteq> 146; x \<noteq> 147; x \<noteq> 148; x \<noteq> 149; x \<noteq>
          150; x \<noteq> 151; x \<noteq> 152; x \<noteq> 153; x \<noteq> 154; x \<noteq> 155; x \<noteq> 156; x \<noteq> 157; x \<noteq> 158; x \<noteq> 159; x \<noteq>
          160; x \<noteq> 161; x \<noteq> 162; x \<noteq> 163; x \<noteq> 164; x \<noteq> 165; x \<noteq> 166; x \<noteq> 167; x \<noteq> 168; x \<noteq> 169; x \<noteq>
          170; x \<noteq> 171; x \<noteq> 172; x \<noteq> 173; x \<noteq> 174; x \<noteq> 175; x \<noteq> 176; x \<noteq> 177; x \<noteq> 178; x \<noteq> 179; x \<noteq>
          180; x \<noteq> 181; x \<noteq> 182; x \<noteq> 183; x \<noteq> 184; x \<noteq> 185; x \<noteq> 186; x \<noteq> 187; x \<noteq> 188; x \<noteq> 189; x \<noteq>
          190; x \<noteq> 191; x \<noteq> 192; x \<noteq> 193; x \<noteq> 194; x \<noteq> 195; x \<noteq> 196; x \<noteq> 197; x \<noteq> 198; x \<noteq> 199; x \<noteq>
          200; x \<noteq> 201; x \<noteq> 202; x \<noteq> 203; x \<noteq> 204; x \<noteq> 205; x \<noteq> 206; x \<noteq> 207; x \<noteq> 208; x \<noteq> 209; x \<noteq>
          210; x \<noteq> 211; x \<noteq> 212; x \<noteq> 213; x \<noteq> 214; x \<noteq> 215; x \<noteq> 216; x \<noteq> 217; x \<noteq> 218; x \<noteq> 219; x \<noteq>
          220; x \<noteq> 221; x \<noteq> 222; x \<noteq> 223; x \<noteq> 224; x \<noteq> 225; x \<noteq> 226; x \<noteq> 227; x \<noteq> 228; x \<noteq> 229; x \<noteq>
          230; x \<noteq> 231; x \<noteq> 232; x \<noteq> 233; x \<noteq> 234; x \<noteq> 235; x \<noteq> 236; x \<noteq> 237; x \<noteq> 238; x \<noteq> 239; x \<noteq>
          240; x \<noteq> 241; x \<noteq> 242; x \<noteq> 243; x \<noteq> 244; x \<noteq> 245; x \<noteq> 246; x \<noteq> 247; x \<noteq> 248; x \<noteq> 249; x \<noteq>
          250; x \<noteq> 251; x \<noteq> 252; x \<noteq> 253; x \<noteq> 254; x \<noteq> 255\<rbrakk> \<Longrightarrow> P"
  apply (subgoal_tac "x \<in> set enum", subst (asm) set_enum_word8_def)
    apply (drule set_strip_insert, assumption)+
   apply (erule emptyE)
  apply (subst enum_UNIV, rule UNIV_I)
  done

end

end


theory Sepref_Additional
imports Sepref_Basic Sepref_Rules
begin

lemma hoare_alt:
  "<P> c <\<lambda>r. Q r > = (\<forall>h as n.
        pHeap h as n \<Turnstile> P \<longrightarrow> (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
        (pHeap h' (new_addrs h as h') (n - t) \<Turnstile> Q r \<and>
        t \<le> n \<and> relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h')))" (is "?L = (\<forall>h as n. ?H h as n \<longrightarrow> (\<exists>h' t r. _ \<and> ?P h as h' n t r))")
proof -
  have "?L = (\<forall>h as n. pHeap h as n \<Turnstile> P \<longrightarrow>
                  (\<forall> \<sigma> t r. run c (Some h) \<sigma> r t \<longrightarrow> \<sigma> \<noteq> None \<and> (?P h as (the \<sigma>) n t r)))"
    unfolding hoare_triple_def by auto
  also have "\<dots> =  (\<forall>h as n. pHeap h as n \<Turnstile> P \<longrightarrow>
              (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
                         ?P h as h' n t r))" apply(subst run_and_execute) by simp
  finally show ?thesis .
qed

lemma extract_cost_otherway:
  assumes
    "\<Gamma> * timeCredit_assn Cost_lb \<Longrightarrow>\<^sub>A G * F"
    "<G> c <\<lambda>r. Q r >"
    "\<And>r. Q r * F \<Longrightarrow>\<^sub>A \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up>(ra \<in> dom M)) * true"
    "(\<And>c. c\<in>ran M \<Longrightarrow> Cost_lb \<le> c)"
  shows "hn_refine \<Gamma> c \<Gamma>' R (REST M)"
proof -
  note pre_rule[OF assms(1) frame_rule[OF assms(2)]]
  then have TR: "\<And>h as n. pHeap h as n \<Turnstile> \<Gamma> * timeCredit_assn Cost_lb \<Longrightarrow>
           (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
                     pHeap h' (new_addrs h as h') (n - t) \<Turnstile> Q r * F \<and> t \<le> n \<and> relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h')"
    unfolding hoare_alt by simp

  show ?thesis
    unfolding hn_refine_def apply auto
  proof -
    fix h as n
    assume "pHeap h as n \<Turnstile> \<Gamma>"
    then have "pHeap h as (n+Cost_lb) \<Turnstile> \<Gamma> * timeCredit_assn Cost_lb"
      by (simp add: mod_timeCredit_dest)
    from TR[OF this] obtain h' t r where "execute c h = Some (r, h', t)"
           and h: "pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile> Q r * F"
           and 3: "t \<le> n + Cost_lb" "relH {a. a < heap.lim h \<and> a \<notin> as} h h'" "heap.lim h \<le> heap.lim h'"
      by blast

    from h assms(3) have h': "pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile>   \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up> (ra \<in> dom M)) * true"
      by (simp add: entails_def)
    then have "\<exists>ra. pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile>   \<Gamma>' *  R ra r * \<up> (ra \<in> dom M) * true"
      by simp
    then obtain ra where h'': "pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile>   \<Gamma>' *  R ra r * \<up> (ra \<in> dom M) * true"
        by blast
    have "pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile>   (\<Gamma>' *  R ra r * true) * \<up> (ra \<in> dom M)"
      apply(rule entailsD[OF _ h''])  by (simp add: entails_triv move_back_pure')
    then have h'': "pHeap h' (new_addrs h as h') (n + Cost_lb - t) \<Turnstile>   \<Gamma>' *  R ra r * true" and radom: "ra \<in> dom M"
      using mod_pure_star_dist  by auto

    show "\<exists>h' t r. execute c h = Some (r, h', t) \<and>
                       (\<exists>ra Ca. Some (enat Ca) \<le> M ra \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') (n + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true) \<and>
                       relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'"
      apply(rule exI[where x=h']) apply(rule exI[where x=t]) apply(rule exI[where x=r])
      apply safe apply fact
          apply(rule exI[where x=ra])
        apply(rule exI[where x=Cost_lb])
        apply safe
      subgoal using assms(4) radom using ranI by force
      subgoal by fact
      subgoal using h'' mod_star_trueI by blast
       apply fact apply fact done
  qed
qed

lemma extract_cost_otherway':
  fixes R
  assumes
    "\<Gamma> * timeCredit_assn Cost_lb \<Longrightarrow>\<^sub>A G * F"
    "\<And>h. h\<Turnstile>\<Gamma> \<Longrightarrow> <G> c <\<lambda>r. Q r >"
    "\<And>r h. h\<Turnstile>\<Gamma> \<Longrightarrow> Q r * F \<Longrightarrow>\<^sub>A \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up>(ra \<in> dom M)) * true"
    "(\<And>c h. h\<Turnstile>\<Gamma> \<Longrightarrow> c\<in>ran M \<Longrightarrow> Cost_lb \<le> c)"
  shows "hn_refine \<Gamma> c \<Gamma>' R (REST M)"
  apply(rule hn_refine_preI)
  apply(rule extract_cost_otherway)
  using assms by auto

lemmas extr = extract_cost_otherway[where F=emp, simplified, OF ent_refl _ ent_refl]

lemma extr': "(\<And>M. m = SPECT M \<Longrightarrow> <\<Gamma> * timeCredit_assn Cost_lb> c <\<lambda>r. \<exists>\<^sub>Ara. \<Gamma>' * (R ra r * \<up> (ra \<in> dom M)) * true>) \<Longrightarrow>
(\<And>c M. m = SPECT M \<Longrightarrow> c \<in> ran M \<Longrightarrow> enat Cost_lb \<le> c) \<Longrightarrow> hn_refine \<Gamma> c \<Gamma>' R m"
  apply(cases m)
    subgoal by simp
  subgoal premises prems for M
    using extr[OF prems(1)[OF prems(3)] prems(2)[OF prems(3)]]  prems(3) by simp
  done

lemma hfrefb_to_hoare_triple:
   assumes
  "(\<And>M h c a t. P a \<Longrightarrow> D a \<le> t a \<Longrightarrow>  h\<Turnstile>fst RS a c \<Longrightarrow> g t a = SPECT M
       \<Longrightarrow> <fst RS a c * timeCredit_assn (D a)> f c <\<lambda>r. \<exists>\<^sub>Ara. snd RS a c * (T ra r * \<up> (ra \<in> dom M)) * true>)"
  "(\<And>co M h c a t. P a \<Longrightarrow> D a \<le> t a \<Longrightarrow> h\<Turnstile>fst RS a c \<Longrightarrow> g t a = SPECT M \<Longrightarrow> co \<in> ran M
       \<Longrightarrow> enat (D a) \<le> co)"
shows "(f,g)\<in>hfrefb P D RS T"
  apply(rule hfrefbI)
  apply(rule hn_refine_preI)
  subgoal for c a t h
    apply(rule extr'[where Cost_lb="D a"])
     apply (rule assms(1)) apply simp_all
    apply (rule assms(2)) apply simp_all
    done
  done

subsection "how to extract a hoare triple from hn_refine"

lemma extract_cost_ub:
  assumes "hn_refine \<Gamma> c \<Gamma>' R (REST M)" "(\<And>c. c\<in>ran M \<Longrightarrow> c \<le> Cost_ub)"
  shows "<\<Gamma> * timeCredit_assn Cost_ub> c <\<lambda>r. \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up>(ra \<in> dom M)) >\<^sub>t"
  using assms(1)  unfolding hn_refine_def
  unfolding hoare_triple_def
  apply clarify
proof (goal_cases)
  case (1 h as \<sigma> r n t)
  from 1(2) have 2: "pHeap h as (n-Cost_ub) \<Turnstile> \<Gamma>" and  nf: "n\<ge>Cost_ub"
    using mod_timeCredit_dest by auto

  from 1(1) have 3: "\<And>h as n Ma.
       pHeap h as n \<Turnstile> \<Gamma> \<Longrightarrow>
      SPECT M = SPECT Ma \<Longrightarrow> (\<exists>h' t r. execute c h = Some (r, h', t) \<and>
       (\<exists>ra Ca. Ma ra \<ge> Some (enat Ca) \<and> t \<le> n + Ca \<and> pHeap h' (new_addrs h as h') ((n + Ca) - t) \<Turnstile> \<Gamma>' * R ra r * true) \<and>
      relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h')"
    by auto

  thm effect_deterministic

  from 3[OF 2 ] obtain h' t' r' where E: "execute c h = Some (r', h', t') " and
    R:  "(\<exists>ra Ca. M ra \<ge> Some (enat Ca) \<and>
                    pHeap h' (new_addrs h as h') (n - Cost_ub + Ca - t') \<Turnstile> \<Gamma>' * R ra r' * true \<and> t' \<le> n - Cost_ub + Ca) \<and>
           relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'" by blast

  have F: "\<sigma> = Some h'" and prime: "r' = r" "t' = t"
    using E 1(3) run.cases apply force
    using E 1(3) run.cases apply force
    using E 1(3) run.cases by force
  then have sig: "the \<sigma> = h'" by auto
  from R  have
    B: "(\<exists>ra Ca. M ra \<ge> Some (enat Ca) \<and>
     pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - Cost_ub + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true \<and>
        t \<le> n - Cost_ub + Ca )" and C:
    "relH {a. a < heap.lim h \<and> a \<notin> as} h (the \<sigma>)" "heap.lim h \<le> heap.lim (the \<sigma>) "
    unfolding prime sig by auto

  from B obtain ra Ca where i: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - Cost_ub + Ca - t) \<Turnstile> \<Gamma>' * R ra r * true"
    and ii:  "t \<le> n - Cost_ub + Ca"  and ineq: "M ra \<ge> Some (enat Ca)"
    using B by auto

  from ineq have radom: "ra \<in> dom M" using domIff by fastforce
  then obtain Mra where Mra: "M ra = Some Mra" by blast
  with assms(2) have "Mra \<le> enat Cost_ub" by (meson ranI)
  with Mra ineq have "Some (enat Ca) \<le> Some (enat Cost_ub)"
    using dual_order.trans by fastforce
  then have ie: "Ca \<le> Cost_ub" by auto

  have pr: "(n - Cost_ub + Ca - t) = (n - t) - (Cost_ub - Ca)" using ie ii nf by auto
  have pl: "(n - (t + (Cost_ub - Ca)) + (Cost_ub - Ca)) = n-t" using ii nf by auto

  have "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>) \<union> {}) ((n - t) - (Cost_ub - Ca) + (Cost_ub - Ca)) \<Turnstile> \<Gamma>' * R ra r * true * true"
    apply(rule mod_star_convI)  apply simp
     apply(rule i[unfolded pr])  by (simp add: top_assn_rule)

  then have H: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * R ra r * true * true"
    by (simp add: pl)

  have "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * R ra r * \<up> (ra \<in> dom M) * true"
    apply(rule entailsD[OF _ H]) using radom by auto2
  then have "\<exists>ra. pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * R ra r * \<up> (ra \<in> dom M) * true"
    by blast
  then have H': "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> (\<exists>\<^sub>Ara. \<Gamma>' *  R ra r * \<up> (ra \<in> dom M) * true)"
    using mod_ex_dist by blast
  have H: "pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up> (ra \<in> dom M)) * true"
    apply(rule entailsD[OF _ H']) by auto2

  from ii ie nf have T: "t \<le> n " by auto

  show ?case
    apply safe
    subgoal using F by auto
    subgoal using H by simp
    subgoal by fact
     apply fact apply fact done
qed

lemma r: "ran (\<lambda>v. if M v then Some (t v) else None) = {t v |v. M v}"
  by (auto simp: ran_is_image domIff split: if_splits)

lemma d: "ra \<in> dom (\<lambda>v. if M v then Some (t v) else None) \<longleftrightarrow> M ra"
  unfolding domIff by (auto)

lemma extract_cost_ub_SPEC: "hn_refine \<Gamma> c \<Gamma>' R (SPEC M t) \<Longrightarrow> (\<And>c. M c \<Longrightarrow> t c \<le> enat Cost_ub) \<Longrightarrow> <\<Gamma> * timeCredit_assn Cost_ub> c <\<lambda>r. \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up> (M ra))>\<^sub>t"
  unfolding SPEC_def
  apply(drule extract_cost_ub[where Cost_ub=Cost_ub])
  by (auto simp: r d)

lemma hnr_hoare_triple_SPEC_conv: "hn_refine \<Gamma> c \<Gamma>' R (SPEC P (\<lambda>_. t)) =  <\<Gamma> * timeCredit_assn t> c <\<lambda>r. \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up> (P ra))>\<^sub>t"
  apply(rule)
  subgoal apply(rule extract_cost_ub_SPEC) by auto
  subgoal unfolding SPEC_def apply(rule extract_cost_otherway[where Cost_lb="t" and F="emp"])
       defer apply assumption apply (auto split:  if_splits simp: domIff)[]
    apply solve_entails
apply (auto split:  if_splits simp: domIff)[]
    by(auto split: if_splits simp: ran_def)
  done

lemma post_rulet:
  "<P> f <Q>\<^sub>t \<Longrightarrow> \<forall>x. Q x \<Longrightarrow>\<^sub>A R x * true \<Longrightarrow> <P> f <R>\<^sub>t"
  apply(rule post_rule[where Q="\<lambda>x. Q x * true"])
  apply auto apply(rule ent_true_drop(1)) by simp

 lemma ht_cons_rule:
  assumes CPRE: "P \<Longrightarrow>\<^sub>A P'"
  assumes CPOST: "\<And>x. Q x \<Longrightarrow>\<^sub>A Q' x"
  assumes R: "<P'> c <Q>"
  shows "<P> c <Q'>" apply(rule cons_post_rule[OF _ CPOST])
   by(rule pre_rule[OF CPRE R])

lemma extract_cost_ub':
  assumes "hn_refine \<Gamma> c \<Gamma>' R (REST M)" "(\<And>c. c\<in>ran M \<Longrightarrow> c \<le> Cost_ub)"
   and pre: "P \<Longrightarrow>\<^sub>A \<Gamma> * timeCredit_assn Cost_ub"
   and post: "\<forall>r. \<Gamma>' * (\<exists>\<^sub>Ara. R ra r * \<up>(ra \<in> dom M)) \<Longrightarrow>\<^sub>A Q r * true"
 shows "<P> c <Q>\<^sub>t"
  apply(rule pre_rule[OF pre])
  apply(rule post_rulet[OF _ post])
  apply(rule extract_cost_ub) by fact+

lemma hn_refineI:
  shows "tt = enat ttt ==> <\<Gamma> * timeCredit_assn ttt> C <\<lambda>r. \<Gamma>' *  RR ra r>\<^sub>t \<Longrightarrow> hn_refine \<Gamma> C \<Gamma>'  RR (SPECT [ra \<mapsto> tt])"
    apply(rule extract_cost_otherway[where F=emp and Cost_lb=ttt and G=" \<Gamma> * timeCredit_assn ttt"])
     apply solve_entails apply simp  apply simp apply solve_entails by simp
lemma RETURNT_SPECT_conv: "RETURNT r = SPECT [r \<mapsto> 0]" unfolding RETURNT_def by auto
lemma hn_refineI0:
  shows "<\<Gamma>> C <\<lambda>r. \<Gamma>' *  RR ra r>\<^sub>t \<Longrightarrow> hn_refine \<Gamma> C \<Gamma>'  RR (RETURNT ra)"
  unfolding RETURNT_SPECT_conv
    apply(rule extract_cost_otherway[where F=emp and Cost_lb=0 and G=" \<Gamma> * timeCredit_assn 0"])
     apply solve_entails apply (simp add: zero_time)  apply simp apply solve_entails by (simp add: zero_enat_def)

end


section \<open>Implementation of Heaps with Arrays\<close>
theory IICF_Impl_Heap
imports
  IICF_Abs_Heap
  "../IICF_Array"
  "../IICF_Array_List"
begin

  (* TODO: Move *)

  term al_assn

  (* TODO: Move *)
  lemma size_mset_param[param]: "(size,size)\<in>\<langle>A\<rangle>mset_rel \<rightarrow> nat_rel"
    by (auto simp: mset_rel_def p2rel_def rel_mset_size)

  (* TODO: Move *)
  lemma rdomp_ref_mk_assn_iff[simp]: "rdomp \<upharpoonleft>(mk_assn A) = rdomp A"
    by (auto simp: rdomp_def)

  thm vcg_prep_ext_rules

  find_theorems pure_part

  lemma rdomp_arl_assn_len:
    assumes "rdomp \<upharpoonleft>(arl_assn:: ('a::llvm_rep list, 'l::len2 word \<times> 'l word \<times> 'a ptr) dr_assn) xs"
    shows "length xs < max_snat LENGTH('l)"
    using assms
    by (auto
      simp: rdomp_def arl_assn_def arl_assn'_def sep_algebra_simps pred_lift_extract_simps
      simp: snat.assn_def
      )

  find_theorems vassn_tag hn_refine

  (* TODO: Very specialized workaround lemma, to work around invalid-recombination
    problem for case that B is pure
  *)
  lemma workaround_invalid_recombine_pure2: "is_pure B \<Longrightarrow> hn_ctxt (invalid_assn A \<times>\<^sub>a 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

  (* TODO: Move
    TODO: Should be generic algorithm!
  *)
  lemma mop_list_swap_unfold: "mop_list_swap xs i j = do {
    xi \<leftarrow> mop_list_get xs i;
    xj \<leftarrow> mop_list_get xs j;
    xs \<leftarrow> mop_list_set xs i xj;
    mop_list_set xs j xi
  }"
  by (auto simp: pw_eq_iff refine_pw_simps swap_def)

  text \<open>We implement the heap data structure by an array.
    The implementation is automatically synthesized by the Sepref-tool.
    \<close>
  subsection \<open>Setup of the Sepref-Tool\<close>

  (* TODO: Move *)
  lemma mset_rel_id: "\<langle>Id\<rangle>mset_rel = Id"
    unfolding mset_rel_def apply (simp add: rel2p multiset.rel_eq)
    by (simp only: p2rel)

  locale heap_impl = heapstruct 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 defines "N\<equiv>LENGTH('l)"
    (*assumes l_len[simp,arith]: "4 < LENGTH('l)"*)
  begin

    abbreviation "assn \<equiv> al_assn' TYPE('l) elem_assn"
    abbreviation "idx_assn \<equiv> snat_assn' TYPE('l)"
    definition "heap_assn \<equiv> hr_comp (al_assn elem_assn) heap_rel1"

    lemma mk_free_heap_assn[sepref_frame_free_rules]: "MK_FREE heap_assn arl_free"
      unfolding heap_assn_def
      by (rule sepref_frame_free_rules)+

    (*context
      assumes l_len_pre: "(4 < LENGTH('l))"
    begin
      private lemma l_len: "4 < LENGTH('l)" using l_len_pre unfolding vcg_tag_defs by auto
    *)

      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]

      sepref_register update_op
      sepref_definition update_impl is "uncurry2 update_op"
        :: "assn\<^sup>d *\<^sub>a idx_assn\<^sup>k *\<^sub>a elem_assn\<^sup>k \<rightarrow>\<^sub>a assn"
        unfolding update_op_def[abs_def]
        apply (annot_snat_const "TYPE('l)")
        by sepref
      lemmas [sepref_fr_rules] = update_impl.refine

      sepref_register val_of_op
      sepref_definition val_of_impl is "uncurry val_of_op" :: "assn\<^sup>k *\<^sub>a idx_assn\<^sup>k \<rightarrow>\<^sub>a elem_assn"
        unfolding val_of_op_def[abs_def]
        apply (annot_snat_const "TYPE('l)")
        by sepref
      lemmas [sepref_fr_rules] = val_of_impl.refine

      sepref_register exch_op
      sepref_definition exch_impl is "uncurry2 exch_op" :: "assn\<^sup>d *\<^sub>a idx_assn\<^sup>k *\<^sub>a idx_assn\<^sup>k \<rightarrow>\<^sub>a assn"
        unfolding exch_op_def[abs_def] mop_list_swap_unfold
        apply (annot_snat_const "TYPE('l)")
        by sepref

      lemmas [sepref_fr_rules] = exch_impl.refine

      sepref_register valid
      sepref_definition valid_impl is "uncurry (RETURN oo valid)" :: "assn\<^sup>k *\<^sub>a idx_assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
        unfolding valid_def[abs_def]
        apply (annot_snat_const "TYPE('l)")
        by sepref
      lemmas [sepref_fr_rules] = valid_impl.refine

      sepref_register prio_of_op
      sepref_definition prio_of_impl is "uncurry (PR_CONST prio_of_op)" :: "assn\<^sup>k *\<^sub>a idx_assn\<^sup>k \<rightarrow>\<^sub>a prio_assn"
        unfolding prio_of_op_def[abs_def] PR_CONST_def
        by sepref
      lemmas [sepref_fr_rules] = prio_of_impl.refine

      sepref_definition append_impl is "uncurry mop_list_append"
        :: "[\<lambda>(xs,_). length xs + 1 < max_snat LENGTH('l)]\<^sub>a assn\<^sup>d *\<^sub>a elem_assn\<^sup>k \<rightarrow> assn"
        by sepref
      lemmas [sepref_fr_rules] = append_impl.refine

      sepref_register swim_op
      sepref_definition swim_impl is
        "uncurry (PR_CONST swim_op)" :: "[\<lambda>_. 4<LENGTH('l)]\<^sub>a assn\<^sup>d *\<^sub>a idx_assn\<^sup>k \<rightarrow> assn"
        unfolding swim_op_def[abs_def] parent_def PR_CONST_def
        apply (annot_snat_const "TYPE('l)")
        (* TODO: Workaround/Hack *)
        supply [sepref_frame_match_rules] = workaround_invalid_recombine_pure2[where B=snat_assn, simplified]
        by sepref_dbg_keep

      lemmas [sepref_fr_rules] = swim_impl.refine

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

      (*lemma bound_aux1: "rdomp assn xs \<Longrightarrow> j\<le>length xs div 2 \<Longrightarrow> 2*j < max_snat LENGTH('l)"
        apply sepref_bounds*)

      (*
      lemma bound_aux2: "\<lbrakk>rdomp assn a1'; 2 * a2' < length a1'\<rbrakk>
        \<Longrightarrow> Suc (2 * a2') < max_snat LENGTH('l)"
        apply sepref_bounds
        apply (drule al_assn_len_bound)
        by auto
      *)

      sepref_register sink_op
      sepref_definition sink_impl is "uncurry (PR_CONST sink_op)" :: "[\<lambda>_. 4<LENGTH('l)]\<^sub>a assn\<^sup>d *\<^sub>a idx_assn\<^sup>k \<rightarrow> assn"
        unfolding sink_op_opt_def[abs_def] sink_op_opt_eq[symmetric,abs_def]  PR_CONST_def
        unfolding overflow_safe_hbound_check Suc_eq_plus1
        (* TODO: Workaround/Hack *)
        supply [sepref_frame_match_rules] = workaround_invalid_recombine_pure2[where B=snat_assn, simplified]
        apply (annot_snat_const "TYPE('l)")
        by sepref

      lemmas [sepref_fr_rules] = sink_impl.refine

      lemma prenorm_heaprel1_len: "(h,m)\<in>heap_rel1 \<Longrightarrow> length h = size m"
        unfolding heap_rel1_def in_br_conv
        by auto
      lemma max_snat_param: "(max_snat,max_snat)\<in>nat_rel \<rightarrow> nat_rel" by simp

      context
        notes [fcomp_norm_unfold] = heap_assn_def[symmetric] list_rel_id_simp mset_rel_id
        notes [fcomp_prenorm_simps] = prenorm_heaprel1_len
        notes [param] = IdI[of N] max_snat_param
      begin

        sepref_definition empty_impl is "uncurry0 empty_op" :: "[\<lambda>_. 4<N]\<^sub>a unit_assn\<^sup>k \<rightarrow> assn"
          unfolding empty_op_def N_def
          apply (rewrite al_fold_custom_empty[where 'l='l])
          by sepref
        sepref_decl_impl (no_register) heap_empty: empty_impl.refine[FCOMP empty_op_refine]
          uses op_mset_empty.fref[of Id] .

        sepref_definition is_empty_impl is "is_empty_op" :: "assn\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
          unfolding is_empty_op_def[abs_def]
          apply (annot_snat_const "TYPE('l)")
          by sepref
        sepref_decl_impl heap_is_empty: is_empty_impl.refine[FCOMP is_empty_op_refine]
          uses op_mset_is_empty.fref[of Id] .

        sepref_definition insert_impl
          is "uncurry insert_op" :: "[\<lambda>(_,xs). 4<N \<and> length xs+1 < max_snat N]\<^sub>a elem_assn\<^sup>k *\<^sub>a assn\<^sup>d \<rightarrow> assn"
          unfolding insert_op_def[abs_def] append_op_def N_def
          by sepref
        sepref_decl_impl heap_insert: insert_impl.refine[FCOMP insert_op_refine]
          uses op_mset_insert.fref[of Id] .

        sepref_definition pop_min_impl is "pop_min_op" :: "[\<lambda>_. 4<N]\<^sub>a assn\<^sup>d \<rightarrow> elem_assn \<times>\<^sub>a assn"
          unfolding pop_min_op_def[abs_def] butlast_op_def N_def
          apply (annot_snat_const "TYPE('l)")
          by sepref
        sepref_decl_impl (no_mop) heap_pop_min: pop_min_impl.refine[FCOMP pop_min_op_refine]
          uses op_prio_pop_min.fref[of Id] .

        sepref_definition peek_min_impl is "peek_min_op" :: "assn\<^sup>k \<rightarrow>\<^sub>a elem_assn"
          unfolding peek_min_op_def[abs_def]
          apply (annot_snat_const "TYPE('l)")
          by sepref
        sepref_decl_impl (no_mop) heap_peek_min: peek_min_impl.refine[FCOMP peek_min_op_refine]
          uses op_prio_peek_min.fref[of Id] .

      end
    (*end        *)

  end

  global_interpretation heap_impl id snat_assn snat_assn return ll_icmp_sle ll_icmp_slt "TYPE('l::len2)" "LENGTH('l)"
    defines h_update_impl = update_impl
        and h_val_of_impl = val_of_impl
        and h_exch_impl = exch_impl
        and h_valid_impl = valid_impl
        and h_prio_of_impl = prio_of_impl
        and h_append_impl = append_impl
        and h_swim_impl = swim_impl
        and h_sink_impl = sink_impl
        and h_empty_impl = empty_impl
        and h_is_empty_impl = is_empty_impl
        and h_insert_impl = insert_impl
        and h_pop_min_impl = pop_min_impl
        and h_peek_min_impl = peek_min_impl

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

  lemmas heap_impl_inlines =
    heap_impl.valid_impl_def[OF heap_impl_axioms]
    heap_impl.prio_of_impl_def[OF heap_impl_axioms]
    heap_impl.val_of_impl_def[OF heap_impl_axioms]
    heap_impl.append_impl_def[OF heap_impl_axioms]
    heap_impl.exch_impl_def[OF heap_impl_axioms]
    heap_impl.empty_impl_def[OF heap_impl_axioms]
    heap_impl.is_empty_impl_def[OF heap_impl_axioms]
    heap_impl.insert_impl_def[OF heap_impl_axioms]
    heap_impl.pop_min_impl_def[OF heap_impl_axioms]
    heap_impl.peek_min_impl_def[OF heap_impl_axioms]

    h_swim_impl_def[symmetric]
    h_sink_impl_def[symmetric]

  lemmas [llvm_inline] = update_impl_def
  lemmas [llvm_inline] = val_of_impl_def
  lemmas [llvm_inline] = exch_impl_def
  lemmas [llvm_inline] = h_valid_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_prio_of_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_append_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_code] = h_swim_impl_def[unfolded heap_impl.swim_impl_def[OF heap_impl_axioms], unfolded heap_impl_inlines]
  lemmas [llvm_code] = h_sink_impl_def[unfolded heap_impl.sink_impl_def[OF heap_impl_axioms], unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_empty_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_is_empty_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_insert_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_pop_min_impl_def[unfolded heap_impl_inlines]
  lemmas [llvm_inline] = h_peek_min_impl_def[unfolded heap_impl_inlines]

  definition [simp]: "op_heap_custom_empty (_::'a::len2 itself) (_::'l::len2 itself) \<equiv> op_mset_empty"
  context fixes Q T :: "_::len2 itself" begin sepref_register "op_heap_custom_empty Q T" end

  lemma op_heap_custom_empty_hnr[sepref_fr_rules]:
    shows "(
      uncurry0 (empty_impl::('a::len2 word,'l)array_list llM ),
      uncurry0 (RETURN (PR_CONST (op_heap_custom_empty TYPE('a) TYPE('l))))) \<in> [\<lambda>_. 4<LENGTH('l::len2)]\<^sub>a unit_assn\<^sup>k \<rightarrow> heap_assn"
    unfolding op_heap_custom_empty_def PR_CONST_def
    by (rule heap_empty_hnr[unfolded PRECOND_def])

  lemma heap_fold_custom_empty:
    "{#} = op_heap_custom_empty TYPE('a::len2) TYPE('l::len2)"
    "op_mset_empty = op_heap_custom_empty TYPE('a::len2) TYPE('l::len2)"
    "mop_mset_empty = RETURN (op_heap_custom_empty TYPE('a::len2) TYPE('l::len2))"
    by auto

definition "sort_by_prio l\<^sub>0 \<equiv> do {
  q \<leftarrow> nfoldli l\<^sub>0 (\<lambda>_. True) (\<lambda>x q. do { ASSERT (size q < length l\<^sub>0); mop_mset_insert x q }) {#};
  ASSERT (q = mset l\<^sub>0);
  (l,q) \<leftarrow> WHILEIT (\<lambda>(l,q). sorted l \<and> (\<forall>x\<in>set l. \<forall>y\<in>#q. x\<le>y) \<and> mset l + q = mset l\<^sub>0)
    (\<lambda>(l,q). \<not>op_mset_is_empty q) (\<lambda>(l,q).
  do {
    (x,q) \<leftarrow> mop_prio_pop_min id q;
    ASSERT (size l < length l\<^sub>0);
    RETURN (l@[x],q)
  }) (op_list_empty,q);
  RETURN l
}"

lemma sort_by_prio_correct: "sort_by_prio l \<le> SPEC (\<lambda>l'. sorted l' \<and> mset l' = mset l)"
  unfolding sort_by_prio_def mop_prio_pop_min_def

  apply (refine_vcg
    nfoldli_rule[where I="\<lambda>ll _ q. q = mset ll"]
    WHILEIT_rule[where R="measure (\<lambda>(l,q). size q)"]
    )
  apply (auto 0 3 dest: in_diffD simp: size_Diff1_less sorted_append_bigger)
  subgoal by (metis add_cancel_right_right le_add1 nat_less_le size_eq_0_iff_empty size_mset size_union)
  subgoal by (metis insert_DiffM union_iff)
  done

(* TODO: Move  *)
function list_intv_induction where
  "list_intv_induction l u = (if l<u then list_intv_induction (Suc l) u else ())"
  by pat_completeness auto

termination
  apply (relation "measure (\<lambda>(l,u). u-l)")
  by auto

(*
lemma nfoldli_range_to_while: "nfoldli [l..<u] c f \<sigma> = do {
    (_,\<sigma>) \<leftarrow> WHILET
      (\<lambda>(i,\<sigma>). i<u \<and> c \<sigma>)
      (\<lambda>(i,\<sigma>). do { \<sigma> \<leftarrow> f i \<sigma>; ASSERT (i<u); RETURN (i+1,\<sigma>) })
      (l,\<sigma>);
    RETURN \<sigma>
  }"
proof (induction l u arbitrary: \<sigma> rule: list_intv_induction.induct)
  case (1 l u)
  show ?case proof (cases "l<u")
    case False thus ?thesis
      by (rewrite WHILET_unfold) simp

  next
    case True
    thm "1.IH"[OF True, abs_def]
    thus ?thesis
      by (rewrite WHILET_unfold) (simp add: upt_conv_Cons "1.IH"[OF True, abs_def])
  qed
qed
*)

sepref_definition sort_impl [llvm_code] is
  "sort_by_prio" :: "[\<lambda>l. length l < max_snat LENGTH(64)]\<^sub>a (al_assn' TYPE(64) (snat_assn' TYPE(64)))\<^sup>k \<rightarrow> al_assn' TYPE(64) (snat_assn' TYPE(64))"
  unfolding sort_by_prio_def[abs_def]
  apply (rewrite nfoldli_by_idx)
  apply (rewrite nfoldli_upt_by_while)
  apply (rewrite heap_fold_custom_empty[where 'l=64 and 'a="64"])
  apply (rewrite at op_list_empty al_fold_custom_empty[where 'l=64])
  apply (annot_snat_const "TYPE(64)")
  by sepref

export_llvm (no_header)
  sort_impl is "sort"
  "arl_new_raw :: (64 word,64) array_list llM" is "arl_new"
  "arl_push_back :: _ \<Rightarrow> _ \<Rightarrow> (64 word,64) array_list llM" is "arl_push_back"
  file "sort.ll"
  (* CAREFUL: The calling conventions generated by this LLVM code are hard/impossible to
    interface from C !? *)

end