From 500af34ed80ce7f70dc090215520a1f0c2f245c4 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 12 Feb 2026 16:18:36 +1100 Subject: [PATCH 01/39] monadic translator: More type-variable handling The monadic translator already includes code to substitute types if the supplied definition has a type variable for the state or exception type, e.g. if the relevant function didn't make use of the state or exception value so it was left fully polymorphic. Update this to also substitute type variables and print a message if the relevant types match but are not identical, e.g. if the state type has a polymorphic parameter that is not instantiated to the same thing. --- translator/monadic/ml_monad_translatorLib.sml | 68 ++++++++----------- 1 file changed, 27 insertions(+), 41 deletions(-) diff --git a/translator/monadic/ml_monad_translatorLib.sml b/translator/monadic/ml_monad_translatorLib.sml index 21489094b1..30995985da 100644 --- a/translator/monadic/ml_monad_translatorLib.sml +++ b/translator/monadic/ml_monad_translatorLib.sml @@ -2938,53 +2938,39 @@ fun abbrev_code (fname,ml_fname,def,th,v) = let (* Some definitions might have polymorphic state and exceptions: those types need to be instantiated before translation *) -fun instantiate_monadic_types def = let - val original_def = def - (* Retrieve the state and exceptions types *) - val def = List.hd (CONJUNCTS def) - val ty = concl def |> strip_forall |> snd |> rhs |> type_of - val state_ty = dest_type ty |> snd |> List.hd - val exn_ty = dest_type ty |> snd |> List.last |> dest_type |> snd |> - List.hd |> dest_type |> snd |> List.last - (* Instantiate them to the proper types *) - val def = - if is_vartype state_ty then - let - val def = Thm.INST_TYPE[state_ty |-> !(#refs_type translator_state)] - original_def - in - print "Instantiated polymorphic monadic state\n"; - def - end - else original_def - - val def = - if is_vartype exn_ty then - let - val def = Thm.INST_TYPE [exn_ty |-> !(#exn_type translator_state)] def - in - print "Instantiated polymorphic monadic exceptions\n"; - def - end - else def -in def end; - fun get_monadic_types_inst tm = let (* Retrieve the state and exceptions types *) val ty = type_of tm val state_ty = dest_type ty |> snd |> List.hd val exn_ty = dest_type ty |> snd |> List.last |> dest_type |> snd |> List.hd |> dest_type |> snd |> List.last - (* Instantiate them to the proper types *) - val tys = - if is_vartype state_ty then - [state_ty |-> !(#refs_type translator_state)] - else [] - val tys = - if is_vartype exn_ty - then (exn_ty |-> !(#exn_type translator_state)) :: tys - else tys -in tys end; + + fun print_inst inst = let + val strs = commafy (map (fn i => type_to_string (#redex i) ^ + " |-> " ^ type_to_string (#residue i)) inst) + in print (String.concat (strs @ ["\n"])) end + + val ref_state_ty = !(#refs_type translator_state) + val inst1 = case total (match_type state_ty) ref_state_ty of + SOME [] => [] + | SOME inst => (print "Instantiating polymorphic monadic state\n"; print_inst inst; inst) + | NONE => (print "Warning: no match on state type\n"; []) + + val ref_exn_ty = !(#exn_type translator_state) + val inst2 = case total (match_type exn_ty) ref_exn_ty of + SOME [] => [] + | SOME inst => (print "Instantiating polymorphic exception state\n"; print_inst inst; inst) + | NONE => (print "Warning: no match on exception type\n"; []) +in inst1 @ inst2 end; + +fun instantiate_monadic_types def = let + val original_def = def + + val def = List.hd (CONJUNCTS def) + val tm = concl def |> strip_forall |> snd |> rhs + val inst = get_monadic_types_inst tm + +in Thm.INST_TYPE inst original_def end; (****************************************************************************** From c4b6ccd5beef8e078f6ca11d3bfd12ff0f868cd8 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Tue, 3 Mar 2026 18:47:01 +1100 Subject: [PATCH 02/39] monadic translator: less dependent on const naming The existing monadic-translator interface code does a bit of guessing of various constant names, and needs to set the translator use_full_type_names setting to false to make the naming predictable enough. This makes the monadic translator incompatible with various translation contexts. Some of this code can be replaced by use of get_type_inv and other query functions to fetch the relevant constants. This seems to allow the monadic translator to run with use_full_type_names present, and doesn't seem to break anything. --- .../ml_monad_translator_interfaceLib.sig | 3 + .../ml_monad_translator_interfaceLib.sml | 60 ++++++++++--------- 2 files changed, 35 insertions(+), 28 deletions(-) diff --git a/translator/monadic/ml_monad_translator_interfaceLib.sig b/translator/monadic/ml_monad_translator_interfaceLib.sig index 7d9b8a6c03..5fe5af92df 100644 --- a/translator/monadic/ml_monad_translator_interfaceLib.sig +++ b/translator/monadic/ml_monad_translator_interfaceLib.sig @@ -47,6 +47,9 @@ signature ml_monad_translator_interfaceLib = sig + (* Sets up monadic syntax, Less invasive than the full version. *) + val minimal_set_up_monadic_translator : unit -> unit + val set_up_monadic_translator : unit -> unit type term = Term.term diff --git a/translator/monadic/ml_monad_translator_interfaceLib.sml b/translator/monadic/ml_monad_translator_interfaceLib.sml index 307d7a575d..737e9d5ba8 100644 --- a/translator/monadic/ml_monad_translator_interfaceLib.sml +++ b/translator/monadic/ml_monad_translator_interfaceLib.sml @@ -15,9 +15,13 @@ open preamble ml_monadBaseLib ml_monadStoreLib ml_monad_translatorLib ******************************************************************************) -fun set_up_monadic_translator () = let +(* Sidestep setting up "syntax" libraries, fetch const from def. *) +fun left_const thm = concl thm + |> strip_conj |> hd |> strip_forall |> snd |> lhs + |> strip_comb |> fst + +fun minimal_set_up_monadic_translator () = let (* Add monadic syntax: do x <- f y; ... od *) - val _ = ParseExtras.temp_loose_equality(); val _ = monadsyntax.temp_add_monadsyntax() (* Parser overloadings *) @@ -25,6 +29,15 @@ fun set_up_monadic_translator () = let val _ = Parse.temp_overload_on("monad_unitbind",ml_monadBaseSyntax.st_ex_ignore_bind_tm); val _ = Parse.temp_overload_on("monad_ignore_bind",ml_monadBaseSyntax.st_ex_ignore_bind_tm); val _ = Parse.temp_overload_on("return",ml_monadBaseSyntax.st_ex_return_tm); + val _ = Parse.temp_overload_on("monad_ignore_bind", ign_c); + val _ = Parse.temp_overload_on("return", left_const st_ex_return_def); +in () end + +fun set_up_monadic_translator () = let + (* Take all steps taken by a previous version. *) + val _ = ParseExtras.temp_loose_equality(); + + val _ = minimal_set_up_monadic_translator(); (* Hide "state" due to semanticPrimitives *) val _ = hide "state"; @@ -39,7 +52,7 @@ in () end ******************************************************************************) -fun toUppers(str) = String.implode (map Char.toUpper (String.explode str)); +val unit_ty = type_of (left_const oneTheory.one_DEF); val unit_ty = oneSyntax.one_ty; @@ -56,8 +69,6 @@ datatype translator_mode = GLOBAL | LOCAL; type state = { state_access_funs : (string * thm * thm) list ref, (* (name, get, set) *) - store_invariant_name : string ref, - store_exn_invariant_name : string ref, exn_type_def : thm ref, additional_type_theories : string list ref, hprop_field_names : (term * string) list ref, @@ -71,8 +82,6 @@ type state = { (* Initial internal state *) val internal_state : state = { state_access_funs = ref [], - store_invariant_name = ref "STATE_STORE", - store_exn_invariant_name = ref "STATE_EXN", exn_type_def = ref ml_translatorTheory.UNIT_TYPE_def, additional_type_theories = ref [], hprop_field_names = ref [], @@ -139,27 +148,27 @@ fun with_state state_type (translator_config : config) = let val accessors = define_monad_access_funs state_type in #state_type internal_state := state_type; - #store_invariant_name internal_state := - (state_type |> dest_type |> fst |> toUppers); #state_access_funs internal_state := accessors; translator_config end; +(* This hack also used in ml_translatorLib. *) +fun guess_const_def tm = let + val stuff = dest_thy_const tm + in DB.fetch (#Thy stuff) (#Name stuff ^ "_def") end + (* * Register the exception type and return the type definition *) fun register_exception_type exn_type = - let val exn_name = (exn_type |> dest_type |> fst |> toUppers) - val exn_type_def_name = exn_name ^ "_TYPE_def" - in ( + ( register_type oneSyntax.one_ty; register_type (pairSyntax.mk_prod(alpha,beta)); register_type (listSyntax.mk_list_type alpha); register_type (optionSyntax.mk_option alpha); register_exn_type exn_type; - #store_exn_invariant_name internal_state := exn_name; - theorem exn_type_def_name - ) end; + guess_const_def (get_type_inv exn_type) + ); (* * Set the exception type, and get monadic exception functions @@ -345,7 +354,7 @@ fun extract_farrays_manip_funs (name, init, get, set, len, sub, upd) = local val IMP_STAR_GC = Q.prove( - `(STAR a x) s ∧ (y = GC) ⇒ (STAR a y) s`, + `(STAR a x) s ∧ (y = cfHeapsBase$GC) ⇒ (STAR a y) s`, fs [set_sepTheory.STAR_def] >> rw [] >> asm_exists_tac >> fs [] >> EVAL_TAC >> @@ -357,11 +366,9 @@ local in fun add_field_access_patterns (hprop_comb, field_name) = let - val store_inv_name = ( !(#store_invariant_name internal_state) ) val state_ty = ( !(#state_type internal_state) ) - val state_predicate = - if state_ty = unit_ty then ml_translatorSyntax.UNIT_TYPE - else Term [QUOTE store_inv_name] + val state_predicate = get_type_inv state_ty + val state_predicate_def = guess_const_def state_predicate val field = Term [QUOTE field_name] val st_field = Term [QUOTE "st.", QUOTE field_name] @@ -383,7 +390,7 @@ in impl_tac >- ( fs [ml_monad_translatorBaseTheory.REFS_PRED_def] >> - fs [fetch "-" (store_inv_name ^ "_def")] >> + fs [state_predicate_def] >> qabbrev_tac `a = ^hprop_comb ^st_field` >> qabbrev_tac `b = GC` >> fs [AC set_sepTheory.STAR_ASSOC set_sepTheory.STAR_COMM] >> @@ -398,18 +405,15 @@ in Cases_on `f ^st_field` >> fs [] >> EVERY_CASE_TAC >> rveq >> fs [] >> - fs [fetch "-" (store_inv_name ^ "_def")] >> + fs [state_predicate_def] >> fs [ml_monadBaseTheory.liftM_def] >> rw [] >> rfs[] >> fs[HPROP_COMB_STAR_COMM, set_sepTheory.STAR_ASSOC] >> metis_tac[set_sepTheory.STAR_ASSOC] ) - val state_exn_name = ( !(#store_exn_invariant_name internal_state) ) val state_exn_ty = ( !(#exn_type internal_state) ) - val state_exn_predicate = - if state_exn_ty = unit_ty then ml_translatorSyntax.UNIT_TYPE - else Term [QUOTE state_exn_name, QUOTE "_TYPE"] + val state_exn_predicate = get_type_inv state_exn_ty val access_thm_list = mapfilter (fn ((_, name), (thm, Thm, _)) => (name^"_"^field_name, thm) @@ -465,7 +469,7 @@ fun start_translation (translator_config : config) = ((!(#refs c) ) |> map from_named_tuple_refs) ((!(#resizeable_arrays c) ) |> map from_named_tuple_rarray) ((!(#fixed_arrays c) ) |> map from_named_tuple_farray) - ( !(#store_invariant_name s) ) + ((!(#state_type c) ) |> dest_type |> fst |> (fn s => s^"_STORE_INV")) ( !(#state_type c) ) ( !(#exn_type_def s) ) ((!(#exn_access_funs c) ) |> map from_named_tuple_exn) @@ -486,7 +490,7 @@ fun start_translation (translator_config : config) = map extract_rarrays_manip_funs) ((!(#fixed_arrays c) ) |> map from_named_tuple_farray |> map extract_farrays_manip_funs) - ( !(#store_invariant_name s) ) + ((!(#state_type c) ) |> dest_type |> fst |> (fn s => s^"_STORE_INV")) ( !(#state_type c) ) ( !(#exn_type_def s) ) ((!(#exn_access_funs c) ) |> map from_named_tuple_exn) From 517a77dfc4b17ea78bf0e6a940fea0107fa7ef29 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Wed, 4 Mar 2026 16:47:28 +1100 Subject: [PATCH 03/39] monadic translator: polymorphism debug and bugfix Handle a case where the updator for a polymorphic state field is too general. This is a bit of a HOL4 specialty, where a record has a type variable (say 'a) that appears in only one field, and an updator for that field is allowed to change the type of the overall datatype by replacing the field. There was already code for handling this in the monad translator, it just seemed to miss a case. I found it by adding some more error diagnostic code along the way, and I might leave it in. --- translator/monadic/ml_monadStoreLib.sml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/translator/monadic/ml_monadStoreLib.sml b/translator/monadic/ml_monadStoreLib.sml index 21d8719186..b93577bd43 100644 --- a/translator/monadic/ml_monadStoreLib.sml +++ b/translator/monadic/ml_monadStoreLib.sml @@ -114,7 +114,14 @@ fun mk_get_refs state = let val get_refs = mk_comb(get_refs, state) |> BETA_CONV |> concl |> rand in get_refs end - +(* wrap ISPECL to give more detailed error. *) +fun ISPECL terms thm = Drule.ISPECL terms thm + handle HOL_ERR err => ( + print "ISPECL failed:\n"; + List.app print_term terms; + print_thm thm; + Drule.ISPECL terms thm + ) fun mk_REF_REL TYPE r x = ISPECL [TYPE, r, x] REF_REL_def |> concl |> dest_eq |> fst @@ -1008,6 +1015,8 @@ fun prove_store_access_specs refs_manip_list in (eval_th, true) end handle HOL_ERR _ => (TRUTH, false) + (* Handle annoying situations where ``\st. st with <| arr := xs |>`` + gets type ``: 'a state => 'b state``. FIXME: same fix for farray? *) val set_subst = let val set_type = type_of set_arr |> dom_rng |> snd |> dom_rng in match_type (snd set_type) (fst set_type) end @@ -1024,7 +1033,7 @@ fun prove_store_access_specs refs_manip_list in rewrite_thm th end else let val th = - ISPECL[name_v,loc,TYPE,EXN_TYPE,H_part,get_arr,set_arr, + ISPECL[name_v,loc,TYPE,EXN_TYPE,H_part,get_arr,set_arr', update_exn,update_rexp] EvalM_R_Marray_update_handle val th = SPEC_ALL th |> UNDISCH |> UNDISCH val th = remove_assumption th |> remove_assumption From 5630e679831c4555c894542abd8e834d09065f80 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Tue, 27 Jan 2026 13:12:36 +1100 Subject: [PATCH 04/39] Add a pure model of heap-sort-in-array (#979) The idea is to write a sort function with a O(n * log(n)) complexity, which exposes a pure functional interface but which uses a mutable array to actually do the rearrangement. This pure file presents a heap-sort algorithm, which the mutable array modelled as a function. Correctness is verified. The next step is to translate or present some CakeML code that implements this algorithm with a mutable array. --- basis/pure/heap_sort_in_funScript.sml | 450 ++++++++++++++++++++++++++ 1 file changed, 450 insertions(+) create mode 100644 basis/pure/heap_sort_in_funScript.sml diff --git a/basis/pure/heap_sort_in_funScript.sml b/basis/pure/heap_sort_in_funScript.sml new file mode 100644 index 0000000000..a72c982057 --- /dev/null +++ b/basis/pure/heap_sort_in_funScript.sml @@ -0,0 +1,450 @@ +(* + Heap-sort in an array, where the array is represented by a function. + + Used to verify a stateful heap sort which uses a mutable array to + hold the heap contents during sorting, e.g. one written in CakeML. + + Could potentially move out of CakeML to HOL4 sorting theories. +*) +Theory heap_sort_in_fun +Ancestors + list rich_list sorting container bag + + +Definition heap_inv_def: + heap_inv R sz hp = (! i. 1n < i /\ i <= sz ==> R (hp (i DIV 2)) (hp i)) +End + +Theorem heap_inv_thm = hd (RES_CANON heap_inv_def) + +Theorem div_2_idem_lemma[local]: + (i = i DIV 2) = (i = 0) +Proof + qspec_then `i` assume_tac arithmeticTheory.ODD_OR_EVEN + \\ fs [] +QED + +Theorem heap_inv_min: + heap_inv R sz hp ==> + transitive R ==> + reflexive R ==> + 1 <= i /\ i <= sz ==> + R (hp 1) (hp i) +Proof + measureInduct_on `I i` + \\ rw [] + \\ fs [] + \\ Cases_on `i = 1` + \\ fs [relationTheory.reflexive_def] + \\ fs [relationTheory.transitive_def] + \\ first_x_assum irule + \\ qexists_tac `hp (i DIV 2)` + \\ drule_then (simp o single) heap_inv_thm + \\ first_x_assum irule + \\ simp [arithmeticTheory.X_LE_DIV] +QED + +Theorem heap_inv_upd: + heap_inv R sz hp ==> + 0 < i ==> + (1 < i ==> R (hp (i DIV 2)) x) ==> + (i * 2 <= sz ==> R x (hp (i * 2))) ==> + (i * 2 + 1 <= sz ==> R x (hp (i * 2 + 1))) ==> + heap_inv R sz (hp(|i |-> x|)) +Proof + rw [heap_inv_def] + \\ first_x_assum (qspec_then `i'` assume_tac) + \\ fs [combinTheory.UPDATE_def] + \\ rw [] \\ gs [div_2_idem_lemma] + \\ qspec_then `i'` assume_tac arithmeticTheory.ODD_OR_EVEN + \\ gs [] +QED + +Definition heap_contents_def: + heap_contents sz hp = LIST_TO_BAG (GENLIST (hp o ((+) 1)) sz) +End + +Theorem heap_contents_mem: + 0 < i /\ i <= sz ==> BAG_IN (hp i) (heap_contents sz hp) +Proof + rw [heap_contents_def, IN_LIST_TO_BAG, MEM_GENLIST] + \\ qexists_tac `i - 1` + \\ simp [] +QED + +Theorem heap_contents_upd: + heap_contents sz (hp(|i |-> x|)) = (if 0 < i /\ i <= sz + then BAG_UNION (heap_contents sz hp) {|x|} - {|hp i|} + else heap_contents sz hp) +Proof + simp [heap_contents_def] + \\ rw [] + >- ( + qspecl_then [`hp`, `sz - (i - 1)`, `i - 1`] + (mp_tac o Q.GEN `hp`) GENLIST_APPEND + \\ rw [LIST_TO_BAG_APPEND] + \\ subgoal `sz + 1 - i = SUC (sz - i)` + \\ simp [GENLIST_CONS, BAG_UNION_INSERT] + \\ ONCE_REWRITE_TAC [BAG_INSERT_commutes] + \\ simp [] + \\ irule (Q.prove (`(a = c) /\ (b = d) ==> (BAG_UNION a b = BAG_UNION c d)`, metis_tac [])) + \\ rw [] + \\ AP_TERM_TAC + \\ irule GENLIST_CONG + \\ simp [combinTheory.UPDATE_APPLY] + ) + >- ( + AP_TERM_TAC + \\ irule GENLIST_CONG + \\ simp [combinTheory.UPDATE_APPLY] + ) +QED + +Definition heap_insert_larger_def: + heap_insert_larger R sz i x hp = (if i = 0 then hp + else if (i * 2) + 1 <= sz /\ R (hp ((i * 2) + 1)) x /\ R (hp ((i * 2) + 1)) (hp (i * 2)) + then heap_insert_larger R sz ((i * 2) + 1) x (hp(|i |-> hp ((i * 2) + 1)|)) + else if i * 2 <= sz /\ R (hp (i * 2)) x /\ ((i * 2) + 1 <= sz ==> R (hp (i * 2)) (hp ((i * 2) + 1))) + then heap_insert_larger R sz (i * 2) x (hp(|i |-> hp (i * 2)|)) + else hp(| i |-> x |)) +Termination + qexists_tac `measure (\(_, sz, i, _). sz - i)` + \\ simp [] +End + +Theorem total_lemma[local]: + total R ==> ~ R x y ==> R y x +Proof + metis_tac [relationTheory.total_def] +QED + +Theorem transitive_lemma[local] = hd (RES_CANON relationTheory.transitive_def) + +Theorem heap_insert_larger_inv: + heap_inv R sz hp ==> R (hp i) x ==> 0 < i ==> i <= sz ==> + reflexive R ==> transitive R ==> total R ==> + heap_inv R sz (heap_insert_larger R sz i x hp) +Proof + qid_spec_tac `hp` + \\ measureInduct_on `(\i. sz - i) i` + \\ rw [] \\ fs [] + \\ drule_then (qspec_then `i` mp_tac) heap_inv_thm + \\ drule_then (qspec_then `i * 2` mp_tac) heap_inv_thm + \\ drule_then (qspec_then `i * 2 + 1` mp_tac) heap_inv_thm + \\ ONCE_REWRITE_TAC [heap_insert_larger_def] + \\ rw [] \\ fs [] + \\ TRY (first_x_assum irule) + \\ irule_at Any heap_inv_upd + \\ fs [relationTheory.reflexive_def, combinTheory.UPDATE_APPLY] + \\ rw [] + \\ drule_then (fsrw_tac [SFY_ss] o single) transitive_lemma + \\ drule_then (simp o single) total_lemma + \\ metis_tac [transitive_lemma, total_lemma] +QED + +Theorem heap_insert_larger_contents: + heap_contents sz (heap_insert_larger R sz i x hp) = + heap_contents sz (hp (|i |-> x|)) +Proof + qid_spec_tac `hp` + \\ measureInduct_on `(\i. sz - i) i` + \\ rw [] + \\ ONCE_REWRITE_TAC [heap_insert_larger_def] + \\ mp_tac heap_contents_mem + \\ rw [] \\ fs [] + \\ simp [heap_contents_upd, combinTheory.UPDATE_APPLY] + \\ simp [BAG_UNION_INSERT] + \\ fs [GSYM BAG_DIFF_INSERT_SUB_BAG] + \\ metis_tac [BAG_DIFF_INSERT_SUB_BAG, BAG_INSERT_commutes, + BAG_DIFF_2L, COMM_BAG_UNION, BAG_DIFF_INSERT_same, + BAG_DIFF_EMPTY] +QED + +Definition heap_pop_def: + heap_pop R sz hp = (hp 1, heap_insert_larger R (sz - 1) 1 (hp sz) hp) +End + +Theorem heap_pop_inv: + heap_inv R sz hp ==> 0 < sz ==> + reflexive R ==> transitive R ==> total R ==> + heap_inv R (sz - 1) (SND (heap_pop R sz hp)) +Proof + rw [heap_pop_def] + \\ Cases_on `sz = 1` + >- ( + simp [heap_inv_def] + ) + \\ irule heap_insert_larger_inv + \\ simp [] + \\ drule_then (irule_at Any) heap_inv_min + \\ simp [] + \\ fs [heap_inv_def] +QED + +Theorem heap_pop_contents: + (heap_pop R sz hp = (x, hp2)) ==> + 0 < sz ==> + (BAG_UNION {|x|} (heap_contents (sz - 1) hp2) = + heap_contents sz hp) +Proof + simp [heap_pop_def] + \\ rw [] + \\ simp [heap_insert_larger_contents, heap_contents_upd] + \\ Cases_on `sz = 1` \\ fs [] + \\ simp [heap_contents_def] + \\ Cases_on `sz` \\ fs [] + \\ simp [GENLIST, SNOC_APPEND, LIST_TO_BAG_APPEND] + \\ Cases_on `n` \\ fs [] + \\ simp [GENLIST_CONS] + \\ simp [GENLIST_CONS, BAG_UNION_INSERT] + \\ simp [arithmeticTheory.SUC_ONE_ADD] +QED + +Theorem heap_pop_min: + (heap_pop R sz hp = (x, hp2)) ==> + heap_inv R sz hp ==> 0 < sz ==> + reflexive R ==> transitive R ==> + (x = hp 1) /\ (0 < (sz - 1) ==> R x (hp2 1)) +Proof + rpt disch_tac + \\ subgoal `0 < sz - 1 ==> BAG_IN (hp2 1) (heap_contents sz hp)` + >- ( + drule heap_pop_contents + \\ simp [] + \\ disch_then (simp o single o GSYM) + \\ simp [heap_contents_def] + \\ Cases_on `sz - 1` \\ simp [] + \\ simp [GENLIST_CONS] + ) + \\ fs [heap_pop_def] + \\ rw [] + \\ fs [heap_contents_def, IN_LIST_TO_BAG, MEM_GENLIST] + \\ drule_then irule heap_inv_min + \\ simp [] +QED + +Definition heap_insert_smaller_def: + heap_insert_smaller R sz i x hp = (if i <= 1 then hp(| i |-> x |) + else if R x (hp (i DIV 2)) + then heap_insert_smaller R sz (i DIV 2) x (hp(|i |-> hp (i DIV 2)|)) + else hp(| i |-> x |)) +End + +Theorem heap_insert_smaller_inv: + heap_inv R sz hp ==> (i < sz ==> R x (hp i)) ==> 0 < i ==> i <= sz ==> + reflexive R ==> transitive R ==> total R ==> + heap_inv R sz (heap_insert_smaller R sz i x hp) +Proof + qid_spec_tac `hp` + \\ measureInduct_on `I i` + \\ rw [] \\ fs [] + \\ drule_then (qspec_then `i` mp_tac) heap_inv_thm + \\ drule_then (qspec_then `i * 2` mp_tac) heap_inv_thm + \\ drule_then (qspec_then `i * 2 + 1` mp_tac) heap_inv_thm + \\ ONCE_REWRITE_TAC [heap_insert_smaller_def] + \\ rw [] \\ fs [] + \\ TRY (first_x_assum irule) + \\ irule_at Any heap_inv_upd + \\ fs [relationTheory.reflexive_def, combinTheory.UPDATE_APPLY, div_2_idem_lemma] + \\ rw [] + \\ fs [dividesTheory.DIV_POS] + \\ drule_then (fsrw_tac [SFY_ss] o single) transitive_lemma + \\ drule_then (simp o single) total_lemma +QED + +Theorem heap_insert_smaller_contents: + 0 < i ==> i <= sz ==> + (heap_contents sz (heap_insert_smaller R sz i x hp) = heap_contents sz (hp (|i |-> x|))) +Proof + qid_spec_tac `hp` + \\ measureInduct_on `I i` + \\ rw [] \\ fs [] + \\ ONCE_REWRITE_TAC [heap_insert_smaller_def] + \\ rw [] + \\ fs [dividesTheory.DIV_POS] + \\ simp [heap_contents_upd, dividesTheory.DIV_POS, combinTheory.UPDATE_APPLY, div_2_idem_lemma] + \\ mp_tac heap_contents_mem + \\ rw [] \\ fs [] + >- ( + simp [BAG_UNION_INSERT] + \\ fs [GSYM BAG_DIFF_INSERT_SUB_BAG] + \\ metis_tac [BAG_DIFF_INSERT_SUB_BAG, BAG_INSERT_commutes, + BAG_DIFF_2L, COMM_BAG_UNION, BAG_DIFF_INSERT_same, + BAG_DIFF_EMPTY] + ) + \\ qspec_then `i` assume_tac arithmeticTheory.ODD_OR_EVEN + \\ gs [] +QED + +Definition heap_add_def: + heap_add R sz hp x = heap_insert_smaller R (sz + 1) (sz + 1) x + (hp(| sz + 1 |-> hp((sz + 1) DIV 2)|)) +End + +Theorem heap_add_inv: + heap_inv R sz hp ==> + reflexive R ==> transitive R ==> total R ==> + heap_inv R (sz + 1) (heap_add R sz hp x) +Proof + rw [heap_add_def] + \\ irule heap_insert_smaller_inv + \\ rw [heap_inv_def] + \\ drule_then (qspec_then `i` mp_tac) heap_inv_thm + \\ rw [] \\ gs [] + \\ rw [combinTheory.UPDATE_def] + \\ fs [div_2_idem_lemma, relationTheory.reflexive_def] + \\ qspec_then `i` assume_tac arithmeticTheory.ODD_OR_EVEN + \\ gs [] +QED + +Theorem heap_add_contents: + heap_contents (sz + 1) (heap_add R sz hp x) = + BAG_UNION {|x|} (heap_contents sz hp) +Proof + simp [heap_add_def, heap_insert_smaller_contents] + \\ simp [heap_contents_upd] + \\ simp [heap_contents_def] + \\ simp [GSYM arithmeticTheory.ADD1] + \\ simp [GENLIST, SNOC_APPEND, LIST_TO_BAG_APPEND] + \\ simp [arithmeticTheory.ADD1] + \\ simp [BAG_UNION_INSERT] + \\ ONCE_REWRITE_TAC [BAG_INSERT_commutes] + \\ simp [] +QED + +Definition heap_add_all_def: + (heap_add_all R sz [] hp = hp) /\ + (heap_add_all R sz (x :: xs) hp = + heap_add_all R (sz + 1) xs (heap_add R sz hp x)) +End + +Theorem heap_add_all_inv: + heap_inv R sz hp ==> + reflexive R ==> transitive R ==> total R ==> + (sz2 = sz + LENGTH xs) ==> + heap_inv R sz2 (heap_add_all R sz xs hp) +Proof + qid_spec_tac `hp` + \\ qid_spec_tac `sz` + \\ qid_spec_tac `sz2` + \\ Induct_on `xs` + \\ simp [heap_add_all_def] + \\ rw [] + \\ simp_tac bool_ss [arithmeticTheory.SUC_ONE_ADD, arithmeticTheory.ADD_ASSOC] + \\ first_x_assum irule + \\ simp [] + \\ irule heap_add_inv + \\ simp [] +QED + +Theorem heap_add_all_contents: + (sz2 = sz + LENGTH xs) ==> + (heap_contents sz2 (heap_add_all R sz xs hp) = + BAG_UNION (heap_contents sz hp) (LIST_TO_BAG xs)) +Proof + qid_spec_tac `hp` + \\ qid_spec_tac `sz` + \\ qid_spec_tac `sz2` + \\ Induct_on `xs` + \\ simp [heap_add_all_def] + \\ rw [] + \\ asm_simp_tac bool_ss [arithmeticTheory.SUC_ONE_ADD, arithmeticTheory.ADD_ASSOC] + \\ simp [heap_add_contents] + \\ simp [BAG_INSERT_UNION] + \\ simp [ASSOC_BAG_UNION] + \\ simp [COMM_BAG_UNION] +QED + +Definition heap_pop_all_def: + heap_pop_all R sz xs hp = (if sz = 0 then xs + else let (x, hp2) = heap_pop R sz hp in + heap_pop_all R (sz - 1) (x :: xs) hp2) +End + +Theorem heap_pop_all_sorted: + heap_inv R sz hp ==> + reflexive R ==> transitive R ==> total R ==> + SORTED (\x y. R y x) xs ==> + (xs <> [] ==> 0 < sz ==> R (HD xs) (hp 1)) ==> + (R2 = (\x y. R y x)) ==> + SORTED R2 (heap_pop_all R sz xs hp) +Proof + qid_spec_tac `hp` + \\ qid_spec_tac `xs` + \\ qid_spec_tac `R2` + \\ Induct_on `sz` + \\ ONCE_REWRITE_TAC [heap_pop_all_def] + \\ simp [] + \\ rw [] + \\ pairarg_tac + \\ drule heap_pop_inv + \\ simp [] + \\ rw [] + \\ fs [] + \\ first_x_assum (drule_then irule) + \\ simp [] + \\ drule heap_pop_min + \\ rw [] + \\ Cases_on `xs` \\ fs [] +QED + +Theorem heap_pop_all_contents: + LIST_TO_BAG (heap_pop_all R sz xs hp) = + BAG_UNION (LIST_TO_BAG xs) (heap_contents sz hp) +Proof + qid_spec_tac `hp` + \\ qid_spec_tac `xs` + \\ Induct_on `sz` + \\ ONCE_REWRITE_TAC [heap_pop_all_def] + \\ simp [] + >- ( + simp [heap_contents_def] + ) + >- ( + rw [] + \\ pairarg_tac \\ fs [] + \\ drule_then (mp_tac o GSYM) heap_pop_contents + \\ simp [] + \\ simp [BAG_INSERT_UNION, COMM_BAG_UNION] + \\ metis_tac [ASSOC_BAG_UNION, COMM_BAG_UNION] + ) +QED + +Definition heap_sort_def: + heap_sort R xs = (case xs of [] => [] + | (x :: _) => (let R2 = (\x y. R y x); + hp = heap_add_all R2 0 xs (K x) in + heap_pop_all R2 (LENGTH xs) [] hp)) +End + +Theorem heap_sort_sorted: + reflexive R ==> transitive R ==> total R ==> + SORTED R (heap_sort R xs) +Proof + rw [heap_sort_def] + \\ Cases_on `xs` \\ fs [] + \\ irule heap_pop_all_sorted + \\ simp [] + \\ irule_at Any heap_add_all_inv + \\ simp [] + \\ simp [heap_inv_def, FUN_EQ_THM] + \\ fs [relationTheory.reflexive_def, relationTheory.total_def] + \\ fs [relationTheory.transitive_def] + \\ metis_tac [] +QED + +Theorem heap_sort_contents: + LIST_TO_BAG (heap_sort R xs) = LIST_TO_BAG xs +Proof + simp [heap_sort_def] + \\ Cases_on `xs` \\ simp [] + \\ simp [heap_pop_all_contents, heap_add_all_contents] + \\ simp [heap_contents_def] +QED + +Theorem heap_sort_perm: + PERM (heap_sort R xs) xs +Proof + simp [GSYM PERM_LIST_TO_BAG, heap_sort_contents] +QED + From 25504e2c86d3d5977115fd8f1de7a628a0af74f8 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Tue, 27 Jan 2026 13:29:30 +1100 Subject: [PATCH 05/39] Convert heap-sort to monad, but fail to translate Convert the pure functional heap-sort representation to a monadic representation compatible with the monadic translator (based on some examples). Attempt to translate to CakeML AST, but blocked on various errors. --- basis/heap_sort_monadicScript.sml | 346 ++++++++++++++++++++++++++++++ 1 file changed, 346 insertions(+) create mode 100644 basis/heap_sort_monadicScript.sml diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml new file mode 100644 index 0000000000..28ef2d5272 --- /dev/null +++ b/basis/heap_sort_monadicScript.sml @@ -0,0 +1,346 @@ +(* + Using the monadic translator to translate heap sorting functions. + + Bit of an experiment, may move to ListProg if useful. +*) +Theory heap_sort_monadic +Ancestors + heap_sort_in_fun ml_translator ml_monad_translator +Libs + preamble ml_monad_translator_interfaceLib + + +val _ = set_up_monadic_translator (); + +(* Create the data type to handle the references *) +Datatype: + state_refs = <| + heap_array : 'a list; + |> +End + +(* Data type for the exceptions. Seems to be standard. *) +Datatype: + state_exn = Fail string | Subscript +End + +val state_type = ``:'el state_refs``; + +val config = local_state_config |> + with_state state_type |> + with_exception ``:state_exn`` |> + with_resizeable_arrays [ + ("heap_array", ``[] : 'el list``, ``Subscript``, ``Subscript``) + ]; + +val _ = start_translation config; + +Definition heap_insert_larger_monadic_def: + heap_insert_larger_monadic R sz i x = (if (i = 0n) \/ i * 2 > sz + then (if i = 0 then return () + else update_heap_array (i - 1) x) + else do + y <- heap_array_sub ((i * 2) - 1); + z <- if (i * 2) + 1 > sz + then return y + else heap_array_sub (i * 2); + if ((i * 2) + 1) <= sz /\ R z x /\ R z y + then do + update_heap_array (i - 1) z; + heap_insert_larger_monadic R sz ((i * 2) + 1) x + od + else if (i * 2) <= sz /\ R y x /\ (((i * 2) + 1) <= sz ==> R y z) + then do + update_heap_array (i - 1) y; + heap_insert_larger_monadic R sz (i * 2) x + od + else update_heap_array (i - 1) x + od) +Termination + qexists_tac `measure (\(_, sz, i, _). sz - i)` + \\ simp [] +End + +Theorem st_ex_bind_split[local]: + (st_ex_bind f g st = (res, st')) <=> + ?r s. (f st = (r, s)) /\ (case r of M_success x => (g x s) = (res, st') + | M_failure y => (res, st') = (M_failure y, s)) +Proof + simp [ml_monadBaseTheory.st_ex_bind_def] + \\ Cases_on `f st` + \\ simp [] + \\ Cases_on `FST (f st)` + \\ gs [] + \\ metis_tac [] +QED + +Theorem st_ex_ignore_bind_simp[local]: + st_ex_ignore_bind f g = st_ex_bind f (\_. g) +Proof + simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_ignore_bind_def] +QED + +Definition st_embed_def: + (st_embed sz hp : 'a state_refs) = + <| heap_array := GENLIST (hp o ((+) 1)) sz |> +End + +Theorem LENGTH_st_embed[local]: + LENGTH (st_embed sz hp).heap_array = sz +Proof + simp [st_embed_def] +QED + +Theorem update_heap_array_st_embed[local]: + i < sz ==> + (update_heap_array i x (st_embed sz hp) = + (M_success (), st_embed sz (hp⦇i + 1 ↦ x⦈))) +Proof + simp [fetch "-" "update_heap_array_def"] + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ simp [st_embed_def, LUPDATE_GENLIST] + \\ simp [combinTheory.UPDATE_def, combinTheory.o_DEF] +QED + +Theorem heap_array_sub_st_embed[local]: + i < sz ==> + (heap_array_sub i (st_embed sz hp) = + (M_success (hp (i + 1)), (st_embed sz hp))) +Proof + simp [fetch "-" "heap_array_sub_def"] + \\ simp [ml_monadBaseTheory.monad_eqs, st_embed_def] +QED + +Theorem monad_simps[local] = LIST_CONJ [ + ml_monadBaseTheory.st_ex_bind_def |> Q.ISPEC `update_heap_array i x`, + update_heap_array_st_embed, + ml_monadBaseTheory.st_ex_bind_def |> Q.ISPEC `heap_array_sub i`, + heap_array_sub_st_embed, + ml_monadBaseTheory.monad_eqs, + st_ex_ignore_bind_simp] + +Theorem heap_insert_larger_monadic_eq: + 0 < i /\ i <= sz /\ sz <= arr_sz ==> + (heap_insert_larger_monadic R sz i x (st_embed arr_sz hp) = + (M_success (), st_embed arr_sz (heap_insert_larger R sz i x hp))) +Proof + qid_spec_tac `hp` + \\ measureInduct_on `(\i. sz - i) i` + \\ rw [] + \\ ONCE_REWRITE_TAC [heap_insert_larger_monadic_def] + \\ ONCE_REWRITE_TAC [heap_insert_larger_def] + \\ rw [] \\ fs [] + \\ simp [monad_simps] + \\ rw [] \\ fs [] + \\ simp [monad_simps] +QED + +Definition heap_pop_monadic_def: + heap_pop_monadic R sz_dec = (do + bot_el <- heap_array_sub 0; + top_el <- heap_array_sub sz_dec; + heap_insert_larger_monadic R sz_dec 1 top_el; + return bot_el + od) +End + +(* The heap_pop_monadic version of sz is one less than the + functional one (the size after the pop), to avoid a translation + side-condition. *) +Theorem heap_pop_monadic_eq: + sz < arr_sz ==> + (heap_pop_monadic R sz (st_embed arr_sz hp) = + (M_success (FST (heap_pop R (sz + 1) hp)), st_embed arr_sz (SND (heap_pop R (sz + 1) hp)))) +Proof + simp [heap_pop_def, heap_pop_monadic_def] + \\ rw [] \\ fs [] + \\ simp [monad_simps, heap_insert_larger_monadic_eq] + \\ Cases_on `sz = 0` + >- ( + (* Works by coincidence for the base case. *) + ONCE_REWRITE_TAC [heap_insert_larger_monadic_def] + \\ ONCE_REWRITE_TAC [heap_insert_larger_def] + \\ simp [monad_simps] + ) + \\ simp [heap_insert_larger_monadic_eq] +QED + +Definition heap_insert_smaller_monadic_def: + heap_insert_smaller_monadic R sz i x = (if (i <= 1n) + then update_heap_array (i - 1) x + else do + y <- heap_array_sub ((i DIV 2) - 1); + if R x y + then do + update_heap_array (i - 1) y; + heap_insert_smaller_monadic R sz (i DIV 2) x + od + else update_heap_array (i - 1) x + od) +End + +Theorem heap_insert_smaller_monadic_eq: + 0 < i /\ i <= sz /\ sz <= arr_sz ==> + (heap_insert_smaller_monadic R sz i x (st_embed arr_sz hp) = + (M_success (), st_embed arr_sz (heap_insert_smaller R sz i x hp))) +Proof + qid_spec_tac `hp` + \\ measureInduct_on `I i` + \\ rw [] + \\ ONCE_REWRITE_TAC [heap_insert_smaller_monadic_def] + \\ ONCE_REWRITE_TAC [heap_insert_smaller_def] + \\ rw [] \\ fs [] + \\ subgoal `i DIV 2 < i` + \\ simp [monad_simps, dividesTheory.DIV_POS] + \\ rw [] \\ fs [] + \\ gs [monad_simps, SUB_ADD, X_LE_DIV, dividesTheory.DIV_POS] +QED + +Definition heap_add_monadic_def: + heap_add_monadic R sz x = (do + el <- if 0 < sz + then heap_array_sub (((sz + 1) DIV 2) - 1) + else return x; + update_heap_array sz el; + heap_insert_smaller_monadic R (sz + 1) (sz + 1) x + od) +End + +Theorem heap_add_monadic_eq: + sz + 1 <= arr_sz ==> + (heap_add_monadic R sz x (st_embed arr_sz hp) = + (M_success (), st_embed arr_sz (heap_add R sz hp x))) +Proof + simp [heap_add_monadic_def, heap_add_def] + \\ subgoal `0 < sz ==> (sz + 1) DIV 2 <= sz` + >- ( + qspec_then `sz` assume_tac arithmeticTheory.ODD_OR_EVEN + \\ fs [] + ) + \\ rw [] + \\ simp [monad_simps, heap_insert_smaller_monadic_eq] + \\ simp [SUB_ADD, X_LE_DIV] + \\ gs [] + \\ ONCE_REWRITE_TAC [heap_insert_smaller_def] + \\ simp [] +QED + +Definition heap_add_all_monadic_def: + (heap_add_all_monadic R sz [] = return sz) /\ + (heap_add_all_monadic R sz (x :: xs) = do + heap_add_monadic R sz x; + heap_add_all_monadic R (sz + 1) xs + od) +End + +Theorem heap_add_all_monadic_eq: + sz + LENGTH xs <= arr_sz ==> + (heap_add_all_monadic R sz xs (st_embed arr_sz hp) = + (M_success (sz + LENGTH xs), st_embed arr_sz (heap_add_all R sz xs hp))) +Proof + qid_spec_tac `hp` + \\ qid_spec_tac `sz` + \\ Induct_on `xs` + \\ ONCE_REWRITE_TAC [heap_add_all_monadic_def] + \\ ONCE_REWRITE_TAC [heap_add_all_def] + \\ simp [monad_simps, heap_add_monadic_eq] +QED + +(* Leads to an exception. + +Defn.Hol_defn "monad_fun" + ` (monad_fun sz xs = if sz = 0 then return xs + else st_ex_bind (return ARB) + (\el. monad_fun (sz - 1) (el :: xs)) + ) + ` + +This exception blocks heap_pop_all_monadic from being +defined with an if/then/else on the RHS. Unfortunately +the 0/SUC version doesn't want to translate. + +*) + +Definition heap_pop_all_monadic_def: + (heap_pop_all_monadic R 0 xs = return xs) /\ + (heap_pop_all_monadic R (SUC next_sz) xs = + do + el <- heap_pop_monadic R next_sz; + heap_pop_all_monadic R next_sz (el :: xs) + od) +End + +Theorem heap_pop_all_monadic_eq: + sz <= arr_sz ==> + ?hp2. (heap_pop_all_monadic R sz xs (st_embed arr_sz hp) = + (M_success (heap_pop_all R sz xs hp), hp2)) +Proof + qid_spec_tac `hp` + \\ qid_spec_tac `xs` + \\ Induct_on `sz` + \\ ONCE_REWRITE_TAC [heap_pop_all_monadic_def] + \\ ONCE_REWRITE_TAC [heap_pop_all_def] + \\ simp [monad_simps, heap_pop_monadic_eq] + \\ rw [] + \\ pairarg_tac \\ fs [] + \\ fs [arithmeticTheory.ADD1] + \\ simp [heap_pop_monadic_eq] +QED + +val run_state_monad_def = + define_run ``: 'a state_refs`` [] "state_monad" + +Definition heap_sort_via_monad_def: + heap_sort_via_monad R xs = (case xs of + [] => [] + | (x :: _) => (case run_state_monad (do + sz <- return (LENGTH xs); + R2 <- return (\x y. R y x); + alloc_heap_array sz x; + heap_add_all_monadic R2 0 xs; + heap_pop_all_monadic R2 sz []; + od) (state_monad []) + of (M_success ys) => ys + | _ => [] + )) +End + +Theorem alloc_heap_array_eq[local]: + alloc_heap_array n v st = (M_success (), st_embed n (K v)) +Proof + simp [fetch "-" "alloc_heap_array_def"] + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ simp [st_embed_def, REPLICATE_GENLIST] + \\ simp [fetch "-" "state_refs_component_equality"] +QED + +Theorem heap_sort_eq: + heap_sort R xs = heap_list_sort$heap_sort R xs +Proof + simp [heap_sort_def, heap_list_sortTheory.heap_sort_def] + \\ Cases_on `xs` \\ simp [] + \\ simp [run_state_monad_def, ml_monadBaseTheory.run_def] + \\ simp [ml_monadBaseTheory.exc_case_eq, pairTheory.FST_EQ_EQUIV] + \\ simp [monad_simps, alloc_heap_array_eq] + \\ simp [heap_add_all_monadic_eq, heap_pop_all_monadic_eq] +QED + +(* Attempt translation of these functions. *) + + +(* Works if the diverging "metis" call is interrupted ??? *) + +val heap_insert_larger_v_thm = heap_insert_larger_monadic_def + |> m_translate; + +(* Works if arithmetic is tweaked to avoid "_ - 1" *) + +val heap_pop_v_thm = heap_pop_monadic_def + |> m_translate; + +(* Doesn't work, and other issues prevent definition another way. *) + +val heap_pop_all_v_thm = heap_pop_all_monadic_def + |> m_translate; + + From bcd249183bc0c0f7bd0c50b151879b75af5c1052 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Mon, 2 Feb 2026 17:10:47 +1100 Subject: [PATCH 06/39] Heap sort via array apparently translating It seems that the cause of recent issues is that the monadic translator is incredibly fragile when it comes to type parameters if the state type needs to be polymorphic. Tweak things to check that the type variable is consistent. This code seems to work with "tvar = ``: 'state``" and "tvar = ``: 'a``" but it does not seem to work with "tvar = ``: 'el``", which is all a bit mysterious. --- basis/heap_sort_monadicScript.sml | 116 +++++++++++++++++++++++------- 1 file changed, 90 insertions(+), 26 deletions(-) diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml index 28ef2d5272..f148c18662 100644 --- a/basis/heap_sort_monadicScript.sml +++ b/basis/heap_sort_monadicScript.sml @@ -3,19 +3,29 @@ Bit of an experiment, may move to ListProg if useful. *) + Theory heap_sort_monadic Ancestors heap_sort_in_fun ml_translator ml_monad_translator Libs - preamble ml_monad_translator_interfaceLib + preamble ml_translatorLib ml_monad_translator_interfaceLib + +(* Part 1. Translator Setup. *) +(* Set up translator to not check subtractions never underflow. *) +val _ = ml_translatorLib.use_sub_check true; val _ = set_up_monadic_translator (); +(* The type variable used as parameter to the state type. It seems very + important that this is used consistently. Strangely `'a` seems to work (for + the current code) though it created problems in a previous iteration. *) +val tvar = ``: 'a``; + (* Create the data type to handle the references *) Datatype: state_refs = <| - heap_array : 'a list; + heap_array : ( ^tvar ) list; |> End @@ -24,17 +34,19 @@ Datatype: state_exn = Fail string | Subscript End -val state_type = ``:'el state_refs``; +val state_type = ``: ( ^tvar ) state_refs``; val config = local_state_config |> with_state state_type |> with_exception ``:state_exn`` |> with_resizeable_arrays [ - ("heap_array", ``[] : 'el list``, ``Subscript``, ``Subscript``) + ("heap_array", listSyntax.mk_list ([], tvar), ``Subscript``, ``Subscript``) ]; val _ = start_translation config; +(* Part 2. Define monadic variants of functions from heap_sort_in_fun theory. *) + Definition heap_insert_larger_monadic_def: heap_insert_larger_monadic R sz i x = (if (i = 0n) \/ i * 2 > sz then (if i = 0 then return () @@ -270,6 +282,19 @@ Definition heap_pop_all_monadic_def: od) End +Theorem heap_pop_all_monadic_if_def: + heap_pop_all_monadic R sz xs = (if sz = 0n + then return xs + else do + el <- heap_pop_monadic R (sz - 1); + heap_pop_all_monadic R (sz - 1) (el :: xs) + od + ) +Proof + Cases_on `sz` + \\ simp [heap_pop_all_monadic_def] +QED + Theorem heap_pop_all_monadic_eq: sz <= arr_sz ==> ?hp2. (heap_pop_all_monadic R sz xs (st_embed arr_sz hp) = @@ -287,21 +312,34 @@ Proof \\ simp [heap_pop_monadic_eq] QED -val run_state_monad_def = - define_run ``: 'a state_refs`` [] "state_monad" -Definition heap_sort_via_monad_def: - heap_sort_via_monad R xs = (case xs of - [] => [] - | (x :: _) => (case run_state_monad (do +(* Part 3. Translation into CakeML AST. *) + +val run_init_state_def = define_run state_type [] "init_state"; + +Definition heap_sort_via_monad_aux1_def: + heap_sort_via_monad_aux1 R x xs = + (do sz <- return (LENGTH xs); R2 <- return (\x y. R y x); alloc_heap_array sz x; heap_add_all_monadic R2 0 xs; heap_pop_all_monadic R2 sz []; - od) (state_monad []) - of (M_success ys) => ys - | _ => [] + od) +End + +Definition heap_sort_via_monad_aux2_def: + heap_sort_via_monad_aux2 R x xs = + run_init_state (heap_sort_via_monad_aux1 R x xs) + (init_state []) +End + +Definition heap_sort_via_monad_def: + heap_sort_via_monad R xs = (case xs of + [] => [] + | (x :: _) => (case heap_sort_via_monad_aux2 R x xs of + M_success ys => ys + | _ => [] )) End @@ -315,32 +353,58 @@ Proof QED Theorem heap_sort_eq: - heap_sort R xs = heap_list_sort$heap_sort R xs + heap_sort_via_monad R xs = heap_sort R xs Proof - simp [heap_sort_def, heap_list_sortTheory.heap_sort_def] + simp [heap_sort_via_monad_def, heap_sort_def, heap_sort_via_monad_aux2_def, + run_init_state_def, heap_sort_via_monad_aux1_def] \\ Cases_on `xs` \\ simp [] - \\ simp [run_state_monad_def, ml_monadBaseTheory.run_def] + \\ simp [ml_monadBaseTheory.run_def] \\ simp [ml_monadBaseTheory.exc_case_eq, pairTheory.FST_EQ_EQUIV] \\ simp [monad_simps, alloc_heap_array_eq] \\ simp [heap_add_all_monadic_eq, heap_pop_all_monadic_eq] QED -(* Attempt translation of these functions. *) +fun fix_state_type thm = let + val types_in_thm = thm |> concl |> all_atoms + |> HOLset.listItems |> map type_of + |> map (fn t => fst (strip_fun t) @ [snd (strip_fun t)]) + |> List.concat + val state_matching_types = types_in_thm + |> filter (can (match_type state_type)) + |> HOLset.fromList Type.compare |> HOLset.listItems + val substs = map (fn t => match_type t state_type) state_matching_types + in case substs of + [] => thm + | [s] => INST_TYPE s thm + | _ => failwith "fix_state_type: multiple!" + end +val heap_insert_larger_v_thm = heap_insert_larger_monadic_def + |> fix_state_type |> m_translate; -(* Works if the diverging "metis" call is interrupted ??? *) +val heap_pop_v_thm = heap_pop_monadic_def + |> fix_state_type |> m_translate; -val heap_insert_larger_v_thm = heap_insert_larger_monadic_def - |> m_translate; +val heap_pop_all_v_thm = heap_pop_all_monadic_def + |> fix_state_type |> m_translate; -(* Works if arithmetic is tweaked to avoid "_ - 1" *) +val heap_insert_smaller_v_thm = heap_insert_smaller_monadic_def + |> fix_state_type |> m_translate; -val heap_pop_v_thm = heap_pop_monadic_def - |> m_translate; +val heap_add_v_thm = heap_add_monadic_def + |> fix_state_type |> m_translate; -(* Doesn't work, and other issues prevent definition another way. *) +val heap_add_all_v_thm = heap_add_all_monadic_def + |> fix_state_type |> m_translate; -val heap_pop_all_v_thm = heap_pop_all_monadic_def - |> m_translate; +val length_v_thm = LENGTH |> translate; + +val heap_sort_via_monad_aux1_v_thm = heap_sort_via_monad_aux1_def + |> fix_state_type |> m_translate; + +val heap_sort_via_monad_aux2_v_thm = heap_sort_via_monad_aux2_def + |> fix_state_type |> m_translate_run; + +val heap_sort_via_monad_v_thm = heap_sort_via_monad_def |> translate; From 0487b97c45864feda611fcaaa8f8b8240a9a3c80 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Wed, 11 Feb 2026 09:07:09 +1100 Subject: [PATCH 07/39] Alternative heap-sort approach, mostly verified Switch out the standard heap-sort, in which the heap points in the opposite direction, for a list-of-heaps sort in which power-of-two-minus-one sized heaps point in the correct direction within the array. This has the advantage that an already sorted array is confirmed sorted without moving anything and in linear time. It also "agrees" with the functional model. Problem though, the mapping of the multiple heaps into the array gets painful to reason about. Saving before trying a different approach. --- basis/heap_sort_monadicScript.sml | 1166 ++++++++++++++++++++++++- basis/pure/heap_sort_in_funScript.sml | 542 ++++++++++++ 2 files changed, 1704 insertions(+), 4 deletions(-) diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml index f148c18662..bdd17713a7 100644 --- a/basis/heap_sort_monadicScript.sml +++ b/basis/heap_sort_monadicScript.sml @@ -10,6 +10,8 @@ Ancestors Libs preamble ml_translatorLib ml_monad_translator_interfaceLib +val _ = ParseExtras.tight_equality(); + (* Part 1. Translator Setup. *) (* Set up translator to not check subtractions never underflow. *) @@ -20,12 +22,13 @@ val _ = set_up_monadic_translator (); (* The type variable used as parameter to the state type. It seems very important that this is used consistently. Strangely `'a` seems to work (for the current code) though it created problems in a previous iteration. *) -val tvar = ``: 'a``; +val tvar = ``: 'state``; (* Create the data type to handle the references *) Datatype: state_refs = <| heap_array : ( ^tvar ) list; + sz_array : num list; |> End @@ -40,11 +43,14 @@ val config = local_state_config |> with_state state_type |> with_exception ``:state_exn`` |> with_resizeable_arrays [ - ("heap_array", listSyntax.mk_list ([], tvar), ``Subscript``, ``Subscript``) + ("heap_array", listSyntax.mk_list ([], tvar), ``Subscript``, ``Subscript``), + ("sz_array", ``[] : num list``, ``Subscript``, ``Subscript``) ]; val _ = start_translation config; +val run_init_state_def = define_run state_type [] "init_state"; + (* Part 2. Define monadic variants of functions from heap_sort_in_fun theory. *) Definition heap_insert_larger_monadic_def: @@ -315,8 +321,6 @@ QED (* Part 3. Translation into CakeML AST. *) -val run_init_state_def = define_run state_type [] "init_state"; - Definition heap_sort_via_monad_aux1_def: heap_sort_via_monad_aux1 R x xs = (do @@ -408,3 +412,1157 @@ val heap_sort_via_monad_aux2_v_thm = heap_sort_via_monad_aux2_def val heap_sort_via_monad_v_thm = heap_sort_via_monad_def |> translate; +(* Second variant. *) +(* Heap list version. *) + +(* 'start_translation' parts at the top *) + +(* Positions of the left child in a suffix encoded balanced tree + of height ht. *) +Definition sfx_heap_left_def: + sfx_heap_left i ht = (i - (2 EXP (ht - 1))) +End + +(* Insert a value into a balanced suffix heap of height ht, replacing the + current top element which is at index i. *) +Definition insert_into_sfx_heap_def: + insert_into_sfx_heap R i ht x = if ht <= 1 + then update_heap_array i x + else do + l <- return (sfx_heap_left i ht); + r <- return (i - 1); + lx <- heap_array_sub l; + rx <- heap_array_sub r; + if R lx x /\ R rx x + then update_heap_array i x + else if R lx rx + then do + update_heap_array i rx; + insert_into_sfx_heap R r (ht - 1) x + od + else do + update_heap_array i lx; + insert_into_sfx_heap R l (ht - 1) x + od + od +End + +(* Insert a value into a sequence of balanced suffix heaps, heights stored + in positions [0 ..< j] of the sz_array. Replace the top elements of the + final heap, which is at index i. *) +Definition insert_into_sfx_heap_list_def: + insert_into_sfx_heap_list R i j x = + if j <= 1 then do + ht <- sz_array_sub (j - 1); + insert_into_sfx_heap R i ht x + od + else do + ht <- sz_array_sub (j - 1); + i2 <- return ((i + 1) - (2 EXP ht)); + t2x <- heap_array_sub i2; + cond1 <- return (~ R t2x x); + cond <- if cond1 /\ (1 < ht) + then do + l <- return (sfx_heap_left i ht); + r <- return (i - 1); + lx <- heap_array_sub l; + rx <- heap_array_sub r; + return (~ R t2x lx /\ ~ R t2x rx) + od + else return cond1; + if cond + then do + update_heap_array i t2x; + insert_into_sfx_heap_list R i2 (j - 1) x + od + else insert_into_sfx_heap R i ht x + od +End + +(* Add another element to the final heap in a sequence of balanced suffix + heaps with i total elements and j total heaps. *) +Definition add_to_sfx_heaps_step1_def: + add_to_sfx_heaps_step1 i j = do + merge <- if j <= 1 + then return F + else do + n1 <- sz_array_sub (j - 1); + n2 <- sz_array_sub (j - 2); + return (n1 = n2); + od; + if merge + then do + n <- sz_array_sub (j - 2); + update_sz_array (j - 2) (n + 1); + return (j - 1); + od + else do + update_sz_array j 1; + return (j + 1); + od + od +End + +(* Also set the top element and preserve invariants. *) +Definition add_to_sfx_heaps_def: + add_to_sfx_heaps R i j x = do + j' <- add_to_sfx_heaps_step1 i j; + insert_into_sfx_heap_list R i j' x; + return j' + od +End + +Definition add_all_to_sfx_heaps_def: + (add_all_to_sfx_heaps R i j [] = return (i, j)) /\ + (add_all_to_sfx_heaps R i j (x :: xs) = do + j <- add_to_sfx_heaps R i j x; + add_all_to_sfx_heaps R (i + 1) j xs; + od) +End + +Definition reinsert_tree_def: + reinsert_tree R i j ht = + do + update_sz_array j ht; + x <- heap_array_sub (i - 1); + upd <- if 0 < j then do + i2 <- return (i - (2 EXP ht)); + t2x <- heap_array_sub i2; + return (~ (R t2x x)) + od else return F; + if upd + then insert_into_sfx_heap_list R (i - 1) (j + 1) x + else return (); + od +End + +Definition sfx_trees_to_list_def: + sfx_trees_to_list R i j acc = + if i = 0 then return acc + else do + ht <- sz_array_sub (j - 1); + x <- heap_array_sub (i - 1); + if ht <= 1 then sfx_trees_to_list R (i - 1) (j - 1) (x :: acc) + else do + l <- return (sfx_heap_left i ht); + reinsert_tree R l (j - 1) (ht - 1); + reinsert_tree R (i - 1) j (ht - 1); + sfx_trees_to_list R (i - 1) (j + 1) (x :: acc) + od + od +End + +Definition sort_via_sfx_trees_worker_def: + sort_via_sfx_trees_worker R x xs = do + sz <- return (LENGTH xs); + alloc_heap_array sz x; + alloc_sz_array (LOG2 sz + 3) 0; + (i, j) <- add_all_to_sfx_heaps R 0 0 xs; + sfx_trees_to_list R i j [] + od +End + +Definition sort_via_sfx_trees_run_worker_def: + sort_via_sfx_trees_run_worker R x xs = + run_init_state (sort_via_sfx_trees_worker R x xs) + (init_state [] []) +End + +Definition sort_via_sfx_trees_def: + sort_via_sfx_trees R xs = (case xs of [] => [] + | x :: _ => (case sort_via_sfx_trees_run_worker R x xs of + M_success ys => ys + | _ => []) + ) +End + + +(* Equivalence of second variant. *) + +Definition bs_tree_to_list_def: + (bs_tree_to_list 0 t = []) /\ + (bs_tree_to_list (SUC ht) t = + bs_tree_to_list ht (case t of Node _ l r => l | _ => t) ++ + bs_tree_to_list ht (case t of Node _ l r => r | _ => t) ++ + [case t of Node x l r => x] + ) +End + +Theorem bs_tree_to_list_tree_rec[local]: + (i = 0 ==> bs_tree_to_list i Empty_Tree = []) /\ + (0 < i ==> bs_tree_to_list i (Node x l r) = + bs_tree_to_list (i - 1) l ++ + bs_tree_to_list (i - 1) r ++ + [x]) +Proof + Cases_on `i` \\ simp [bs_tree_to_list_def] +QED + +Definition two_exp_min_1_def: + two_exp_min_1 i = (2n EXP i) - 1 +End + +Theorem two_exp_min_1_less_rec: + 0 < i ==> two_exp_min_1 i = two_exp_min_1 (i - 1) + two_exp_min_1 (i - 1) + 1 +Proof + Cases_on `i` + \\ fs [two_exp_min_1_def, EXP] + \\ rw [SUB_RIGHT_ADD] +QED + +Theorem two_exp_min_1_rec: + two_exp_min_1 0 = 0 /\ + two_exp_min_1 (SUC i) = two_exp_min_1 i + two_exp_min_1 i + 1 +Proof + simp [two_exp_min_1_less_rec] \\ simp [two_exp_min_1_def] +QED + +Theorem to_two_exp_min_1: + (2n EXP i) = (two_exp_min_1 i + 1) +Proof + rw [two_exp_min_1_def, SUB_RIGHT_ADD] +QED + +Theorem sfx_heap_left_two_exp_min_1: + sfx_heap_left n ht = n - (two_exp_min_1 (ht - 1)) - 1 +Proof + simp [sfx_heap_left_def, to_two_exp_min_1] +QED + +Theorem LENGTH_bs_tree_to_list: + ! i t. LENGTH (bs_tree_to_list i t) = two_exp_min_1 i +Proof + Induct + \\ simp [bs_tree_to_list_def, two_exp_min_1_rec] +QED + +Definition tree_balanced_height_def: + (tree_balanced_height i Empty_Tree = (i = 0n)) /\ + (tree_balanced_height i (Node x l r) = ( + (i > 0) /\ tree_balanced_height (i - 1) l /\ + tree_balanced_height (i - 1) r) + ) +End + +Theorem tree_balanced_height_0: + (tree_balanced_height 0 t = (t = Empty_Tree)) +Proof + Cases_on `t` \\ simp [tree_balanced_height_def] +QED + +Theorem tree_balanced_height_pos: + 0 < ht ==> tree_balanced_height ht t = + (?x l r. t = Node x l r /\ tree_balanced_height (ht - 1) l /\ + tree_balanced_height (ht - 1) r) +Proof + Cases_on `t` \\ simp [tree_balanced_height_def] +QED + +(* +Theorem tree_balanced_height_length_sfx_eq: + tree_balanced_height ht t ==> + (LENGTH (tree_sfx_list t) = ((2 EXP ht) - 1)) +Proof + qid_spec_tac `ht` \\ Induct_on `t` + \\ fs [tree_sfx_list_def, tree_balanced_height_def] + \\ rw [] + \\ Cases_on `ht` \\ fs [] + \\ res_tac + \\ simp [EXP] + \\ simp [SUB_RIGHT_ADD] + \\ rw [] +QED +*) + +(* +Theorem tree_balanced_height_length_sfx_eq: + tree_balanced_height ht t ==> 0 < ht ==> + (LENGTH (tree_sfx_list t) = two_exp_min_2 ht + 1) +Proof + qid_spec_tac `ht` \\ Induct_on `t` + \\ simp [tree_balanced_height_def, tree_sfx_list_def, two_exp_min_2_rec] + \\ rw [] + \\ Cases_on `ht` \\ fs [] + \\ simp [two_exp_min_2_rec] + \\ rw [] + \\ fs [tree_balanced_height_0, tree_sfx_list_def] + \\ res_tac + \\ simp [] +QED + +Definition tree_list_len_eq_def: + tree_list_len_eq xs t ht i = + (tree_balanced_height ht t /\ + (i = LENGTH xs + LENGTH (tree_sfx_list t) - 1)) +End + +Theorem tree_list_len_eq_bases: + (tree_list_len_eq xs Empty_Tree ht i = ((ht = 0) /\ (i = LENGTH xs - 1))) /\ + (tree_list_len_eq xs t 0 i = ((t = Empty_Tree) /\ (i = LENGTH xs - 1))) +Proof + simp [tree_list_len_eq_def, tree_balanced_height_def, tree_sfx_list_def] + \\ Cases_on `t` \\ simp [tree_balanced_height_def, tree_sfx_list_def] +QED + +Theorem tree_list_len_eq_split: + tree_list_len_eq xs (Node x l r) ht i ==> + tree_list_len_eq xs l (ht - 1) (i - (2 EXP (ht - 1))) /\ + tree_list_len_eq (xs ++ tree_sfx_list l) r (ht - 1) (i - 1) +Proof + rw [tree_list_len_eq_def] + \\ fs [tree_balanced_height_def, tree_sfx_list_def] + \\ imp_res_tac tree_balanced_height_length_sfx_eq + \\ Cases_on `ht` \\ full_simp_tac std_ss [] + \\ simp [EXP] + \\ Cases_on `n = 0` \\ fs [] + \\ subgoal `?x. 2 EXP n = (2 + x)` + \\ fs [] + \\ qexists_tac `(2 EXP n) - 2` + \\ simp [SUB_RIGHT_ADD] + \\ rw [] +QED + +Definition tree_len_eq_def: + tree_len_eq n t ht i = + (tree_balanced_height ht t /\ (i = n + LENGTH (tree_sfx_list t) - 1)) +End + +Theorem tree_len_eq_bases: + (tree_len_eq n Empty_Tree ht i = ((ht = 0) /\ (i = n - 1))) /\ + (tree_len_eq n t 0 i = ((t = Empty_Tree) /\ (i = n - 1))) +Proof + simp [tree_len_eq_def, tree_balanced_height_def, tree_sfx_list_def] + \\ Cases_on `t` \\ simp [tree_balanced_height_def, tree_sfx_list_def] +QED + +Theorem tree_len_eq_split: + tree_len_eq n (Node x l r) ht i ==> + tree_len_eq n l (ht - 1) (i - (2 EXP (ht - 1))) /\ + tree_len_eq (n + LENGTH (tree_sfx_list l)) r (ht - 1) (i - 1) +Proof + rw [tree_len_eq_def] + \\ fs [tree_balanced_height_def, tree_sfx_list_def] + \\ imp_res_tac tree_balanced_height_length_sfx_eq + \\ full_simp_tac std_ss [] + \\ subgoal `ht > 1 ==> ?x. 2 EXP (ht - 1) = (2 + x)` + \\ Cases_on `ht - 1` \\ Cases_on `ht` \\ full_simp_tac std_ss [] + \\ fs [] + \\ qexists_tac `(2 EXP SUC n) - 2` + \\ simp [SUB_RIGHT_ADD] + \\ rw [] +QED +*) + +Theorem return_bind_eq: + st_ex_bind (return v) f = f v +Proof + simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] +QED + +(* +Theorem heap_array_sub_eq_intro: + tree_list_len_eq xs t ht i ==> + (st.heap_array = xs ++ tree_sfx_list t ++ ys) ==> + 0 < ht ==> + (f (case t of Node y _ _ => y) st = (M_success v, st_fin)) ==> + (st_ex_bind (heap_array_sub i) f st = (M_success v, st_fin)) +Proof + simp [fetch "-" "heap_array_sub_def"] + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ rw [] + \\ imp_res_tac tree_balanced_height_length_sfx_eq + \\ simp [] + \\ fs [tree_list_len_eq_def] + \\ Cases_on `t` \\ fs [tree_balanced_height_def] + \\ fs [tree_sfx_list_def] + \\ simp [EL_APPEND] +QED + +Theorem heap_array_sub_eq_intro2: + tree_len_eq n t ht i ==> + 0 < ht ==> + (DROP n st.heap_array = tree_sfx_list t ++ ys) ==> + (f (case t of Node y _ _ => y) st = (M_success v, st_fin)) ==> + (st_ex_bind (heap_array_sub i) f st = (M_success v, st_fin)) +Proof + simp [fetch "-" "heap_array_sub_def"] + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ rpt disch_tac + \\ Cases_on `LENGTH st.heap_array <= n` + >- ( + fs (RES_CANON miscTheory.DROP_NIL) + \\ Cases_on `t` \\ fs [tree_sfx_list_def, tree_len_eq_bases] + ) + \\ subgoal `?xs. (st.heap_array = xs ++ tree_sfx_list t ++ ys) /\ (LENGTH xs = n)` + >- ( + qexists_tac `TAKE n st.heap_array` + \\ simp [LENGTH_TAKE] + \\ metis_tac [TAKE_DROP, APPEND_ASSOC] + ) + \\ fs [tree_len_eq_def] + \\ simp [EL_APPEND] + \\ Cases_on `t` \\ fs [tree_balanced_height_def] + \\ fs [tree_sfx_list_def] + \\ simp [EL_APPEND] +QED + + +Theorem update_heap_array_eq: + tree_list_len_eq xs t ht i ==> + (st.heap_array = xs ++ tree_sfx_list t ++ ys) ==> + 0 < ht ==> + (st2 = st with <| heap_array := + xs ++ tree_sfx_list (case t of Node _ l r => Node x l r) ++ ys |>) ==> + (update_heap_array i x st = (M_success (), st2)) +Proof + simp [fetch "-" "update_heap_array_def"] + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ rw [] + \\ imp_res_tac tree_balanced_height_length_sfx_eq + \\ simp [] + \\ fs [tree_list_len_eq_def] + \\ Cases_on `t` \\ fs [tree_balanced_height_def] + \\ fs [tree_sfx_list_def] + \\ simp [LUPDATE_APPEND, LUPDATE_DEF] +QED + +Theorem update_heap_array_eq_intro: + tree_list_len_eq xs t ht i ==> + (st.heap_array = xs ++ tree_sfx_list t ++ ys) ==> + 0 < ht ==> + (!st' prev_xs. (st = st' with <| heap_array := prev_xs |>) /\ + (st'.heap_array = xs ++ tree_sfx_list (case t of Node _ l r => Node x l r) ++ ys) ==> + (f () st' = (M_success v, st_fin))) ==> + (st_ex_bind (update_heap_array i x) f st = (M_success v, st_fin)) +Proof + simp [ml_monadBaseTheory.monad_eqs] + \\ rw [] + \\ first_x_assum (irule_at Any) + \\ drule_then (irule_at Any) update_heap_array_eq + \\ simp [] + \\ simp [fetch "-" "state_refs_component_equality"] +QED + +Theorem bind_return_eq: + st_ex_bind f return = f +Proof + rw [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] +QED + + +Theorem balanced_sfx_heap_left_eq: + tree_balanced_height (ht - 1) l ==> + 1 < ht ==> + (sfx_heap_left (oths + LENGTH (tree_sfx_list l)) ht = oths - 1) +Proof + rw [] + \\ subgoal `!i. sfx_heap_left i ht = i - (LENGTH (tree_sfx_list l)) - 1` + >- ( + imp_res_tac tree_balanced_height_length_sfx_eq + \\ simp [sfx_heap_left_def, SUB_RIGHT_SUB] + \\ simp [SUB_RIGHT_ADD] + ) + \\ fs [] + \\ imp_res_tac (GSYM tree_balanced_height_length_sfx_eq) + \\ Cases_on `l` \\ fs [tree_balanced_height_def, tree_sfx_list_def] +QED +*) + +Definition bs_tree_list_to_list_def: + bs_tree_list_to_list ts = FLAT (MAP (\(t, i). bs_tree_to_list i t) (REVERSE ts)) +End + +Theorem bs_tree_list_to_list_rec: + bs_tree_list_to_list (t_i :: ts) = ( + bs_tree_list_to_list ts ++ bs_tree_to_list (SND t_i) (FST t_i) + ) /\ + bs_tree_list_to_list [] = [] +Proof + simp [bs_tree_list_to_list_def] + \\ rpt (pairarg_tac \\ fs[]) +QED + +Theorem monad_simps[local] = LIST_CONJ + [fetch "-" "update_heap_array_def", fetch "-" "heap_array_sub_def", + ml_monadBaseTheory.monad_eqs, st_ex_ignore_bind_simp, + fetch "-" "update_sz_array_def", fetch "-" "sz_array_sub_def"] + +Theorem tree_len_simps_no_less = LIST_CONJ + [tree_balanced_height_def, tree_balanced_height_0, + two_exp_min_1_rec, + LENGTH_bs_tree_to_list, bs_tree_to_list_def, + bs_tree_to_list_tree_rec, bs_tree_list_to_list_rec] + +Theorem tree_len_simps = LIST_CONJ [tree_len_simps_no_less, + two_exp_min_1_less_rec] + +Theorem TAKE_DROP_eq_imp[local]: + !xs i j. TAKE i (DROP j xs) = ys ==> + i <= LENGTH ys ==> + ys = [] \/ (?xs_pre xs_post. xs = xs_pre ++ ys ++ xs_post /\ + j = LENGTH xs_pre /\ i = LENGTH ys) +Proof + Cases_on `ys = []` \\ simp [] + \\ rw [] + \\ qexists_tac `TAKE j xs` + \\ qexists_tac `DROP (i + j) xs` + \\ fs [GSYM TAKE_SUM] + \\ fs [LENGTH_TAKE_EQ] +QED + +Theorem TAKE_DROP_last_eq_imp[local]: + TAKE l (DROP ((i + 1) - l) xs) = ys /\ + i + 1 <= LENGTH xs /\ l <= i + 1 /\ + l <= LENGTH ys /\ 0 < l ==> + ?xs_pre xs_post. xs = xs_pre ++ ys ++ xs_post /\ + l = LENGTH ys /\ i = LENGTH xs_pre + (LENGTH ys - 1) +Proof + rpt strip_tac + \\ dxrule TAKE_DROP_eq_imp + \\ Cases_on `ys = []` \\ fs [] + \\ rw [] + \\ irule_at Any EQ_REFL + \\ simp [] +QED + +Theorem insert_into_sfx_heap_eq: + ! t R i ht x st. + TAKE (two_exp_min_1 ht) (DROP ((i + 1) - two_exp_min_1 ht) st.heap_array) = + bs_tree_to_list ht t /\ + i + 1 <= LENGTH st.heap_array /\ + two_exp_min_1 ht <= i + 1 /\ + ht > 0 /\ + tree_balanced_height ht t ==> + (insert_into_sfx_heap R i ht x st = + (M_success (), st with <| heap_array := TAKE ((i + 1) - two_exp_min_1 ht) st.heap_array + ++ bs_tree_to_list ht (insert_tree_inv R t x) ++ DROP (i + 1) st.heap_array |>)) +Proof + Induct + \\ simp [tree_len_simps] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] + \\ rpt strip_tac + \\ dxrule TAKE_DROP_last_eq_imp + \\ simp [tree_len_simps] + \\ rw [] \\ fs [] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] + >- ( + Cases_on `ht = 1` \\ fs [tree_len_simps] + \\ fs [insert_tree_inv_def, tree_len_simps] + \\ simp [monad_simps, LUPDATE_APPEND, LUPDATE_DEF] + ) + >- ( + fs [tree_balanced_height_pos] + \\ simp [monad_simps, tree_len_simps, sfx_heap_left_two_exp_min_1] + \\ simp [EL_APPEND, tree_len_simps, LEFT_ADD_DISTRIB] + \\ rpt TOP_CASE_TAC \\ simp [ml_monadBaseTheory.monad_eqs] + >- ( + simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ simp [insert_tree_inv_def, tree_len_simps] + ) + >- ( + simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ simp [tree_len_simps] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] + \\ simp_tac bool_ss [GSYM APPEND_ASSOC, APPEND] + ) + >- ( + simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ simp [tree_len_simps] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] + ) + ) +QED + + +Theorem mk_sub_min_1[local]: + (x + 1n) - (2 EXP ht) = (x - two_exp_min_1 ht) +Proof + simp [two_exp_min_1_def] + \\ Cases_on `2 EXP ht` \\ simp [] + \\ fs [] +QED + +Theorem EL_APPEND_PLUS[local]: + EL (LENGTH xs + n) (xs ++ ys) = EL n ys +Proof + simp [EL_APPEND] +QED + +Theorem two_exp_min_1_pos[local]: + (0 < two_exp_min_1 r) = (0 < r) +Proof + Cases_on `r` \\ simp [two_exp_min_1_rec] +QED + +Theorem insert_into_sfx_heap_list_eq: + ! j ts R i x xs ys st. + TAKE (LENGTH (bs_tree_list_to_list ts)) + (DROP ((i + 1) - (LENGTH (bs_tree_list_to_list ts))) st.heap_array) = + bs_tree_list_to_list ts /\ + i + 1 <= LENGTH st.heap_array /\ + LENGTH (bs_tree_list_to_list ts) <= i + 1 /\ + TAKE j st.sz_array = MAP SND (REVERSE ts) /\ + j <= LENGTH st.sz_array ==> + 0 < j /\ EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> + insert_into_sfx_heap_list R i j x st = + (M_success (), st with <| heap_array := TAKE ((i + 1) - LENGTH (bs_tree_list_to_list ts)) st.heap_array + ++ bs_tree_list_to_list (insert_trees_inv R ts x) ++ DROP (i + 1) st.heap_array |>) +Proof + Induct + \\ simp [] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_list_def] + \\ rpt strip_tac + \\ dxrule TAKE_DROP_last_eq_imp + \\ fs [tree_len_simps] + \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [] + \\ gs [tree_len_simps] + \\ simp [insert_trees_inv_def] + \\ rw [] + >- ( + Cases_on `t` \\ fs [] + \\ Cases_on `j` \\ fs [] + \\ qpat_x_assum `TAKE _ _ = _` (assume_tac o Q.AP_TERM `\x. (EL 0 x, LENGTH x)`) + \\ gs [HD_TAKE] + \\ simp [monad_simps] + \\ drule_at (Pat `tree_balanced_height _ _`) insert_into_sfx_heap_eq + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] + ) + >- ( + gs [tree_len_simps, two_exp_min_1_pos] + \\ first_x_assum (qspec_then `t` assume_tac) + \\ qpat_x_assum `TAKE _ _ = _` (assume_tac o Q.AP_TERM `\x. (TAKE j x, EL j x, LENGTH x)`) + \\ Cases_on `j` \\ fs [] + \\ Cases_on `HD t` \\ Cases_on `t` \\ fs [] + \\ gs [ADD1, EL_TAKE, EL_APPEND, TAKE_TAKE] + \\ gs [tree_balanced_height_pos] + \\ simp [monad_simps, tree_len_simps] + \\ full_simp_tac bool_ss [to_two_exp_min_1] + \\ full_simp_tac bool_ss [GSYM ADD_ASSOC, GSYM APPEND_ASSOC, EL_APPEND_PLUS] + \\ full_simp_tac bool_ss [to_two_exp_min_1] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, + EL_APPEND1, EL_APPEND2] + \\ TOP_CASE_TAC + >- ( + simp [monad_simps] + \\ simp [tree_len_simps, sfx_heap_left_two_exp_min_1, LEFT_ADD_DISTRIB] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, + EL_APPEND1, EL_APPEND2] + \\ gs [tree_balanced_height_pos] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, + EL_APPEND1, EL_APPEND2] + \\ rw [] + >- ( + simp [monad_simps] + \\ simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, + EL_APPEND1, EL_APPEND2, LUPDATE_APPEND, LUPDATE_DEF] + ) + >- ( + irule EQ_TRANS \\ irule_at Any insert_into_sfx_heap_eq + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, + EL_APPEND1, EL_APPEND2, LUPDATE_APPEND, LUPDATE_DEF] + \\ irule_at Any EQ_REFL + \\ simp [tree_len_simps] + ) + ) + >- ( + simp [monad_simps] + \\ simp [tree_len_simps, sfx_heap_left_two_exp_min_1, LEFT_ADD_DISTRIB] + \\ TOP_CASE_TAC \\ fs [] + >- ( + Cases_on `r = 1` \\ fs [] + \\ fs [tree_len_simps] + \\ simp [monad_simps] + \\ fs [tree_len_simps] + \\ simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, + EL_APPEND1, EL_APPEND2, LUPDATE_APPEND, LUPDATE_DEF] + \\ simp_tac bool_ss [GSYM APPEND_ASSOC, APPEND] + ) + >- ( + irule EQ_TRANS \\ irule_at Any insert_into_sfx_heap_eq + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, + EL_APPEND1, EL_APPEND2, LUPDATE_APPEND, LUPDATE_DEF] + \\ irule_at Any EQ_REFL + \\ simp [tree_len_simps] + ) + ) + ) +QED + +Theorem MAP_SND_insert_trees_inv[local]: + !ts. MAP SND (insert_trees_inv R ts x) = MAP SND ts +Proof + Induct \\ simp [pairTheory.FORALL_PROD, insert_trees_inv_def] + \\ rw [] + \\ rpt (TOP_CASE_TAC \\ simp []) + \\ simp [] +QED + +Theorem MAP_LENGTH_insert_trees_inv[local]: + MAP (LENGTH o (\(t, n). bs_tree_to_list n t)) + (insert_trees_inv R ts x) = + MAP (LENGTH o (\(t, n). bs_tree_to_list n t)) ts +Proof + qspec_then `ts` (mp_tac o Q.AP_TERM `MAP two_exp_min_1`) MAP_SND_insert_trees_inv + \\ simp [MAP_MAP_o, o_DEF, UNCURRY, tree_len_simps] +QED + +Theorem LENGTH_insert_trees_inv[local] = + Q.AP_TERM `LENGTH` (SPEC_ALL MAP_LENGTH_insert_trees_inv) + |> REWRITE_RULE [LENGTH_MAP] + +Theorem LENGTH_list_of_insert_trees[local]: + LENGTH (bs_tree_list_to_list (insert_trees_inv R ts x)) = + LENGTH (bs_tree_list_to_list ts) +Proof + simp [bs_tree_list_to_list_def, LENGTH_FLAT, MAP_MAP_o, MAP_REVERSE] + \\ simp [MAP_LENGTH_insert_trees_inv] +QED + +Theorem TAKE_EQ_GENLIST: + !n xs. TAKE n xs = GENLIST (\i. EL i xs) (MIN n (LENGTH xs)) +Proof + Induct \\ rw [] + \\ Cases_on `xs` \\ fs [] + \\ irule EQ_SYM + \\ simp [llistTheory.GENLIST_EQ_CONS] + \\ simp [o_DEF, MIN_DEF] + \\ rw [] +QED + +Theorem bind_assoc: + st_ex_bind (st_ex_bind f g) h = do + x <- f; + y <- g x; + h y + od +Proof + rw [ml_monadBaseTheory.st_ex_bind_def, FUN_EQ_THM] + \\ rpt (TOP_CASE_TAC \\ fs []) +QED + +Theorem add_to_sfx_heaps_step1_eq: + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> + TAKE i st.heap_array = bs_tree_list_to_list ts /\ + TAKE j st.sz_array = MAP SND (REVERSE ts) /\ + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ + i + 1 < LENGTH st.heap_array /\ + j + 1 < LENGTH st.sz_array ==> + ?st'. + (let ts2 = add_trees_step1 ts (EL i st.heap_array); + xs = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in + add_to_sfx_heaps_step1 i j st = (M_success l2, st') /\ + TAKE (i + 1) st'.heap_array = xs /\ + TAKE l2 st'.sz_array = MAP SND (REVERSE ts2) /\ + LENGTH st'.sz_array = LENGTH st.sz_array /\ + LENGTH st'.heap_array = LENGTH st.heap_array + ) +Proof + rw [] + \\ simp [add_to_sfx_heaps_step1_def, add_trees_step1_def] + \\ Cases_on `ts` \\ fs [] + >- ( + simp [monad_simps] + \\ fs [tree_len_simps] + \\ fs [Q.SPEC `1` TAKE_EQ_GENLIST, MIN_DEF, EL_LUPDATE, HD_LUPDATE] + ) + \\ Cases_on `t` \\ fs [] + >- ( + simp [monad_simps] + \\ fs [tree_len_simps] + \\ fs [Q.SPEC `2` TAKE_EQ_GENLIST, Q.SPEC `1` TAKE_EQ_GENLIST, MIN_DEF, EL_LUPDATE, HD_LUPDATE] + \\ fs [TAKE_SUM] + ) + \\ rpt (TOP_CASE_TAC \\ fs []) + >- ( + simp [monad_simps] + \\ fs [ADD1, TAKE_SUM, EL_DROP, EL_LUPDATE] + \\ gs [Q.SPEC `2` TAKE_EQ_GENLIST, Q.SPEC `1` TAKE_EQ_GENLIST, MIN_DEF, HD_DROP, EL_DROP] + \\ simp [monad_simps] + \\ fs [tree_len_simps_no_less, HD_DROP, EL_LUPDATE] + \\ irule EQ_TRANS + \\ first_x_assum (irule_at Any) + \\ irule listTheory.LIST_EQ + \\ simp [EL_TAKE, EL_LUPDATE] + ) + >- ( + simp [monad_simps] + \\ fs [ADD1, TAKE_SUM, EL_DROP, EL_LUPDATE] + \\ gs [Q.SPEC `2` TAKE_EQ_GENLIST, Q.SPEC `1` TAKE_EQ_GENLIST, MIN_DEF, HD_DROP, EL_DROP] + \\ simp [monad_simps] + \\ fs [tree_len_simps_no_less, HD_DROP, EL_LUPDATE] + \\ qpat_x_assum `_ = MAP _ (REVERSE _)` (assume_tac o GSYM) + \\ irule listTheory.LIST_EQ + \\ rw [EL_TAKE, EL_APPEND] + \\ simp [EL_LUPDATE, EL_DROP] + \\ rw [] + \\ Cases_on `x = LENGTH t'` \\ fs [] + \\ Cases_on `x = LENGTH t' + 1` \\ fs [] + ) +QED + +Theorem LENGTH_add_trees_step1_adj[local]: + LENGTH (add_trees_step1 ts x) = LENGTH (I (add_trees_step1 ts) ARB) +Proof + simp [add_trees_step1_def] + \\ rpt (TOP_CASE_TAC \\ fs []) +QED + +Theorem LENGTH_add_tree_step1_facts: + 0 < LENGTH (add_trees_step1 ts x) /\ + LENGTH (bs_tree_list_to_list (add_trees_step1 ts x)) = + LENGTH (bs_tree_list_to_list ts) + 1 /\ + LENGTH (add_trees_step1 ts x) <= LENGTH ts + 1 /\ + (MAP SND (add_trees_step1 ts x) = MAP SND (add_trees_step1 ts y)) = T /\ + (LENGTH (add_trees_step1 ts x) = LENGTH (add_trees_step1 ts y)) = T +Proof + simp [add_trees_step1_def] + \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps]) +QED + +Theorem inv_add_tree_step1: + (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (add_trees_step1 ts x) + ) /\ + (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) ==> + SORTED ($<=) (TAKE 2 (MAP SND (add_trees_step1 ts x))) /\ + SORTED ($<) (MAP SND (DROP 1 (add_trees_step1 ts x))) + ) +Proof + simp [add_trees_step1_def] + \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps]) + \\ rpt (pairarg_tac \\ fs []) + \\ rw [] + \\ fs [] + \\ imp_res_tac SORTED_TL \\ fs [] + \\ Cases_on `t'` \\ fs [] +QED + +Theorem insert_trees_adj_with_inv[local]: + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> + insert_trees_inv R ((Node x_dc l r, n) :: ts) x = + insert_trees_inv R ((Node y_dc l r, n) :: ts) x +Proof + simp [insert_trees_inv_def] + \\ rpt (TOP_CASE_TAC \\ fs []) \\ rw [] \\ fs [tree_len_simps] + \\ simp [insert_tree_inv_def] +QED + +Theorem insert_trees_adj_add_trees_with_inv[local]: + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> + insert_trees_inv R (add_trees_step1 ts x_dc) x = + insert_trees_inv R (add_trees_step1 ts y_dc) x +Proof + simp [add_trees_step1_def] + \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps]) + \\ rw [] + \\ irule insert_trees_adj_with_inv + \\ simp [] +QED + +Theorem add_to_sfx_heaps_eq: + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> + TAKE i st.heap_array = bs_tree_list_to_list ts /\ + TAKE j st.sz_array = MAP SND (REVERSE ts) /\ + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ + i + 1 < LENGTH st.heap_array /\ + j + 1 < LENGTH st.sz_array ==> + ?st'. + (let ts2 = add_trees R ts x; xs = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in + add_to_sfx_heaps R i j x st = (M_success l2, st') /\ + TAKE (i + 1) st'.heap_array = xs /\ + TAKE l2 st'.sz_array = MAP SND (REVERSE ts2) /\ + LENGTH st'.sz_array = LENGTH st.sz_array /\ + LENGTH st'.heap_array = LENGTH st.heap_array + ) +Proof + simp [add_to_sfx_heaps_def, add_trees_def] + \\ rpt strip_tac + \\ mp_tac add_to_sfx_heaps_step1_eq + \\ rpt strip_tac + \\ gs [monad_simps] + \\ irule_at Any insert_into_sfx_heap_list_eq + \\ qexists_tac `add_trees_step1 ts (EL i st.heap_array)` + \\ fs [tree_len_simps_no_less, LENGTH_insert_trees_inv] + \\ fs [LENGTH_add_tree_step1_facts, inv_add_tree_step1, LENGTH_list_of_insert_trees] + \\ rpt conj_tac + >- ( + irule LESS_EQ_TRANS + \\ MAP_FIRST (irule_at Any) (CONJUNCTS LENGTH_add_tree_step1_facts) + \\ simp [] + ) + >- ( + simp [TAKE_APPEND1, LENGTH_add_tree_step1_facts, LENGTH_list_of_insert_trees, + TAKE_LENGTH_TOO_LONG] + \\ AP_TERM_TAC + \\ irule insert_trees_adj_add_trees_with_inv + \\ simp [] + ) + >- ( + simp [MAP_REVERSE, MAP_SND_insert_trees_inv] + \\ irule (Q.prove (`a = b /\ TAKE b xs = zs/\ zs = ys ==> TAKE a xs = ys`, simp [])) + \\ first_x_assum (irule_at Any) + \\ simp [MAP_REVERSE, LENGTH_add_tree_step1_facts] + ) +QED + +Theorem LENGTH_to_list_add_trees: + LENGTH (bs_tree_list_to_list (add_trees R ts x)) = + LENGTH (bs_tree_list_to_list ts) + 1 +Proof + simp [add_trees_def, LENGTH_list_of_insert_trees, LENGTH_add_tree_step1_facts] +QED + +Theorem insert_tree_inv_balance_inv: + !t ht. tree_balanced_height ht t ==> + tree_balanced_height ht (insert_tree_inv R t x) +Proof + Induct \\ simp [insert_tree_inv_def] + \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps]) +QED + +Theorem insert_trees_inv_balance_inv: + !ts x. EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (insert_trees_inv R ts x) +Proof + Induct \\ simp [pairTheory.FORALL_PROD, insert_trees_inv_def] + \\ rw [] + \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps, insert_tree_inv_balance_inv]) +QED + +Theorem inv_add_tree: + (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (add_trees R ts x) + ) /\ + (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) ==> + SORTED ($<=) (TAKE 2 (MAP SND (add_trees R ts x))) /\ + SORTED ($<) (MAP SND (DROP 1 (add_trees R ts x))) + ) +Proof + simp [add_trees_def, MAP_SND_insert_trees_inv, MAP_DROP] + \\ simp [GSYM MAP_DROP, inv_add_tree_step1, insert_trees_inv_balance_inv] +QED + +Theorem sum_gt_exp_2: + !js n. EVERYi (\i j. j >= (2 EXP i) * n) js ==> + SUM js >= ((2 EXP LENGTH js) - 1) * n +Proof + Induct + \\ rw [EVERYi_def] + \\ first_x_assum (qspec_then `2 * n` mp_tac) + \\ fs [o_DEF, EXP] +QED + +Theorem sum_lengths_greater_equal_exp[local]: + ! ts n. EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED $< (MAP SND ts) /\ + ts <> [] /\ n <= SND (HD ts) /\ 1 <= n ==> + ((2 EXP (LENGTH ts + (n - 1))) - 1) <= LENGTH (bs_tree_list_to_list ts) +Proof + Induct \\ rw [] + \\ fs [tree_len_simps] + \\ pairarg_tac \\ fs [] + \\ first_x_assum (qspec_then `SUC n` mp_tac) + \\ imp_res_tac SORTED_TL + \\ simp [tree_len_simps, EXP] + \\ Cases_on `ts` \\ fs [] + >- ( + simp [tree_len_simps] + \\ simp [two_exp_min_1_def, LEFT_SUB_DISTRIB] + \\ simp [GSYM EXP, ADD1] + \\ rw [SUB_RIGHT_ADD] + ) + >- ( + rw [] + \\ gs [ADD1] + ) +QED + +Theorem inv_trees_less_via_exp[local]: + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED $< (DROP 1 (MAP SND ts)) /\ + LENGTH (bs_tree_list_to_list ts) < 2 ** lg /\ + lg + i + 2 <= bd ==> + LENGTH ts + i < bd +Proof + rw [] + \\ fs [GSYM MAP_DROP] + \\ drule_at (Pat `SORTED _ _`) sum_lengths_greater_equal_exp + \\ simp [EVERY_DROP] + \\ disch_then (qspec_then `1` mp_tac) + \\ Cases_on `LENGTH ts <= 1` \\ fs [] + \\ impl_tac + >- ( + fs [HD_DROP, EVERY_EL, UNCURRY] + \\ first_x_assum (qspec_then `1` mp_tac) + \\ simp [] + ) + \\ disch_tac + \\ subgoal `2n ** (LENGTH ts - 1) < 2 ** lg` + >- ( + drule_then irule LESS_EQ_LESS_TRANS + \\ Cases_on `ts` \\ fs [tree_len_simps] + \\ pairarg_tac \\ fs [] + \\ gs [tree_len_simps] + ) + \\ fs [] +QED + +Theorem add_all_to_sfx_heaps_eq: + !xs i j ts st. EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ + TAKE i st.heap_array = bs_tree_list_to_list ts /\ + TAKE j st.sz_array = MAP SND (REVERSE ts) /\ + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ + i + LENGTH xs < LENGTH st.heap_array /\ + lg + 3 <= LENGTH st.sz_array /\ + i + LENGTH xs < 2 EXP lg ==> + ?st'. + (let ts2 = build_trees R ts xs; ys = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in + add_all_to_sfx_heaps R i j xs st = (M_success (LENGTH ys, l2), st') /\ + TAKE (LENGTH ys) st'.heap_array = ys /\ + TAKE l2 st'.sz_array = MAP SND (REVERSE ts2) /\ + LENGTH st'.sz_array = LENGTH st.sz_array /\ + LENGTH st'.heap_array = LENGTH st.heap_array + ) +Proof + Induct + \\ rw [add_all_to_sfx_heaps_def, build_trees_def] + \\ simp [monad_simps] + \\ fs [] + \\ qmatch_goalsub_abbrev_tac `add_to_sfx_heaps _ i j x` + \\ mp_tac add_to_sfx_heaps_eq + \\ simp [] + \\ impl_tac + >- ( + fs [markerTheory.Abbrev_def] + \\ irule inv_trees_less_via_exp + \\ simp [GSYM MAP_DROP] + \\ qexists_tac `lg` \\ simp [] + ) + \\ rw [] + \\ last_x_assum (drule_at (Pat `_ = MAP _ _`)) + \\ gs [markerTheory.Abbrev_def, LENGTH_to_list_add_trees] + \\ simp [inv_add_tree] +QED + +(* TODO: reinsert tree, sfx_trees_to_list and toplevel + +Theorem reinsert_tree_eq: + + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ + TAKE i st.heap_array = bs_tree_list_to_list ts ++ bs_tree_to_list ht t /\ + TAKE j st.sz_array = MAP SND (REVERSE ts) /\ + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts ++ bs_tree_to_list ht t) /\ + i + LENGTH xs < LENGTH st.heap_array /\ + lg + 3 <= LENGTH st.sz_array /\ + i + LENGTH xs < 2 EXP lg /\ + 0 < ht /\ tree_balanced_height ht t ==> + ?st'. + (let ts2 = extend_trees R ts t ht; ys = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in + reinsert_tree R i j ht st = (M_success (), st') /\ + TAKE (LENGTH ys) st'.heap_array = ys /\ + DROP (LENGTH ys) st'.heap_array = DROP (LENGTH ys) st.heap_array /\ + TAKE l2 st'.sz_array = MAP SND (REVERSE ts2) /\ + LENGTH st'.sz_array = LENGTH st.sz_array /\ + LENGTH st'.heap_array = LENGTH st.heap_array + ) + +Proof + + rw [reinsert_tree_def] + \\ simp [monad_simps] + \\ drule inv_trees_less_via_exp + \\ simp [GSYM MAP_DROP] + \\ disch_then (qspecl_then [`lg`, `0`, `LENGTH st.sz_array`] mp_tac) + \\ rw [] + + >- ( + simp [monad_simps] + \\ gs [tree_len_simps, to_two_exp_min_1, tree_balanced_height_pos] + \\ fs [TAKE_SUM, EL_DROP] + \\ Cases_on `ts` \\ fs [] + \\ pairarg_tac \\ fs [] + \\ gs [tree_len_simps, tree_balanced_height_pos] + \\ fs [TAKE_SUM, EL_DROP] + \\ fs [listTheory.APPEND_11_LENGTH, LENGTH_TAKE, LENGTH_DROP] + + +print_match [] ``(_ ++ _) = (_ ++ _)`` + + + +Theorem sfx_trees_to_list_eq: + + !i j acc ts st. EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ + TAKE i st.heap_array = bs_tree_list_to_list ts /\ + TAKE j st.sz_array = MAP SND (REVERSE ts) /\ + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ + i < LENGTH st.heap_array /\ + lg + 4 <= LENGTH st.sz_array /\ + i < 2 EXP lg ==> + ?st'. sfx_trees_to_list R i j acc st = (M_success (pull_trees R ts acc), st') + +Proof + + Induct + \\ ONCE_REWRITE_TAC [sfx_trees_to_list_def] + >- ( + rw [] + \\ Cases_on `ts` \\ fs [] + \\ simp [monad_simps, pull_trees_def] + \\ rpt (pairarg_tac \\ fs []) \\ gs [tree_len_simps, tree_balanced_height_pos] + ) + \\ rw [] + \\ simp [monad_simps] + \\ drule inv_trees_less_via_exp + \\ simp [GSYM MAP_DROP] + \\ disch_then (qspecl_then [`lg`, `0`, `LENGTH st.sz_array`] mp_tac) + \\ rw [] + >- ( + Cases_on `ts` \\ fs [tree_len_simps] + \\ pairarg_tac \\ fs [] + \\ gs [tree_len_simps, tree_balanced_height_pos] + \\ gs [ADD1, TAKE_SUM] + \\ Cases_on `n = 1` \\ fs [tree_len_simps] + \\ simp [pull_trees_def, extend_trees_def] + \\ fs [HD_DROP] + \\ first_x_assum irule + \\ simp [] + \\ Cases_on `t` \\ fs [] + \\ imp_res_tac SORTED_TL + \\ simp [] + \\ qmatch_goalsub_abbrev_tac `TAKE 1 tl_ts` + \\ Cases_on `tl_ts` \\ fs [] + ) + >- ( + simp [monad_simps, sfx_heap_left_two_exp_min_1] + \\ Cases_on `ts` \\ fs [tree_len_simps] + \\ pairarg_tac \\ fs [] + \\ gs [tree_len_simps, tree_balanced_height_pos] + \\ gs [ADD1, TAKE_SUM] + \\ fs [tree_len_simps, LEFT_ADD_DISTRIB] + \\ irule_at Any (Q.SPECL [`j`, `(t, n) :: ts`] insert_into_sfx_heap_list_eq) + \\ simp [ADD1, TAKE_SUM, EL_LUPDATE] + \\ simp [tree_len_simps] + \\ qexists_tac `t` \\ simp [] + \\ hphp + + +TAKE1 + + \\, rpt (pairarg_tac \\ fs []) \\ gs [tree_len_simps, tree_balanced_height_pos] + \\ fs [ADD1] + \\ + + \\ irule inv_trees_less_via_exp +*) + diff --git a/basis/pure/heap_sort_in_funScript.sml b/basis/pure/heap_sort_in_funScript.sml index a72c982057..807b694f81 100644 --- a/basis/pure/heap_sort_in_funScript.sml +++ b/basis/pure/heap_sort_in_funScript.sml @@ -6,6 +6,7 @@ Could potentially move out of CakeML to HOL4 sorting theories. *) + Theory heap_sort_in_fun Ancestors list rich_list sorting container bag @@ -448,3 +449,544 @@ Proof simp [GSYM PERM_LIST_TO_BAG, heap_sort_contents] QED +Datatype: + simple_tree = Empty_Tree | Node 'a simple_tree simple_tree +End + +Definition tree_top_less_def: + tree_top_less R Empty_Tree y = T /\ + tree_top_less R (Node x _ _) y = R x y +End + +Definition heap_tree_inv_def: + (heap_tree_inv R n Empty_Tree = (n = 0)) /\ + (heap_tree_inv R n (Node y l r) = (n > 0 /\ + heap_tree_inv R (n - 1) l /\ tree_top_less R l y /\ + heap_tree_inv R (n - 1) r /\ tree_top_less R r y + )) +End + +Theorem heap_tree_inv_empty_eq_eq[local]: + heap_tree_inv R n t ==> ((t = Empty_Tree) = (n = 0)) +Proof + Cases_on `t` \\ simp [heap_tree_inv_def] +QED + +Definition heaps_tree_inv_def: + heaps_tree_inv R xs = (EVERY (\(t, n). heap_tree_inv R n t /\ n > 0) xs /\ + SORTED (\(t1, _) (t2, _). case t1 of Empty_Tree => F | Node x _ _ => + (case t2 of Empty_Tree => F | Node y _ _ => R y x)) xs + ) +End + +Theorem heaps_tree_inv_rec_def: + (heaps_tree_inv R [] = T) /\ + (heaps_tree_inv R (x :: xs) = (heap_tree_inv R (SND x) (FST x) /\ SND x > 0 /\ + ((xs <> []) ==> tree_top_less R (FST (HD xs)) (case x of (Node y _ _, _) => y)) /\ + heaps_tree_inv R xs)) +Proof + simp [heaps_tree_inv_def] + \\ Cases_on `x` \\ simp [] + \\ Cases_on `xs` \\ simp [] + \\ rpt (pairarg_tac \\ fs []) + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [hd (CONJUNCTS heap_tree_inv_def)] + \\ simp [tree_top_less_def] + \\ EQ_TAC \\ rw [] \\ simp [] +QED + +Definition tree_to_bag_def: + tree_to_bag Empty_Tree = {||} /\ + tree_to_bag (Node x l r) = BAG_INSERT x (BAG_UNION (tree_to_bag l) (tree_to_bag r)) +End + +(* Insert into a balanced heap/tree maintaining the invariant. *) +Definition insert_tree_inv_def: + insert_tree_inv R Empty_Tree x = Empty_Tree /\ + insert_tree_inv R (Node _ l r) x = (case l of Empty_Tree => Node x l r + | Node lx _ _ => (case r of Empty_Tree => Node x l r + | Node rx _ _ => if R lx x /\ R rx x then Node x l r + else if R lx rx then Node rx l (insert_tree_inv R r x) + else Node lx (insert_tree_inv R l x) r + )) +End + +Theorem insert_tree_inv_size: + simple_tree_size (K 0) (insert_tree_inv R t x) = + simple_tree_size (K 0) t +Proof + Induct_on `t` + \\ simp [insert_tree_inv_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] +QED + +(* Insert into a chain of heap/trees. *) +Definition insert_trees_inv_def: + (insert_trees_inv R [] x = []) /\ + (insert_trees_inv R ((t1, n1) :: ts) x = (case ts of + | [] => [(insert_tree_inv R t1 x, n1)] + | (t2, n2) :: tl_ts => + (case t1 of Empty_Tree => + (* won't happen, leave list the same *) ((t1, n1) :: ts) + | Node _ l r => (case t2 of Empty_Tree => + (* won't happen, leave list the same *) ((t1, n1) :: ts) + | Node t2x _ _ => if ~ (R t2x x) /\ + ~ (case l of Empty_Tree => F | Node lx _ _ => R t2x lx) /\ + ~ (case r of Empty_Tree => F | Node rx _ _ => R t2x rx) + then (Node t2x l r, n1) :: insert_trees_inv R ts x + else (insert_tree_inv R t1 x, n1) :: ts + )))) +End + +Theorem insert_trees_inv_size: + MAP (simple_tree_size (K 0) o FST) (insert_trees_inv R ts x) = + MAP (simple_tree_size (K 0) o FST) ts +Proof + measureInduct_on `LENGTH ts` + \\ Cases_on `ts` + \\ simp [insert_trees_inv_def] + \\ Cases_on `h` + \\ simp [insert_trees_inv_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [insert_tree_inv_size] +QED + +Theorem insert_trees_inv_length = + Q.AP_TERM `LENGTH` insert_trees_inv_size |> REWRITE_RULE [LENGTH_MAP] + +Definition add_trees_step1_def: + add_trees_step1 ts x = (case ts of + (t1, n1) :: (t2, n2) :: ts2 => if n1 = n2 + then (Node x t2 t1, n1 + 1) :: ts2 + else (Node x Empty_Tree Empty_Tree, 1) :: ts + | _ => (Node x Empty_Tree Empty_Tree, 1) :: ts + ) +End + +Definition add_trees_def: + add_trees R ts x = insert_trees_inv R (add_trees_step1 ts x) x +End + +Definition build_trees_def: + build_trees R ts [] = ts /\ + build_trees R ts (x :: xs) = build_trees R (add_trees R ts x) xs +End + +Definition extend_trees_def: + extend_trees R ts t n = (case t of + Empty_Tree => ts + | Node x l r => (let ord = (case ts of ((Node y _ _, _) :: _) => R y x | _ => T) + in if ord then (t, n) :: ts + else insert_trees_inv R ((t, n) :: ts) x + )) +End + +Theorem extend_trees_size: + SUM (MAP (\t_n. simple_tree_size (K 0) (FST t_n)) (extend_trees R ts t n)) = + simple_tree_size (K 0) t + SUM (MAP (\t_n. simple_tree_size (K 0) (FST t_n)) ts) +Proof + simp [extend_trees_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [REWRITE_RULE [combinTheory.o_DEF] insert_trees_inv_size] +QED + +Definition pull_trees_def: + pull_trees R [] acc = acc /\ + pull_trees R ((Empty_Tree, _) :: ts) acc = acc /\ + pull_trees R ((Node x l r, n) :: ts) acc = + let ts2 = extend_trees R ts l (n - 1); + ts3 = extend_trees R ts2 r (n - 1) + in pull_trees R ts3 (x :: acc) +Termination + WF_REL_TAC `measure (\(R, ts, acc). SUM (MAP (simple_tree_size (K 0) o FST) ts))` + \\ rw [] + \\ simp [extend_trees_size] +End + +Definition another_heap_sort_def: + another_heap_sort R xs = pull_trees R (build_trees R [] xs) [] +End + +(* Invariant preservation. *) +Theorem insert_tree_inv_less[local]: + (case t of Node _ l r => tree_top_less R l y /\ tree_top_less R r y | _ => T) ==> + R x y ==> + transitive R ==> total R ==> + tree_top_less R (insert_tree_inv R t x) y +Proof + Cases_on `t` \\ simp [insert_tree_inv_def, tree_top_less_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [tree_top_less_def] +QED + +Theorem insert_tree_inv: + heap_tree_inv R n t ==> + transitive R ==> total R ==> + heap_tree_inv R n (insert_tree_inv R t x) +Proof + qid_spec_tac `n` + \\ Induct_on `t` + \\ rw [insert_tree_inv_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ gs [heap_tree_inv_def, tree_top_less_def] + \\ irule_at Any insert_tree_inv_less + \\ simp [] + \\ metis_tac [total_lemma, transitive_lemma] +QED + +Theorem insert_tree_inv_greater[local]: + R x y \/ (case l of Node ly _ _ => R x ly | _ => F) \/ + (case r of Node ry _ _ => R x ry | _ => F) ==> + transitive R ==> total R ==> + ((l = Empty_Tree) = (r = Empty_Tree)) ==> + R x (case insert_tree_inv R (Node x_old l r) y of + Empty_Tree => Anything | Node z _ _ => z) +Proof + simp [insert_tree_inv_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [tree_top_less_def] + \\ metis_tac [transitive_lemma, total_lemma] +QED + +Theorem insert_tree_inv_contents: + tree_to_bag (insert_tree_inv R t x) = (case t of Empty_Tree => {||} + | Node _ l r => tree_to_bag (Node x l r)) +Proof + Induct_on `t` + \\ simp [insert_tree_inv_def, tree_to_bag_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [tree_to_bag_def] + \\ simp [BAG_UNION_INSERT] + \\ simp [BAG_INSERT_commutes] +QED + +Theorem tree_top_less_mono: + tree_top_less R t x ==> R x y ==> + transitive R ==> + tree_top_less R t y +Proof + Cases_on `t` + \\ simp [tree_top_less_def] + \\ metis_tac [transitive_lemma] +QED + +Theorem tree_top_less_neg[local]: + (~ (case t of Empty_Tree => F | Node y _ _ => R x y)) ==> + total R ==> + tree_top_less R t x +Proof + BasicProvers.EVERY_CASE_TAC \\ simp [tree_top_less_def] + \\ metis_tac [total_lemma] +QED + +Theorem heap_tree_inv_mono: + heap_tree_inv R n (Node x l r) ==> + R x y ==> transitive R ==> + heap_tree_inv R n (Node y l r) +Proof + simp [heap_tree_inv_def] + \\ metis_tac [tree_top_less_mono] +QED + +Theorem insert_trees_inv_less[local]: + (case ts of [] => F | (Empty_Tree, _) :: _ => F | ((Node _ l r, _) :: ts2) => + tree_top_less R l y /\ tree_top_less R r y /\ + (ts2 <> [] ==> FST (HD (ts2)) <> Empty_Tree /\ + tree_top_less R (FST (HD ts2)) y)) ==> + R x y ==> + transitive R ==> total R ==> + tree_top_less R (FST (HD (insert_trees_inv R ts x))) y +Proof + BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [insert_trees_inv_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ rw [] + \\ fs [tree_top_less_def, insert_tree_inv_less] +QED + +Theorem insert_trees_inv: + heaps_tree_inv R ts ==> + transitive R ==> total R ==> + heaps_tree_inv R (insert_trees_inv R ts x) +Proof + Induct_on `ts` + \\ simp [insert_trees_inv_def, pairTheory.FORALL_PROD, heaps_tree_inv_rec_def] + \\ rpt gen_tac + \\ ntac 2 BasicProvers.TOP_CASE_TAC + \\ simp [insert_tree_inv, heaps_tree_inv_rec_def] + \\ ntac 2 BasicProvers.TOP_CASE_TAC + \\ simp [insert_tree_inv, heaps_tree_inv_rec_def] + \\ fs [hd (CONJUNCTS heap_tree_inv_def)] + \\ csimp [] + \\ rw [heaps_tree_inv_rec_def] + \\ simp [insert_tree_inv] + >- ( + fs [heap_tree_inv_def, tree_top_less_def] + \\ rpt (dxrule tree_top_less_neg) + \\ simp [] + ) + >- ( + irule insert_trees_inv_less + \\ fs [heap_tree_inv_def, tree_top_less_def] + \\ fsrw_tac [SFY_ss] [total_lemma] + \\ rpt strip_tac + \\ Cases_on `t` \\ fs [] + \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def] + ) + >- ( + simp [tree_top_less_def] + \\ irule insert_tree_inv_greater + \\ fs [heap_tree_inv_def] + \\ rpt (dxrule heap_tree_inv_empty_eq_eq) + \\ simp [] + ) +QED + +Theorem insert_trees_inv_contents: + EVERY (\p. FST p <> Empty_Tree) ts ==> + (FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) (insert_trees_inv R ts x)) = + (case ts of [] => {||} + | (Node _ l r, _) :: ts => BAG_UNION (tree_to_bag (Node x l r)) + (FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) ts))) + ) +Proof + Induct_on `ts` + \\ simp [pairTheory.FORALL_PROD, insert_trees_inv_def, tree_to_bag_def] + \\ rw [] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def] + \\ gs [] + \\ simp [insert_tree_inv_contents, tree_to_bag_def] + \\ simp [BAG_UNION_INSERT] + \\ simp [BAG_INSERT_commutes] +QED + +Theorem insert_trees_non_empty: + EVERY (\p. FST p <> Empty_Tree) ts ==> + EVERY (\p. FST p <> Empty_Tree) (insert_trees_inv R ts x) +Proof + Induct_on `ts` + \\ simp [pairTheory.FORALL_PROD, insert_trees_inv_def] + \\ rw [] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ gs [] + \\ rw [insert_tree_inv_def] +QED + +Theorem build_trees_contents: + EVERY (\p. FST p <> Empty_Tree) ts ==> + FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) (build_trees R ts xs)) = + BAG_UNION (LIST_TO_BAG xs) (FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) ts)) /\ + EVERY (\p. FST p <> Empty_Tree) (build_trees R ts xs) +Proof + qid_spec_tac `ts` + \\ Induct_on `xs` + \\ rw [build_trees_def] + \\ simp [add_trees_def, add_trees_step1_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ fs [] + \\ simp [insert_trees_inv_contents, insert_trees_non_empty, tree_to_bag_def] + \\ simp [BAG_UNION_INSERT] + \\ simp [BAG_INSERT_commutes, ASSOC_BAG_UNION, COMM_BAG_UNION] +QED + +Theorem insert_tree_inv_adj[local]: + insert_tree_inv R (Node x_dc l r) x = + insert_tree_inv R (Node y_dc l r) x +Proof + simp [insert_tree_inv_def] +QED + +Theorem insert_tree_adj_inv[local]: + heap_tree_inv R n (insert_tree_inv R (Node x l r) x) + ==> + heap_tree_inv R n (insert_tree_inv R (Node x_dc l r) x) +Proof + simp [insert_tree_inv_def] +QED + +Theorem insert_trees_adj_inv1[local]: + heaps_tree_inv R (insert_trees_inv R ((Node x_dc l r, n) :: ts) x) ==> + heaps_tree_inv R (insert_trees_inv R ((Node y_dc l r, n) :: ts) x) +Proof + simp [insert_trees_inv_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [insert_tree_inv_def] + \\ csimp [heaps_tree_inv_rec_def, heap_tree_inv_def] +QED + +Theorem insert_trees_adj_inv2[local]: + heaps_tree_inv R ts ==> + heap_tree_inv R n (Node x_dc l r) ==> + transitive R ==> total R ==> reflexive R ==> + heaps_tree_inv R (insert_trees_inv R ((Node x_dc l r, n) :: ts) x) +Proof + Cases_on `heaps_tree_inv R ((Node x_dc l r, n) :: ts)` + \\ simp [insert_trees_inv] + \\ rw [] + \\ irule insert_trees_adj_inv1 + \\ qexists_tac `case HD ts of (Node x _ _, _) => x` + \\ irule insert_trees_inv + \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def] + \\ Cases_on `FST (HD ts)` \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [] + \\ fs [tree_top_less_def] + \\ simp [heaps_tree_inv_rec_def, heap_tree_inv_def, tree_top_less_def] + \\ fs [relationTheory.reflexive_def] + \\ rw [] + \\ drule_then irule tree_top_less_mono + \\ simp [] + \\ metis_tac [total_lemma] +QED + +Theorem insert_trees_adj_inv3[local]: + heaps_tree_inv R ts ==> + heap_tree_inv R (n - 1) l ==> + heap_tree_inv R (n - 1) r ==> + n > 0 ==> + transitive R ==> total R ==> reflexive R ==> + heaps_tree_inv R (insert_trees_inv R ((Node x_dc l r, n) :: ts) x) +Proof + Cases_on `heap_tree_inv R n (Node (case l of Node y _ _ => y) l r) \/ + heap_tree_inv R n (Node (case r of Node y _ _ => y) l r)` + >- ( + rw [] \\ fs [] + \\ irule insert_trees_adj_inv1 + \\ irule_at Any insert_trees_adj_inv2 + \\ simp [] + \\ first_x_assum (irule_at Any) + ) + >- ( + rw [] \\ fs [] + \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def] + \\ BasicProvers.EVERY_CASE_TAC \\ fs [tree_top_less_def] + \\ gs [relationTheory.reflexive_def] + \\ irule insert_trees_adj_inv1 + \\ irule_at Any insert_trees_adj_inv2 + \\ simp [heap_tree_inv_def, relationTheory.reflexive_def, tree_top_less_def] + \\ metis_tac [total_lemma] + ) +QED + +Theorem build_trees_inv: + heaps_tree_inv R ts ==> + transitive R ==> total R ==> reflexive R ==> + heaps_tree_inv R (build_trees R ts xs) +Proof + qid_spec_tac `ts` + \\ Induct_on `xs` + \\ rw [build_trees_def] + \\ simp [add_trees_def, add_trees_step1_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [] + \\ first_x_assum irule + \\ simp [] + \\ irule insert_trees_adj_inv3 + \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def, tree_top_less_def] +QED + +Theorem extend_trees_contents[local]: + EVERY (\p. FST p <> Empty_Tree) ts ==> + FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) (extend_trees R ts t n)) = + BAG_UNION (tree_to_bag t) (FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) ts)) +Proof + simp [extend_trees_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [tree_to_bag_def] + \\ simp [insert_trees_inv_contents, insert_trees_non_empty, tree_to_bag_def] +QED + +Theorem extend_trees_not_empty[local]: + EVERY (\p. FST p <> Empty_Tree) ts ==> + EVERY (\p. FST p <> Empty_Tree) (extend_trees R ts t n) +Proof + simp [extend_trees_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ simp [insert_trees_non_empty] +QED + +Theorem extend_trees_inv[local]: + (t <> Empty_Tree ==> heap_tree_inv R n t) ==> + heaps_tree_inv R ts ==> + total R /\ transitive R /\ reflexive R ==> + heaps_tree_inv R (extend_trees R ts t n) +Proof + simp [extend_trees_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ csimp [heaps_tree_inv_rec_def, heap_tree_inv_def, tree_top_less_def] + \\ rw [] + \\ irule insert_trees_adj_inv3 + \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def] +QED + +Theorem extend_trees_less[local]: + (ts <> [] ==> tree_top_less R (FST (HD ts)) x) ==> + tree_top_less R t x ==> + total R ==> transitive R ==> + (extend_trees R ts t n <> []) ==> + heaps_tree_inv R ts ==> + heap_tree_inv R n t ==> + tree_top_less R (FST (HD (extend_trees R ts t n))) x +Proof + simp [extend_trees_def] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] + \\ rw [] + \\ irule insert_trees_inv_less + \\ fs [tree_top_less_def] + \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def] + \\ fsrw_tac [SFY_ss] [tree_top_less_mono] + \\ CCONTR_TAC + \\ Cases_on `ts` + \\ gs [heaps_tree_inv_rec_def, heap_tree_inv_def] +QED + +Theorem pull_trees_contents: + ! R ts acc. EVERY (\p. FST p <> Empty_Tree) ts ==> + LIST_TO_BAG (pull_trees R ts acc) = + BAG_UNION (FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) ts)) (LIST_TO_BAG acc) +Proof + recInduct pull_trees_ind + \\ rw [] + \\ simp [pull_trees_def, tree_to_bag_def] + \\ simp [extend_trees_contents, extend_trees_not_empty] + \\ simp [BAG_UNION_INSERT] + \\ simp [BAG_INSERT_commutes, ASSOC_BAG_UNION, COMM_BAG_UNION] +QED + +Theorem pull_trees_sorted: + ! R ts acc. heaps_tree_inv R ts ==> + transitive R ==> total R ==> reflexive R ==> + SORTED R acc ==> + ((ts <> []) ==> (acc <> []) ==> tree_top_less R (FST (HD ts)) (HD acc)) ==> + SORTED R (pull_trees R ts acc) +Proof + recInduct pull_trees_ind + \\ rw [] \\ fs [] + \\ simp [pull_trees_def] + \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def, tree_top_less_def] + \\ gs [] + \\ first_x_assum irule + \\ simp [extend_trees_inv] + \\ rw [] + \\ simp [extend_trees_less, extend_trees_inv] + \\ Cases_on `acc` + \\ fs [] +QED + +Theorem another_heap_sort_sorted: + reflexive R ==> transitive R ==> total R ==> + SORTED R (another_heap_sort R xs) +Proof + rw [another_heap_sort_def] + \\ irule pull_trees_sorted + \\ simp [] + \\ irule build_trees_inv + \\ simp [heaps_tree_inv_def] +QED + +Theorem another_heap_sort_contents: + LIST_TO_BAG (another_heap_sort R xs) = LIST_TO_BAG xs +Proof + rw [another_heap_sort_def] + \\ simp [pull_trees_contents, build_trees_contents] +QED + From e5ce0a5fe1a3a5908864dc4652556dee21e8343e Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 12 Feb 2026 12:45:15 +1100 Subject: [PATCH 08/39] Verify and translate monadic versions I gave up on setting up a separation-style approach and just verified everything using TAKE/DROP. Some of the proofs are a bit of a mess. --- basis/heap_sort_monadicScript.sml | 435 ++++++++++++++++++++++++++---- 1 file changed, 387 insertions(+), 48 deletions(-) diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml index bdd17713a7..c3953f8ed9 100644 --- a/basis/heap_sort_monadicScript.sml +++ b/basis/heap_sort_monadicScript.sml @@ -552,11 +552,20 @@ Definition sfx_trees_to_list_def: od End +Definition above_log2_def: + above_log2 i v n = if n = 0n \/ v <= n + then i + else above_log2 (i + 1n) v (n * 2) +Termination + WF_REL_TAC `measure (\(i, v, n). (v - n))` +End + Definition sort_via_sfx_trees_worker_def: sort_via_sfx_trees_worker R x xs = do sz <- return (LENGTH xs); - alloc_heap_array sz x; - alloc_sz_array (LOG2 sz + 3) 0; + alloc_heap_array (sz + 1) x; + sz_log <- return (above_log2 0 (sz + 1) 1); + alloc_sz_array (sz_log + 5) 0; (i, j) <- add_all_to_sfx_heaps R 0 0 xs; sfx_trees_to_list R i j [] od @@ -632,7 +641,7 @@ QED Theorem LENGTH_bs_tree_to_list: ! i t. LENGTH (bs_tree_to_list i t) = two_exp_min_1 i Proof - Induct + Induct \\ simp [bs_tree_to_list_def, two_exp_min_1_rec] QED @@ -838,7 +847,7 @@ Proof simp [ml_monadBaseTheory.monad_eqs] \\ rw [] \\ first_x_assum (irule_at Any) - \\ drule_then (irule_at Any) update_heap_array_eq + \\ drule_then (irule_at Any) update_heap_array_eq \\ simp [] \\ simp [fetch "-" "state_refs_component_equality"] QED @@ -886,7 +895,7 @@ QED Theorem monad_simps[local] = LIST_CONJ [fetch "-" "update_heap_array_def", fetch "-" "heap_array_sub_def", ml_monadBaseTheory.monad_eqs, st_ex_ignore_bind_simp, - fetch "-" "update_sz_array_def", fetch "-" "sz_array_sub_def"] + fetch "-" "update_sz_array_def", fetch "-" "sz_array_sub_def"] Theorem tree_len_simps_no_less = LIST_CONJ [tree_balanced_height_def, tree_balanced_height_0, @@ -897,6 +906,43 @@ Theorem tree_len_simps_no_less = LIST_CONJ Theorem tree_len_simps = LIST_CONJ [tree_len_simps_no_less, two_exp_min_1_less_rec] +Definition array_mappings_def: + array_mappings xs = LIST_TO_BAG (MAPi (\i x. (i, x)) xs) +End + +Definition array_upd_mappings_def: + array_of_mappings bg = GENLIST (\i. (CHOICE (\x. BAG_IN (i, x) bg))) (bag_size (K 0) bg) +End + +Definition list_mappings_from_def: + list_mappings_from xs i = LIST_TO_BAG (MAPi (\j x. (i + j, x)) xs) +End + +Theorem list_mappings_from_append: + list_mappings_from (xs ++ ys) i = + BAG_UNION (list_mappings_from xs i) (list_mappings_from ys (i + LENGTH xs)) +Proof + simp [list_mappings_from_def, MAPi_APPEND, LIST_TO_BAG_APPEND, o_DEF] +QED + +Theorem list_mappings_from_bases: + list_mappings_from [x] i = {|(i, x)|} /\ + list_mappings_from [] j = {||} +Proof + simp [list_mappings_from_def] +QED + +Theorem array_mappings_eq_from: + array_mappings xs = list_mappings_from xs 0 +Proof + simp [array_mappings_def, list_mappings_from_def] +QED + +Theorem array_mappings_of: + array_mappings (array_of_mappings bg) = bg +Proof + simp [array_mappings_def, array_of_mappings_def] + Theorem TAKE_DROP_eq_imp[local]: !xs i j. TAKE i (DROP j xs) = ys ==> i <= LENGTH ys ==> @@ -926,7 +972,105 @@ Proof \\ simp [] QED +Theorem array_mappings_IMP_EL: + BAG_IN (i, x) (array_mappings arr) ==> + EL i arr = x /\ i < LENGTH arr +Proof + rw [array_mappings_def] + \\ fs [IN_LIST_TO_BAG, MEM_MAPi] +QED + +(* +Theorem list_mappings_LUPDATE: + !arr j i. i < LENGTH arr ==> + list_mappings_from (LUPDATE y i arr) j = + (list_mappings_from arr j - {|(i + j, EL i arr)|} + {|(i + j, y)|}) +Proof + Induct \\ fs [list_mappings_from_def] + \\ rw [o_DEF] + \\ Cases_on `i` \\ fs [LUPDATE_DEF] + \\ simp [o_DEF, BAG_UNION_INSERT] + \\ simp [ADD1] + \\ simp [BAG_INSERT_UNION] + \\ cheat +QED + +Theorem array_mappings_LUPDATE: + array_mappings arr = xs /\ xs = BAG_UNION {|(i, x)|} others ==> + array_mappings (LUPDATE y i arr) = BAG_UNION {|(i, y)|} others +Proof + rw [] + \\ mp_tac array_mappings_IMP_EL + \\ fs [array_mappings_eq_from] + \\ simp [list_mappings_LUPDATE] + \\ simp [COMM_BAG_UNION] +QED + +Theorem update_heap_array_mappings: + array_mappings st.heap_array = xs /\ + xs = BAG_UNION {|(i, prev_x)|} others ==> + ?arr. update_heap_array i x st = (M_success (), st with heap_array := arr) /\ + array_mappings arr = {|(i,x)|} ⊎ others +Proof + simp [fetch "-" "update_heap_array_def", ml_monadBaseTheory.monad_eqs] + \\ rw [] + \\ irule_at Any EQ_REFL + \\ simp [array_mappings_LUPDATE] + \\ irule (UNDISCH array_mappings_IMP_EL |> BODY_CONJUNCTS |> List.last |> DISCH_ALL) + \\ simp [EXISTS_OR_THM] +QED + +Theorem heap_array_sub_mappings: + array_mappings st.heap_array = xs /\ + xs = BAG_UNION {|(i, x)|} others ==> + ?arr. heap_array_sub i st = (M_success x, st) +Proof + cheat +QED + + +Theorem update_heap_array_mappings2: + array_mappings st.heap_array = BAG_UNION {|(i, prev_x)|} others /\ + (!arr. array_mappings arr = {|(i,x)|} ⊎ others ==> P arr) ==> + ?arr. update_heap_array i x st = (M_success (), st with heap_array := arr) /\ P arr +Proof + cheat +QED + +fun use_ex_thm1 thm (alist, gl) = let + val (ex_vars, gl2) = strip_exists gl + val conjs = strip_conj gl2 + val possible_gl_lhss = conjs |> mapfilter (fst o dest_eq) + |> filter (fn t => not (exists (fn v => free_in v t) ex_vars)) + val thm_concl = concl thm |> strip_imp |> snd + val key_lhs = thm_concl |> strip_exists |> snd |> strip_conj |> hd |> lhs + val lhs_vars = FVL [key_lhs] (HOLset.empty Term.compare) + val thm_vars = FVL [concl thm] (HOLset.empty Term.compare) + val gen_vars = HOLset.listItems (HOLset.difference (thm_vars, lhs_vars)) + in MAP_FIRST (fn gl_lhs => let + val (inst, tinst) = match_term key_lhs gl_lhs + val thm2 = INST_TYPE tinst thm |> INST inst |> GENL gen_vars + in mp_tac thm2 end) possible_gl_lhss (alist, gl) end + +fun use_ex_thm thm = (REWRITE_TAC [PULL_EXISTS] >> use_ex_thm1 thm) + +Theorem FUNNY_PULL_FORALL1: + !P R. (?x. P x ==> R) ==> + ((!x. P x) ==> R) +Proof + metis_tac [] +QED + +Theorem FUNNY_PULL_FORALL: + !P Q R. (?x. P x /\ (Q x ==> R)) ==> + ((!x. P x ==> Q x) ==> R) +Proof + metis_tac [] +QED +*) + Theorem insert_into_sfx_heap_eq: + ! t R i ht x st. TAKE (two_exp_min_1 ht) (DROP ((i + 1) - two_exp_min_1 ht) st.heap_array) = bs_tree_to_list ht t /\ @@ -998,7 +1142,7 @@ Proof QED Theorem insert_into_sfx_heap_list_eq: - ! j ts R i x xs ys st. + ! j ts R i x st. TAKE (LENGTH (bs_tree_list_to_list ts)) (DROP ((i + 1) - (LENGTH (bs_tree_list_to_list ts))) st.heap_array) = bs_tree_list_to_list ts /\ @@ -1312,7 +1456,7 @@ Proof QED Theorem LENGTH_to_list_add_trees: - LENGTH (bs_tree_list_to_list (add_trees R ts x)) = + LENGTH (bs_tree_list_to_list (add_trees R ts x)) = LENGTH (bs_tree_list_to_list ts) + 1 Proof simp [add_trees_def, LENGTH_list_of_insert_trees, LENGTH_add_tree_step1_facts] @@ -1452,18 +1596,23 @@ Proof \\ simp [inv_add_tree] QED -(* TODO: reinsert tree, sfx_trees_to_list and toplevel +Theorem TAKE_LUPDATE_CASES: + !xs i j. TAKE i (LUPDATE x j xs) = (if j < i then LUPDATE x j (TAKE i xs) else TAKE i xs) +Proof + Induct \\ fs [] + \\ simp [LUPDATE_DEF] + \\ rw [] + \\ fs [] + \\ Cases_on `i` \\ fs [] +QED Theorem reinsert_tree_eq: - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ TAKE i st.heap_array = bs_tree_list_to_list ts ++ bs_tree_to_list ht t /\ TAKE j st.sz_array = MAP SND (REVERSE ts) /\ j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts ++ bs_tree_to_list ht t) /\ - i + LENGTH xs < LENGTH st.heap_array /\ - lg + 3 <= LENGTH st.sz_array /\ - i + LENGTH xs < 2 EXP lg /\ + i < LENGTH st.heap_array /\ + j + 1 < LENGTH st.sz_array /\ 0 < ht /\ tree_balanced_height ht t ==> ?st'. (let ts2 = extend_trees R ts t ht; ys = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in @@ -1474,33 +1623,84 @@ Theorem reinsert_tree_eq: LENGTH st'.sz_array = LENGTH st.sz_array /\ LENGTH st'.heap_array = LENGTH st.heap_array ) - Proof - rw [reinsert_tree_def] \\ simp [monad_simps] - \\ drule inv_trees_less_via_exp - \\ simp [GSYM MAP_DROP] - \\ disch_then (qspecl_then [`lg`, `0`, `LENGTH st.sz_array`] mp_tac) - \\ rw [] - + \\ qmatch_goalsub_abbrev_tac `(if C then check else return F) st_upd` + \\ subgoal `(if C then check else return F) st_upd = + (M_success (case (t, ts) of (Node x _ _, ((Node y _ _, _) :: _)) => ~ R y x | _ => F), st_upd)` >- ( - simp [monad_simps] - \\ gs [tree_len_simps, to_two_exp_min_1, tree_balanced_height_pos] - \\ fs [TAKE_SUM, EL_DROP] - \\ Cases_on `ts` \\ fs [] + fs [markerTheory.Abbrev_def] + \\ gs [tree_balanced_height_pos] + \\ gs [TAKE_SUM, tree_len_simps, listTheory.APPEND_11_LENGTH, + Q.SPECL [`two_exp_min_1 i`, `two_exp_min_1 i`] TAKE_SUM |> REWRITE_RULE [GSYM TIMES2]] + \\ Cases_on `ts` \\ fs [monad_simps] \\ pairarg_tac \\ fs [] - \\ gs [tree_len_simps, tree_balanced_height_pos] - \\ fs [TAKE_SUM, EL_DROP] - \\ fs [listTheory.APPEND_11_LENGTH, LENGTH_TAKE, LENGTH_DROP] + \\ gs [tree_balanced_height_pos, tree_len_simps] + \\ gs [TAKE_SUM, tree_len_simps, listTheory.APPEND_11_LENGTH, + Q.SPECL [`two_exp_min_1 i`, `two_exp_min_1 i`] TAKE_SUM |> REWRITE_RULE [GSYM TIMES2]] + \\ fs [EL_DROP, tree_len_simps, LEFT_ADD_DISTRIB, to_two_exp_min_1] + ) + >- ( + fs [] + \\ qmatch_goalsub_abbrev_tac `(if C2 then _ else return _)` + \\ subgoal `extend_trees R ts t ht = (if C2 then insert_trees_inv R ((t,ht) :: ts) + (case t of Node x _ _ => x) else (t, ht) :: ts)` + >- ( + fs [markerTheory.Abbrev_def] + \\ simp [extend_trees_def] + \\ gs [tree_balanced_height_pos] + \\ BasicProvers.EVERY_CASE_TAC \\ fs [] + ) + \\ rw [] + >- ( + irule_at Any insert_into_sfx_heap_list_eq + \\ qexists_tac `(t, ht) :: ts` + \\ fs [tree_len_simps, markerTheory.Abbrev_def, TAKE_SUM, EL_LUPDATE] + \\ fs [tree_len_simps, LENGTH_list_of_insert_trees, LENGTH_insert_trees_inv, + TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] + \\ simp [MAP_REVERSE, MAP_SND_insert_trees_inv] + \\ simp [ADD1, TAKE_SUM, EL_LUPDATE] + \\ simp [TAKE_LUPDATE_CASES, MAP_REVERSE] + \\ gs [tree_balanced_height_pos] + \\ gs [TAKE_SUM, tree_len_simps, listTheory.APPEND_11_LENGTH, + Q.SPECL [`two_exp_min_1 i`, `two_exp_min_1 i`] TAKE_SUM |> REWRITE_RULE [GSYM TIMES2]] + \\ fs [EL_DROP] + ) + >- ( + simp [monad_simps] + \\ fs [markerTheory.Abbrev_def, tree_len_simps] + \\ simp [ADD1, TAKE_SUM, EL_LUPDATE] + \\ simp [TAKE_LUPDATE_CASES, MAP_REVERSE] + ) + ) +QED + +Theorem LENGTH_extend_trees_facts[local]: + tree_balanced_height ht t /\ 0 < ht ==> + LENGTH (extend_trees R ts t ht) = LENGTH ts + 1 + /\ + MAP SND (extend_trees R ts t ht) = ht :: MAP SND ts + /\ + LENGTH (bs_tree_list_to_list (extend_trees R ts t ht)) = + LENGTH (bs_tree_list_to_list ts) + LENGTH (bs_tree_to_list ht t) /\ + (EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) (extend_trees R ts t ht) + ) +Proof + rw [extend_trees_def] + \\ fs [tree_len_simps, tree_balanced_height_pos] + \\ BasicProvers.EVERY_CASE_TAC \\ fs [] + \\ simp [LENGTH_insert_trees_inv, MAP_SND_insert_trees_inv, + LENGTH_list_of_insert_trees, tree_len_simps, insert_trees_inv_balance_inv] +QED -print_match [] ``(_ ++ _) = (_ ++ _)`` +Theorem TAKE_2_times_two_exp[local] = + Q.SPECL [`two_exp_min_1 i`, `two_exp_min_1 i`] TAKE_SUM |> REWRITE_RULE [GSYM TIMES2] - Theorem sfx_trees_to_list_eq: - !i j acc ts st. EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ TAKE i st.heap_array = bs_tree_list_to_list ts /\ @@ -1510,9 +1710,7 @@ Theorem sfx_trees_to_list_eq: lg + 4 <= LENGTH st.sz_array /\ i < 2 EXP lg ==> ?st'. sfx_trees_to_list R i j acc st = (M_success (pull_trees R ts acc), st') - Proof - Induct \\ ONCE_REWRITE_TAC [sfx_trees_to_list_def] >- ( @@ -1525,7 +1723,7 @@ Proof \\ simp [monad_simps] \\ drule inv_trees_less_via_exp \\ simp [GSYM MAP_DROP] - \\ disch_then (qspecl_then [`lg`, `0`, `LENGTH st.sz_array`] mp_tac) + \\ disch_then (qspecl_then [`lg`, `2`, `LENGTH st.sz_array`] mp_tac) \\ rw [] >- ( Cases_on `ts` \\ fs [tree_len_simps] @@ -1545,24 +1743,165 @@ Proof ) >- ( simp [monad_simps, sfx_heap_left_two_exp_min_1] - \\ Cases_on `ts` \\ fs [tree_len_simps] + \\ qabbrev_tac `ts_case = ts` + \\ Cases_on `ts_case` \\ fs [tree_len_simps_no_less] + \\ qabbrev_tac `orig_ts = ts` \\ pairarg_tac \\ fs [] - \\ gs [tree_len_simps, tree_balanced_height_pos] - \\ gs [ADD1, TAKE_SUM] - \\ fs [tree_len_simps, LEFT_ADD_DISTRIB] - \\ irule_at Any (Q.SPECL [`j`, `(t, n) :: ts`] insert_into_sfx_heap_list_eq) - \\ simp [ADD1, TAKE_SUM, EL_LUPDATE] - \\ simp [tree_len_simps] - \\ qexists_tac `t` \\ simp [] - \\ hphp + \\ gs [tree_len_simps_no_less, tree_balanced_height_pos] + \\ gs [ADD1, TAKE_SUM, tree_len_simps_no_less, APPEND_11_LENGTH, TAKE_2_times_two_exp] + \\ qmatch_goalsub_abbrev_tac `reinsert_tree _ i_l j_l ht_l _` + \\ qspecl_then [`i_l`, `j_l`, `ht_l`, `st`, `TL orig_ts`, `l`] + mp_tac (Q.GENL [`i`, `j`, `ht`, `st`, `ts`, `t`] reinsert_tree_eq) + \\ qspec_then `n` assume_tac (GEN_ALL two_exp_min_1_less_rec) + \\ gs [markerTheory.Abbrev_def, tree_len_simps_no_less, LEFT_ADD_DISTRIB] + \\ gs [ADD1, TAKE_SUM, tree_len_simps_no_less, APPEND_11_LENGTH, TAKE_2_times_two_exp] + \\ strip_tac + \\ simp [] + \\ qspecl_then [`i`, `j_l + 1`, `ht_l`, `st'`, `extend_trees R (TL orig_ts) l ht_l`, `r`] + mp_tac (Q.GENL [`i`, `j`, `ht`, `st`, `ts`, `t`] reinsert_tree_eq) + \\ gs [tree_len_simps_no_less, LEFT_ADD_DISTRIB, LENGTH_extend_trees_facts, MAP_REVERSE] + \\ full_simp_tac bool_ss [ADD_ASSOC] + \\ gs [ADD1, TAKE_SUM, tree_len_simps_no_less, APPEND_11_LENGTH, TAKE_2_times_two_exp] + \\ fs [DROP_DROP] + \\ strip_tac + \\ simp [pull_trees_def] + \\ qmatch_goalsub_abbrev_tac `pull_trees _ next_ts next_acc` + \\ first_x_assum (qspecl_then [`next_acc`, `next_ts`] mp_tac) + \\ fs [markerTheory.Abbrev_def, EL_DROP, tree_len_simps, + LENGTH_extend_trees_facts, LEFT_ADD_DISTRIB] + \\ disch_then irule + \\ gs [ADD1, TAKE_SUM, tree_len_simps_no_less, APPEND_11_LENGTH, TAKE_2_times_two_exp] + \\ simp [EL_DROP, MAP_DROP, LENGTH_extend_trees_facts] + \\ gs [tree_len_simps, TAKE_SUM, EL_DROP, TAKE_2_times_two_exp] + \\ qmatch_goalsub_abbrev_tac `SORTED _ (_ :: tl_ts)` + \\ Cases_on `tl_ts` \\ fs [] + ) +QED + +Theorem above_log2_is_above_ind[local]: + ! i v n. n = 2 EXP i ==> v <= 2 ** (above_log2 i v n) +Proof + recInduct above_log2_ind + \\ rw [] \\ fs [] + \\ ONCE_REWRITE_TAC [above_log2_def] + \\ rw [] \\ fs [EXP_ADD] +QED +Theorem build_trees_facts: + !xs ts. + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> + LENGTH (bs_tree_list_to_list (build_trees R ts xs)) = + LENGTH (bs_tree_list_to_list ts) + LENGTH xs /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) (build_trees R ts xs) /\ + (SORTED $< (MAP SND (DROP 1 ts)) /\ SORTED $<= (TAKE 2 (MAP SND ts)) ==> + SORTED $< (MAP SND (DROP 1 (build_trees R ts xs))) /\ + SORTED $<= (TAKE 2 (MAP SND (build_trees R ts xs)))) +Proof + Induct \\ simp [tree_len_simps, build_trees_def] + \\ rw [] + \\ simp [inv_add_tree, LENGTH_to_list_add_trees] + \\ fs [IMP_CONJ_THM, FORALL_AND_THM] +QED -TAKE1 +Theorem sort_via_sfx_trees_eq: + sort_via_sfx_trees R xs = another_heap_sort R xs +Proof + simp [sort_via_sfx_trees_def, another_heap_sort_def] + \\ TOP_CASE_TAC \\ simp [] + >- ( + simp [build_trees_def, pull_trees_def] + ) + >- ( + simp [sort_via_sfx_trees_run_worker_def, run_init_state_def, + ml_monadBaseTheory.run_def, sort_via_sfx_trees_worker_def] + \\ simp [ml_monadBaseTheory.exc_case_eq, pairTheory.FST_EQ_EQUIV] + \\ DISJ1_TAC + \\ simp [fetch "-" "alloc_heap_array_def", fetch "-" "alloc_sz_array_def", monad_simps] + \\ qmatch_goalsub_abbrev_tac `add_all_to_sfx_heaps _ _ _ xs st` + \\ qspecl_then [`above_log2 0 (LENGTH xs + 1) 1`, `xs`, `0`, `0`, `[]`, `st`] + mp_tac (add_all_to_sfx_heaps_eq |> Q.GEN `lg`) + \\ fs [tree_len_simps, markerTheory.Abbrev_def] + \\ qspecl_then [`0`, `LENGTH xs + 1`, `1`] assume_tac above_log2_is_above_ind + \\ gs [LESS_LESS_EQ_TRANS] + \\ strip_tac + \\ simp [] + \\ irule sfx_trees_to_list_eq + \\ simp [build_trees_facts, tree_len_simps] + \\ irule_at Any (Q.prove (`(x + 1n) + 4 = y ==> x + 4 <= y`, simp [])) + \\ simp [] + ) +QED - \\, rpt (pairarg_tac \\ fs []) \\ gs [tree_len_simps, tree_balanced_height_pos] - \\ fs [ADD1] - \\ +(* Final section: translation of the sfx variants. *) + +fun fix_state_type thm = let + val types_in_thm = thm |> concl |> all_atoms + |> HOLset.listItems |> map type_of + |> map (fn t => fst (strip_fun t) @ [snd (strip_fun t)]) + |> List.concat + val state_matching_types = types_in_thm + |> filter (can (match_type state_type)) + |> HOLset.fromList Type.compare |> HOLset.listItems + val substs = map (fn t => match_type t state_type) state_matching_types + in case substs of + [] => thm + | [s] => INST_TYPE s thm + | _ => failwith "fix_state_type: multiple!" + end + +Definition comp_exp_def: + comp_exp m x 0 = x /\ + comp_exp (m : num) x (SUC i) = comp_exp m (x * m) i +End + +Theorem comp_exp_eq_ind[local]: + !i x. comp_exp m x i = x * (m EXP i) +Proof + Induct \\ simp [comp_exp_def, EXP] +QED + +Theorem use_comp_exp: + (m EXP i) = comp_exp m 1 i +Proof + simp [comp_exp_eq_ind] +QED + +val comp_exp_v_thm = comp_exp_def |> translate; + +val sfx_heap_left_v_thm = sfx_heap_left_def + |> REWRITE_RULE [use_comp_exp] |> translate; + +val insert_into_sfx_heap_v_thm = insert_into_sfx_heap_def + |> fix_state_type |> m_translate; + +val insert_into_sfx_heap_list_v_thm = insert_into_sfx_heap_list_def + |> REWRITE_RULE [use_comp_exp] + |> fix_state_type |> m_translate; + +val add_to_sfx_heaps_v_thm = add_to_sfx_heaps_def + |> SIMP_RULE bool_ss [add_to_sfx_heaps_step1_def, bind_assoc] + |> fix_state_type |> m_translate; + +val add_all_to_sfx_heaps_v_thm = add_all_to_sfx_heaps_def + |> fix_state_type |> m_translate; + +val reinsert_tree_v_thm = reinsert_tree_def + |> REWRITE_RULE [use_comp_exp] + |> fix_state_type |> m_translate; + +val sfx_trees_to_list_v_thm = sfx_trees_to_list_def + |> fix_state_type |> m_translate; + +val length_v_thm = LENGTH |> translate; + +val above_log2_v_thm = above_log2_def |> translate; + +val sort_via_sfx_trees_worker_v_thm = sort_via_sfx_trees_worker_def + |> fix_state_type |> m_translate; + +val sort_via_sfx_trees_run_worker_v_thm = sort_via_sfx_trees_run_worker_def + |> fix_state_type |> m_translate_run; + +val sort_via_sfx_trees_v_thm = sort_via_sfx_trees_def |> translate; - \\ irule inv_trees_less_via_exp -*) From 7d330060b739a3d099b730946fc7ce0b2c2dbb17 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 12 Feb 2026 17:14:52 +1100 Subject: [PATCH 09/39] Clean up experiments and previous versions --- basis/heap_sort_monadicScript.sml | 818 ++---------------------------- 1 file changed, 48 insertions(+), 770 deletions(-) diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml index c3953f8ed9..c6fa8d160f 100644 --- a/basis/heap_sort_monadicScript.sml +++ b/basis/heap_sort_monadicScript.sml @@ -10,8 +10,6 @@ Ancestors Libs preamble ml_translatorLib ml_monad_translator_interfaceLib -val _ = ParseExtras.tight_equality(); - (* Part 1. Translator Setup. *) (* Set up translator to not check subtractions never underflow. *) @@ -51,371 +49,12 @@ val _ = start_translation config; val run_init_state_def = define_run state_type [] "init_state"; -(* Part 2. Define monadic variants of functions from heap_sort_in_fun theory. *) - -Definition heap_insert_larger_monadic_def: - heap_insert_larger_monadic R sz i x = (if (i = 0n) \/ i * 2 > sz - then (if i = 0 then return () - else update_heap_array (i - 1) x) - else do - y <- heap_array_sub ((i * 2) - 1); - z <- if (i * 2) + 1 > sz - then return y - else heap_array_sub (i * 2); - if ((i * 2) + 1) <= sz /\ R z x /\ R z y - then do - update_heap_array (i - 1) z; - heap_insert_larger_monadic R sz ((i * 2) + 1) x - od - else if (i * 2) <= sz /\ R y x /\ (((i * 2) + 1) <= sz ==> R y z) - then do - update_heap_array (i - 1) y; - heap_insert_larger_monadic R sz (i * 2) x - od - else update_heap_array (i - 1) x - od) -Termination - qexists_tac `measure (\(_, sz, i, _). sz - i)` - \\ simp [] -End - -Theorem st_ex_bind_split[local]: - (st_ex_bind f g st = (res, st')) <=> - ?r s. (f st = (r, s)) /\ (case r of M_success x => (g x s) = (res, st') - | M_failure y => (res, st') = (M_failure y, s)) -Proof - simp [ml_monadBaseTheory.st_ex_bind_def] - \\ Cases_on `f st` - \\ simp [] - \\ Cases_on `FST (f st)` - \\ gs [] - \\ metis_tac [] -QED - -Theorem st_ex_ignore_bind_simp[local]: - st_ex_ignore_bind f g = st_ex_bind f (\_. g) -Proof - simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_ignore_bind_def] -QED - -Definition st_embed_def: - (st_embed sz hp : 'a state_refs) = - <| heap_array := GENLIST (hp o ((+) 1)) sz |> -End - -Theorem LENGTH_st_embed[local]: - LENGTH (st_embed sz hp).heap_array = sz -Proof - simp [st_embed_def] -QED - -Theorem update_heap_array_st_embed[local]: - i < sz ==> - (update_heap_array i x (st_embed sz hp) = - (M_success (), st_embed sz (hp⦇i + 1 ↦ x⦈))) -Proof - simp [fetch "-" "update_heap_array_def"] - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ simp [st_embed_def, LUPDATE_GENLIST] - \\ simp [combinTheory.UPDATE_def, combinTheory.o_DEF] -QED - -Theorem heap_array_sub_st_embed[local]: - i < sz ==> - (heap_array_sub i (st_embed sz hp) = - (M_success (hp (i + 1)), (st_embed sz hp))) -Proof - simp [fetch "-" "heap_array_sub_def"] - \\ simp [ml_monadBaseTheory.monad_eqs, st_embed_def] -QED - -Theorem monad_simps[local] = LIST_CONJ [ - ml_monadBaseTheory.st_ex_bind_def |> Q.ISPEC `update_heap_array i x`, - update_heap_array_st_embed, - ml_monadBaseTheory.st_ex_bind_def |> Q.ISPEC `heap_array_sub i`, - heap_array_sub_st_embed, - ml_monadBaseTheory.monad_eqs, - st_ex_ignore_bind_simp] - -Theorem heap_insert_larger_monadic_eq: - 0 < i /\ i <= sz /\ sz <= arr_sz ==> - (heap_insert_larger_monadic R sz i x (st_embed arr_sz hp) = - (M_success (), st_embed arr_sz (heap_insert_larger R sz i x hp))) -Proof - qid_spec_tac `hp` - \\ measureInduct_on `(\i. sz - i) i` - \\ rw [] - \\ ONCE_REWRITE_TAC [heap_insert_larger_monadic_def] - \\ ONCE_REWRITE_TAC [heap_insert_larger_def] - \\ rw [] \\ fs [] - \\ simp [monad_simps] - \\ rw [] \\ fs [] - \\ simp [monad_simps] -QED - -Definition heap_pop_monadic_def: - heap_pop_monadic R sz_dec = (do - bot_el <- heap_array_sub 0; - top_el <- heap_array_sub sz_dec; - heap_insert_larger_monadic R sz_dec 1 top_el; - return bot_el - od) -End - -(* The heap_pop_monadic version of sz is one less than the - functional one (the size after the pop), to avoid a translation - side-condition. *) -Theorem heap_pop_monadic_eq: - sz < arr_sz ==> - (heap_pop_monadic R sz (st_embed arr_sz hp) = - (M_success (FST (heap_pop R (sz + 1) hp)), st_embed arr_sz (SND (heap_pop R (sz + 1) hp)))) -Proof - simp [heap_pop_def, heap_pop_monadic_def] - \\ rw [] \\ fs [] - \\ simp [monad_simps, heap_insert_larger_monadic_eq] - \\ Cases_on `sz = 0` - >- ( - (* Works by coincidence for the base case. *) - ONCE_REWRITE_TAC [heap_insert_larger_monadic_def] - \\ ONCE_REWRITE_TAC [heap_insert_larger_def] - \\ simp [monad_simps] - ) - \\ simp [heap_insert_larger_monadic_eq] -QED - -Definition heap_insert_smaller_monadic_def: - heap_insert_smaller_monadic R sz i x = (if (i <= 1n) - then update_heap_array (i - 1) x - else do - y <- heap_array_sub ((i DIV 2) - 1); - if R x y - then do - update_heap_array (i - 1) y; - heap_insert_smaller_monadic R sz (i DIV 2) x - od - else update_heap_array (i - 1) x - od) -End - -Theorem heap_insert_smaller_monadic_eq: - 0 < i /\ i <= sz /\ sz <= arr_sz ==> - (heap_insert_smaller_monadic R sz i x (st_embed arr_sz hp) = - (M_success (), st_embed arr_sz (heap_insert_smaller R sz i x hp))) -Proof - qid_spec_tac `hp` - \\ measureInduct_on `I i` - \\ rw [] - \\ ONCE_REWRITE_TAC [heap_insert_smaller_monadic_def] - \\ ONCE_REWRITE_TAC [heap_insert_smaller_def] - \\ rw [] \\ fs [] - \\ subgoal `i DIV 2 < i` - \\ simp [monad_simps, dividesTheory.DIV_POS] - \\ rw [] \\ fs [] - \\ gs [monad_simps, SUB_ADD, X_LE_DIV, dividesTheory.DIV_POS] -QED - -Definition heap_add_monadic_def: - heap_add_monadic R sz x = (do - el <- if 0 < sz - then heap_array_sub (((sz + 1) DIV 2) - 1) - else return x; - update_heap_array sz el; - heap_insert_smaller_monadic R (sz + 1) (sz + 1) x - od) -End - -Theorem heap_add_monadic_eq: - sz + 1 <= arr_sz ==> - (heap_add_monadic R sz x (st_embed arr_sz hp) = - (M_success (), st_embed arr_sz (heap_add R sz hp x))) -Proof - simp [heap_add_monadic_def, heap_add_def] - \\ subgoal `0 < sz ==> (sz + 1) DIV 2 <= sz` - >- ( - qspec_then `sz` assume_tac arithmeticTheory.ODD_OR_EVEN - \\ fs [] - ) - \\ rw [] - \\ simp [monad_simps, heap_insert_smaller_monadic_eq] - \\ simp [SUB_ADD, X_LE_DIV] - \\ gs [] - \\ ONCE_REWRITE_TAC [heap_insert_smaller_def] - \\ simp [] -QED - -Definition heap_add_all_monadic_def: - (heap_add_all_monadic R sz [] = return sz) /\ - (heap_add_all_monadic R sz (x :: xs) = do - heap_add_monadic R sz x; - heap_add_all_monadic R (sz + 1) xs - od) -End - -Theorem heap_add_all_monadic_eq: - sz + LENGTH xs <= arr_sz ==> - (heap_add_all_monadic R sz xs (st_embed arr_sz hp) = - (M_success (sz + LENGTH xs), st_embed arr_sz (heap_add_all R sz xs hp))) -Proof - qid_spec_tac `hp` - \\ qid_spec_tac `sz` - \\ Induct_on `xs` - \\ ONCE_REWRITE_TAC [heap_add_all_monadic_def] - \\ ONCE_REWRITE_TAC [heap_add_all_def] - \\ simp [monad_simps, heap_add_monadic_eq] -QED - -(* Leads to an exception. - -Defn.Hol_defn "monad_fun" - ` (monad_fun sz xs = if sz = 0 then return xs - else st_ex_bind (return ARB) - (\el. monad_fun (sz - 1) (el :: xs)) - ) - ` - -This exception blocks heap_pop_all_monadic from being -defined with an if/then/else on the RHS. Unfortunately -the 0/SUC version doesn't want to translate. - -*) - -Definition heap_pop_all_monadic_def: - (heap_pop_all_monadic R 0 xs = return xs) /\ - (heap_pop_all_monadic R (SUC next_sz) xs = - do - el <- heap_pop_monadic R next_sz; - heap_pop_all_monadic R next_sz (el :: xs) - od) -End - -Theorem heap_pop_all_monadic_if_def: - heap_pop_all_monadic R sz xs = (if sz = 0n - then return xs - else do - el <- heap_pop_monadic R (sz - 1); - heap_pop_all_monadic R (sz - 1) (el :: xs) - od - ) -Proof - Cases_on `sz` - \\ simp [heap_pop_all_monadic_def] -QED - -Theorem heap_pop_all_monadic_eq: - sz <= arr_sz ==> - ?hp2. (heap_pop_all_monadic R sz xs (st_embed arr_sz hp) = - (M_success (heap_pop_all R sz xs hp), hp2)) -Proof - qid_spec_tac `hp` - \\ qid_spec_tac `xs` - \\ Induct_on `sz` - \\ ONCE_REWRITE_TAC [heap_pop_all_monadic_def] - \\ ONCE_REWRITE_TAC [heap_pop_all_def] - \\ simp [monad_simps, heap_pop_monadic_eq] - \\ rw [] - \\ pairarg_tac \\ fs [] - \\ fs [arithmeticTheory.ADD1] - \\ simp [heap_pop_monadic_eq] -QED - - -(* Part 3. Translation into CakeML AST. *) - -Definition heap_sort_via_monad_aux1_def: - heap_sort_via_monad_aux1 R x xs = - (do - sz <- return (LENGTH xs); - R2 <- return (\x y. R y x); - alloc_heap_array sz x; - heap_add_all_monadic R2 0 xs; - heap_pop_all_monadic R2 sz []; - od) -End - -Definition heap_sort_via_monad_aux2_def: - heap_sort_via_monad_aux2 R x xs = - run_init_state (heap_sort_via_monad_aux1 R x xs) - (init_state []) -End - -Definition heap_sort_via_monad_def: - heap_sort_via_monad R xs = (case xs of - [] => [] - | (x :: _) => (case heap_sort_via_monad_aux2 R x xs of - M_success ys => ys - | _ => [] - )) -End - -Theorem alloc_heap_array_eq[local]: - alloc_heap_array n v st = (M_success (), st_embed n (K v)) -Proof - simp [fetch "-" "alloc_heap_array_def"] - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ simp [st_embed_def, REPLICATE_GENLIST] - \\ simp [fetch "-" "state_refs_component_equality"] -QED - -Theorem heap_sort_eq: - heap_sort_via_monad R xs = heap_sort R xs -Proof - simp [heap_sort_via_monad_def, heap_sort_def, heap_sort_via_monad_aux2_def, - run_init_state_def, heap_sort_via_monad_aux1_def] - \\ Cases_on `xs` \\ simp [] - \\ simp [ml_monadBaseTheory.run_def] - \\ simp [ml_monadBaseTheory.exc_case_eq, pairTheory.FST_EQ_EQUIV] - \\ simp [monad_simps, alloc_heap_array_eq] - \\ simp [heap_add_all_monadic_eq, heap_pop_all_monadic_eq] -QED - -fun fix_state_type thm = let - val types_in_thm = thm |> concl |> all_atoms - |> HOLset.listItems |> map type_of - |> map (fn t => fst (strip_fun t) @ [snd (strip_fun t)]) - |> List.concat - val state_matching_types = types_in_thm - |> filter (can (match_type state_type)) - |> HOLset.fromList Type.compare |> HOLset.listItems - val substs = map (fn t => match_type t state_type) state_matching_types - in case substs of - [] => thm - | [s] => INST_TYPE s thm - | _ => failwith "fix_state_type: multiple!" - end - -val heap_insert_larger_v_thm = heap_insert_larger_monadic_def - |> fix_state_type |> m_translate; - -val heap_pop_v_thm = heap_pop_monadic_def - |> fix_state_type |> m_translate; - -val heap_pop_all_v_thm = heap_pop_all_monadic_def - |> fix_state_type |> m_translate; - -val heap_insert_smaller_v_thm = heap_insert_smaller_monadic_def - |> fix_state_type |> m_translate; - -val heap_add_v_thm = heap_add_monadic_def - |> fix_state_type |> m_translate; - -val heap_add_all_v_thm = heap_add_all_monadic_def - |> fix_state_type |> m_translate; - -val length_v_thm = LENGTH |> translate; - -val heap_sort_via_monad_aux1_v_thm = heap_sort_via_monad_aux1_def - |> fix_state_type |> m_translate; - -val heap_sort_via_monad_aux2_v_thm = heap_sort_via_monad_aux2_def - |> fix_state_type |> m_translate_run; - -val heap_sort_via_monad_v_thm = heap_sort_via_monad_def |> translate; - - -(* Second variant. *) -(* Heap list version. *) +(* It seems important to turn this on last, or something turns it off again? *) +val _ = ParseExtras.tight_equality(); -(* 'start_translation' parts at the top *) +(* Part 2. Definition of heap-list sort via "suffix encoded" balanced trees. + Every heap/tree is of power-of-two-minus-one size, with the largest element + at the end, and two equal-sized smaller trees before it. *) (* Positions of the left child in a suffix encoded balanced tree of height ht. *) @@ -479,8 +118,8 @@ Definition insert_into_sfx_heap_list_def: od End -(* Add another element to the final heap in a sequence of balanced suffix - heaps with i total elements and j total heaps. *) +(* Expand the total size of a sequence of balanced suffix heaps from i to + i + 1 total elements, starting with j total heaps. *) Definition add_to_sfx_heaps_step1_def: add_to_sfx_heaps_step1 i j = do merge <- if j <= 1 @@ -503,7 +142,8 @@ Definition add_to_sfx_heaps_step1_def: od End -(* Also set the top element and preserve invariants. *) +(* Expand from i to i + 1 elements, set the new element, and preserve the heap + invariants. *) Definition add_to_sfx_heaps_def: add_to_sfx_heaps R i j x = do j' <- add_to_sfx_heaps_step1 i j; @@ -512,6 +152,7 @@ Definition add_to_sfx_heaps_def: od End +(* Extend a list of suffix heaps by a list of values. *) Definition add_all_to_sfx_heaps_def: (add_all_to_sfx_heaps R i j [] = return (i, j)) /\ (add_all_to_sfx_heaps R i j (x :: xs) = do @@ -520,6 +161,8 @@ Definition add_all_to_sfx_heaps_def: od) End +(* Take an intact heap in the correct position and add it to the heap sequence, + i.e. ensure its top element is the overall top element. *) Definition reinsert_tree_def: reinsert_tree R i j ht = do @@ -536,6 +179,7 @@ Definition reinsert_tree_def: od End +(* Reduce a sequence of suffix-encoded heaps to a list. *) Definition sfx_trees_to_list_def: sfx_trees_to_list R i j acc = if i = 0 then return acc @@ -552,6 +196,7 @@ Definition sfx_trees_to_list_def: od End +(* Compute an overapproximation of the base-2 logarithm of v *) Definition above_log2_def: above_log2 i v n = if n = 0n \/ v <= n then i @@ -585,8 +230,8 @@ Definition sort_via_sfx_trees_def: ) End - -(* Equivalence of second variant. *) +(* Part 3. Proof that this monadic encoding computes the same as the pure heap + list sort implementation. *) Definition bs_tree_to_list_def: (bs_tree_to_list 0 t = []) /\ @@ -667,219 +312,9 @@ Proof Cases_on `t` \\ simp [tree_balanced_height_def] QED -(* -Theorem tree_balanced_height_length_sfx_eq: - tree_balanced_height ht t ==> - (LENGTH (tree_sfx_list t) = ((2 EXP ht) - 1)) -Proof - qid_spec_tac `ht` \\ Induct_on `t` - \\ fs [tree_sfx_list_def, tree_balanced_height_def] - \\ rw [] - \\ Cases_on `ht` \\ fs [] - \\ res_tac - \\ simp [EXP] - \\ simp [SUB_RIGHT_ADD] - \\ rw [] -QED -*) - -(* -Theorem tree_balanced_height_length_sfx_eq: - tree_balanced_height ht t ==> 0 < ht ==> - (LENGTH (tree_sfx_list t) = two_exp_min_2 ht + 1) -Proof - qid_spec_tac `ht` \\ Induct_on `t` - \\ simp [tree_balanced_height_def, tree_sfx_list_def, two_exp_min_2_rec] - \\ rw [] - \\ Cases_on `ht` \\ fs [] - \\ simp [two_exp_min_2_rec] - \\ rw [] - \\ fs [tree_balanced_height_0, tree_sfx_list_def] - \\ res_tac - \\ simp [] -QED - -Definition tree_list_len_eq_def: - tree_list_len_eq xs t ht i = - (tree_balanced_height ht t /\ - (i = LENGTH xs + LENGTH (tree_sfx_list t) - 1)) -End - -Theorem tree_list_len_eq_bases: - (tree_list_len_eq xs Empty_Tree ht i = ((ht = 0) /\ (i = LENGTH xs - 1))) /\ - (tree_list_len_eq xs t 0 i = ((t = Empty_Tree) /\ (i = LENGTH xs - 1))) -Proof - simp [tree_list_len_eq_def, tree_balanced_height_def, tree_sfx_list_def] - \\ Cases_on `t` \\ simp [tree_balanced_height_def, tree_sfx_list_def] -QED - -Theorem tree_list_len_eq_split: - tree_list_len_eq xs (Node x l r) ht i ==> - tree_list_len_eq xs l (ht - 1) (i - (2 EXP (ht - 1))) /\ - tree_list_len_eq (xs ++ tree_sfx_list l) r (ht - 1) (i - 1) -Proof - rw [tree_list_len_eq_def] - \\ fs [tree_balanced_height_def, tree_sfx_list_def] - \\ imp_res_tac tree_balanced_height_length_sfx_eq - \\ Cases_on `ht` \\ full_simp_tac std_ss [] - \\ simp [EXP] - \\ Cases_on `n = 0` \\ fs [] - \\ subgoal `?x. 2 EXP n = (2 + x)` - \\ fs [] - \\ qexists_tac `(2 EXP n) - 2` - \\ simp [SUB_RIGHT_ADD] - \\ rw [] -QED - -Definition tree_len_eq_def: - tree_len_eq n t ht i = - (tree_balanced_height ht t /\ (i = n + LENGTH (tree_sfx_list t) - 1)) -End - -Theorem tree_len_eq_bases: - (tree_len_eq n Empty_Tree ht i = ((ht = 0) /\ (i = n - 1))) /\ - (tree_len_eq n t 0 i = ((t = Empty_Tree) /\ (i = n - 1))) -Proof - simp [tree_len_eq_def, tree_balanced_height_def, tree_sfx_list_def] - \\ Cases_on `t` \\ simp [tree_balanced_height_def, tree_sfx_list_def] -QED - -Theorem tree_len_eq_split: - tree_len_eq n (Node x l r) ht i ==> - tree_len_eq n l (ht - 1) (i - (2 EXP (ht - 1))) /\ - tree_len_eq (n + LENGTH (tree_sfx_list l)) r (ht - 1) (i - 1) -Proof - rw [tree_len_eq_def] - \\ fs [tree_balanced_height_def, tree_sfx_list_def] - \\ imp_res_tac tree_balanced_height_length_sfx_eq - \\ full_simp_tac std_ss [] - \\ subgoal `ht > 1 ==> ?x. 2 EXP (ht - 1) = (2 + x)` - \\ Cases_on `ht - 1` \\ Cases_on `ht` \\ full_simp_tac std_ss [] - \\ fs [] - \\ qexists_tac `(2 EXP SUC n) - 2` - \\ simp [SUB_RIGHT_ADD] - \\ rw [] -QED -*) - -Theorem return_bind_eq: - st_ex_bind (return v) f = f v -Proof - simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] -QED - -(* -Theorem heap_array_sub_eq_intro: - tree_list_len_eq xs t ht i ==> - (st.heap_array = xs ++ tree_sfx_list t ++ ys) ==> - 0 < ht ==> - (f (case t of Node y _ _ => y) st = (M_success v, st_fin)) ==> - (st_ex_bind (heap_array_sub i) f st = (M_success v, st_fin)) -Proof - simp [fetch "-" "heap_array_sub_def"] - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ rw [] - \\ imp_res_tac tree_balanced_height_length_sfx_eq - \\ simp [] - \\ fs [tree_list_len_eq_def] - \\ Cases_on `t` \\ fs [tree_balanced_height_def] - \\ fs [tree_sfx_list_def] - \\ simp [EL_APPEND] -QED - -Theorem heap_array_sub_eq_intro2: - tree_len_eq n t ht i ==> - 0 < ht ==> - (DROP n st.heap_array = tree_sfx_list t ++ ys) ==> - (f (case t of Node y _ _ => y) st = (M_success v, st_fin)) ==> - (st_ex_bind (heap_array_sub i) f st = (M_success v, st_fin)) -Proof - simp [fetch "-" "heap_array_sub_def"] - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ rpt disch_tac - \\ Cases_on `LENGTH st.heap_array <= n` - >- ( - fs (RES_CANON miscTheory.DROP_NIL) - \\ Cases_on `t` \\ fs [tree_sfx_list_def, tree_len_eq_bases] - ) - \\ subgoal `?xs. (st.heap_array = xs ++ tree_sfx_list t ++ ys) /\ (LENGTH xs = n)` - >- ( - qexists_tac `TAKE n st.heap_array` - \\ simp [LENGTH_TAKE] - \\ metis_tac [TAKE_DROP, APPEND_ASSOC] - ) - \\ fs [tree_len_eq_def] - \\ simp [EL_APPEND] - \\ Cases_on `t` \\ fs [tree_balanced_height_def] - \\ fs [tree_sfx_list_def] - \\ simp [EL_APPEND] -QED - - -Theorem update_heap_array_eq: - tree_list_len_eq xs t ht i ==> - (st.heap_array = xs ++ tree_sfx_list t ++ ys) ==> - 0 < ht ==> - (st2 = st with <| heap_array := - xs ++ tree_sfx_list (case t of Node _ l r => Node x l r) ++ ys |>) ==> - (update_heap_array i x st = (M_success (), st2)) -Proof - simp [fetch "-" "update_heap_array_def"] - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ rw [] - \\ imp_res_tac tree_balanced_height_length_sfx_eq - \\ simp [] - \\ fs [tree_list_len_eq_def] - \\ Cases_on `t` \\ fs [tree_balanced_height_def] - \\ fs [tree_sfx_list_def] - \\ simp [LUPDATE_APPEND, LUPDATE_DEF] -QED - -Theorem update_heap_array_eq_intro: - tree_list_len_eq xs t ht i ==> - (st.heap_array = xs ++ tree_sfx_list t ++ ys) ==> - 0 < ht ==> - (!st' prev_xs. (st = st' with <| heap_array := prev_xs |>) /\ - (st'.heap_array = xs ++ tree_sfx_list (case t of Node _ l r => Node x l r) ++ ys) ==> - (f () st' = (M_success v, st_fin))) ==> - (st_ex_bind (update_heap_array i x) f st = (M_success v, st_fin)) -Proof - simp [ml_monadBaseTheory.monad_eqs] - \\ rw [] - \\ first_x_assum (irule_at Any) - \\ drule_then (irule_at Any) update_heap_array_eq - \\ simp [] - \\ simp [fetch "-" "state_refs_component_equality"] -QED - -Theorem bind_return_eq: - st_ex_bind f return = f -Proof - rw [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] - \\ BasicProvers.EVERY_CASE_TAC \\ simp [] -QED - - -Theorem balanced_sfx_heap_left_eq: - tree_balanced_height (ht - 1) l ==> - 1 < ht ==> - (sfx_heap_left (oths + LENGTH (tree_sfx_list l)) ht = oths - 1) -Proof - rw [] - \\ subgoal `!i. sfx_heap_left i ht = i - (LENGTH (tree_sfx_list l)) - 1` - >- ( - imp_res_tac tree_balanced_height_length_sfx_eq - \\ simp [sfx_heap_left_def, SUB_RIGHT_SUB] - \\ simp [SUB_RIGHT_ADD] - ) - \\ fs [] - \\ imp_res_tac (GSYM tree_balanced_height_length_sfx_eq) - \\ Cases_on `l` \\ fs [tree_balanced_height_def, tree_sfx_list_def] -QED -*) - Definition bs_tree_list_to_list_def: - bs_tree_list_to_list ts = FLAT (MAP (\(t, i). bs_tree_to_list i t) (REVERSE ts)) + bs_tree_list_to_list ts = + FLAT (MAP (\(t, i). bs_tree_to_list i t) (REVERSE ts)) End Theorem bs_tree_list_to_list_rec: @@ -892,57 +327,26 @@ Proof \\ rpt (pairarg_tac \\ fs[]) QED +Theorem st_ex_ignore_bind_simp[local]: + st_ex_ignore_bind f g = st_ex_bind f (\_. g) +Proof + simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_ignore_bind_def] +QED + Theorem monad_simps[local] = LIST_CONJ [fetch "-" "update_heap_array_def", fetch "-" "heap_array_sub_def", ml_monadBaseTheory.monad_eqs, st_ex_ignore_bind_simp, fetch "-" "update_sz_array_def", fetch "-" "sz_array_sub_def"] -Theorem tree_len_simps_no_less = LIST_CONJ +Theorem tree_len_simps_no_less[local] = LIST_CONJ [tree_balanced_height_def, tree_balanced_height_0, two_exp_min_1_rec, LENGTH_bs_tree_to_list, bs_tree_to_list_def, bs_tree_to_list_tree_rec, bs_tree_list_to_list_rec] -Theorem tree_len_simps = LIST_CONJ [tree_len_simps_no_less, +Theorem tree_len_simps[local] = LIST_CONJ [tree_len_simps_no_less, two_exp_min_1_less_rec] -Definition array_mappings_def: - array_mappings xs = LIST_TO_BAG (MAPi (\i x. (i, x)) xs) -End - -Definition array_upd_mappings_def: - array_of_mappings bg = GENLIST (\i. (CHOICE (\x. BAG_IN (i, x) bg))) (bag_size (K 0) bg) -End - -Definition list_mappings_from_def: - list_mappings_from xs i = LIST_TO_BAG (MAPi (\j x. (i + j, x)) xs) -End - -Theorem list_mappings_from_append: - list_mappings_from (xs ++ ys) i = - BAG_UNION (list_mappings_from xs i) (list_mappings_from ys (i + LENGTH xs)) -Proof - simp [list_mappings_from_def, MAPi_APPEND, LIST_TO_BAG_APPEND, o_DEF] -QED - -Theorem list_mappings_from_bases: - list_mappings_from [x] i = {|(i, x)|} /\ - list_mappings_from [] j = {||} -Proof - simp [list_mappings_from_def] -QED - -Theorem array_mappings_eq_from: - array_mappings xs = list_mappings_from xs 0 -Proof - simp [array_mappings_def, list_mappings_from_def] -QED - -Theorem array_mappings_of: - array_mappings (array_of_mappings bg) = bg -Proof - simp [array_mappings_def, array_of_mappings_def] - Theorem TAKE_DROP_eq_imp[local]: !xs i j. TAKE i (DROP j xs) = ys ==> i <= LENGTH ys ==> @@ -972,105 +376,7 @@ Proof \\ simp [] QED -Theorem array_mappings_IMP_EL: - BAG_IN (i, x) (array_mappings arr) ==> - EL i arr = x /\ i < LENGTH arr -Proof - rw [array_mappings_def] - \\ fs [IN_LIST_TO_BAG, MEM_MAPi] -QED - -(* -Theorem list_mappings_LUPDATE: - !arr j i. i < LENGTH arr ==> - list_mappings_from (LUPDATE y i arr) j = - (list_mappings_from arr j - {|(i + j, EL i arr)|} + {|(i + j, y)|}) -Proof - Induct \\ fs [list_mappings_from_def] - \\ rw [o_DEF] - \\ Cases_on `i` \\ fs [LUPDATE_DEF] - \\ simp [o_DEF, BAG_UNION_INSERT] - \\ simp [ADD1] - \\ simp [BAG_INSERT_UNION] - \\ cheat -QED - -Theorem array_mappings_LUPDATE: - array_mappings arr = xs /\ xs = BAG_UNION {|(i, x)|} others ==> - array_mappings (LUPDATE y i arr) = BAG_UNION {|(i, y)|} others -Proof - rw [] - \\ mp_tac array_mappings_IMP_EL - \\ fs [array_mappings_eq_from] - \\ simp [list_mappings_LUPDATE] - \\ simp [COMM_BAG_UNION] -QED - -Theorem update_heap_array_mappings: - array_mappings st.heap_array = xs /\ - xs = BAG_UNION {|(i, prev_x)|} others ==> - ?arr. update_heap_array i x st = (M_success (), st with heap_array := arr) /\ - array_mappings arr = {|(i,x)|} ⊎ others -Proof - simp [fetch "-" "update_heap_array_def", ml_monadBaseTheory.monad_eqs] - \\ rw [] - \\ irule_at Any EQ_REFL - \\ simp [array_mappings_LUPDATE] - \\ irule (UNDISCH array_mappings_IMP_EL |> BODY_CONJUNCTS |> List.last |> DISCH_ALL) - \\ simp [EXISTS_OR_THM] -QED - -Theorem heap_array_sub_mappings: - array_mappings st.heap_array = xs /\ - xs = BAG_UNION {|(i, x)|} others ==> - ?arr. heap_array_sub i st = (M_success x, st) -Proof - cheat -QED - - -Theorem update_heap_array_mappings2: - array_mappings st.heap_array = BAG_UNION {|(i, prev_x)|} others /\ - (!arr. array_mappings arr = {|(i,x)|} ⊎ others ==> P arr) ==> - ?arr. update_heap_array i x st = (M_success (), st with heap_array := arr) /\ P arr -Proof - cheat -QED - -fun use_ex_thm1 thm (alist, gl) = let - val (ex_vars, gl2) = strip_exists gl - val conjs = strip_conj gl2 - val possible_gl_lhss = conjs |> mapfilter (fst o dest_eq) - |> filter (fn t => not (exists (fn v => free_in v t) ex_vars)) - val thm_concl = concl thm |> strip_imp |> snd - val key_lhs = thm_concl |> strip_exists |> snd |> strip_conj |> hd |> lhs - val lhs_vars = FVL [key_lhs] (HOLset.empty Term.compare) - val thm_vars = FVL [concl thm] (HOLset.empty Term.compare) - val gen_vars = HOLset.listItems (HOLset.difference (thm_vars, lhs_vars)) - in MAP_FIRST (fn gl_lhs => let - val (inst, tinst) = match_term key_lhs gl_lhs - val thm2 = INST_TYPE tinst thm |> INST inst |> GENL gen_vars - in mp_tac thm2 end) possible_gl_lhss (alist, gl) end - -fun use_ex_thm thm = (REWRITE_TAC [PULL_EXISTS] >> use_ex_thm1 thm) - -Theorem FUNNY_PULL_FORALL1: - !P R. (?x. P x ==> R) ==> - ((!x. P x) ==> R) -Proof - metis_tac [] -QED - -Theorem FUNNY_PULL_FORALL: - !P Q R. (?x. P x /\ (Q x ==> R)) ==> - ((!x. P x ==> Q x) ==> R) -Proof - metis_tac [] -QED -*) - Theorem insert_into_sfx_heap_eq: - ! t R i ht x st. TAKE (two_exp_min_1 ht) (DROP ((i + 1) - two_exp_min_1 ht) st.heap_array) = bs_tree_to_list ht t /\ @@ -1120,15 +426,6 @@ Proof ) QED - -Theorem mk_sub_min_1[local]: - (x + 1n) - (2 EXP ht) = (x - two_exp_min_1 ht) -Proof - simp [two_exp_min_1_def] - \\ Cases_on `2 EXP ht` \\ simp [] - \\ fs [] -QED - Theorem EL_APPEND_PLUS[local]: EL (LENGTH xs + n) (xs ++ ys) = EL n ys Proof @@ -1278,17 +575,6 @@ Proof \\ rw [] QED -Theorem bind_assoc: - st_ex_bind (st_ex_bind f g) h = do - x <- f; - y <- g x; - h y - od -Proof - rw [ml_monadBaseTheory.st_ex_bind_def, FUN_EQ_THM] - \\ rpt (TOP_CASE_TAC \\ fs []) -QED - Theorem add_to_sfx_heaps_step1_eq: EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> TAKE i st.heap_array = bs_tree_list_to_list ts /\ @@ -1349,14 +635,7 @@ Proof ) QED -Theorem LENGTH_add_trees_step1_adj[local]: - LENGTH (add_trees_step1 ts x) = LENGTH (I (add_trees_step1 ts) ARB) -Proof - simp [add_trees_step1_def] - \\ rpt (TOP_CASE_TAC \\ fs []) -QED - -Theorem LENGTH_add_tree_step1_facts: +Theorem LENGTH_add_tree_step1_facts[local]: 0 < LENGTH (add_trees_step1 ts x) /\ LENGTH (bs_tree_list_to_list (add_trees_step1 ts x)) = LENGTH (bs_tree_list_to_list ts) + 1 /\ @@ -1368,7 +647,7 @@ Proof \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps]) QED -Theorem inv_add_tree_step1: +Theorem inv_add_tree_step1[local]: (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (add_trees_step1 ts x) ) /\ @@ -1455,14 +734,14 @@ Proof ) QED -Theorem LENGTH_to_list_add_trees: +Theorem LENGTH_to_list_add_trees[local]: LENGTH (bs_tree_list_to_list (add_trees R ts x)) = LENGTH (bs_tree_list_to_list ts) + 1 Proof simp [add_trees_def, LENGTH_list_of_insert_trees, LENGTH_add_tree_step1_facts] QED -Theorem insert_tree_inv_balance_inv: +Theorem insert_tree_inv_balance_inv[local]: !t ht. tree_balanced_height ht t ==> tree_balanced_height ht (insert_tree_inv R t x) Proof @@ -1470,7 +749,7 @@ Proof \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps]) QED -Theorem insert_trees_inv_balance_inv: +Theorem insert_trees_inv_balance_inv[local]: !ts x. EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (insert_trees_inv R ts x) Proof @@ -1479,7 +758,7 @@ Proof \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps, insert_tree_inv_balance_inv]) QED -Theorem inv_add_tree: +Theorem inv_add_trees[local]: (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (add_trees R ts x) ) /\ @@ -1493,16 +772,6 @@ Proof \\ simp [GSYM MAP_DROP, inv_add_tree_step1, insert_trees_inv_balance_inv] QED -Theorem sum_gt_exp_2: - !js n. EVERYi (\i j. j >= (2 EXP i) * n) js ==> - SUM js >= ((2 EXP LENGTH js) - 1) * n -Proof - Induct - \\ rw [EVERYi_def] - \\ first_x_assum (qspec_then `2 * n` mp_tac) - \\ fs [o_DEF, EXP] -QED - Theorem sum_lengths_greater_equal_exp[local]: ! ts n. EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ SORTED $< (MAP SND ts) /\ @@ -1593,10 +862,10 @@ Proof \\ rw [] \\ last_x_assum (drule_at (Pat `_ = MAP _ _`)) \\ gs [markerTheory.Abbrev_def, LENGTH_to_list_add_trees] - \\ simp [inv_add_tree] + \\ simp [inv_add_trees] QED -Theorem TAKE_LUPDATE_CASES: +Theorem TAKE_LUPDATE_CASES[local]: !xs i j. TAKE i (LUPDATE x j xs) = (if j < i then LUPDATE x j (TAKE i xs) else TAKE i xs) Proof Induct \\ fs [] @@ -1695,11 +964,9 @@ Proof LENGTH_list_of_insert_trees, tree_len_simps, insert_trees_inv_balance_inv] QED - Theorem TAKE_2_times_two_exp[local] = Q.SPECL [`two_exp_min_1 i`, `two_exp_min_1 i`] TAKE_SUM |> REWRITE_RULE [GSYM TIMES2] - Theorem sfx_trees_to_list_eq: !i j acc ts st. EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ @@ -1787,7 +1054,7 @@ Proof \\ rw [] \\ fs [EXP_ADD] QED -Theorem build_trees_facts: +Theorem build_trees_facts[local]: !xs ts. EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> LENGTH (bs_tree_list_to_list (build_trees R ts xs)) = @@ -1799,7 +1066,7 @@ Theorem build_trees_facts: Proof Induct \\ simp [tree_len_simps, build_trees_def] \\ rw [] - \\ simp [inv_add_tree, LENGTH_to_list_add_trees] + \\ simp [inv_add_trees, LENGTH_to_list_add_trees] \\ fs [IMP_CONJ_THM, FORALL_AND_THM] QED @@ -1832,7 +1099,7 @@ Proof ) QED -(* Final section: translation of the sfx variants. *) +(* Part 4: translation of the sfx variants. *) fun fix_state_type thm = let val types_in_thm = thm |> concl |> all_atoms @@ -1878,6 +1145,17 @@ val insert_into_sfx_heap_list_v_thm = insert_into_sfx_heap_list_def |> REWRITE_RULE [use_comp_exp] |> fix_state_type |> m_translate; +Theorem bind_assoc[local]: + st_ex_bind (st_ex_bind f g) h = do + x <- f; + y <- g x; + h y + od +Proof + rw [ml_monadBaseTheory.st_ex_bind_def, FUN_EQ_THM] + \\ rpt (TOP_CASE_TAC \\ fs []) +QED + val add_to_sfx_heaps_v_thm = add_to_sfx_heaps_def |> SIMP_RULE bool_ss [add_to_sfx_heaps_step1_def, bind_assoc] |> fix_state_type |> m_translate; From c2367bad5adf8b9c8bcee5ec0d2dcbaa6e2c50f5 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 19 Feb 2026 11:33:39 +1100 Subject: [PATCH 10/39] Try predicative/hoare monadic sort verification Attempt to port the proof of simulation of the 979 heap-list-sort from a "direct" version on the monadic semantics to a postcondition/hoare style approach. The big upgrade would be if we could do something separation-ish about the array, since each worker works on a "focal chunk" of the array leaving the rest unchanged, and it would be a huge upgrade if the disjointness of these could be made more implicit. --- basis/heap_sort_monadicScript.sml | 397 ++++++++++++++++++++++++++++++ 1 file changed, 397 insertions(+) diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml index c6fa8d160f..2e826b9505 100644 --- a/basis/heap_sort_monadicScript.sml +++ b/basis/heap_sort_monadicScript.sml @@ -1183,3 +1183,400 @@ val sort_via_sfx_trees_run_worker_v_thm = sort_via_sfx_trees_run_worker_def val sort_via_sfx_trees_v_thm = sort_via_sfx_trees_def |> translate; +(* An alternative proof of equivalence. *) + +Definition monad_prop_def: + monad_prop s m Q = (case m s of (M_success v, s') => Q v s' | _ => F) +End + +Theorem monad_prop_bind: + monad_prop s f P /\ (! x s'. P x s' ==> monad_prop s' (g x) Q) ==> + monad_prop s (st_ex_bind f g) Q +Proof + simp [monad_prop_def, ml_monadBaseTheory.st_ex_bind_def] + \\ BasicProvers.EVERY_CASE_TAC \\ fs [] +QED + +Theorem monad_prop_exI: + (? x s'. m s = (M_success x, s') /\ Q x s') ==> + monad_prop s m Q +Proof + rw [monad_prop_def] \\ simp [] +QED + +Theorem monad_prop_postcond_imp: + monad_prop s m P /\ (!x s'. P x s' ==> Q x s') ==> + monad_prop s m Q +Proof + rw [monad_prop_def] + \\ BasicProvers.EVERY_CASE_TAC \\ fs [] +QED + +Theorem monad_prop_return: + Q x s ==> monad_prop s (return x) Q +Proof + simp [ml_monadBaseTheory.st_ex_return_def, monad_prop_def] +QED + +Theorem return_bind_eq: + st_ex_bind (return v) f = f v +Proof + simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] +QED + +Definition array_eqs_def: + array_eqs bg arr = (FINITE_BAG bg /\ BAG_ALL_DISTINCT (BAG_IMAGE FST bg) /\ + (!i x. BAG_IN (i, x) bg ==> i < LENGTH arr /\ EL i arr = x)) +End + +Theorem array_eqs_insert: + array_eqs (BAG_INSERT (i, x) bg) arr = + (array_eqs bg arr /\ i < LENGTH arr /\ EL i arr = x /\ (~ BAG_IN i (BAG_IMAGE FST bg))) +Proof + simp [array_eqs_def] + \\ EQ_TAC \\ rw [] \\ fs [] + \\ gs [BAG_ALL_DISTINCT_THM, BAG_IMAGE_FINITE_INSERT] + \\ fs [DISJ_IMP_THM, FORALL_AND_THM] + \\ res_tac \\ fs [] +QED + +Theorem array_eqs_LUPDATE: + array_eqs bg arr /\ (~ BAG_IN i (BAG_IMAGE FST bg)) ==> + array_eqs bg (LUPDATE x i arr) +Proof + rw [array_eqs_def] + \\ rw [EL_LUPDATE] + \\ gs [bagTheory.BAG_IN_FINITE_BAG_IMAGE] + \\ metis_tac [] +QED + +Theorem heap_array_sub_prop: + i < LENGTH s.heap_array ==> + monad_prop s (heap_array_sub i) + (\rv s'. rv = EL i s.heap_array /\ s' = s) +Proof + rw [] + \\ irule monad_prop_exI + \\ simp [monad_simps] +QED + +Theorem update_heap_array_prop: + i < LENGTH s.heap_array ==> + monad_prop s (update_heap_array i x) + (\rv s'. s' = (s with <| heap_array := LUPDATE x i s.heap_array |>)) +Proof + rw [] + \\ irule monad_prop_exI + \\ simp [monad_simps] +QED + +Definition list_mappings_from_def: + list_mappings_from xs i = LIST_TO_BAG (MAPi (\j x. (i + j, x)) xs) +End + +Theorem list_mappings_from_append: + list_mappings_from (xs ++ ys) i = + BAG_UNION (list_mappings_from xs i) (list_mappings_from ys (i + LENGTH xs)) +Proof + simp [list_mappings_from_def, MAPi_APPEND, LIST_TO_BAG_APPEND, o_DEF] +QED + +Theorem list_mappings_from_bases: + list_mappings_from [x] i = {|(i, x)|} /\ + list_mappings_from [] j = {||} +Proof + simp [list_mappings_from_def] +QED + +Theorem insert_into_sfx_heap_eq: + + ! t R i ht x st. + array_eqs (BAG_UNION others + (list_mappings_from (bs_tree_to_list ht t) ((i + 1) - two_exp_min_1 ht))) st.heap_array ==> + i + 1 <= LENGTH st.heap_array /\ + two_exp_min_1 ht <= i + 1 /\ + ht > 0 /\ + tree_balanced_height ht t ==> + monad_prop st (insert_into_sfx_heap R i ht x) + (\_ st'. ?arr'. st' = st with <| heap_array := arr' |> /\ + LENGTH arr' = LENGTH st.heap_array /\ + array_eqs (BAG_UNION others + (list_mappings_from (bs_tree_to_list ht (insert_tree_inv R t x)) + ((i + 1) - two_exp_min_1 ht))) arr') +Proof + + Induct + \\ simp [tree_len_simps] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] + \\ rpt strip_tac + \\ rw [] \\ fs [] + >- ( + Cases_on `ht = 1` \\ fs [tree_len_simps] + \\ fs [insert_tree_inv_def, tree_len_simps] + \\ fs [list_mappings_from_bases, BAG_UNION_INSERT, array_eqs_insert] + \\ irule monad_prop_postcond_imp \\ irule_at Any update_heap_array_prop + \\ simp [] + \\ irule_at Any EQ_REFL + \\ simp [array_eqs_LUPDATE, EL_LUPDATE] + ) + >- ( + + fs [tree_balanced_height_pos] + \\ simp [return_bind_eq] + \\ fs [tree_len_simps, sfx_heap_left_two_exp_min_1] + \\ fs [list_mappings_from_bases, list_mappings_from_append, + BAG_UNION_INSERT, array_eqs_insert] + \\ irule monad_prop_bind \\ irule_at Any heap_array_sub_prop \\ rw [] + \\ irule monad_prop_bind \\ irule_at Any heap_array_sub_prop + \\ fs [list_mappings_from_bases, list_mappings_from_append, + BAG_UNION_INSERT, array_eqs_insert] + + \\ irule monad_prop_bind \\ irule_at Any heap_array_sub_prop + + + \\ simp [EL_APPEND, tree_len_simps, LEFT_ADD_DISTRIB] + \\ rpt TOP_CASE_TAC \\ simp [ml_monadBaseTheory.monad_eqs] + >- ( + simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ simp [insert_tree_inv_def, tree_len_simps] + ) + >- ( + simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ simp [tree_len_simps] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] + \\ simp_tac bool_ss [GSYM APPEND_ASSOC, APPEND] + ) + >- ( + simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ simp [tree_len_simps] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] + ) + ) +QED + + +Theorem test: + 3 < LENGTH st.heap_array ==> + monad_prop st + do + x <- heap_array_sub 1; + y <- heap_array_sub 2; + z <- heap_array_sub 3; + return (x + y + z) + od (\rv st. T) + +Proof + + rw [] + \\ irule monad_prop_bind \\ irule_at Any heap_array_sub_prop \\ rw [] + \\ simp [] + \\ irule monad_prop_bind \\ irule_at Any heap_array_sub_prop \\ simp [] + + conj_tac + + + + +Theorem broken: + (! s i. monad_postcond s (get i) (\rv s'. rv = get_pure s i /\ s' = s)) + ==> + ?Q. monad_postcond s' (get k) Q /\ (Conds Q) +Proof + strip_tac + >> pop_assum (irule_at Any) + >> cheat +QED + +Theorem works: + (! s i. monad_postcond s (get i) (\rv s'. rv = get_pure s i /\ s' = s)) + ==> + ?Q. monad_postcond s (get k) Q /\ (Conds Q) +Proof + strip_tac + >> pop_assum (irule_at Any) + >> cheat +QED + +Theorem works: + + (! s i. monad_postcond s (get i) (\rv s'. rv = get_pure s i /\ s' = s)) + ==> + ?Q. monad_postcond s' (get k) Q /\ (Conds Q) + + + strip_tac + >> pop_assum (irule_at Any) + + +Theorem + + ∃P. Q P /\ monad_prop s' (heap_array_sub 2) P + +\\ irule_at Any heap_array_sub_prop + +Theorem works: + Q /\ (!x. R f x (\y. y = x)) + ==> + R f z (\y. y = z) /\ Q +Proof + strip_tac + >> pop_assum (irule_at Any) + >> simp [] +QED + +Theorem fails: + Q /\ (!x. R f x (\y. y = x)) + ==> + R f y (\z. z = y) /\ Q + +Proof + strip_tac + >> pop_assum (qspec_then `y` (irule_at Any)) + + >> simp [] +QED + + + + + + +Definition result_prop_def: + result_prop x Q = Q x +End + +Theorem result_prop_LET: + result_prop v P /\ (!x. P x ==> result_prop (f x) Q) ==> + result_prop (LET f v) Q +Proof + simp [result_prop_def] +QED + +Theorem result_tup_eq_fst: + result_prop (x, y) (\t. FST t = x) +Proof + simp [result_prop_def] +QED + +Theorem works: + result_prop (let x = (1n, T); y = (2n, F); z = (3n, ()) in FST x + FST y + FST z) (\n. n > 5) +Proof + irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] + \\ irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] + \\ irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] + \\ fs [] + \\ simp [result_prop_def] +QED + +Theorem works: + result_prop (let x = (1n, T); y = (2n, F); z = (3n, ()) in FST x + FST y + FST z) (\n. n > 5) +Proof + irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] + \\ irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] + \\ irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] + \\ fs [] + \\ simp [result_prop_def] +QED + + +(* Another alternative proof, via array->fun->tree directed equivalence. *) + + +Definition extract_tree_def: + extract_tree 0 i arr = Empty_Tree /\ + extract_tree (SUC ht) i arr = Node (EL (i + (two_exp_min_1 (SUC ht) - 1)) arr) + (extract_tree ht i arr) (extract_tree ht (i + two_exp_min_1 ht) arr) +End + +Theorem extract_tree_less_rec[local]: + 0 < ht ==> extract_tree ht i arr = Node (EL (i + (two_exp_min_1 ht - 1)) arr) + (extract_tree (ht - 1) i arr) (extract_tree (ht - 1) (i + two_exp_min_1 (ht - 1)) arr) +Proof + Cases_on `ht` \\ simp [extract_tree_def] +QED + +Definition update_range_def: + update_range i j f xs = TAKE i xs ++ GENLIST f j ++ DROP (i + j) xs +End + +Theorem EL_update_range: + k < LENGTH xs ==> + EL k (update_range i j f xs) = (if k < i \/ k >= i + j + then EL k xs else f (k - i)) +Proof + simp [update_range_def] + \\ rw [] + \\ simp [EL_APPEND, LENGTH_TAKE_EQ] + \\ rw [] + \\ fs [EL_TAKE, EL_DROP] +QED + +Theorem insert_into_sfx_heap_eq: + + ! t R i ht x st. + t = extract_tree ht (i - two_exp_min_1 ht) st.heap_array /\ + i + 1 <= LENGTH st.heap_array /\ + two_exp_min_1 ht <= i + 1 /\ + ht > 0 ==> + ? arr upd_f. + arr = update_range ((i + 1) - two_exp_min_1 ht) (two_exp_min_1 ht) upd_f st.heap_array /\ + insert_into_sfx_heap R i ht x st = (M_success (), st with <| heap_array := arr |>) /\ + extract_tree ht ((i + 1) - two_exp_min_1 ht) arr = + insert_tree_inv R t x + +Proof + + Induct + \\ csimp [extract_tree_less_rec] + \\ rw [] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] + \\ subgoal `?base. i = base + (two_exp_min_1 ht - 1)` + >- ( + qexists_tac `(i + 1) - (two_exp_min_1 ht)` + \\ fs [two_exp_min_1_less_rec, two_exp_min_1_pos] + ) + \\ rw [] \\ fs [] + >- ( + Cases_on `ht = 1` \\ fs [extract_tree_def] + \\ fs [two_exp_min_1_rec, two_exp_min_1_less_rec] + \\ simp [monad_simps, fetch "-" "state_refs_component_equality"] + \\ simp [insert_tree_inv_def] + \\ simp [EL_update_range] + (* this is somewhat annoying *) + + \\ cheat + ) + + >- ( + fs [two_exp_min_1_less_rec, sfx_heap_left_two_exp_min_1] + \\ simp [monad_simps] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ simp [extract_tree_less_rec, two_exp_min_1_less_rec] + \\ rw [] \\ fs [] + + \\ simp [monad_simps, tree_len_simps, sfx_heap_left_two_exp_min_1] + \\ simp [EL_APPEND, tree_len_simps, LEFT_ADD_DISTRIB] + \\ rpt TOP_CASE_TAC \\ simp [ml_monadBaseTheory.monad_eqs] + >- ( + simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ simp [insert_tree_inv_def, tree_len_simps] + ) + >- ( + simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ simp [tree_len_simps] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] + \\ simp_tac bool_ss [GSYM APPEND_ASSOC, APPEND] + ) + >- ( + simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ simp [tree_len_simps] + \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] + ) + ) +QED + + From 0ee3c386659c9f5bbb05ad4280e12f9fd23fd49f Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Mon, 23 Feb 2026 14:46:04 +1100 Subject: [PATCH 11/39] Some parts proven via mini-sep-logic After figuring out some issues with polymorphism, present a mechanism that sort of works involving disjoint array chunk membership. It works, and the most involved proof is now much faster and much more step-by-step. The other proofs are getting clunkier though. Sigh. Time to try something else. --- basis/heap_sort_monadicScript.sml | 906 +++++++++++++++++++++++++----- 1 file changed, 780 insertions(+), 126 deletions(-) diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml index 2e826b9505..8c2d35ce25 100644 --- a/basis/heap_sort_monadicScript.sml +++ b/basis/heap_sort_monadicScript.sml @@ -290,6 +290,13 @@ Proof \\ simp [bs_tree_to_list_def, two_exp_min_1_rec] QED +Theorem LAST_bs_tree_to_list[local]: + 0 < ht ==> LAST (bs_tree_to_list ht t) = ( + case t of Node x _ _ => x) +Proof + Cases_on `ht` \\ simp [bs_tree_to_list_def, two_exp_min_1_rec] +QED + Definition tree_balanced_height_def: (tree_balanced_height i Empty_Tree = (i = 0n)) /\ (tree_balanced_height i (Node x l r) = ( @@ -304,6 +311,12 @@ Proof Cases_on `t` \\ simp [tree_balanced_height_def] QED +Theorem tree_balanced_height_eq_0[local]: + ht = 0 ==> (tree_balanced_height ht t = (t = Empty_Tree)) +Proof + Cases_on `t` \\ simp [tree_balanced_height_def] +QED + Theorem tree_balanced_height_pos: 0 < ht ==> tree_balanced_height ht t = (?x l r. t = Node x l r /\ tree_balanced_height (ht - 1) l /\ @@ -1288,200 +1301,841 @@ Proof simp [list_mappings_from_def] QED +Definition array_chunks_end_in_def: + array_chunks_end_in xs arr = ( + EVERY (\(i, zs). LENGTH zs - 1 <= i) xs /\ + let ys = FLAT (MAP (\(i, zs). + MAPi (\j z. ((i - (LENGTH zs - 1)) + j, z)) zs) xs) in + ALL_DISTINCT (MAP FST ys) /\ + EVERY (\(j, z). j < LENGTH arr /\ EL j arr = z) ys + ) +End + +Theorem array_chunks_end_in_append[local]: + array_chunks_end_in (xs ++ ys) = array_chunks_end_in (ys ++ xs) +Proof + simp [array_chunks_end_in_def, FUN_EQ_THM, ALL_DISTINCT_APPEND', DISJOINT_SYM] + \\ rw [] \\ EQ_TAC \\ rw [] \\ simp [] +QED + +Theorem array_chunks_end_in_rotate[local]: + array_chunks_end_in (x :: xs) = array_chunks_end_in (xs ++ [x]) +Proof + simp [Once array_chunks_end_in_append] +QED + +Theorem array_chunks_end_in_null[local]: + array_chunks_end_in ((i, []) :: xs) = array_chunks_end_in xs +Proof + simp [array_chunks_end_in_def, FUN_EQ_THM] +QED + +Theorem list_to_bag_flat_eq: + !xs ys. LIST_TO_BAG xs = LIST_TO_BAG ys ==> + LIST_TO_BAG (FLAT xs) = LIST_TO_BAG (FLAT ys) +Proof + Induct + >- ( + Cases \\ simp [] + ) + >- ( + rw [] + \\ first_assum (mp_tac o Q.AP_TERM `BAG_IN h`) + \\ rw [IN_LIST_TO_BAG] + \\ fs [MEM_SPLIT] + \\ fs [LIST_TO_BAG_APPEND] + \\ fsrw_tac [bagSimps.BAG_AC_ss] [BAG_INSERT_UNION] + \\ simp_tac bool_ss [GSYM LIST_TO_BAG_APPEND, GSYM FLAT_APPEND] + \\ first_x_assum irule + \\ simp [LIST_TO_BAG_APPEND] + ) +QED + +Theorem array_chunks_end_in_bag_eq: + ! xs ys zs. LIST_TO_BAG xs = LIST_TO_BAG ys ==> + array_chunks_end_in xs = array_chunks_end_in ys +Proof + rw [] + \\ simp [array_chunks_end_in_def, FUN_EQ_THM] + \\ simp [EVERY_FLAT] + \\ rw [GSYM EVERY_LIST_TO_BAG, LIST_TO_BAG_MAP] + \\ rpt (irule AND_CONG \\ rw []) + \\ simp [GSYM containerTheory.LIST_TO_BAG_DISTINCT] + \\ simp [LIST_TO_BAG_MAP] + \\ AP_TERM_TAC + \\ AP_TERM_TAC + \\ irule list_to_bag_flat_eq + \\ simp [LIST_TO_BAG_MAP] +QED + +Theorem array_chunks_end_in_chunk_append[local]: + array_chunks_end_in ((i, xs ++ ys) :: zs) arr = ( + (LENGTH xs + LENGTH ys) - 1 <= i /\ + array_chunks_end_in ((i - LENGTH ys, xs) :: (i, ys) :: zs) arr + ) +Proof + simp [array_chunks_end_in_def] + \\ Cases_on `xs = []` \\ csimp [] + \\ Cases_on `ys = []` \\ csimp [] + >- ( + EQ_TAC \\ rw [] \\ fs [] + ) + \\ simp [MAPi_APPEND, o_DEF, GSYM CONJ_ASSOC] + \\ Cases_on `LENGTH xs` \\ fs [] + \\ Cases_on `LENGTH ys` \\ fs [] + \\ csimp [ADD1] +QED + +Theorem array_chunks_end_in_chunk_append_fun[local]: + (LENGTH xs + LENGTH ys) - 1 <= i ==> + array_chunks_end_in ((i, xs ++ ys) :: zs) = ( + array_chunks_end_in ((i - LENGTH ys, xs) :: (i, ys) :: zs) + ) +Proof + simp [FUN_EQ_THM, array_chunks_end_in_chunk_append] +QED + +Theorem array_chunks_end_in_EL[local]: + array_chunks_end_in ((i, [x]) :: zs) arr ==> + i < LENGTH arr /\ EL i arr = x +Proof + rw [array_chunks_end_in_def] +QED + +Theorem array_chunks_end_in_EL_each_LAST[local]: + array_chunks_end_in xs arr ==> + EVERY (\(i, xs). 0 < LENGTH xs ==> i < LENGTH arr /\ EL i arr = LAST xs) xs +Proof + rw [array_chunks_end_in_def] + \\ rw [EVERY_MEM] + \\ pairarg_tac \\ fs [] + \\ fs [MEM_SPLIT] \\ fs [] + \\ disch_tac + \\ qpat_x_assum `EVERY _ (MAPi _ _)` mp_tac + \\ simp [EVERY_EL] + \\ disch_then (qspec_then `LENGTH xs' - 1` mp_tac) + \\ imp_res_tac LENGTH_NOT_NULL + \\ fs [NULL_EQ, LAST_EL, PRE_SUB1] +QED + +Theorem array_chunks_end_in_LUPDATE[local]: + array_chunks_end_in ((i, [x]) :: zs) arr ==> + array_chunks_end_in ((i, [y]) :: zs) (LUPDATE y i arr) +Proof + rw [array_chunks_end_in_def, EL_LUPDATE] + \\ fs [EVERY_FLAT, EVERY_MAP] + \\ subgoal `!f g. EVERY f zs /\ (EVERY f zs = EVERY g zs) ==> EVERY g zs` + \\ csimp [] + \\ pop_assum (drule_then irule) + \\ irule EVERY_CONG + \\ simp [FORALL_PROD] \\ rw [] + \\ irule EVERY_CONG + \\ simp [MEM_MAPi, PULL_EXISTS] + \\ rw [] + \\ dxrule (hd (RES_CANON MEM_SPLIT)) + \\ rw [] \\ fs [] + \\ fs [MEM_MAPi] +QED + +Theorem array_chunks_end_in_tree_split[local]: + 0 < ht ==> ( + array_chunks_end_in ((i, bs_tree_to_list ht (Node x l r)) :: xs) arr <=> + (2 * two_exp_min_1 (ht - 1) <= i) /\ + array_chunks_end_in ( + (i - (two_exp_min_1 (ht - 1) + 1), bs_tree_to_list (ht - 1) l) :: + (i - 1, bs_tree_to_list (ht - 1) r) :: (i, [x]) :: xs) arr + ) +Proof + csimp [bs_tree_to_list_tree_rec] + \\ simp [array_chunks_end_in_chunk_append] + \\ rw [] \\ EQ_TAC \\ rw [] + \\ fs [LENGTH_bs_tree_to_list] +QED + +Theorem array_chunks_end_in_tree_split_fun[local]: + 0 < ht /\ (2 * two_exp_min_1 (ht - 1) <= i) ==> ( + array_chunks_end_in ((i, bs_tree_to_list ht (Node x l r)) :: xs) = + array_chunks_end_in ( + (i - (two_exp_min_1 (ht - 1) + 1), bs_tree_to_list (ht - 1) l) :: + (i - 1, bs_tree_to_list (ht - 1) r) :: (i, [x]) :: xs) + ) +Proof + simp [FUN_EQ_THM, array_chunks_end_in_tree_split] +QED + +Theorem array_chunks_end_in_bag_eq[local]: + array_chunks_end_in xs arr /\ LIST_TO_BAG xs = LIST_TO_BAG ys ==> + array_chunks_end_in ys arr + +Proof + + cheat + +QED + +Theorem array_chunks_end_in_bag_eq_LUPDATE[local]: + array_chunks_end_in xs arr /\ + MEM (i, [z]) xs /\ + LIST_TO_BAG ys = ((LIST_TO_BAG xs - {|(i, [z])|}) + {|(i, [y])|}) ==> + array_chunks_end_in ys (LUPDATE y i arr) + +Proof + + cheat + +QED + +Theorem EQ_REFL_OR[local]: + x = x \/ P +Proof + simp [] +QED + +val rotate_ + (CHANGED_TAC (REWRITE_TAC [array_chunks_end_in_rotate]) \\ simp [APPEND]) + + +Definition eq_array_def: + eq_array p p' P = (?arr. p = (FST p', + (SND p' : 'a state_refs) with <| heap_array := arr |>) /\ P arr) +End + +Theorem eq_array_sub: + i < LENGTH (acc s) ==> + eq_array (st_ex_bind (Marray_sub acc exn i) f s) (M_success v, s') P = + eq_array (f (EL i (acc s)) s) (M_success v, s') P +Proof + simp [eq_array_def, monad_simps] +QED + +fun dest_list_apps t = let + open listSyntax + fun f xs yss [] = (xs, yss) + | f xs yss (t :: ts) = if is_cons t + then f (fst (dest_cons t) :: xs) yss (snd (dest_cons t) :: ts) + else if is_append t + then f xs yss (fst (dest_append t) :: snd (dest_append t) :: ts) + else f xs (t :: yss) ts + in f [] [] [t] end + +fun chunks_conv pred t = let + val (f, xs) = strip_comb t + val _ = same_const ``array_chunks_end_in`` f orelse + failwith "not array_chunks_end_in" + val _ = (length xs = 2) orelse failwith "not enough args" + val (chk_vs, oths) = dest_list_apps (hd xs) + val el_typ = listSyntax.dest_list_type (type_of (hd xs)) + val (pick, reject) = partition pred chk_vs + val base = if null oths then listSyntax.mk_list ([], el_typ) + else foldr listSyntax.mk_append (last oths) (butlast oths) + val rhs_chks = foldr listSyntax.mk_cons base (pick @ reject) + val eq = mk_eq (t, list_mk_comb (f, [rhs_chks, last xs])) + +fun pred t = can (match_term ``(_, [_])``) t + + Theorem insert_into_sfx_heap_eq: ! t R i ht x st. - array_eqs (BAG_UNION others - (list_mappings_from (bs_tree_to_list ht t) ((i + 1) - two_exp_min_1 ht))) st.heap_array ==> + array_chunks_end_in ((i, bs_tree_to_list ht t) :: others) st.heap_array /\ i + 1 <= LENGTH st.heap_array /\ two_exp_min_1 ht <= i + 1 /\ ht > 0 /\ tree_balanced_height ht t ==> - monad_prop st (insert_into_sfx_heap R i ht x) - (\_ st'. ?arr'. st' = st with <| heap_array := arr' |> /\ - LENGTH arr' = LENGTH st.heap_array /\ - array_eqs (BAG_UNION others - (list_mappings_from (bs_tree_to_list ht (insert_tree_inv R t x)) - ((i + 1) - two_exp_min_1 ht))) arr') + eq_array (insert_into_sfx_heap R i ht x st) + (M_success (), st) + (array_chunks_end_in ((i, bs_tree_to_list ht (insert_tree_inv R t x)) :: others)) + Proof Induct - \\ simp [tree_len_simps] + \\ simp [tree_balanced_height_def] \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] - \\ rpt strip_tac - \\ rw [] \\ fs [] + \\ rw [] >- ( - Cases_on `ht = 1` \\ fs [tree_len_simps] - \\ fs [insert_tree_inv_def, tree_len_simps] - \\ fs [list_mappings_from_bases, BAG_UNION_INSERT, array_eqs_insert] - \\ irule monad_prop_postcond_imp \\ irule_at Any update_heap_array_prop - \\ simp [] + Cases_on `ht = 1` \\ fs [tree_balanced_height_0] + \\ simp [monad_simps, eq_array_def] \\ irule_at Any EQ_REFL - \\ simp [array_eqs_LUPDATE, EL_LUPDATE] + \\ fs [array_chunks_end_in_tree_split, bs_tree_to_list_def, + insert_tree_inv_def, array_chunks_end_in_null] + \\ drule_then irule array_chunks_end_in_LUPDATE ) >- ( - fs [tree_balanced_height_pos] - \\ simp [return_bind_eq] - \\ fs [tree_len_simps, sfx_heap_left_two_exp_min_1] - \\ fs [list_mappings_from_bases, list_mappings_from_append, - BAG_UNION_INSERT, array_eqs_insert] - \\ irule monad_prop_bind \\ irule_at Any heap_array_sub_prop \\ rw [] - \\ irule monad_prop_bind \\ irule_at Any heap_array_sub_prop - \\ fs [list_mappings_from_bases, list_mappings_from_append, - BAG_UNION_INSERT, array_eqs_insert] - - \\ irule monad_prop_bind \\ irule_at Any heap_array_sub_prop - - - \\ simp [EL_APPEND, tree_len_simps, LEFT_ADD_DISTRIB] + (* split array chunks once *) + gs [array_chunks_end_in_tree_split] + (* then expand the tree further to get top node vals *) + \\ gs [tree_balanced_height_pos] + (* continue *) + \\ simp [sfx_heap_left_def, to_two_exp_min_1] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ simp [monad_simps, return_bind_eq, eq_array_sub] + \\ imp_res_tac array_chunks_end_in_EL_each_LAST + \\ gs [LENGTH_bs_tree_to_list, LAST_bs_tree_to_list, two_exp_min_1_pos] \\ rpt TOP_CASE_TAC \\ simp [ml_monadBaseTheory.monad_eqs] >- ( - simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ simp [insert_tree_inv_def, tree_len_simps] - ) - >- ( - simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ simp [tree_len_simps] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] - \\ simp_tac bool_ss [GSYM APPEND_ASSOC, APPEND] + simp [eq_array_def, monad_simps] + \\ irule_at Any EQ_REFL + \\ simp [Once array_chunks_end_in_tree_split] + \\ drule_then (irule_at Any) array_chunks_end_in_bag_eq_LUPDATE + \\ simp [] + \\ fsrw_tac [simpLib.ac_ss [(DISJ_ASSOC, DISJ_COMM)]] [] + \\ irule_at Any EQ_REFL_OR + \\ simp [BAG_INSERT_commutes, BAG_UNION_INSERT] ) >- ( - simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ simp [tree_len_simps] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] - ) - ) -QED + irule_at Any array_chunks_end_in_bag_eq + \\ ONCE_REWRITE_TAC [CONJ_COMM] + \\ ONCE_REWRITE_TAC [CONJ_ASSOC] + \\ first_x_assum (irule_at Any) + -Theorem test: - 3 < LENGTH st.heap_array ==> - monad_prop st - do - x <- heap_array_sub 1; - y <- heap_array_sub 2; - z <- heap_array_sub 3; - return (x + y + z) - od (\rv st. T) - + +Theorem insert_into_sfx_heap_eq: + + ! ht i st t others. + array_chunks_end_in ((i, bs_tree_to_list ht t) :: others) st.heap_array /\ + i + 1 <= LENGTH st.heap_array /\ + two_exp_min_1 ht <= i + 1 /\ + ht > 0 /\ + tree_balanced_height ht t ==> + ? arr'. + insert_into_sfx_heap R i ht x st = (M_success (), st with <| heap_array := arr' |>) /\ + array_chunks_end_in ((i, bs_tree_to_list ht (insert_tree_inv R t x)) :: others) arr' + Proof - rw [] - \\ irule monad_prop_bind \\ irule_at Any heap_array_sub_prop \\ rw [] - \\ simp [] - \\ irule monad_prop_bind \\ irule_at Any heap_array_sub_prop \\ simp [] + Induct + \\ simp [tree_balanced_height_def, ADD1] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] + \\ rw [] + >- ( + Cases_on `ht` \\ fs [tree_balanced_height_pos, tree_balanced_height_0] + \\ simp [monad_simps] + \\ irule_at Any EQ_REFL + \\ fs [array_chunks_end_in_tree_split, bs_tree_to_list_def, + insert_tree_inv_def, array_chunks_end_in_null] + \\ drule_then irule array_chunks_end_in_LUPDATE + ) + >- ( - conj_tac + (* unfold tree once *) + fs [Once tree_balanced_height_pos] + (* split array chunks once *) + \\ gs [array_chunks_end_in_tree_split] + (* then expand the tree further to get top node vals *) + \\ gs [tree_balanced_height_pos] + \\ simp [sfx_heap_left_def, to_two_exp_min_1] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ simp [monad_simps] + \\ imp_res_tac array_chunks_end_in_EL_each_LAST + \\ gs [LENGTH_bs_tree_to_list, LAST_bs_tree_to_list, two_exp_min_1_pos] + \\ rpt TOP_CASE_TAC \\ simp [] + >- ( + simp [monad_simps] + \\ irule_at Any EQ_REFL + \\ simp [Once array_chunks_end_in_tree_split_fun] + \\ qpat_x_assum `array_chunks_end_in _ _` mp_tac -Theorem broken: - (! s i. monad_postcond s (get i) (\rv s'. rv = get_pure s i /\ s' = s)) - ==> - ?Q. monad_postcond s' (get k) Q /\ (Conds Q) -Proof - strip_tac - >> pop_assum (irule_at Any) - >> cheat -QED + \\ drule_then (irule_at Any) array_chunks_end_in_bag_eq_LUPDATE + \\ simp [] + \\ fsrw_tac [simpLib.ac_ss [(DISJ_ASSOC, DISJ_COMM)]] [] + \\ irule_at Any EQ_REFL_OR + \\ simp [BAG_INSERT_commutes, BAG_UNION_INSERT] + ) + >- ( -Theorem works: - (! s i. monad_postcond s (get i) (\rv s'. rv = get_pure s i /\ s' = s)) - ==> - ?Q. monad_postcond s (get k) Q /\ (Conds Q) -Proof - strip_tac - >> pop_assum (irule_at Any) - >> cheat -QED + ONCE_REWRITE_TAC [ml_monadBaseTheory.monad_eqs] + \\ simp [PULL_EXISTS] -Theorem works: + qmatch_goalsub_abbrev_tac `insert_into_sfx_heap _ i2 _ _ st2` + \\ first_x_assum (qspecl_then [`i2`, `st2`] mp_tac) + \\ dxrule (hd (RES_CANON array_chunks_end_in_rotate)) + \\ rw [] + \\ first_x_assum drule - (! s i. monad_postcond s (get i) (\rv s'. rv = get_pure s i /\ s' = s)) - ==> - ?Q. monad_postcond s' (get k) Q /\ (Conds Q) + irule_at Any array_chunks_end_in_bag_eq + \\ ONCE_REWRITE_TAC [CONJ_COMM] + \\ ONCE_REWRITE_TAC [CONJ_ASSOC] + \\ first_x_assum (irule_at Any) + + \\ fsrw_tac [bagLib.SBAG_SOLVE_ss] [] + + + + \\ rpt (irule array_chunks_end_in_LUPDATE ORELSE + (CHANGED_TAC (REWRITE_TAC [array_chunks_end_in_rotate]) \\ simp [APPEND]) + ) + \\ REWRITE_TAC [GSYM APPEND_ASSOC] + \\ ONCE_REWRITE_TAC [array_chunks_end_in_append] + \\ simp [] + \\ first_assum (irule_at Any) + ) +REWRITE_TAC [array_chunks_end_in_rotate]) + \\ - strip_tac - >> pop_assum (irule_at Any) -Theorem +Theorem monad_eq_helper[local]: + (?s'. mv = (M_success x, s') /\ (SND mv = s' ==> s = s' /\ Q)) ==> + mv = (M_success x, s) /\ Q +Proof + rw [] \\ fs [] +QED + +Definition monad_eq_array_prop_def: + monad_eq_array_prop mv x s P = + (case mv of (M_success x', (s' : 'a state_refs)) => + x' = x /\ (?arr. s' = (s with <| heap_array := arr |>) /\ P arr) + | _ => F) +End - ∃P. Q P /\ monad_prop s' (heap_array_sub 2) P +Theorem monad_eq_array_prop_array_upd[local]: + monad_eq_array_prop mv x (heap_array_fupd f s) P = + monad_eq_array_prop mv x s P +Proof + simp [monad_eq_array_prop_def] +QED + +Theorem monad_eq_array_prop_eraseI: + (case mv of (M_success x', s') => + x' = x /\ (s' with <| heap_array := [] |>) = (s with <| heap_array := [] |>) /\ + P s'.heap_array + | _ => F) ==> + monad_eq_array_prop mv x s P +Proof + simp [monad_eq_array_prop_def] + \\ BasicProvers.EVERY_CASE_TAC \\ fs [] + \\ simp [fetch "-" "state_refs_component_equality"] +QED -\\ irule_at Any heap_array_sub_prop +Theorem monad_eq_array_prop_exI: + (?s'. mv = (M_success x', s') /\ + x' = x /\ (s' with <| heap_array := [] |>) = (s with <| heap_array := [] |>) /\ + P s'.heap_array) ==> + monad_eq_array_prop mv x s P +Proof + rw [] \\ irule monad_eq_array_prop_eraseI + \\ simp [] +QED -Theorem works: - Q /\ (!x. R f x (\y. y = x)) +Theorem monad_eq_array_prop_bindI: + monad_eq_array_prop (m (st : 'a state_refs)) y (bd_st : 'a state_refs) Q /\ + (! upd_st arr. Q upd_st.heap_array /\ bd_st = (upd_st with <| heap_array := arr |>) ==> + monad_eq_array_prop (f y upd_st) x st' P) ==> - R f z (\y. y = z) /\ Q + monad_eq_array_prop (st_ex_bind m f st) x st' P Proof - strip_tac - >> pop_assum (irule_at Any) - >> simp [] + rw [] \\ irule monad_eq_array_prop_exI + \\ simp [monad_simps] + \\ Cases_on `FST (m st)` \\ Cases_on `m st` \\ fs [monad_eq_array_prop_def] + \\ rw [] + \\ first_x_assum (qspecl_then [`bd_st with heap_array := arr`, `bd_st.heap_array`] mp_tac) + \\ rpt (TOP_CASE_TAC \\ fs []) + \\ simp [fetch "-" "state_refs_component_equality"] QED -Theorem fails: - Q /\ (!x. R f x (\y. y = x)) +Theorem monad_eq_array_prop_bindI_rdonly: + monad_eq_array_prop (m st) y st ((=) st.heap_array) /\ + monad_eq_array_prop (f y st) x st' P ==> - R f y (\z. z = y) /\ Q + monad_eq_array_prop (st_ex_bind m f st) x st' P +Proof + rw [] \\ irule monad_eq_array_prop_bindI + \\ last_assum (irule_at Any) + \\ rw [] + \\ fs [] + \\ subgoal `(upd_st with heap_array := upd_st.heap_array) = upd_st` + \\ fs [] + \\ simp [fetch "-" "state_refs_component_equality"] +QED + +Theorem heap_array_sub_bind_eq: + i < LENGTH st.heap_array ==> + st_ex_bind (heap_array_sub i) f st = + f (EL i st.heap_array) st +Proof + rw [] + \\ fs [ml_monadBaseTheory.st_ex_bind_def] + \\ simp [ml_monadBaseTheory.exc_case_eq, pair_case_eq] + \\ simp [monad_simps] +QED +Theorem sz_array_sub_bind_eq: + i < LENGTH st.sz_array ==> + st_ex_bind (sz_array_sub i) f st = + f (EL i st.sz_array) st Proof - strip_tac - >> pop_assum (qspec_then `y` (irule_at Any)) + rw [] + \\ fs [ml_monadBaseTheory.st_ex_bind_def] + \\ simp [ml_monadBaseTheory.exc_case_eq, pair_case_eq] + \\ simp [monad_simps] +QED + +Theorem update_sz_array_prop: + i < LENGTH st.sz_array ==> + monad_eq_array_prop (update_sz_array i x st) () + (st with <| sz_array := LUPDATE x i st.sz_array |>) + ((=) st.heap_array) +Proof + rw [] \\ irule monad_eq_array_prop_exI + \\ simp [monad_simps] +QED + +Theorem update_heap_array_prop: + array_chunks_end_in ((i, [prev_x]) :: others) st.heap_array ==> + monad_eq_array_prop (update_heap_array i x st) () st + (array_chunks_end_in ((i, [x]) :: others)) +Proof + rw [] \\ irule monad_eq_array_prop_exI + \\ simp [monad_simps] + \\ imp_res_tac array_chunks_end_in_EL_each_LAST + \\ fs [] + \\ drule_then irule array_chunks_end_in_LUPDATE +QED - >> simp [] +Theorem monad_eq_array_prop_postcondI: + monad_eq_array_prop mv x s P /\ (!arr. P arr ==> Q arr) ==> + monad_eq_array_prop mv x s Q +Proof + rw [monad_eq_array_prop_def] + \\ EVERY_CASE_TAC \\ fs [] + \\ irule_at Any EQ_REFL \\ simp [] QED +Theorem array_chunks_end_in_bag_eq_IMP[local]: + array_chunks_end_in xs arr /\ + LIST_TO_BAG xs = LIST_TO_BAG ys ==> + array_chunks_end_in ys arr +Proof + metis_tac [array_chunks_end_in_bag_eq] +QED +val chunks_const = ``array_chunks_end_in`` +fun chunk_select_conv pat tm = let + val (f, xs) = strip_comb tm + val _ = same_const chunks_const f orelse + failwith "not array_chunks_end_in" + val _ = not (null xs) orelse failwith "array_chunks_end_in no args" + val cs = hd xs + val ts = find_terms (fn t => listSyntax.is_cons t + andalso can (match_term pat) (rand (rator t))) cs + val _ = not (null ts) orelse failwith ("no chunk matches") + val cs2 = Term.subst [hd ts |-> rand (hd ts)] cs + val cs3 = listSyntax.mk_cons (rand (rator (hd ts)), cs2) + val rhs = list_mk_comb (f, cs3 :: tl xs) + val _ = not (aconv tm rhs) orelse failwith "chunk_select_conv: done" + val eq = mk_eq (tm, list_mk_comb (f, cs3 :: tl xs)) + in prove (eq, TRY AP_THM_TAC + \\ irule array_chunks_end_in_bag_eq + \\ fsrw_tac [bagSimps.BAG_AC_ss] [BAG_INSERT_UNION]) + end +fun chunk_select_tac pat = POP_ASSUM_LIST (fn asms => let + fun do_conv asm = if can (find_term (same_const chunks_const)) (concl asm) + then let + val asm2 = CONV_RULE (ONCE_DEPTH_CONV (chunk_select_conv pat)) asm + in (asm2, aconv (concl asm2) (concl asm)) end + else (asm, true) + val conv_asms = map do_conv asms + val (no_upd, upd) = partition snd conv_asms + in MAP_EVERY (ASSUME_TAC o fst) (rev (upd @ no_upd)) + >> CONV_TAC (ONCE_DEPTH_CONV (chunk_select_conv pat)) end) +fun select_chunk_goal pat = CONV_TAC (DEPTH_CONV (chunk_select_conv pat)) -Definition result_prop_def: - result_prop x Q = Q x -End +fun select_chunk_asm pat = qpat_x_assum `array_chunks_end_in _ _` + (assume_tac o CONV_RULE (chunk_select_conv pat)) -Theorem result_prop_LET: - result_prop v P /\ (!x. P x ==> result_prop (f x) Q) ==> - result_prop (LET f v) Q +(* chunks ends variant *) +Theorem insert_into_sfx_heap_eq: + ! ht i st t others. + array_chunks_end_in ((i, bs_tree_to_list ht t) :: others) st.heap_array /\ + ht > 0 /\ + tree_balanced_height ht t ==> + monad_eq_array_prop (insert_into_sfx_heap R i ht x st) () st + (array_chunks_end_in ((i, bs_tree_to_list ht (insert_tree_inv R t x)) :: others)) Proof - simp [result_prop_def] + Induct + \\ simp [tree_balanced_height_def, ADD1] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] + \\ rw [] + >- ( + Cases_on `ht` \\ fs [tree_balanced_height_pos, tree_balanced_height_0] + \\ irule monad_eq_array_prop_exI + \\ simp [monad_simps] + \\ imp_res_tac array_chunks_end_in_EL_each_LAST + \\ fs [LENGTH_bs_tree_to_list, two_exp_min_1_pos] + \\ fs [array_chunks_end_in_tree_split, bs_tree_to_list_def, + insert_tree_inv_def, array_chunks_end_in_null] + \\ drule_then irule array_chunks_end_in_LUPDATE + ) + >- ( + (* unfold tree once *) + fs [Once tree_balanced_height_pos] + (* split array chunks once *) + \\ gs [array_chunks_end_in_tree_split] + (* then expand the tree further to get top node vals *) + \\ gs [tree_balanced_height_pos] + \\ simp [sfx_heap_left_def, to_two_exp_min_1] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ imp_res_tac array_chunks_end_in_EL_each_LAST + \\ gs [LENGTH_bs_tree_to_list, LAST_bs_tree_to_list, two_exp_min_1_pos] + \\ simp [return_bind_eq, heap_array_sub_bind_eq] + \\ rpt TOP_CASE_TAC \\ simp [] + >- ( + simp [Once array_chunks_end_in_tree_split_fun] + \\ chunk_select_tac ``(_, [_])`` + \\ drule_then irule update_heap_array_prop + ) + >- ( + simp [st_ex_ignore_bind_simp] + \\ simp [Once array_chunks_end_in_tree_split_fun] + \\ chunk_select_tac ``(_, [_])`` + \\ irule monad_eq_array_prop_bindI + \\ dxrule_then (irule_at Any) update_heap_array_prop + \\ rw [] + \\ chunk_select_tac ``(_ - 1n, _)`` + \\ first_x_assum dxrule + \\ simp [monad_eq_array_prop_array_upd] + ) + >- ( + simp [st_ex_ignore_bind_simp] + \\ simp [Once array_chunks_end_in_tree_split_fun] + \\ chunk_select_tac ``(_, [_])`` + \\ irule monad_eq_array_prop_bindI + \\ dxrule_then (irule_at Any) update_heap_array_prop + \\ rw [] + \\ chunk_select_tac ``(_ - (_ + 1n), _)`` + \\ first_x_assum dxrule + \\ simp [monad_eq_array_prop_array_upd] + ) + ) QED -Theorem result_tup_eq_fst: - result_prop (x, y) (\t. FST t = x) +Definition bs_tree_list_chunks_def: + bs_tree_list_chunks i [] = [] /\ + bs_tree_list_chunks i ((t, ht) :: ts) = + ((i, bs_tree_to_list ht t) :: bs_tree_list_chunks (i - two_exp_min_1 ht) ts) +End + +Theorem insert_into_sfx_heap_list_eq: + ! j ts R i x others st. + array_chunks_end_in ((i, bs_tree_list_to_list ts) :: others) st.heap_array /\ + TAKE j st.sz_array = MAP SND (REVERSE ts) /\ + j <= LENGTH st.sz_array ==> + 0 < j /\ EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> + monad_eq_array_prop (insert_into_sfx_heap_list R i j x st) () st + (array_chunks_end_in ((i, bs_tree_list_to_list (insert_trees_inv R ts x)) :: others)) Proof - simp [result_prop_def] + Induct + \\ simp [] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_list_def] + \\ rpt strip_tac + \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [] + \\ gs [ADD1, TAKE_SUM] + \\ simp [insert_trees_inv_def] + \\ rw [] + >- ( + Cases_on `j` \\ fs [] + \\ gs [tree_balanced_height_pos, bs_tree_list_to_list_rec] + \\ simp [sz_array_sub_bind_eq] + \\ irule insert_into_sfx_heap_eq + \\ simp [tree_balanced_height_pos] + ) + >- ( + gs [bs_tree_list_to_list_rec, tree_balanced_height_pos, ADD1, + array_chunks_end_in_chunk_append] + \\ simp [sz_array_sub_bind_eq, return_bind_eq] + \\ imp_res_tac array_chunks_end_in_EL_each_LAST + \\ gs [EL_TAKE, EL_APPEND, array_chunks_end_in_tree_split, + LENGTH_bs_tree_to_list, two_exp_min_1_pos, APPEND] + \\ simp [to_two_exp_min_1] + \\ qpat_x_assum `0 < LENGTH (bs_tree_list_to_list _) ==> _` mp_tac + \\ impl_keep_tac + >- ( + Cases_on `HD t` \\ Cases_on `t` \\ fs [] + \\ gs [bs_tree_list_to_list_rec, tree_balanced_height_pos] + \\ simp [bs_tree_to_list_tree_rec] + ) + \\ rw [] + \\ Cases_on `HD t` \\ Cases_on `t` \\ fs [] + \\ gs [tree_balanced_height_pos] + \\ simp [heap_array_sub_bind_eq] + \\ irule monad_eq_array_prop_bindI_rdonly + \\ qmatch_goalsub_abbrev_tac `bs_tree_list_to_list (COND tree_conds _ _)` + \\ qexists_tac `tree_conds` + \\ conj_tac + >- ( + Cases_on `j` \\ fs [ADD1, TAKE_SUM] + \\ fs [markerTheory.Abbrev_def, bs_tree_list_to_list_rec, + bs_tree_to_list_tree_rec] + \\ reverse (rw []) + >- ( + gs [] + \\ irule monad_eq_array_prop_exI + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ gs [tree_balanced_height_eq_0] + ) + >- ( + gs [tree_balanced_height_pos] + \\ fs [array_chunks_end_in_chunk_append] + \\ chunk_select_tac ``(_, _ ++ _)`` + \\ fs [array_chunks_end_in_chunk_append] + \\ simp [sfx_heap_left_def, to_two_exp_min_1] + \\ imp_res_tac array_chunks_end_in_EL_each_LAST + \\ gs [LENGTH_bs_tree_to_list, two_exp_min_1_pos] + \\ simp [heap_array_sub_bind_eq, LAST_bs_tree_to_list] + \\ irule monad_eq_array_prop_exI + \\ simp [ml_monadBaseTheory.monad_eqs] + ) + ) + >- ( + qpat_x_assum `Abbrev _` (K all_tac) + \\ rw [] + >- ( + fs [st_ex_ignore_bind_simp, bs_tree_to_list_tree_rec] + \\ chunk_select_tac ``(_, _ ++ _)`` + \\ fs [array_chunks_end_in_chunk_append] + \\ chunk_select_tac ``(_, [_])`` + \\ irule monad_eq_array_prop_bindI + \\ dxrule_then (irule_at Any) update_heap_array_prop + \\ rw [] + \\ simp [bs_tree_list_to_list_rec] + \\ dep_rewrite.DEP_REWRITE_TAC [array_chunks_end_in_chunk_append_fun] + \\ fs [LENGTH_bs_tree_to_list, LENGTH_list_of_insert_trees] + \\ simp [monad_eq_array_prop_array_upd] + \\ first_x_assum irule + \\ simp [tree_balanced_height_def] + \\ chunk_select_tac ``(_, bs_tree_to_list _ (Node _ _ _))`` + \\ simp [array_chunks_end_in_tree_split] + \\ chunk_select_tac ``(_, [_])`` + \\ gs [bs_tree_list_to_list_rec, bs_tree_to_list_tree_rec] + ) + >- ( + ONCE_REWRITE_TAC [bs_tree_list_to_list_rec] + \\ simp [array_chunks_end_in_chunk_append_fun, LENGTH_bs_tree_to_list] + \\ chunk_select_tac ``(_, bs_tree_to_list _ _)`` + \\ irule insert_into_sfx_heap_eq + \\ simp [tree_balanced_height_def] + ) + ) + ) QED -Theorem works: - result_prop (let x = (1n, T); y = (2n, F); z = (3n, ()) in FST x + FST y + FST z) (\n. n > 5) +Theorem add_to_sfx_heaps_step1_eq: + array_chunks_end_in ((i, [x]) :: (i - 1, bs_tree_list_to_list ts) :: others) st.heap_array /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + 0 < i /\ + TAKE j st.sz_array = MAP SND (REVERSE ts) /\ + j = LENGTH ts /\ j + 1 < LENGTH st.sz_array ==> + let ts2 = add_trees_step1 ts x; + xs = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in + monad_eq_array_prop (add_to_sfx_heaps_step1 i j st) l2 + (st with <| sz_array := MAP SND (REVERSE ts2) ++ DROP l2 st.sz_array |>) + (array_chunks_end_in ((i, bs_tree_list_to_list ts2) :: others)) Proof - irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] - \\ irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] - \\ irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] - \\ fs [] - \\ simp [result_prop_def] + rw [] + \\ simp [add_to_sfx_heaps_step1_def, add_trees_step1_def] + \\ irule monad_eq_array_prop_bindI_rdonly + \\ qexists_tac `case ts of (_, n1) :: (_, n2) :: _ => n1 = n2 | _ => F` + \\ conj_tac + >- ( + Cases_on `ts` \\ fs [] + \\ simp [monad_eq_array_prop_exI, ml_monadBaseTheory.monad_eqs] + \\ fs [ADD1, TAKE_SUM] + \\ Cases_on `t` \\ fs [] + \\ simp [monad_eq_array_prop_exI, ml_monadBaseTheory.monad_eqs] + \\ fs [ADD1, TAKE_SUM] + \\ simp [sz_array_sub_bind_eq] + \\ rpt (pairarg_tac \\ fs []) + \\ simp [monad_eq_array_prop_exI, ml_monadBaseTheory.monad_eqs] + ) + \\ rw [] + >- ( + (* merge case *) + rpt (TOP_CASE_TAC \\ fs [ADD1, TAKE_SUM]) + \\ simp [sz_array_sub_bind_eq, st_ex_ignore_bind_simp] + \\ irule monad_eq_array_prop_bindI + \\ irule_at Any update_sz_array_prop + \\ rw [] + \\ simp [monad_eq_array_prop_array_upd] + \\ qspec_then `st.sz_array` mp_tac LESS_LENGTH + \\ disch_then (qspec_then `LENGTH t'` mp_tac) + \\ rw [] + \\ fs [EL_APPEND, TAKE_APPEND1, LUPDATE_APPEND, LUPDATE_def] + \\ rw [] + \\ gs [TAKE_LENGTH_TOO_LONG, DROP_APPEND2, monad_eq_array_prop_array_upd] + \\ irule monad_eq_array_prop_exI + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ fs [bs_tree_list_to_list_rec, bs_tree_to_list_tree_rec] + \\ ONCE_REWRITE_TAC [array_chunks_end_in_chunk_append] + \\ fs [] + \\ chunk_select_tac ``(_ - 1n, _)`` + \\ simp [] + \\ fs [array_chunks_end_in_chunk_append] + \\ gs [LENGTH_bs_tree_to_list, two_exp_min_1_less_rec] + ) + >- ( + (* no merge case *) + simp [st_ex_ignore_bind_simp] + \\ qmatch_goalsub_abbrev_tac `bs_tree_list_to_list upd_trees` + \\ subgoal `upd_trees = (Node x Empty_Tree Empty_Tree, 1) :: ts` + >- ( + every_case_tac \\ fs [] + ) + \\ simp [] + \\ irule monad_eq_array_prop_bindI + \\ irule_at Any update_sz_array_prop + \\ rw [] + \\ fs [ADD1] + \\ qspec_then `st.sz_array` mp_tac LESS_LENGTH + \\ disch_then (qspec_then `LENGTH ts` mp_tac) + \\ rw [] + \\ fs [LUPDATE_APPEND, LUPDATE_DEF, TAKE_APPEND1] + \\ gs [TAKE_LENGTH_TOO_LONG, DROP_APPEND2, monad_eq_array_prop_array_upd] + \\ irule monad_eq_array_prop_exI + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ simp [bs_tree_list_to_list_rec, bs_tree_to_list_tree_rec] + \\ chunk_select_tac ``(_ - 1n, _)`` + \\ simp [array_chunks_end_in_chunk_append] + \\ fs [array_chunks_end_in_def] + ) QED -Theorem works: - result_prop (let x = (1n, T); y = (2n, F); z = (3n, ()) in FST x + FST y + FST z) (\n. n > 5) +Theorem add_to_sfx_heaps_eq: + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + 0 < i /\ + array_chunks_end_in ((i, [x]) :: (i - 1, bs_tree_list_to_list ts) :: others) st.heap_array /\ + TAKE j st.sz_array = MAP SND (REVERSE ts) /\ + j = LENGTH ts /\ j + 1 < LENGTH st.sz_array ==> + (let ts2 = add_trees R ts x; xs = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in + monad_eq_array_prop (add_to_sfx_heaps R i j x st) l2 + (st with <| sz_array := MAP SND (REVERSE ts2) ++ DROP l2 st.sz_array |>) + (array_chunks_end_in ((i, bs_tree_list_to_list ts2) :: others)) + ) + Proof - irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] - \\ irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] - \\ irule result_prop_LET \\ irule_at Any result_tup_eq_fst \\ rpt strip_tac \\ simp_tac bool_ss [] + + simp [add_to_sfx_heaps_def, add_trees_def, st_ex_ignore_bind_simp] + \\ rpt strip_tac + \\ irule monad_eq_array_prop_bindI + \\ dxrule_then (irule_at Any) (SIMP_RULE bool_ss [LET_THM] add_to_sfx_heaps_step1_eq) \\ fs [] - \\ simp [result_prop_def] -QED + \\ rw [] + \\ irule monad_eq_array_prop_bindI + \\ dxrule_then (irule_at Any) insert_into_sfx_heap_list_eq + \\ simp [LENGTH_add_tree_step1_facts] + \\ + \\ simp [ -(* Another alternative proof, via array->fun->tree directed equivalence. *) Definition extract_tree_def: From 269e4ebb7670089f157cfc4017d632c6d41d1178 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 26 Feb 2026 16:30:26 +1100 Subject: [PATCH 12/39] A better proof Finally, an approach I'm happy with. Committing then will clean this up. --- basis/heap_sort_monadicScript.sml | 633 +++++++++++++++++++++++++++++- 1 file changed, 631 insertions(+), 2 deletions(-) diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml index 8c2d35ce25..bb314ec514 100644 --- a/basis/heap_sort_monadicScript.sml +++ b/basis/heap_sort_monadicScript.sml @@ -121,7 +121,7 @@ End (* Expand the total size of a sequence of balanced suffix heaps from i to i + 1 total elements, starting with j total heaps. *) Definition add_to_sfx_heaps_step1_def: - add_to_sfx_heaps_step1 i j = do + add_to_sfx_heaps_step1 j = do merge <- if j <= 1 then return F else do @@ -146,7 +146,7 @@ End invariants. *) Definition add_to_sfx_heaps_def: add_to_sfx_heaps R i j x = do - j' <- add_to_sfx_heaps_step1 i j; + j' <- add_to_sfx_heaps_step1 j; insert_into_sfx_heap_list R i j' x; return j' od @@ -991,7 +991,9 @@ Theorem sfx_trees_to_list_eq: i < 2 EXP lg ==> ?st'. sfx_trees_to_list R i j acc st = (M_success (pull_trees R ts acc), st') Proof + Induct + \\ REWRITE_TAC [] \\ ONCE_REWRITE_TAC [sfx_trees_to_list_def] >- ( rw [] @@ -1000,6 +1002,12 @@ Proof \\ rpt (pairarg_tac \\ fs []) \\ gs [tree_len_simps, tree_balanced_height_pos] ) \\ rw [] + + \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [bs_tree_list_to_list_rec] + \\ simp [sz_array_sub_bind_eq, ADD1] + \\ gs [tree_balanced_height_pos, bs_tree_to_list_tree_rec, ADD1] + \\ gs [ + \\ simp [monad_simps] \\ drule inv_trees_less_via_exp \\ simp [GSYM MAP_DROP] @@ -1196,6 +1204,627 @@ val sort_via_sfx_trees_run_worker_v_thm = sort_via_sfx_trees_run_worker_def val sort_via_sfx_trees_v_thm = sort_via_sfx_trees_def |> translate; + + +(* Yet another attempt at equivalence. *) + + +Definition mk_st_def: + mk_st hps szs = + (<| + sz_array := REVERSE (FST szs) ++ SND szs; + heap_array := bs_tree_list_to_list (FST hps) ++ SND hps + |> : 'a state_refs) +End + +Definition encode_heap_list_def: + encode_heap_list heaps szs = + (<| + sz_array := REVERSE szs; + heap_array := bs_tree_list_to_list heaps; + |> : 'a state_refs) +End + +Definition is_last_ix_def: + is_last_ix szs i = (SUM (MAP two_exp_min_1 szs) = i + 1) +End + +Theorem is_last_ix_eq_min_1: + is_last_ix szs i ==> i = SUM (MAP two_exp_min_1 szs) - 1 +Proof + simp [is_last_ix_def] +QED + +Theorem encode_heap_list_ix_EL: + !k. is_last_ix (DROP k hps) i /\ EL k hps = (hp, n) /\ 0 < n ==> + EL i (encode_heap_list hps ovs oss).heap_array = + (case hp of Node x _ _ => x) /\ + i < LENGTH (encode_heap_list hps ovs oss).heap_array +Proof + gen_tac \\ disch_tac + \\ Cases_on `~ (k < LENGTH hps)` + >- ( + fs [is_last_ix_def, DROP_LENGTH_TOO_LONG, bs_tree_list_to_list_rec] + ) + \\ fs [] + \\ dxrule LESS_LENGTH + \\ strip_tac + \\ fs [DROP_APPEND1, DROP_LENGTH_TOO_LONG, EL_APPEND] + \\ fs [is_last_ix_def, encode_heap_list_def, bs_tree_list_to_list_def] + \\ subgoal `i = LENGTH (bs_tree_list_to_list ys2) + (LENGTH (bs_tree_to_list n hp) - 1)` + \\ Cases_on `n` \\ fs [] + \\ fs [REVERSE_APPEND, bs_tree_to_list_def, bs_tree_list_to_list_def] + \\ simp [EL_APPEND] +QED + +Theorem LENGTH_bs_tree_list_to_list_eq_SUM[local]: + LENGTH (bs_tree_list_to_list ts) = SUM (MAP two_exp_min_1 (MAP SND ts)) +Proof + simp [bs_tree_list_to_list_def, LENGTH_FLAT, MAP_MAP_o, o_DEF] + \\ simp [UNCURRY, LENGTH_bs_tree_to_list, MAP_REVERSE, SUM_REVERSE] +QED + +Theorem update_heap_array_bind: + + 0 < n /\ is_last_ix (n :: MAP SND hps) i ==> + f () (mk_st (((case hp of Node _ l r => Node x l r), n) :: hps, oths) szs) = rhs ==> + st_ex_bind (update_heap_array i x) f (mk_st ((hp, n) :: hps, oths) szs) = rhs + +Proof + + rw [] + \\ simp [ml_monadBaseTheory.st_ex_bind_def] + \\ imp_res_tac is_last_ix_eq_min_1 + \\ TOP_CASE_TAC + \\ fs [ml_monadBaseTheory.monad_eqs, fetch "-" "update_heap_array_def"] + \\ fs [mk_st_def, LENGTH_bs_tree_list_to_list_eq_SUM, is_last_ix_def] + \\ simp [bs_tree_list_to_list_rec, LUPDATE_APPEND, LENGTH_bs_tree_list_to_list_eq_SUM] + \\ Cases_on `n` \\ fs [two_exp_min_1_rec] + \\ rpt (AP_TERM_TAC ORELSE AP_THM_TAC) + \\ Cases_on `hp` \\ simp [bs_tree_to_list_def] + + \\ AP_THM_TAC + \\ AP_TERM_TAC + \\ AP_TERM_TAC + + \\ simp [bs_tree_list_to_list_rec, bs_tree_to_list_def] + \\ simp [LUPDATE_APPEND, LENGTH_bs_tree_list_to_list_eq_SUM, LENGTH_bs_tree_to_list] + \\ fs [two_exp_min_1_rec] + +print_match [] ``LENGTH (bs_tree_list_to_list _)`` + + rw [] + \\ drule encode_heap_list_ix_EL + \\ simp [ml_monadBaseTheory.st_ex_bind_def] + \\ disch_then (qspecl_then [`ovs`, `oss`] assume_tac) + \\ Cases_on `heap_array_sub i (encode_heap_list hps ovs oss)` + \\ fs [ml_monadBaseTheory.monad_eqs, fetch "-" "heap_array_sub_def"] + \\ fs [] +QED + + + +Theorem heap_array_sub_encode_bind: + ! k. + is_last_ix base_hps i /\ hps = base_hps ++ [(hp, n)] ++ oths /\ 0 < n /\ + f (case hp of (Node x _ _) => x) (encode_heap_list hps szs) = rhs ==> + + st_ex_bind (heap_array_sub i) f (mk_st ( hps szs) = rhs + +Proof + + rw [] + \\ drule encode_heap_list_ix_EL + \\ simp [ml_monadBaseTheory.st_ex_bind_def] + \\ disch_then (qspecl_then [`ovs`, `oss`] assume_tac) + \\ Cases_on `heap_array_sub i (encode_heap_list hps ovs oss)` + \\ fs [ml_monadBaseTheory.monad_eqs, fetch "-" "heap_array_sub_def"] + \\ fs [] +QED + +Theorem bind_return_eq: + st_ex_bind m return = m +Proof + cheat +QED + +Theorem update_heap_array_bind: + !f. 0 < n /\ is_last_ix (n :: MAP SND hps) i ==> + f () (mk_st (((case hp of Node _ l r => Node x l r), n) :: hps, oths) szs) = rhs ==> + st_ex_bind (update_heap_array i x) f (mk_st ((hp, n) :: hps, oths) szs) = rhs +Proof + cheat +QED + +Theorem update_heap_array_mk_st_eq: + is_last_ix (n :: MAP SND hps) i ==> + update_heap_array i x (mk_st ((Node x_dc l r, n) :: hps, oths) szs) = + (M_success (), mk_st ((Node x l r, n) :: hps, oths) szs) +Proof + cheat +QED + +Theorem bind_success_eqI: + m st = (M_success v, st2) /\ f v st2 = rhs ==> + st_ex_bind m f st = rhs +Proof + simp [ml_monadBaseTheory.st_ex_bind_def] +QED + +Theorem bind_success_rdonly_eqI = + Q.INST [`st2` |-> `st`] bind_success_eqI + +Theorem heap_array_sub_left: + is_last_ix (ht :: MAP SND hps) i /\ 1 < ht ==> + st_ex_bind (heap_array_sub (sfx_heap_left i ht)) f + (mk_st ((Node x (Node lx ll lr) r, ht) :: hps, oths) szs) = + f lx (mk_st ((Node x (Node lx ll lr) r, ht) :: hps, oths) szs) +Proof + cheat +QED + +Theorem heap_array_sub_right: + is_last_ix (ht :: MAP SND hps) i /\ 1 < ht ==> + st_ex_bind (heap_array_sub (i - 1)) f + (mk_st ((Node x l (Node rx rl rr), ht) :: hps, oths) szs) = + f rx (mk_st ((Node x l (Node rx rl rr), ht) :: hps, oths) szs) +Proof + cheat +QED + +Theorem heap_array_sub_curr: + is_last_ix (ht :: MAP SND hps) i /\ 0 < ht ==> + st_ex_bind (heap_array_sub i) f + (mk_st ((Node x l r, ht) :: hps, oths) szs) = + f x (mk_st ((Node x l r, ht) :: hps, oths) szs) +Proof + cheat +QED + +Theorem heap_array_sub_prev: + is_last_ix (ht :: MAP SND hps) i /\ 0 < LENGTH hps /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) hps ==> + st_ex_bind (heap_array_sub (i - two_exp_min_1 ht)) f + (mk_st ((t, ht) :: hps, oths) szs) = + f (case hps of (Node x _ _, _) :: _ => x) (mk_st ((t, ht) :: hps, oths) szs) +Proof + cheat +QED + +Theorem mk_st_node_split_r: + 0 < ht ==> + mk_st ((Node x l r, ht) :: hps, oths) szs = + mk_st ((r, ht - 1) :: (l, ht - 1) :: hps, x :: oths) szs +Proof + cheat +QED + +Theorem mk_st_node_split_l: + 0 < ht ==> + mk_st ((Node x l r, ht) :: hps, oths) szs = + mk_st ((l, ht - 1) :: hps, bs_tree_to_list (ht - 1) r ++ x :: oths) szs +Proof + cheat +QED + +Theorem mk_st_move_others: + mk_st ((t, ht) :: hps, oths) szs_pair = + mk_st (hps, bs_tree_to_list ht t ++ oths) szs_pair /\ + mk_st hps_pair (n :: szs, sz_oths) = + mk_st hps_pair (szs, n :: sz_oths) +Proof + cheat +QED + +Theorem is_last_ix_imps: + is_last_ix (ht :: hts) i ==> + (1 < ht ==> is_last_ix (ht - 1 :: hts) (sfx_heap_left i ht)) /\ + (1 < ht ==> is_last_ix (ht - 1 :: ht - 1 :: hts) (i - 1)) /\ + (0 < ht /\ 0 < LENGTH hts ==> is_last_ix hts (i - two_exp_min_1 ht)) +Proof + cheat +QED + +Theorem sz_array_sub_bind_eq: + i < LENGTH szs ==> + st_ex_bind (sz_array_sub i) f (mk_st hps (szs, oths)) = + f (EL (LENGTH szs - (i + 1)) szs) (mk_st hps (szs, oths)) +Proof + cheat +QED + +Theorem update_sz_array_eq: + i < LENGTH szs ==> + update_sz_array i x (mk_st hps (szs, oths)) = + (M_success (), mk_st hps (LUPDATE x (LENGTH szs - (i + 1)) szs, oths)) +Proof + cheat +QED + +Theorem insert_into_sfx_heap_eq: + ! ht hps oths t R i x st. + is_last_ix (ht :: MAP SND hps) i /\ ht > 0 /\ + tree_balanced_height ht t ==> + insert_into_sfx_heap R i ht x (mk_st ((t, ht) :: hps, oths) szs) = + (M_success (), (mk_st ((insert_tree_inv R t x, ht) :: hps, oths) szs)) +Proof + Induct + \\ simp [ADD1] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] + \\ simp [tree_balanced_height_pos] + \\ rw [] + >- ( + Cases_on `ht` \\ fs [tree_balanced_height_0] + \\ simp [insert_tree_inv_def, update_heap_array_mk_st_eq] + ) + >- ( + simp [return_bind_eq] + \\ gs [tree_balanced_height_pos] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ drule_then assume_tac is_last_ix_imps + \\ gs [] + \\ simp [heap_array_sub_left, heap_array_sub_right] + \\ rpt TOP_CASE_TAC + \\ simp [update_heap_array_mk_st_eq, st_ex_ignore_bind_simp] + >- ( + simp [st_ex_ignore_bind_simp] + \\ irule bind_success_eqI + \\ simp [update_heap_array_mk_st_eq] + \\ simp [Once mk_st_node_split_r] + \\ simp [mk_st_node_split_r] + ) + >- ( + simp [st_ex_ignore_bind_simp] + \\ irule bind_success_eqI + \\ simp [update_heap_array_mk_st_eq] + \\ simp [Once mk_st_node_split_l] + \\ simp [mk_st_node_split_l] + ) + ) +QED + +Theorem insert_into_sfx_heap_list_eq: + ! j ts R i x oths szs. + j = LENGTH ts /\ + is_last_ix (MAP SND ts) i /\ + 0 < j /\ EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> + insert_into_sfx_heap_list R i j x (mk_st (ts, oths) (MAP SND ts, szs)) = + (M_success (), mk_st (insert_trees_inv R ts x, oths) (MAP SND ts, szs)) +Proof + Induct + \\ simp [] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_list_def] + \\ rpt strip_tac + \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [] + \\ gs [ADD1, TAKE_SUM] + \\ simp [insert_trees_inv_def] + \\ rw [] + >- ( + Cases_on `t` \\ fs [] + \\ simp [sz_array_sub_bind_eq, return_bind_eq] + \\ simp [insert_into_sfx_heap_eq] + ) + \\ simp [sz_array_sub_bind_eq, return_bind_eq] + \\ simp [ADD1] + \\ simp [to_two_exp_min_1, heap_array_sub_prev] + \\ irule bind_success_rdonly_eqI + \\ qexists_tac `case t of ((Node t2x _ _, _) :: _) => + ~ R t2x x /\ ~ (case q of Node _ (Node lx _ _) _ => R t2x lx | _ => F) /\ + ~ (case q of Node _ _ (Node rx _ _) => R t2x rx | _ => F) | _ => F` + \\ conj_tac + >- ( + Cases_on `HD t` \\ Cases_on `t` \\ fs [] + \\ rw [] + >- ( + gs [tree_balanced_height_pos] + \\ simp [heap_array_sub_left, heap_array_sub_right] + \\ simp [ml_monadBaseTheory.monad_eqs] + ) + >- ( + simp [ml_monadBaseTheory.monad_eqs] + \\ gs [tree_balanced_height_pos, tree_balanced_height_eq_0] + ) + ) + \\ simp [] + \\ TOP_CASE_TAC + >- ( + gs [tree_balanced_height_pos] + \\ simp [st_ex_ignore_bind_simp] + \\ irule bind_success_eqI + \\ simp [update_heap_array_mk_st_eq] + \\ simp [mk_st_move_others] + \\ drule_then assume_tac is_last_ix_imps + \\ gs [] + \\ Cases_on `HD t` \\ Cases_on `t` \\ fs [] + \\ gs [tree_balanced_height_pos] + \\ simp [insert_trees_inv_def, mk_st_move_others] + ) + >- ( + simp [insert_into_sfx_heap_eq] + \\ Cases_on `HD t` \\ Cases_on `t` \\ fs [] + \\ gs [tree_balanced_height_pos] + ) +QED + +Theorem add_to_sfx_heaps_step1_eq: + j = LENGTH ts /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + 0 < LENGTH oth_szs ==> + ? oth_szs2. + let ts2 = add_trees_step1 ts x in + add_to_sfx_heaps_step1 j (mk_st (ts, x :: oths) (MAP SND ts, oth_szs)) = + (M_success (LENGTH ts2), mk_st (ts2, oths) (MAP SND ts2, oth_szs2)) /\ + LENGTH ts2 + LENGTH oth_szs2 = LENGTH ts + LENGTH oth_szs +Proof + rw [] + \\ simp [add_to_sfx_heaps_step1_def, add_trees_step1_def] + \\ irule_at Any bind_success_rdonly_eqI + \\ qexists_tac `case ts of (_, n1) :: (_, n2) :: _ => n1 = n2 | _ => F` + \\ simp [GSYM PULL_EXISTS] + \\ conj_tac + >- ( + every_case_tac \\ fs [] + \\ simp [sz_array_sub_bind_eq, ADD1] + \\ simp [ml_monadBaseTheory.monad_eqs] + ) + \\ TOP_CASE_TAC + >- ( + every_case_tac \\ fs [] + \\ simp [sz_array_sub_bind_eq, ADD1, st_ex_ignore_bind_simp] + \\ irule_at Any bind_success_eqI + \\ simp [update_sz_array_eq, ml_monadBaseTheory.monad_eqs] + \\ simp [ADD1, LUPDATE_DEF] + \\ simp [mk_st_node_split_r, mk_st_move_others] + \\ irule_at Any EQ_REFL + \\ simp [] + ) + >- ( + simp [st_ex_ignore_bind_simp] + \\ irule_at Any bind_success_eqI + \\ Cases_on `oth_szs` \\ fs [] + \\ simp [GSYM mk_st_move_others] + \\ simp [update_sz_array_eq, ml_monadBaseTheory.monad_eqs] + \\ simp [ADD1, LUPDATE_DEF] + \\ every_case_tac \\ fs [] + \\ simp [mk_st_move_others, bs_tree_to_list_tree_rec] + \\ REWRITE_TAC [GSYM APPEND_ASSOC, APPEND] + \\ irule_at Any EQ_REFL + \\ simp [] + ) +QED + +Theorem add_to_sfx_heaps_eq: + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + 0 < LENGTH oth_szs /\ 0 < LENGTH oths ==> + let ts2 = add_trees R ts x in + ? oth_szs2. + add_to_sfx_heaps R i j x (mk_st (ts, oths) (MAP SND ts, oth_szs)) = + (M_success (LENGTH ts2), mk_st (ts2, TL oths) (MAP SND ts2, oth_szs2)) /\ + LENGTH ts2 + LENGTH oth_szs2 = LENGTH ts + LENGTH oth_szs +Proof + rpt strip_tac + \\ qspecl_then [`HD oths`, `TL oths`] mp_tac (Q.GENL [`x`, `oths`] add_to_sfx_heaps_step1_eq) + \\ Cases_on `oths` \\ fs [] + \\ rw [] + \\ simp [add_to_sfx_heaps_def, add_trees_def] + \\ irule_at Any bind_success_eqI + \\ simp [st_ex_ignore_bind_simp] + \\ irule_at Any bind_success_eqI + \\ simp [ml_monadBaseTheory.monad_eqs, LENGTH_insert_trees_inv] + \\ dep_rewrite.DEP_REWRITE_TAC [insert_into_sfx_heap_list_eq] + \\ simp [LENGTH_add_tree_step1_facts, inv_add_tree_step1, is_last_ix_def, + GSYM LENGTH_bs_tree_list_to_list_eq_SUM] + \\ simp [MAP_SND_insert_trees_inv] + \\ irule_at Any (Q.prove (`a = b /\ c = d ==> mk_st a c = mk_st b d`, simp [])) + \\ simp [] + \\ metis_tac [insert_trees_adj_add_trees_with_inv, LENGTH_add_tree_step1_facts] +QED + +Theorem add_all_to_sfx_heaps_eq: + !xs i j ts oths oth_szs. + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ + lg + 3 <= LENGTH ts + LENGTH oth_szs /\ + i + LENGTH xs < 2 EXP lg ==> + LENGTH xs <= LENGTH oths ==> + let ts2 = build_trees R ts xs in + ? oth_szs2. + add_all_to_sfx_heaps R i j xs (mk_st (ts, oths) (MAP SND ts, oth_szs)) = + (M_success (LENGTH (bs_tree_list_to_list ts2), LENGTH ts2), + mk_st (ts2, DROP (LENGTH xs) oths) (MAP SND ts2, oth_szs2)) /\ + LENGTH ts2 + LENGTH oth_szs2 = LENGTH ts + LENGTH oth_szs +Proof + Induct + \\ simp [add_all_to_sfx_heaps_def, build_trees_def] + >- ( + simp [ml_monadBaseTheory.monad_eqs] + \\ metis_tac [] + ) + \\ rpt strip_tac + \\ irule_at Any bind_success_eqI + \\ qmatch_goalsub_abbrev_tac `add_to_sfx_heaps R i j x` + \\ mp_tac add_to_sfx_heaps_eq + \\ fs [markerTheory.Abbrev_def] + \\ impl_keep_tac + >- ( + (* exponential argument that there is space in szs array *) + drule inv_trees_less_via_exp + \\ disch_then (qspecl_then [`lg`, `1`] mp_tac) + \\ simp [GSYM MAP_DROP] + \\ disch_then dxrule + \\ simp [] + ) + \\ rw [] \\ simp [] + \\ qmatch_goalsub_abbrev_tac `mk_st (ts2, _)` + \\ first_x_assum (qspecl_then [`ts2`, `TL oths`, `oth_szs2`] mp_tac) + \\ fs [markerTheory.Abbrev_def] + \\ simp [LENGTH_to_list_add_trees, inv_add_trees] + \\ rw [] \\ simp [] + \\ Cases_on `oths` \\ fs [] + \\ irule_at Any EQ_REFL + \\ simp [] +QED + +Theorem reinsert_tree_eq: + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ((t, ht) :: ts)) /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ + 0 < ht /\ tree_balanced_height ht t ==> + reinsert_tree R i j ht (mk_st ((t, ht) :: ts, oths) (dc :: MAP SND ts, oth_szs)) = + (let ts2 = extend_trees R ts t ht in + (M_success (), mk_st (ts2, oths) (MAP SND ts2, oth_szs))) +Proof + simp [reinsert_tree_def, extend_trees_def] + \\ rw [] + \\ gs [tree_balanced_height_pos] + \\ qmatch_goalsub_abbrev_tac `mk_st (COND tree_cond _ _, _)` + \\ simp [st_ex_ignore_bind_simp] + \\ irule_at Any bind_success_eqI + \\ simp [update_sz_array_eq] + \\ dep_rewrite.DEP_REWRITE_TAC [heap_array_sub_curr] + \\ conj_asm1_tac + >- ( + fs [markerTheory.Abbrev_def] + \\ simp [is_last_ix_def, LENGTH_bs_tree_list_to_list_eq_SUM] + \\ fs [two_exp_min_1_less_rec] + ) + \\ irule_at Any bind_success_rdonly_eqI + \\ qexists_tac `~ tree_cond` + \\ conj_tac + >- ( + rw [] + \\ simp [return_bind_eq, to_two_exp_min_1] + \\ simp [heap_array_sub_prev |> Q.GEN `i` |> Q.SPEC `i - 1` + |> SIMP_RULE (srw_ss ()) [GSYM SUB_PLUS, ADD_COMM]] + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ every_case_tac \\ fs [markerTheory.Abbrev_def] + \\ gs [tree_balanced_height_pos] + ) + \\ rw [] + >- ( + simp [ADD1, LUPDATE_DEF] + \\ qmatch_goalsub_abbrev_tac `mk_st (tt :: ts, _)` + \\ qspecl_then [`j`, `tt :: ts`] (mp_tac o Q.GEN `j`) insert_into_sfx_heap_list_eq + \\ fs [markerTheory.Abbrev_def, tree_balanced_height_def, ADD1] + \\ simp [MAP_SND_insert_trees_inv] + ) + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ simp [ADD1, LUPDATE_DEF] +QED + +Theorem sfx_trees_to_list_eq: + !i j acc ts oths oth_szs. + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ + LENGTH ts = j /\ LENGTH (bs_tree_list_to_list ts) = i /\ + lg + 4 <= LENGTH ts + LENGTH oth_szs /\ + i < 2 EXP lg ==> + ?st'. sfx_trees_to_list R i j acc (mk_st (ts, oths) (MAP SND ts, oth_szs)) = + (M_success (pull_trees R ts acc), st') +Proof + Induct + \\ REWRITE_TAC [] + \\ ONCE_REWRITE_TAC [sfx_trees_to_list_def] + >- ( + rw [] + \\ Cases_on `ts` \\ fs [] + \\ simp [monad_simps, pull_trees_def] + \\ rpt (pairarg_tac \\ fs []) \\ gs [tree_len_simps, tree_balanced_height_pos] + ) + \\ rw [] + \\ subgoal `is_last_ix (MAP SND ts) i` + >- ( + fs [is_last_ix_def, ADD1] + \\ fs [LENGTH_bs_tree_list_to_list_eq_SUM] + ) + \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [bs_tree_list_to_list_rec] + \\ simp [sz_array_sub_bind_eq, ADD1] + \\ gs [tree_balanced_height_pos, bs_tree_to_list_tree_rec, ADD1] + \\ simp [heap_array_sub_curr] +(* + \\ drule inv_trees_less_via_exp + \\ simp [GSYM MAP_DROP] + \\ disch_then (qspecl_then [`lg`, `2`] mp_tac) +*) + \\ subgoal `SORTED $<= (TAKE 2 (MAP SND t)) ∧ SORTED $< (DROP 1 (MAP SND t))` + >- ( + Cases_on `TL t` \\ Cases_on `t` \\ fs [] + ) + \\ rw [] + >- ( + gs [tree_balanced_height_eq_0] + \\ simp [mk_st_move_others, bs_tree_to_list_tree_rec, pull_trees_def, + extend_trees_def] + \\ first_x_assum irule + \\ fs [bs_tree_to_list_tree_rec, MAP_DROP] + ) + >- ( + simp [st_ex_ignore_bind_simp, return_bind_eq] + \\ simp [mk_st_node_split_l] + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ dep_rewrite.DEP_REWRITE_TAC [reinsert_tree_eq] + \\ qpat_x_assum `_ = _ + 1n` (assume_tac o GSYM) + \\ simp [MAP_DROP, sfx_heap_left_def, bs_tree_list_to_list_rec, + LENGTH_bs_tree_to_list, to_two_exp_min_1] + \\ Cases_on `oth_szs` + >- ( + (* log/exp proof there is still a spare sz slot *) + gs [] + \\ drule inv_trees_less_via_exp + \\ disch_then (qspecl_then [`lg`, `2`] mp_tac) + \\ simp [] + \\ disch_then drule + \\ simp [] + ) + \\ simp [GSYM mk_st_move_others] + \\ dep_rewrite.DEP_REWRITE_TAC [reinsert_tree_eq] + \\ simp [LENGTH_extend_trees_facts, MAP_DROP, bs_tree_list_to_list_rec] + \\ conj_tac + >- ( + Cases_on `t` \\ fs [] + ) + \\ qmatch_goalsub_abbrev_tac `sfx_trees_to_list _ _ _ acc2 (mk_st (ts, oths2) (_, oth_szs2))` + \\ first_x_assum (qspecl_then [`acc2`, `ts`, `oths2`, `oth_szs2`] mp_tac) + \\ fs [markerTheory.Abbrev_def, LENGTH_extend_trees_facts, ADD1, MAP_DROP] + \\ impl_tac + >- ( + Cases_on `t` \\ fs [] + ) + \\ rw [] \\ simp [] + \\ simp [pull_trees_def] + ) +QED + +Theorem sort_via_sfx_trees_eq: + sort_via_sfx_trees R xs = another_heap_sort R xs +Proof + simp [sort_via_sfx_trees_def, another_heap_sort_def] + \\ Cases_on `xs` + >- ( + simp [build_trees_def, pull_trees_def] + ) + \\ simp [sort_via_sfx_trees_run_worker_def] + \\ simp [run_init_state_def, ml_monadBaseTheory.run_def, sort_via_sfx_trees_worker_def] + \\ simp [ml_monadBaseTheory.exc_case_eq, pairTheory.FST_EQ_EQUIV] + \\ DISJ1_TAC + \\ simp [fetch "-" "alloc_heap_array_def", fetch "-" "alloc_sz_array_def", monad_simps] + \\ qmatch_goalsub_abbrev_tac `add_all_to_sfx_heaps _ _ _ xs st` + \\ qspecl_then [`above_log2 0 (LENGTH xs + 1) 1`, `xs`, + `0`, `0`, `[]`, `st.heap_array`, `st.sz_array`] + mp_tac (add_all_to_sfx_heaps_eq |> Q.GEN `lg`) + \\ qspecl_then [`0`, `LENGTH xs + 1`, `1`] assume_tac above_log2_is_above_ind + \\ gs [markerTheory.Abbrev_def, bs_tree_list_to_list_rec, ADD1] + \\ simp [mk_st_def |> Q.SPEC `([], x)`, bs_tree_list_to_list_rec] + \\ rw [] \\ simp [] + \\ dep_rewrite.DEP_REWRITE_TAC [sfx_trees_to_list_eq |> Q.GEN `lg`] + \\ simp [build_trees_facts] + \\ simp [ADD1, bs_tree_list_to_list_rec] + \\ drule_at_then Any (irule_at Any) LESS_LESS_EQ_TRANS + \\ simp [] +QED + (* An alternative proof of equivalence. *) Definition monad_prop_def: From aed3ba8def6168bebe7559d8cf3429e4be00f3ac Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 26 Feb 2026 17:05:40 +1100 Subject: [PATCH 13/39] Reduce to the better proof --- basis/heap_sort_monadicScript.sml | 1923 +++-------------------------- 1 file changed, 145 insertions(+), 1778 deletions(-) diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml index bb314ec514..f0a00fb60f 100644 --- a/basis/heap_sort_monadicScript.sml +++ b/basis/heap_sort_monadicScript.sml @@ -233,6 +233,8 @@ End (* Part 3. Proof that this monadic encoding computes the same as the pure heap list sort implementation. *) +(* 3.1: Setup *) + Definition bs_tree_to_list_def: (bs_tree_to_list 0 t = []) /\ (bs_tree_to_list (SUC ht) t = @@ -256,7 +258,7 @@ Definition two_exp_min_1_def: two_exp_min_1 i = (2n EXP i) - 1 End -Theorem two_exp_min_1_less_rec: +Theorem two_exp_min_1_less_rec[local]: 0 < i ==> two_exp_min_1 i = two_exp_min_1 (i - 1) + two_exp_min_1 (i - 1) + 1 Proof Cases_on `i` @@ -264,26 +266,20 @@ Proof \\ rw [SUB_RIGHT_ADD] QED -Theorem two_exp_min_1_rec: +Theorem two_exp_min_1_rec[local]: two_exp_min_1 0 = 0 /\ two_exp_min_1 (SUC i) = two_exp_min_1 i + two_exp_min_1 i + 1 Proof simp [two_exp_min_1_less_rec] \\ simp [two_exp_min_1_def] QED -Theorem to_two_exp_min_1: +Theorem to_two_exp_min_1[local]: (2n EXP i) = (two_exp_min_1 i + 1) Proof rw [two_exp_min_1_def, SUB_RIGHT_ADD] QED -Theorem sfx_heap_left_two_exp_min_1: - sfx_heap_left n ht = n - (two_exp_min_1 (ht - 1)) - 1 -Proof - simp [sfx_heap_left_def, to_two_exp_min_1] -QED - -Theorem LENGTH_bs_tree_to_list: +Theorem LENGTH_bs_tree_to_list[local]: ! i t. LENGTH (bs_tree_to_list i t) = two_exp_min_1 i Proof Induct @@ -305,7 +301,7 @@ Definition tree_balanced_height_def: ) End -Theorem tree_balanced_height_0: +Theorem tree_balanced_height_0[local]: (tree_balanced_height 0 t = (t = Empty_Tree)) Proof Cases_on `t` \\ simp [tree_balanced_height_def] @@ -317,7 +313,7 @@ Proof Cases_on `t` \\ simp [tree_balanced_height_def] QED -Theorem tree_balanced_height_pos: +Theorem tree_balanced_height_pos[local]: 0 < ht ==> tree_balanced_height ht t = (?x l r. t = Node x l r /\ tree_balanced_height (ht - 1) l /\ tree_balanced_height (ht - 1) r) @@ -330,7 +326,7 @@ Definition bs_tree_list_to_list_def: FLAT (MAP (\(t, i). bs_tree_to_list i t) (REVERSE ts)) End -Theorem bs_tree_list_to_list_rec: +Theorem bs_tree_list_to_list_rec[local]: bs_tree_list_to_list (t_i :: ts) = ( bs_tree_list_to_list ts ++ bs_tree_to_list (SND t_i) (FST t_i) ) /\ @@ -346,6 +342,7 @@ Proof simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_ignore_bind_def] QED +(* Theorem monad_simps[local] = LIST_CONJ [fetch "-" "update_heap_array_def", fetch "-" "heap_array_sub_def", ml_monadBaseTheory.monad_eqs, st_ex_ignore_bind_simp, @@ -388,62 +385,7 @@ Proof \\ irule_at Any EQ_REFL \\ simp [] QED - -Theorem insert_into_sfx_heap_eq: - ! t R i ht x st. - TAKE (two_exp_min_1 ht) (DROP ((i + 1) - two_exp_min_1 ht) st.heap_array) = - bs_tree_to_list ht t /\ - i + 1 <= LENGTH st.heap_array /\ - two_exp_min_1 ht <= i + 1 /\ - ht > 0 /\ - tree_balanced_height ht t ==> - (insert_into_sfx_heap R i ht x st = - (M_success (), st with <| heap_array := TAKE ((i + 1) - two_exp_min_1 ht) st.heap_array - ++ bs_tree_to_list ht (insert_tree_inv R t x) ++ DROP (i + 1) st.heap_array |>)) -Proof - Induct - \\ simp [tree_len_simps] - \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] - \\ rpt strip_tac - \\ dxrule TAKE_DROP_last_eq_imp - \\ simp [tree_len_simps] - \\ rw [] \\ fs [] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] - >- ( - Cases_on `ht = 1` \\ fs [tree_len_simps] - \\ fs [insert_tree_inv_def, tree_len_simps] - \\ simp [monad_simps, LUPDATE_APPEND, LUPDATE_DEF] - ) - >- ( - fs [tree_balanced_height_pos] - \\ simp [monad_simps, tree_len_simps, sfx_heap_left_two_exp_min_1] - \\ simp [EL_APPEND, tree_len_simps, LEFT_ADD_DISTRIB] - \\ rpt TOP_CASE_TAC \\ simp [ml_monadBaseTheory.monad_eqs] - >- ( - simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ simp [insert_tree_inv_def, tree_len_simps] - ) - >- ( - simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ simp [tree_len_simps] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] - \\ simp_tac bool_ss [GSYM APPEND_ASSOC, APPEND] - ) - >- ( - simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ simp [tree_len_simps] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] - ) - ) -QED - -Theorem EL_APPEND_PLUS[local]: - EL (LENGTH xs + n) (xs ++ ys) = EL n ys -Proof - simp [EL_APPEND] -QED +*) Theorem two_exp_min_1_pos[local]: (0 < two_exp_min_1 r) = (0 < r) @@ -451,102 +393,6 @@ Proof Cases_on `r` \\ simp [two_exp_min_1_rec] QED -Theorem insert_into_sfx_heap_list_eq: - ! j ts R i x st. - TAKE (LENGTH (bs_tree_list_to_list ts)) - (DROP ((i + 1) - (LENGTH (bs_tree_list_to_list ts))) st.heap_array) = - bs_tree_list_to_list ts /\ - i + 1 <= LENGTH st.heap_array /\ - LENGTH (bs_tree_list_to_list ts) <= i + 1 /\ - TAKE j st.sz_array = MAP SND (REVERSE ts) /\ - j <= LENGTH st.sz_array ==> - 0 < j /\ EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> - insert_into_sfx_heap_list R i j x st = - (M_success (), st with <| heap_array := TAKE ((i + 1) - LENGTH (bs_tree_list_to_list ts)) st.heap_array - ++ bs_tree_list_to_list (insert_trees_inv R ts x) ++ DROP (i + 1) st.heap_array |>) -Proof - Induct - \\ simp [] - \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_list_def] - \\ rpt strip_tac - \\ dxrule TAKE_DROP_last_eq_imp - \\ fs [tree_len_simps] - \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [] - \\ gs [tree_len_simps] - \\ simp [insert_trees_inv_def] - \\ rw [] - >- ( - Cases_on `t` \\ fs [] - \\ Cases_on `j` \\ fs [] - \\ qpat_x_assum `TAKE _ _ = _` (assume_tac o Q.AP_TERM `\x. (EL 0 x, LENGTH x)`) - \\ gs [HD_TAKE] - \\ simp [monad_simps] - \\ drule_at (Pat `tree_balanced_height _ _`) insert_into_sfx_heap_eq - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] - ) - >- ( - gs [tree_len_simps, two_exp_min_1_pos] - \\ first_x_assum (qspec_then `t` assume_tac) - \\ qpat_x_assum `TAKE _ _ = _` (assume_tac o Q.AP_TERM `\x. (TAKE j x, EL j x, LENGTH x)`) - \\ Cases_on `j` \\ fs [] - \\ Cases_on `HD t` \\ Cases_on `t` \\ fs [] - \\ gs [ADD1, EL_TAKE, EL_APPEND, TAKE_TAKE] - \\ gs [tree_balanced_height_pos] - \\ simp [monad_simps, tree_len_simps] - \\ full_simp_tac bool_ss [to_two_exp_min_1] - \\ full_simp_tac bool_ss [GSYM ADD_ASSOC, GSYM APPEND_ASSOC, EL_APPEND_PLUS] - \\ full_simp_tac bool_ss [to_two_exp_min_1] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, - EL_APPEND1, EL_APPEND2] - \\ TOP_CASE_TAC - >- ( - simp [monad_simps] - \\ simp [tree_len_simps, sfx_heap_left_two_exp_min_1, LEFT_ADD_DISTRIB] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, - EL_APPEND1, EL_APPEND2] - \\ gs [tree_balanced_height_pos] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, - EL_APPEND1, EL_APPEND2] - \\ rw [] - >- ( - simp [monad_simps] - \\ simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, - EL_APPEND1, EL_APPEND2, LUPDATE_APPEND, LUPDATE_DEF] - ) - >- ( - irule EQ_TRANS \\ irule_at Any insert_into_sfx_heap_eq - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, - EL_APPEND1, EL_APPEND2, LUPDATE_APPEND, LUPDATE_DEF] - \\ irule_at Any EQ_REFL - \\ simp [tree_len_simps] - ) - ) - >- ( - simp [monad_simps] - \\ simp [tree_len_simps, sfx_heap_left_two_exp_min_1, LEFT_ADD_DISTRIB] - \\ TOP_CASE_TAC \\ fs [] - >- ( - Cases_on `r = 1` \\ fs [] - \\ fs [tree_len_simps] - \\ simp [monad_simps] - \\ fs [tree_len_simps] - \\ simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, - EL_APPEND1, EL_APPEND2, LUPDATE_APPEND, LUPDATE_DEF] - \\ simp_tac bool_ss [GSYM APPEND_ASSOC, APPEND] - ) - >- ( - irule EQ_TRANS \\ irule_at Any insert_into_sfx_heap_eq - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2, - EL_APPEND1, EL_APPEND2, LUPDATE_APPEND, LUPDATE_DEF] - \\ irule_at Any EQ_REFL - \\ simp [tree_len_simps] - ) - ) - ) -QED - Theorem MAP_SND_insert_trees_inv[local]: !ts. MAP SND (insert_trees_inv R ts x) = MAP SND ts Proof @@ -562,7 +408,7 @@ Theorem MAP_LENGTH_insert_trees_inv[local]: MAP (LENGTH o (\(t, n). bs_tree_to_list n t)) ts Proof qspec_then `ts` (mp_tac o Q.AP_TERM `MAP two_exp_min_1`) MAP_SND_insert_trees_inv - \\ simp [MAP_MAP_o, o_DEF, UNCURRY, tree_len_simps] + \\ simp [MAP_MAP_o, o_DEF, UNCURRY, bs_tree_list_to_list_rec, LENGTH_bs_tree_to_list] QED Theorem LENGTH_insert_trees_inv[local] = @@ -577,76 +423,8 @@ Proof \\ simp [MAP_LENGTH_insert_trees_inv] QED -Theorem TAKE_EQ_GENLIST: - !n xs. TAKE n xs = GENLIST (\i. EL i xs) (MIN n (LENGTH xs)) -Proof - Induct \\ rw [] - \\ Cases_on `xs` \\ fs [] - \\ irule EQ_SYM - \\ simp [llistTheory.GENLIST_EQ_CONS] - \\ simp [o_DEF, MIN_DEF] - \\ rw [] -QED - -Theorem add_to_sfx_heaps_step1_eq: - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> - TAKE i st.heap_array = bs_tree_list_to_list ts /\ - TAKE j st.sz_array = MAP SND (REVERSE ts) /\ - j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ - i + 1 < LENGTH st.heap_array /\ - j + 1 < LENGTH st.sz_array ==> - ?st'. - (let ts2 = add_trees_step1 ts (EL i st.heap_array); - xs = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in - add_to_sfx_heaps_step1 i j st = (M_success l2, st') /\ - TAKE (i + 1) st'.heap_array = xs /\ - TAKE l2 st'.sz_array = MAP SND (REVERSE ts2) /\ - LENGTH st'.sz_array = LENGTH st.sz_array /\ - LENGTH st'.heap_array = LENGTH st.heap_array - ) -Proof - rw [] - \\ simp [add_to_sfx_heaps_step1_def, add_trees_step1_def] - \\ Cases_on `ts` \\ fs [] - >- ( - simp [monad_simps] - \\ fs [tree_len_simps] - \\ fs [Q.SPEC `1` TAKE_EQ_GENLIST, MIN_DEF, EL_LUPDATE, HD_LUPDATE] - ) - \\ Cases_on `t` \\ fs [] - >- ( - simp [monad_simps] - \\ fs [tree_len_simps] - \\ fs [Q.SPEC `2` TAKE_EQ_GENLIST, Q.SPEC `1` TAKE_EQ_GENLIST, MIN_DEF, EL_LUPDATE, HD_LUPDATE] - \\ fs [TAKE_SUM] - ) - \\ rpt (TOP_CASE_TAC \\ fs []) - >- ( - simp [monad_simps] - \\ fs [ADD1, TAKE_SUM, EL_DROP, EL_LUPDATE] - \\ gs [Q.SPEC `2` TAKE_EQ_GENLIST, Q.SPEC `1` TAKE_EQ_GENLIST, MIN_DEF, HD_DROP, EL_DROP] - \\ simp [monad_simps] - \\ fs [tree_len_simps_no_less, HD_DROP, EL_LUPDATE] - \\ irule EQ_TRANS - \\ first_x_assum (irule_at Any) - \\ irule listTheory.LIST_EQ - \\ simp [EL_TAKE, EL_LUPDATE] - ) - >- ( - simp [monad_simps] - \\ fs [ADD1, TAKE_SUM, EL_DROP, EL_LUPDATE] - \\ gs [Q.SPEC `2` TAKE_EQ_GENLIST, Q.SPEC `1` TAKE_EQ_GENLIST, MIN_DEF, HD_DROP, EL_DROP] - \\ simp [monad_simps] - \\ fs [tree_len_simps_no_less, HD_DROP, EL_LUPDATE] - \\ qpat_x_assum `_ = MAP _ (REVERSE _)` (assume_tac o GSYM) - \\ irule listTheory.LIST_EQ - \\ rw [EL_TAKE, EL_APPEND] - \\ simp [EL_LUPDATE, EL_DROP] - \\ rw [] - \\ Cases_on `x = LENGTH t'` \\ fs [] - \\ Cases_on `x = LENGTH t' + 1` \\ fs [] - ) -QED +Theorem tree_to_list_unfold = LIST_CONJ [ + bs_tree_list_to_list_rec, bs_tree_to_list_tree_rec] Theorem LENGTH_add_tree_step1_facts[local]: 0 < LENGTH (add_trees_step1 ts x) /\ @@ -657,7 +435,7 @@ Theorem LENGTH_add_tree_step1_facts[local]: (LENGTH (add_trees_step1 ts x) = LENGTH (add_trees_step1 ts y)) = T Proof simp [add_trees_step1_def] - \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps]) + \\ rpt (TOP_CASE_TAC \\ fs [tree_to_list_unfold]) QED Theorem inv_add_tree_step1[local]: @@ -671,7 +449,7 @@ Theorem inv_add_tree_step1[local]: ) Proof simp [add_trees_step1_def] - \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps]) + \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def]) \\ rpt (pairarg_tac \\ fs []) \\ rw [] \\ fs [] @@ -685,7 +463,7 @@ Theorem insert_trees_adj_with_inv[local]: insert_trees_inv R ((Node y_dc l r, n) :: ts) x Proof simp [insert_trees_inv_def] - \\ rpt (TOP_CASE_TAC \\ fs []) \\ rw [] \\ fs [tree_len_simps] + \\ rpt (TOP_CASE_TAC \\ fs []) \\ rw [] \\ fs [tree_balanced_height_def] \\ simp [insert_tree_inv_def] QED @@ -695,58 +473,12 @@ Theorem insert_trees_adj_add_trees_with_inv[local]: insert_trees_inv R (add_trees_step1 ts y_dc) x Proof simp [add_trees_step1_def] - \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps]) + \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def]) \\ rw [] \\ irule insert_trees_adj_with_inv \\ simp [] QED -Theorem add_to_sfx_heaps_eq: - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> - TAKE i st.heap_array = bs_tree_list_to_list ts /\ - TAKE j st.sz_array = MAP SND (REVERSE ts) /\ - j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ - i + 1 < LENGTH st.heap_array /\ - j + 1 < LENGTH st.sz_array ==> - ?st'. - (let ts2 = add_trees R ts x; xs = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in - add_to_sfx_heaps R i j x st = (M_success l2, st') /\ - TAKE (i + 1) st'.heap_array = xs /\ - TAKE l2 st'.sz_array = MAP SND (REVERSE ts2) /\ - LENGTH st'.sz_array = LENGTH st.sz_array /\ - LENGTH st'.heap_array = LENGTH st.heap_array - ) -Proof - simp [add_to_sfx_heaps_def, add_trees_def] - \\ rpt strip_tac - \\ mp_tac add_to_sfx_heaps_step1_eq - \\ rpt strip_tac - \\ gs [monad_simps] - \\ irule_at Any insert_into_sfx_heap_list_eq - \\ qexists_tac `add_trees_step1 ts (EL i st.heap_array)` - \\ fs [tree_len_simps_no_less, LENGTH_insert_trees_inv] - \\ fs [LENGTH_add_tree_step1_facts, inv_add_tree_step1, LENGTH_list_of_insert_trees] - \\ rpt conj_tac - >- ( - irule LESS_EQ_TRANS - \\ MAP_FIRST (irule_at Any) (CONJUNCTS LENGTH_add_tree_step1_facts) - \\ simp [] - ) - >- ( - simp [TAKE_APPEND1, LENGTH_add_tree_step1_facts, LENGTH_list_of_insert_trees, - TAKE_LENGTH_TOO_LONG] - \\ AP_TERM_TAC - \\ irule insert_trees_adj_add_trees_with_inv - \\ simp [] - ) - >- ( - simp [MAP_REVERSE, MAP_SND_insert_trees_inv] - \\ irule (Q.prove (`a = b /\ TAKE b xs = zs/\ zs = ys ==> TAKE a xs = ys`, simp [])) - \\ first_x_assum (irule_at Any) - \\ simp [MAP_REVERSE, LENGTH_add_tree_step1_facts] - ) -QED - Theorem LENGTH_to_list_add_trees[local]: LENGTH (bs_tree_list_to_list (add_trees R ts x)) = LENGTH (bs_tree_list_to_list ts) + 1 @@ -759,7 +491,7 @@ Theorem insert_tree_inv_balance_inv[local]: tree_balanced_height ht (insert_tree_inv R t x) Proof Induct \\ simp [insert_tree_inv_def] - \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps]) + \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def]) QED Theorem insert_trees_inv_balance_inv[local]: @@ -768,7 +500,7 @@ Theorem insert_trees_inv_balance_inv[local]: Proof Induct \\ simp [pairTheory.FORALL_PROD, insert_trees_inv_def] \\ rw [] - \\ rpt (TOP_CASE_TAC \\ fs [tree_len_simps, insert_tree_inv_balance_inv]) + \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def, insert_tree_inv_balance_inv]) QED Theorem inv_add_trees[local]: @@ -792,14 +524,14 @@ Theorem sum_lengths_greater_equal_exp[local]: ((2 EXP (LENGTH ts + (n - 1))) - 1) <= LENGTH (bs_tree_list_to_list ts) Proof Induct \\ rw [] - \\ fs [tree_len_simps] + \\ fs [tree_to_list_unfold, LENGTH_bs_tree_to_list] \\ pairarg_tac \\ fs [] \\ first_x_assum (qspec_then `SUC n` mp_tac) \\ imp_res_tac SORTED_TL - \\ simp [tree_len_simps, EXP] + \\ simp [EXP] \\ Cases_on `ts` \\ fs [] >- ( - simp [tree_len_simps] + simp [tree_to_list_unfold] \\ simp [two_exp_min_1_def, LEFT_SUB_DISTRIB] \\ simp [GSYM EXP, ADD1] \\ rw [SUB_RIGHT_ADD] @@ -833,129 +565,11 @@ Proof \\ subgoal `2n ** (LENGTH ts - 1) < 2 ** lg` >- ( drule_then irule LESS_EQ_LESS_TRANS - \\ Cases_on `ts` \\ fs [tree_len_simps] + \\ Cases_on `ts` \\ fs [tree_to_list_unfold] \\ pairarg_tac \\ fs [] - \\ gs [tree_len_simps] - ) - \\ fs [] -QED - -Theorem add_all_to_sfx_heaps_eq: - !xs i j ts st. EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ - TAKE i st.heap_array = bs_tree_list_to_list ts /\ - TAKE j st.sz_array = MAP SND (REVERSE ts) /\ - j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ - i + LENGTH xs < LENGTH st.heap_array /\ - lg + 3 <= LENGTH st.sz_array /\ - i + LENGTH xs < 2 EXP lg ==> - ?st'. - (let ts2 = build_trees R ts xs; ys = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in - add_all_to_sfx_heaps R i j xs st = (M_success (LENGTH ys, l2), st') /\ - TAKE (LENGTH ys) st'.heap_array = ys /\ - TAKE l2 st'.sz_array = MAP SND (REVERSE ts2) /\ - LENGTH st'.sz_array = LENGTH st.sz_array /\ - LENGTH st'.heap_array = LENGTH st.heap_array - ) -Proof - Induct - \\ rw [add_all_to_sfx_heaps_def, build_trees_def] - \\ simp [monad_simps] - \\ fs [] - \\ qmatch_goalsub_abbrev_tac `add_to_sfx_heaps _ i j x` - \\ mp_tac add_to_sfx_heaps_eq - \\ simp [] - \\ impl_tac - >- ( - fs [markerTheory.Abbrev_def] - \\ irule inv_trees_less_via_exp - \\ simp [GSYM MAP_DROP] - \\ qexists_tac `lg` \\ simp [] + \\ gs [tree_balanced_height_pos, tree_to_list_unfold] ) - \\ rw [] - \\ last_x_assum (drule_at (Pat `_ = MAP _ _`)) - \\ gs [markerTheory.Abbrev_def, LENGTH_to_list_add_trees] - \\ simp [inv_add_trees] -QED - -Theorem TAKE_LUPDATE_CASES[local]: - !xs i j. TAKE i (LUPDATE x j xs) = (if j < i then LUPDATE x j (TAKE i xs) else TAKE i xs) -Proof - Induct \\ fs [] - \\ simp [LUPDATE_DEF] - \\ rw [] \\ fs [] - \\ Cases_on `i` \\ fs [] -QED - -Theorem reinsert_tree_eq: - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - TAKE i st.heap_array = bs_tree_list_to_list ts ++ bs_tree_to_list ht t /\ - TAKE j st.sz_array = MAP SND (REVERSE ts) /\ - j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts ++ bs_tree_to_list ht t) /\ - i < LENGTH st.heap_array /\ - j + 1 < LENGTH st.sz_array /\ - 0 < ht /\ tree_balanced_height ht t ==> - ?st'. - (let ts2 = extend_trees R ts t ht; ys = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in - reinsert_tree R i j ht st = (M_success (), st') /\ - TAKE (LENGTH ys) st'.heap_array = ys /\ - DROP (LENGTH ys) st'.heap_array = DROP (LENGTH ys) st.heap_array /\ - TAKE l2 st'.sz_array = MAP SND (REVERSE ts2) /\ - LENGTH st'.sz_array = LENGTH st.sz_array /\ - LENGTH st'.heap_array = LENGTH st.heap_array - ) -Proof - rw [reinsert_tree_def] - \\ simp [monad_simps] - \\ qmatch_goalsub_abbrev_tac `(if C then check else return F) st_upd` - \\ subgoal `(if C then check else return F) st_upd = - (M_success (case (t, ts) of (Node x _ _, ((Node y _ _, _) :: _)) => ~ R y x | _ => F), st_upd)` - >- ( - fs [markerTheory.Abbrev_def] - \\ gs [tree_balanced_height_pos] - \\ gs [TAKE_SUM, tree_len_simps, listTheory.APPEND_11_LENGTH, - Q.SPECL [`two_exp_min_1 i`, `two_exp_min_1 i`] TAKE_SUM |> REWRITE_RULE [GSYM TIMES2]] - \\ Cases_on `ts` \\ fs [monad_simps] - \\ pairarg_tac \\ fs [] - \\ gs [tree_balanced_height_pos, tree_len_simps] - \\ gs [TAKE_SUM, tree_len_simps, listTheory.APPEND_11_LENGTH, - Q.SPECL [`two_exp_min_1 i`, `two_exp_min_1 i`] TAKE_SUM |> REWRITE_RULE [GSYM TIMES2]] - \\ fs [EL_DROP, tree_len_simps, LEFT_ADD_DISTRIB, to_two_exp_min_1] - ) - >- ( - fs [] - \\ qmatch_goalsub_abbrev_tac `(if C2 then _ else return _)` - \\ subgoal `extend_trees R ts t ht = (if C2 then insert_trees_inv R ((t,ht) :: ts) - (case t of Node x _ _ => x) else (t, ht) :: ts)` - >- ( - fs [markerTheory.Abbrev_def] - \\ simp [extend_trees_def] - \\ gs [tree_balanced_height_pos] - \\ BasicProvers.EVERY_CASE_TAC \\ fs [] - ) - \\ rw [] - >- ( - irule_at Any insert_into_sfx_heap_list_eq - \\ qexists_tac `(t, ht) :: ts` - \\ fs [tree_len_simps, markerTheory.Abbrev_def, TAKE_SUM, EL_LUPDATE] - \\ fs [tree_len_simps, LENGTH_list_of_insert_trees, LENGTH_insert_trees_inv, - TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] - \\ simp [MAP_REVERSE, MAP_SND_insert_trees_inv] - \\ simp [ADD1, TAKE_SUM, EL_LUPDATE] - \\ simp [TAKE_LUPDATE_CASES, MAP_REVERSE] - \\ gs [tree_balanced_height_pos] - \\ gs [TAKE_SUM, tree_len_simps, listTheory.APPEND_11_LENGTH, - Q.SPECL [`two_exp_min_1 i`, `two_exp_min_1 i`] TAKE_SUM |> REWRITE_RULE [GSYM TIMES2]] - \\ fs [EL_DROP] - ) - >- ( - simp [monad_simps] - \\ fs [markerTheory.Abbrev_def, tree_len_simps] - \\ simp [ADD1, TAKE_SUM, EL_LUPDATE] - \\ simp [TAKE_LUPDATE_CASES, MAP_REVERSE] - ) - ) QED Theorem LENGTH_extend_trees_facts[local]: @@ -971,99 +585,11 @@ Theorem LENGTH_extend_trees_facts[local]: ) Proof rw [extend_trees_def] - \\ fs [tree_len_simps, tree_balanced_height_pos] + \\ fs [tree_to_list_unfold, tree_balanced_height_pos] \\ BasicProvers.EVERY_CASE_TAC \\ fs [] \\ simp [LENGTH_insert_trees_inv, MAP_SND_insert_trees_inv, - LENGTH_list_of_insert_trees, tree_len_simps, insert_trees_inv_balance_inv] -QED - -Theorem TAKE_2_times_two_exp[local] = - Q.SPECL [`two_exp_min_1 i`, `two_exp_min_1 i`] TAKE_SUM |> REWRITE_RULE [GSYM TIMES2] - -Theorem sfx_trees_to_list_eq: - !i j acc ts st. EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ - TAKE i st.heap_array = bs_tree_list_to_list ts /\ - TAKE j st.sz_array = MAP SND (REVERSE ts) /\ - j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ - i < LENGTH st.heap_array /\ - lg + 4 <= LENGTH st.sz_array /\ - i < 2 EXP lg ==> - ?st'. sfx_trees_to_list R i j acc st = (M_success (pull_trees R ts acc), st') -Proof - - Induct - \\ REWRITE_TAC [] - \\ ONCE_REWRITE_TAC [sfx_trees_to_list_def] - >- ( - rw [] - \\ Cases_on `ts` \\ fs [] - \\ simp [monad_simps, pull_trees_def] - \\ rpt (pairarg_tac \\ fs []) \\ gs [tree_len_simps, tree_balanced_height_pos] - ) - \\ rw [] - - \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [bs_tree_list_to_list_rec] - \\ simp [sz_array_sub_bind_eq, ADD1] - \\ gs [tree_balanced_height_pos, bs_tree_to_list_tree_rec, ADD1] - \\ gs [ - - \\ simp [monad_simps] - \\ drule inv_trees_less_via_exp - \\ simp [GSYM MAP_DROP] - \\ disch_then (qspecl_then [`lg`, `2`, `LENGTH st.sz_array`] mp_tac) - \\ rw [] - >- ( - Cases_on `ts` \\ fs [tree_len_simps] - \\ pairarg_tac \\ fs [] - \\ gs [tree_len_simps, tree_balanced_height_pos] - \\ gs [ADD1, TAKE_SUM] - \\ Cases_on `n = 1` \\ fs [tree_len_simps] - \\ simp [pull_trees_def, extend_trees_def] - \\ fs [HD_DROP] - \\ first_x_assum irule - \\ simp [] - \\ Cases_on `t` \\ fs [] - \\ imp_res_tac SORTED_TL - \\ simp [] - \\ qmatch_goalsub_abbrev_tac `TAKE 1 tl_ts` - \\ Cases_on `tl_ts` \\ fs [] - ) - >- ( - simp [monad_simps, sfx_heap_left_two_exp_min_1] - \\ qabbrev_tac `ts_case = ts` - \\ Cases_on `ts_case` \\ fs [tree_len_simps_no_less] - \\ qabbrev_tac `orig_ts = ts` - \\ pairarg_tac \\ fs [] - \\ gs [tree_len_simps_no_less, tree_balanced_height_pos] - \\ gs [ADD1, TAKE_SUM, tree_len_simps_no_less, APPEND_11_LENGTH, TAKE_2_times_two_exp] - \\ qmatch_goalsub_abbrev_tac `reinsert_tree _ i_l j_l ht_l _` - \\ qspecl_then [`i_l`, `j_l`, `ht_l`, `st`, `TL orig_ts`, `l`] - mp_tac (Q.GENL [`i`, `j`, `ht`, `st`, `ts`, `t`] reinsert_tree_eq) - \\ qspec_then `n` assume_tac (GEN_ALL two_exp_min_1_less_rec) - \\ gs [markerTheory.Abbrev_def, tree_len_simps_no_less, LEFT_ADD_DISTRIB] - \\ gs [ADD1, TAKE_SUM, tree_len_simps_no_less, APPEND_11_LENGTH, TAKE_2_times_two_exp] - \\ strip_tac - \\ simp [] - \\ qspecl_then [`i`, `j_l + 1`, `ht_l`, `st'`, `extend_trees R (TL orig_ts) l ht_l`, `r`] - mp_tac (Q.GENL [`i`, `j`, `ht`, `st`, `ts`, `t`] reinsert_tree_eq) - \\ gs [tree_len_simps_no_less, LEFT_ADD_DISTRIB, LENGTH_extend_trees_facts, MAP_REVERSE] - \\ full_simp_tac bool_ss [ADD_ASSOC] - \\ gs [ADD1, TAKE_SUM, tree_len_simps_no_less, APPEND_11_LENGTH, TAKE_2_times_two_exp] - \\ fs [DROP_DROP] - \\ strip_tac - \\ simp [pull_trees_def] - \\ qmatch_goalsub_abbrev_tac `pull_trees _ next_ts next_acc` - \\ first_x_assum (qspecl_then [`next_acc`, `next_ts`] mp_tac) - \\ fs [markerTheory.Abbrev_def, EL_DROP, tree_len_simps, - LENGTH_extend_trees_facts, LEFT_ADD_DISTRIB] - \\ disch_then irule - \\ gs [ADD1, TAKE_SUM, tree_len_simps_no_less, APPEND_11_LENGTH, TAKE_2_times_two_exp] - \\ simp [EL_DROP, MAP_DROP, LENGTH_extend_trees_facts] - \\ gs [tree_len_simps, TAKE_SUM, EL_DROP, TAKE_2_times_two_exp] - \\ qmatch_goalsub_abbrev_tac `SORTED _ (_ :: tl_ts)` - \\ Cases_on `tl_ts` \\ fs [] - ) + LENGTH_list_of_insert_trees, tree_to_list_unfold, tree_balanced_height_def, + insert_trees_inv_balance_inv] QED Theorem above_log2_is_above_ind[local]: @@ -1085,275 +611,67 @@ Theorem build_trees_facts[local]: SORTED $< (MAP SND (DROP 1 (build_trees R ts xs))) /\ SORTED $<= (TAKE 2 (MAP SND (build_trees R ts xs)))) Proof - Induct \\ simp [tree_len_simps, build_trees_def] + Induct \\ simp [tree_to_list_unfold, build_trees_def] \\ rw [] \\ simp [inv_add_trees, LENGTH_to_list_add_trees] \\ fs [IMP_CONJ_THM, FORALL_AND_THM] QED -Theorem sort_via_sfx_trees_eq: - sort_via_sfx_trees R xs = another_heap_sort R xs -Proof - simp [sort_via_sfx_trees_def, another_heap_sort_def] - \\ TOP_CASE_TAC \\ simp [] - >- ( - simp [build_trees_def, pull_trees_def] - ) - >- ( - simp [sort_via_sfx_trees_run_worker_def, run_init_state_def, - ml_monadBaseTheory.run_def, sort_via_sfx_trees_worker_def] - \\ simp [ml_monadBaseTheory.exc_case_eq, pairTheory.FST_EQ_EQUIV] - \\ DISJ1_TAC - \\ simp [fetch "-" "alloc_heap_array_def", fetch "-" "alloc_sz_array_def", monad_simps] - \\ qmatch_goalsub_abbrev_tac `add_all_to_sfx_heaps _ _ _ xs st` - \\ qspecl_then [`above_log2 0 (LENGTH xs + 1) 1`, `xs`, `0`, `0`, `[]`, `st`] - mp_tac (add_all_to_sfx_heaps_eq |> Q.GEN `lg`) - \\ fs [tree_len_simps, markerTheory.Abbrev_def] - \\ qspecl_then [`0`, `LENGTH xs + 1`, `1`] assume_tac above_log2_is_above_ind - \\ gs [LESS_LESS_EQ_TRANS] - \\ strip_tac - \\ simp [] - \\ irule sfx_trees_to_list_eq - \\ simp [build_trees_facts, tree_len_simps] - \\ irule_at Any (Q.prove (`(x + 1n) + 4 = y ==> x + 4 <= y`, simp [])) - \\ simp [] - ) -QED - -(* Part 4: translation of the sfx variants. *) +(* 3.2: State/Heap-list equivalence setup. *) -fun fix_state_type thm = let - val types_in_thm = thm |> concl |> all_atoms - |> HOLset.listItems |> map type_of - |> map (fn t => fst (strip_fun t) @ [snd (strip_fun t)]) - |> List.concat - val state_matching_types = types_in_thm - |> filter (can (match_type state_type)) - |> HOLset.fromList Type.compare |> HOLset.listItems - val substs = map (fn t => match_type t state_type) state_matching_types - in case substs of - [] => thm - | [s] => INST_TYPE s thm - | _ => failwith "fix_state_type: multiple!" - end +Definition mk_st_def: + mk_st hps szs = + (<| + sz_array := REVERSE (FST szs) ++ SND szs; + heap_array := bs_tree_list_to_list (FST hps) ++ SND hps + |> : 'a state_refs) +End -Definition comp_exp_def: - comp_exp m x 0 = x /\ - comp_exp (m : num) x (SUC i) = comp_exp m (x * m) i +Definition is_last_ix_def: + is_last_ix szs i = (SUM (MAP two_exp_min_1 szs) = i + 1) End -Theorem comp_exp_eq_ind[local]: - !i x. comp_exp m x i = x * (m EXP i) +Theorem is_last_ix_eq_min_1: + is_last_ix szs i ==> i = SUM (MAP two_exp_min_1 szs) - 1 Proof - Induct \\ simp [comp_exp_def, EXP] + simp [is_last_ix_def] QED -Theorem use_comp_exp: - (m EXP i) = comp_exp m 1 i +Theorem bind_success_eqI: + m st = (M_success v, st2) /\ f v st2 = rhs ==> + st_ex_bind m f st = rhs Proof - simp [comp_exp_eq_ind] + simp [ml_monadBaseTheory.st_ex_bind_def] QED -val comp_exp_v_thm = comp_exp_def |> translate; - -val sfx_heap_left_v_thm = sfx_heap_left_def - |> REWRITE_RULE [use_comp_exp] |> translate; - -val insert_into_sfx_heap_v_thm = insert_into_sfx_heap_def - |> fix_state_type |> m_translate; - -val insert_into_sfx_heap_list_v_thm = insert_into_sfx_heap_list_def - |> REWRITE_RULE [use_comp_exp] - |> fix_state_type |> m_translate; +Theorem bind_success_rdonly_eqI = + Q.INST [`st2` |-> `st`] bind_success_eqI -Theorem bind_assoc[local]: - st_ex_bind (st_ex_bind f g) h = do - x <- f; - y <- g x; - h y - od +Theorem mk_st_node_split_r: + 0 < ht ==> + mk_st ((Node x l r, ht) :: hps, oths) szs = + mk_st ((r, ht - 1) :: (l, ht - 1) :: hps, x :: oths) szs Proof - rw [ml_monadBaseTheory.st_ex_bind_def, FUN_EQ_THM] - \\ rpt (TOP_CASE_TAC \\ fs []) + cheat QED -val add_to_sfx_heaps_v_thm = add_to_sfx_heaps_def - |> SIMP_RULE bool_ss [add_to_sfx_heaps_step1_def, bind_assoc] - |> fix_state_type |> m_translate; - -val add_all_to_sfx_heaps_v_thm = add_all_to_sfx_heaps_def - |> fix_state_type |> m_translate; - -val reinsert_tree_v_thm = reinsert_tree_def - |> REWRITE_RULE [use_comp_exp] - |> fix_state_type |> m_translate; - -val sfx_trees_to_list_v_thm = sfx_trees_to_list_def - |> fix_state_type |> m_translate; - -val length_v_thm = LENGTH |> translate; - -val above_log2_v_thm = above_log2_def |> translate; - -val sort_via_sfx_trees_worker_v_thm = sort_via_sfx_trees_worker_def - |> fix_state_type |> m_translate; - -val sort_via_sfx_trees_run_worker_v_thm = sort_via_sfx_trees_run_worker_def - |> fix_state_type |> m_translate_run; - -val sort_via_sfx_trees_v_thm = sort_via_sfx_trees_def |> translate; - - - - -(* Yet another attempt at equivalence. *) - - -Definition mk_st_def: - mk_st hps szs = - (<| - sz_array := REVERSE (FST szs) ++ SND szs; - heap_array := bs_tree_list_to_list (FST hps) ++ SND hps - |> : 'a state_refs) -End - -Definition encode_heap_list_def: - encode_heap_list heaps szs = - (<| - sz_array := REVERSE szs; - heap_array := bs_tree_list_to_list heaps; - |> : 'a state_refs) -End - -Definition is_last_ix_def: - is_last_ix szs i = (SUM (MAP two_exp_min_1 szs) = i + 1) -End - -Theorem is_last_ix_eq_min_1: - is_last_ix szs i ==> i = SUM (MAP two_exp_min_1 szs) - 1 -Proof - simp [is_last_ix_def] -QED - -Theorem encode_heap_list_ix_EL: - !k. is_last_ix (DROP k hps) i /\ EL k hps = (hp, n) /\ 0 < n ==> - EL i (encode_heap_list hps ovs oss).heap_array = - (case hp of Node x _ _ => x) /\ - i < LENGTH (encode_heap_list hps ovs oss).heap_array -Proof - gen_tac \\ disch_tac - \\ Cases_on `~ (k < LENGTH hps)` - >- ( - fs [is_last_ix_def, DROP_LENGTH_TOO_LONG, bs_tree_list_to_list_rec] - ) - \\ fs [] - \\ dxrule LESS_LENGTH - \\ strip_tac - \\ fs [DROP_APPEND1, DROP_LENGTH_TOO_LONG, EL_APPEND] - \\ fs [is_last_ix_def, encode_heap_list_def, bs_tree_list_to_list_def] - \\ subgoal `i = LENGTH (bs_tree_list_to_list ys2) + (LENGTH (bs_tree_to_list n hp) - 1)` - \\ Cases_on `n` \\ fs [] - \\ fs [REVERSE_APPEND, bs_tree_to_list_def, bs_tree_list_to_list_def] - \\ simp [EL_APPEND] -QED - -Theorem LENGTH_bs_tree_list_to_list_eq_SUM[local]: - LENGTH (bs_tree_list_to_list ts) = SUM (MAP two_exp_min_1 (MAP SND ts)) -Proof - simp [bs_tree_list_to_list_def, LENGTH_FLAT, MAP_MAP_o, o_DEF] - \\ simp [UNCURRY, LENGTH_bs_tree_to_list, MAP_REVERSE, SUM_REVERSE] -QED - -Theorem update_heap_array_bind: - - 0 < n /\ is_last_ix (n :: MAP SND hps) i ==> - f () (mk_st (((case hp of Node _ l r => Node x l r), n) :: hps, oths) szs) = rhs ==> - st_ex_bind (update_heap_array i x) f (mk_st ((hp, n) :: hps, oths) szs) = rhs - -Proof - - rw [] - \\ simp [ml_monadBaseTheory.st_ex_bind_def] - \\ imp_res_tac is_last_ix_eq_min_1 - \\ TOP_CASE_TAC - \\ fs [ml_monadBaseTheory.monad_eqs, fetch "-" "update_heap_array_def"] - \\ fs [mk_st_def, LENGTH_bs_tree_list_to_list_eq_SUM, is_last_ix_def] - \\ simp [bs_tree_list_to_list_rec, LUPDATE_APPEND, LENGTH_bs_tree_list_to_list_eq_SUM] - \\ Cases_on `n` \\ fs [two_exp_min_1_rec] - \\ rpt (AP_TERM_TAC ORELSE AP_THM_TAC) - \\ Cases_on `hp` \\ simp [bs_tree_to_list_def] - - \\ AP_THM_TAC - \\ AP_TERM_TAC - \\ AP_TERM_TAC - - \\ simp [bs_tree_list_to_list_rec, bs_tree_to_list_def] - \\ simp [LUPDATE_APPEND, LENGTH_bs_tree_list_to_list_eq_SUM, LENGTH_bs_tree_to_list] - \\ fs [two_exp_min_1_rec] - -print_match [] ``LENGTH (bs_tree_list_to_list _)`` - - rw [] - \\ drule encode_heap_list_ix_EL - \\ simp [ml_monadBaseTheory.st_ex_bind_def] - \\ disch_then (qspecl_then [`ovs`, `oss`] assume_tac) - \\ Cases_on `heap_array_sub i (encode_heap_list hps ovs oss)` - \\ fs [ml_monadBaseTheory.monad_eqs, fetch "-" "heap_array_sub_def"] - \\ fs [] -QED - - - -Theorem heap_array_sub_encode_bind: - ! k. - is_last_ix base_hps i /\ hps = base_hps ++ [(hp, n)] ++ oths /\ 0 < n /\ - f (case hp of (Node x _ _) => x) (encode_heap_list hps szs) = rhs ==> - - st_ex_bind (heap_array_sub i) f (mk_st ( hps szs) = rhs - -Proof - - rw [] - \\ drule encode_heap_list_ix_EL - \\ simp [ml_monadBaseTheory.st_ex_bind_def] - \\ disch_then (qspecl_then [`ovs`, `oss`] assume_tac) - \\ Cases_on `heap_array_sub i (encode_heap_list hps ovs oss)` - \\ fs [ml_monadBaseTheory.monad_eqs, fetch "-" "heap_array_sub_def"] - \\ fs [] -QED - -Theorem bind_return_eq: - st_ex_bind m return = m -Proof - cheat -QED - -Theorem update_heap_array_bind: - !f. 0 < n /\ is_last_ix (n :: MAP SND hps) i ==> - f () (mk_st (((case hp of Node _ l r => Node x l r), n) :: hps, oths) szs) = rhs ==> - st_ex_bind (update_heap_array i x) f (mk_st ((hp, n) :: hps, oths) szs) = rhs +Theorem mk_st_node_split_l: + 0 < ht ==> + mk_st ((Node x l r, ht) :: hps, oths) szs = + mk_st ((l, ht - 1) :: hps, bs_tree_to_list (ht - 1) r ++ x :: oths) szs Proof cheat QED -Theorem update_heap_array_mk_st_eq: - is_last_ix (n :: MAP SND hps) i ==> - update_heap_array i x (mk_st ((Node x_dc l r, n) :: hps, oths) szs) = - (M_success (), mk_st ((Node x l r, n) :: hps, oths) szs) +Theorem mk_st_move_others: + mk_st ((t, ht) :: hps, oths) szs_pair = + mk_st (hps, bs_tree_to_list ht t ++ oths) szs_pair /\ + mk_st hps_pair (n :: szs, sz_oths) = + mk_st hps_pair (szs, n :: sz_oths) Proof cheat QED -Theorem bind_success_eqI: - m st = (M_success v, st2) /\ f v st2 = rhs ==> - st_ex_bind m f st = rhs -Proof - simp [ml_monadBaseTheory.st_ex_bind_def] -QED - -Theorem bind_success_rdonly_eqI = - Q.INST [`st2` |-> `st`] bind_success_eqI - Theorem heap_array_sub_left: is_last_ix (ht :: MAP SND hps) i /\ 1 < ht ==> st_ex_bind (heap_array_sub (sfx_heap_left i ht)) f @@ -1391,38 +709,31 @@ Proof cheat QED -Theorem mk_st_node_split_r: - 0 < ht ==> - mk_st ((Node x l r, ht) :: hps, oths) szs = - mk_st ((r, ht - 1) :: (l, ht - 1) :: hps, x :: oths) szs -Proof - cheat -QED - -Theorem mk_st_node_split_l: - 0 < ht ==> - mk_st ((Node x l r, ht) :: hps, oths) szs = - mk_st ((l, ht - 1) :: hps, bs_tree_to_list (ht - 1) r ++ x :: oths) szs +Theorem update_heap_array_mk_st_eq: + is_last_ix (n :: MAP SND hps) i ==> + update_heap_array i x (mk_st ((Node x_dc l r, n) :: hps, oths) szs) = + (M_success (), mk_st ((Node x l r, n) :: hps, oths) szs) Proof cheat QED -Theorem mk_st_move_others: - mk_st ((t, ht) :: hps, oths) szs_pair = - mk_st (hps, bs_tree_to_list ht t ++ oths) szs_pair /\ - mk_st hps_pair (n :: szs, sz_oths) = - mk_st hps_pair (szs, n :: sz_oths) +Theorem return_bind_eq: + st_ex_bind (return v) f = f v Proof - cheat + simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] QED Theorem is_last_ix_imps: is_last_ix (ht :: hts) i ==> (1 < ht ==> is_last_ix (ht - 1 :: hts) (sfx_heap_left i ht)) /\ (1 < ht ==> is_last_ix (ht - 1 :: ht - 1 :: hts) (i - 1)) /\ - (0 < ht /\ 0 < LENGTH hts ==> is_last_ix hts (i - two_exp_min_1 ht)) + (0 < ht /\ 0 < LENGTH hts /\ 0 < HD hts ==> is_last_ix hts (i - two_exp_min_1 ht)) Proof - cheat + fs [is_last_ix_def] + \\ rw [] + \\ fs [sfx_heap_left_def, to_two_exp_min_1, two_exp_min_1_less_rec] + \\ Cases_on `hts` \\ fs [] + \\ fs [sfx_heap_left_def, to_two_exp_min_1, two_exp_min_1_less_rec] QED Theorem sz_array_sub_bind_eq: @@ -1441,6 +752,15 @@ Proof cheat QED +Theorem LENGTH_bs_tree_list_to_list_eq_SUM[local]: + LENGTH (bs_tree_list_to_list ts) = SUM (MAP two_exp_min_1 (MAP SND ts)) +Proof + simp [bs_tree_list_to_list_def, LENGTH_FLAT, MAP_MAP_o, o_DEF] + \\ simp [UNCURRY, LENGTH_bs_tree_to_list, MAP_REVERSE, SUM_REVERSE] +QED + +(* 3.3: Proofs of equivalence *) + Theorem insert_into_sfx_heap_eq: ! ht hps oths t R i x st. is_last_ix (ht :: MAP SND hps) i /\ ht > 0 /\ @@ -1730,8 +1050,8 @@ Proof >- ( rw [] \\ Cases_on `ts` \\ fs [] - \\ simp [monad_simps, pull_trees_def] - \\ rpt (pairarg_tac \\ fs []) \\ gs [tree_len_simps, tree_balanced_height_pos] + \\ simp [ml_monadBaseTheory.monad_eqs, pull_trees_def] + \\ rpt (pairarg_tac \\ fs []) \\ gs [tree_to_list_unfold, tree_balanced_height_pos] ) \\ rw [] \\ subgoal `is_last_ix (MAP SND ts) i` @@ -1809,7 +1129,8 @@ Proof \\ simp [run_init_state_def, ml_monadBaseTheory.run_def, sort_via_sfx_trees_worker_def] \\ simp [ml_monadBaseTheory.exc_case_eq, pairTheory.FST_EQ_EQUIV] \\ DISJ1_TAC - \\ simp [fetch "-" "alloc_heap_array_def", fetch "-" "alloc_sz_array_def", monad_simps] + \\ simp [fetch "-" "alloc_heap_array_def", fetch "-" "alloc_sz_array_def", + ml_monadBaseTheory.monad_eqs, st_ex_ignore_bind_simp] \\ qmatch_goalsub_abbrev_tac `add_all_to_sfx_heaps _ _ _ xs st` \\ qspecl_then [`above_log2 0 (LENGTH xs + 1) 1`, `xs`, `0`, `0`, `[]`, `st.heap_array`, `st.sz_array`] @@ -1825,1041 +1146,87 @@ Proof \\ simp [] QED -(* An alternative proof of equivalence. *) - -Definition monad_prop_def: - monad_prop s m Q = (case m s of (M_success v, s') => Q v s' | _ => F) -End - -Theorem monad_prop_bind: - monad_prop s f P /\ (! x s'. P x s' ==> monad_prop s' (g x) Q) ==> - monad_prop s (st_ex_bind f g) Q -Proof - simp [monad_prop_def, ml_monadBaseTheory.st_ex_bind_def] - \\ BasicProvers.EVERY_CASE_TAC \\ fs [] -QED - -Theorem monad_prop_exI: - (? x s'. m s = (M_success x, s') /\ Q x s') ==> - monad_prop s m Q -Proof - rw [monad_prop_def] \\ simp [] -QED - -Theorem monad_prop_postcond_imp: - monad_prop s m P /\ (!x s'. P x s' ==> Q x s') ==> - monad_prop s m Q -Proof - rw [monad_prop_def] - \\ BasicProvers.EVERY_CASE_TAC \\ fs [] -QED - -Theorem monad_prop_return: - Q x s ==> monad_prop s (return x) Q -Proof - simp [ml_monadBaseTheory.st_ex_return_def, monad_prop_def] -QED +(* Part 4: translation of the sfx variants. *) -Theorem return_bind_eq: - st_ex_bind (return v) f = f v -Proof - simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] -QED +fun fix_state_type thm = let + val types_in_thm = thm |> concl |> all_atoms + |> HOLset.listItems |> map type_of + |> map (fn t => fst (strip_fun t) @ [snd (strip_fun t)]) + |> List.concat + val state_matching_types = types_in_thm + |> filter (can (match_type state_type)) + |> HOLset.fromList Type.compare |> HOLset.listItems + val substs = map (fn t => match_type t state_type) state_matching_types + in case substs of + [] => thm + | [s] => INST_TYPE s thm + | _ => failwith "fix_state_type: multiple!" + end -Definition array_eqs_def: - array_eqs bg arr = (FINITE_BAG bg /\ BAG_ALL_DISTINCT (BAG_IMAGE FST bg) /\ - (!i x. BAG_IN (i, x) bg ==> i < LENGTH arr /\ EL i arr = x)) +Definition comp_exp_def: + comp_exp m x 0 = x /\ + comp_exp (m : num) x (SUC i) = comp_exp m (x * m) i End -Theorem array_eqs_insert: - array_eqs (BAG_INSERT (i, x) bg) arr = - (array_eqs bg arr /\ i < LENGTH arr /\ EL i arr = x /\ (~ BAG_IN i (BAG_IMAGE FST bg))) +Theorem comp_exp_eq_ind[local]: + !i x. comp_exp m x i = x * (m EXP i) Proof - simp [array_eqs_def] - \\ EQ_TAC \\ rw [] \\ fs [] - \\ gs [BAG_ALL_DISTINCT_THM, BAG_IMAGE_FINITE_INSERT] - \\ fs [DISJ_IMP_THM, FORALL_AND_THM] - \\ res_tac \\ fs [] + Induct \\ simp [comp_exp_def, EXP] QED -Theorem array_eqs_LUPDATE: - array_eqs bg arr /\ (~ BAG_IN i (BAG_IMAGE FST bg)) ==> - array_eqs bg (LUPDATE x i arr) +Theorem use_comp_exp: + (m EXP i) = comp_exp m 1 i Proof - rw [array_eqs_def] - \\ rw [EL_LUPDATE] - \\ gs [bagTheory.BAG_IN_FINITE_BAG_IMAGE] - \\ metis_tac [] + simp [comp_exp_eq_ind] QED -Theorem heap_array_sub_prop: - i < LENGTH s.heap_array ==> - monad_prop s (heap_array_sub i) - (\rv s'. rv = EL i s.heap_array /\ s' = s) -Proof - rw [] - \\ irule monad_prop_exI - \\ simp [monad_simps] -QED +val comp_exp_v_thm = comp_exp_def |> translate; -Theorem update_heap_array_prop: - i < LENGTH s.heap_array ==> - monad_prop s (update_heap_array i x) - (\rv s'. s' = (s with <| heap_array := LUPDATE x i s.heap_array |>)) -Proof - rw [] - \\ irule monad_prop_exI - \\ simp [monad_simps] -QED +val sfx_heap_left_v_thm = sfx_heap_left_def + |> REWRITE_RULE [use_comp_exp] |> translate; -Definition list_mappings_from_def: - list_mappings_from xs i = LIST_TO_BAG (MAPi (\j x. (i + j, x)) xs) -End +val insert_into_sfx_heap_v_thm = insert_into_sfx_heap_def + |> fix_state_type |> m_translate; -Theorem list_mappings_from_append: - list_mappings_from (xs ++ ys) i = - BAG_UNION (list_mappings_from xs i) (list_mappings_from ys (i + LENGTH xs)) -Proof - simp [list_mappings_from_def, MAPi_APPEND, LIST_TO_BAG_APPEND, o_DEF] -QED +val insert_into_sfx_heap_list_v_thm = insert_into_sfx_heap_list_def + |> REWRITE_RULE [use_comp_exp] + |> fix_state_type |> m_translate; -Theorem list_mappings_from_bases: - list_mappings_from [x] i = {|(i, x)|} /\ - list_mappings_from [] j = {||} +Theorem bind_assoc[local]: + st_ex_bind (st_ex_bind f g) h = do + x <- f; + y <- g x; + h y + od Proof - simp [list_mappings_from_def] + rw [ml_monadBaseTheory.st_ex_bind_def, FUN_EQ_THM] + \\ rpt (TOP_CASE_TAC \\ fs []) QED -Definition array_chunks_end_in_def: - array_chunks_end_in xs arr = ( - EVERY (\(i, zs). LENGTH zs - 1 <= i) xs /\ - let ys = FLAT (MAP (\(i, zs). - MAPi (\j z. ((i - (LENGTH zs - 1)) + j, z)) zs) xs) in - ALL_DISTINCT (MAP FST ys) /\ - EVERY (\(j, z). j < LENGTH arr /\ EL j arr = z) ys - ) -End +val add_to_sfx_heaps_v_thm = add_to_sfx_heaps_def + |> SIMP_RULE bool_ss [add_to_sfx_heaps_step1_def, bind_assoc] + |> fix_state_type |> m_translate; -Theorem array_chunks_end_in_append[local]: - array_chunks_end_in (xs ++ ys) = array_chunks_end_in (ys ++ xs) -Proof - simp [array_chunks_end_in_def, FUN_EQ_THM, ALL_DISTINCT_APPEND', DISJOINT_SYM] - \\ rw [] \\ EQ_TAC \\ rw [] \\ simp [] -QED +val add_all_to_sfx_heaps_v_thm = add_all_to_sfx_heaps_def + |> fix_state_type |> m_translate; -Theorem array_chunks_end_in_rotate[local]: - array_chunks_end_in (x :: xs) = array_chunks_end_in (xs ++ [x]) -Proof - simp [Once array_chunks_end_in_append] -QED +val reinsert_tree_v_thm = reinsert_tree_def + |> REWRITE_RULE [use_comp_exp] + |> fix_state_type |> m_translate; -Theorem array_chunks_end_in_null[local]: - array_chunks_end_in ((i, []) :: xs) = array_chunks_end_in xs -Proof - simp [array_chunks_end_in_def, FUN_EQ_THM] -QED +val sfx_trees_to_list_v_thm = sfx_trees_to_list_def + |> fix_state_type |> m_translate; -Theorem list_to_bag_flat_eq: - !xs ys. LIST_TO_BAG xs = LIST_TO_BAG ys ==> - LIST_TO_BAG (FLAT xs) = LIST_TO_BAG (FLAT ys) -Proof - Induct - >- ( - Cases \\ simp [] - ) - >- ( - rw [] - \\ first_assum (mp_tac o Q.AP_TERM `BAG_IN h`) - \\ rw [IN_LIST_TO_BAG] - \\ fs [MEM_SPLIT] - \\ fs [LIST_TO_BAG_APPEND] - \\ fsrw_tac [bagSimps.BAG_AC_ss] [BAG_INSERT_UNION] - \\ simp_tac bool_ss [GSYM LIST_TO_BAG_APPEND, GSYM FLAT_APPEND] - \\ first_x_assum irule - \\ simp [LIST_TO_BAG_APPEND] - ) -QED +val length_v_thm = LENGTH |> translate; -Theorem array_chunks_end_in_bag_eq: - ! xs ys zs. LIST_TO_BAG xs = LIST_TO_BAG ys ==> - array_chunks_end_in xs = array_chunks_end_in ys -Proof - rw [] - \\ simp [array_chunks_end_in_def, FUN_EQ_THM] - \\ simp [EVERY_FLAT] - \\ rw [GSYM EVERY_LIST_TO_BAG, LIST_TO_BAG_MAP] - \\ rpt (irule AND_CONG \\ rw []) - \\ simp [GSYM containerTheory.LIST_TO_BAG_DISTINCT] - \\ simp [LIST_TO_BAG_MAP] - \\ AP_TERM_TAC - \\ AP_TERM_TAC - \\ irule list_to_bag_flat_eq - \\ simp [LIST_TO_BAG_MAP] -QED +val above_log2_v_thm = above_log2_def |> translate; -Theorem array_chunks_end_in_chunk_append[local]: - array_chunks_end_in ((i, xs ++ ys) :: zs) arr = ( - (LENGTH xs + LENGTH ys) - 1 <= i /\ - array_chunks_end_in ((i - LENGTH ys, xs) :: (i, ys) :: zs) arr - ) -Proof - simp [array_chunks_end_in_def] - \\ Cases_on `xs = []` \\ csimp [] - \\ Cases_on `ys = []` \\ csimp [] - >- ( - EQ_TAC \\ rw [] \\ fs [] - ) - \\ simp [MAPi_APPEND, o_DEF, GSYM CONJ_ASSOC] - \\ Cases_on `LENGTH xs` \\ fs [] - \\ Cases_on `LENGTH ys` \\ fs [] - \\ csimp [ADD1] -QED +val sort_via_sfx_trees_worker_v_thm = sort_via_sfx_trees_worker_def + |> fix_state_type |> m_translate; -Theorem array_chunks_end_in_chunk_append_fun[local]: - (LENGTH xs + LENGTH ys) - 1 <= i ==> - array_chunks_end_in ((i, xs ++ ys) :: zs) = ( - array_chunks_end_in ((i - LENGTH ys, xs) :: (i, ys) :: zs) - ) -Proof - simp [FUN_EQ_THM, array_chunks_end_in_chunk_append] -QED - -Theorem array_chunks_end_in_EL[local]: - array_chunks_end_in ((i, [x]) :: zs) arr ==> - i < LENGTH arr /\ EL i arr = x -Proof - rw [array_chunks_end_in_def] -QED - -Theorem array_chunks_end_in_EL_each_LAST[local]: - array_chunks_end_in xs arr ==> - EVERY (\(i, xs). 0 < LENGTH xs ==> i < LENGTH arr /\ EL i arr = LAST xs) xs -Proof - rw [array_chunks_end_in_def] - \\ rw [EVERY_MEM] - \\ pairarg_tac \\ fs [] - \\ fs [MEM_SPLIT] \\ fs [] - \\ disch_tac - \\ qpat_x_assum `EVERY _ (MAPi _ _)` mp_tac - \\ simp [EVERY_EL] - \\ disch_then (qspec_then `LENGTH xs' - 1` mp_tac) - \\ imp_res_tac LENGTH_NOT_NULL - \\ fs [NULL_EQ, LAST_EL, PRE_SUB1] -QED - -Theorem array_chunks_end_in_LUPDATE[local]: - array_chunks_end_in ((i, [x]) :: zs) arr ==> - array_chunks_end_in ((i, [y]) :: zs) (LUPDATE y i arr) -Proof - rw [array_chunks_end_in_def, EL_LUPDATE] - \\ fs [EVERY_FLAT, EVERY_MAP] - \\ subgoal `!f g. EVERY f zs /\ (EVERY f zs = EVERY g zs) ==> EVERY g zs` - \\ csimp [] - \\ pop_assum (drule_then irule) - \\ irule EVERY_CONG - \\ simp [FORALL_PROD] \\ rw [] - \\ irule EVERY_CONG - \\ simp [MEM_MAPi, PULL_EXISTS] - \\ rw [] - \\ dxrule (hd (RES_CANON MEM_SPLIT)) - \\ rw [] \\ fs [] - \\ fs [MEM_MAPi] -QED - -Theorem array_chunks_end_in_tree_split[local]: - 0 < ht ==> ( - array_chunks_end_in ((i, bs_tree_to_list ht (Node x l r)) :: xs) arr <=> - (2 * two_exp_min_1 (ht - 1) <= i) /\ - array_chunks_end_in ( - (i - (two_exp_min_1 (ht - 1) + 1), bs_tree_to_list (ht - 1) l) :: - (i - 1, bs_tree_to_list (ht - 1) r) :: (i, [x]) :: xs) arr - ) -Proof - csimp [bs_tree_to_list_tree_rec] - \\ simp [array_chunks_end_in_chunk_append] - \\ rw [] \\ EQ_TAC \\ rw [] - \\ fs [LENGTH_bs_tree_to_list] -QED - -Theorem array_chunks_end_in_tree_split_fun[local]: - 0 < ht /\ (2 * two_exp_min_1 (ht - 1) <= i) ==> ( - array_chunks_end_in ((i, bs_tree_to_list ht (Node x l r)) :: xs) = - array_chunks_end_in ( - (i - (two_exp_min_1 (ht - 1) + 1), bs_tree_to_list (ht - 1) l) :: - (i - 1, bs_tree_to_list (ht - 1) r) :: (i, [x]) :: xs) - ) -Proof - simp [FUN_EQ_THM, array_chunks_end_in_tree_split] -QED - -Theorem array_chunks_end_in_bag_eq[local]: - array_chunks_end_in xs arr /\ LIST_TO_BAG xs = LIST_TO_BAG ys ==> - array_chunks_end_in ys arr - -Proof - - cheat - -QED - -Theorem array_chunks_end_in_bag_eq_LUPDATE[local]: - array_chunks_end_in xs arr /\ - MEM (i, [z]) xs /\ - LIST_TO_BAG ys = ((LIST_TO_BAG xs - {|(i, [z])|}) + {|(i, [y])|}) ==> - array_chunks_end_in ys (LUPDATE y i arr) - -Proof - - cheat - -QED - -Theorem EQ_REFL_OR[local]: - x = x \/ P -Proof - simp [] -QED - -val rotate_ - (CHANGED_TAC (REWRITE_TAC [array_chunks_end_in_rotate]) \\ simp [APPEND]) - - -Definition eq_array_def: - eq_array p p' P = (?arr. p = (FST p', - (SND p' : 'a state_refs) with <| heap_array := arr |>) /\ P arr) -End - -Theorem eq_array_sub: - i < LENGTH (acc s) ==> - eq_array (st_ex_bind (Marray_sub acc exn i) f s) (M_success v, s') P = - eq_array (f (EL i (acc s)) s) (M_success v, s') P -Proof - simp [eq_array_def, monad_simps] -QED - -fun dest_list_apps t = let - open listSyntax - fun f xs yss [] = (xs, yss) - | f xs yss (t :: ts) = if is_cons t - then f (fst (dest_cons t) :: xs) yss (snd (dest_cons t) :: ts) - else if is_append t - then f xs yss (fst (dest_append t) :: snd (dest_append t) :: ts) - else f xs (t :: yss) ts - in f [] [] [t] end - -fun chunks_conv pred t = let - val (f, xs) = strip_comb t - val _ = same_const ``array_chunks_end_in`` f orelse - failwith "not array_chunks_end_in" - val _ = (length xs = 2) orelse failwith "not enough args" - val (chk_vs, oths) = dest_list_apps (hd xs) - val el_typ = listSyntax.dest_list_type (type_of (hd xs)) - val (pick, reject) = partition pred chk_vs - val base = if null oths then listSyntax.mk_list ([], el_typ) - else foldr listSyntax.mk_append (last oths) (butlast oths) - val rhs_chks = foldr listSyntax.mk_cons base (pick @ reject) - val eq = mk_eq (t, list_mk_comb (f, [rhs_chks, last xs])) - -fun pred t = can (match_term ``(_, [_])``) t - - -Theorem insert_into_sfx_heap_eq: - - ! t R i ht x st. - array_chunks_end_in ((i, bs_tree_to_list ht t) :: others) st.heap_array /\ - i + 1 <= LENGTH st.heap_array /\ - two_exp_min_1 ht <= i + 1 /\ - ht > 0 /\ - tree_balanced_height ht t ==> - eq_array (insert_into_sfx_heap R i ht x st) - (M_success (), st) - (array_chunks_end_in ((i, bs_tree_to_list ht (insert_tree_inv R t x)) :: others)) - -Proof - - Induct - \\ simp [tree_balanced_height_def] - \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] - \\ rw [] - >- ( - Cases_on `ht = 1` \\ fs [tree_balanced_height_0] - \\ simp [monad_simps, eq_array_def] - \\ irule_at Any EQ_REFL - \\ fs [array_chunks_end_in_tree_split, bs_tree_to_list_def, - insert_tree_inv_def, array_chunks_end_in_null] - \\ drule_then irule array_chunks_end_in_LUPDATE - ) - >- ( - - (* split array chunks once *) - gs [array_chunks_end_in_tree_split] - (* then expand the tree further to get top node vals *) - \\ gs [tree_balanced_height_pos] - (* continue *) - \\ simp [sfx_heap_left_def, to_two_exp_min_1] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ simp [monad_simps, return_bind_eq, eq_array_sub] - \\ imp_res_tac array_chunks_end_in_EL_each_LAST - \\ gs [LENGTH_bs_tree_to_list, LAST_bs_tree_to_list, two_exp_min_1_pos] - \\ rpt TOP_CASE_TAC \\ simp [ml_monadBaseTheory.monad_eqs] - >- ( - simp [eq_array_def, monad_simps] - \\ irule_at Any EQ_REFL - \\ simp [Once array_chunks_end_in_tree_split] - \\ drule_then (irule_at Any) array_chunks_end_in_bag_eq_LUPDATE - \\ simp [] - \\ fsrw_tac [simpLib.ac_ss [(DISJ_ASSOC, DISJ_COMM)]] [] - \\ irule_at Any EQ_REFL_OR - \\ simp [BAG_INSERT_commutes, BAG_UNION_INSERT] - ) - >- ( - irule_at Any array_chunks_end_in_bag_eq - \\ ONCE_REWRITE_TAC [CONJ_COMM] - \\ ONCE_REWRITE_TAC [CONJ_ASSOC] - \\ first_x_assum (irule_at Any) - - - - -Theorem insert_into_sfx_heap_eq: - - ! ht i st t others. - array_chunks_end_in ((i, bs_tree_to_list ht t) :: others) st.heap_array /\ - i + 1 <= LENGTH st.heap_array /\ - two_exp_min_1 ht <= i + 1 /\ - ht > 0 /\ - tree_balanced_height ht t ==> - ? arr'. - insert_into_sfx_heap R i ht x st = (M_success (), st with <| heap_array := arr' |>) /\ - array_chunks_end_in ((i, bs_tree_to_list ht (insert_tree_inv R t x)) :: others) arr' - -Proof - - Induct - \\ simp [tree_balanced_height_def, ADD1] - \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] - \\ rw [] - >- ( - Cases_on `ht` \\ fs [tree_balanced_height_pos, tree_balanced_height_0] - \\ simp [monad_simps] - \\ irule_at Any EQ_REFL - \\ fs [array_chunks_end_in_tree_split, bs_tree_to_list_def, - insert_tree_inv_def, array_chunks_end_in_null] - \\ drule_then irule array_chunks_end_in_LUPDATE - ) - >- ( - - (* unfold tree once *) - fs [Once tree_balanced_height_pos] - (* split array chunks once *) - \\ gs [array_chunks_end_in_tree_split] - (* then expand the tree further to get top node vals *) - \\ gs [tree_balanced_height_pos] - \\ simp [sfx_heap_left_def, to_two_exp_min_1] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ simp [monad_simps] - \\ imp_res_tac array_chunks_end_in_EL_each_LAST - \\ gs [LENGTH_bs_tree_to_list, LAST_bs_tree_to_list, two_exp_min_1_pos] - \\ rpt TOP_CASE_TAC \\ simp [] - - >- ( - simp [monad_simps] - \\ irule_at Any EQ_REFL - \\ simp [Once array_chunks_end_in_tree_split_fun] - - \\ qpat_x_assum `array_chunks_end_in _ _` mp_tac - - - \\ drule_then (irule_at Any) array_chunks_end_in_bag_eq_LUPDATE - \\ simp [] - \\ fsrw_tac [simpLib.ac_ss [(DISJ_ASSOC, DISJ_COMM)]] [] - \\ irule_at Any EQ_REFL_OR - \\ simp [BAG_INSERT_commutes, BAG_UNION_INSERT] - ) - >- ( - - ONCE_REWRITE_TAC [ml_monadBaseTheory.monad_eqs] - \\ simp [PULL_EXISTS] - - qmatch_goalsub_abbrev_tac `insert_into_sfx_heap _ i2 _ _ st2` - \\ first_x_assum (qspecl_then [`i2`, `st2`] mp_tac) - \\ dxrule (hd (RES_CANON array_chunks_end_in_rotate)) - \\ rw [] - \\ first_x_assum drule - - irule_at Any array_chunks_end_in_bag_eq - \\ ONCE_REWRITE_TAC [CONJ_COMM] - \\ ONCE_REWRITE_TAC [CONJ_ASSOC] - \\ first_x_assum (irule_at Any) - - \\ fsrw_tac [bagLib.SBAG_SOLVE_ss] [] - - - - \\ rpt (irule array_chunks_end_in_LUPDATE ORELSE - (CHANGED_TAC (REWRITE_TAC [array_chunks_end_in_rotate]) \\ simp [APPEND]) - ) - \\ REWRITE_TAC [GSYM APPEND_ASSOC] - \\ ONCE_REWRITE_TAC [array_chunks_end_in_append] - \\ simp [] - \\ first_assum (irule_at Any) - ) - -REWRITE_TAC [array_chunks_end_in_rotate]) - \\ - - - -Theorem monad_eq_helper[local]: - (?s'. mv = (M_success x, s') /\ (SND mv = s' ==> s = s' /\ Q)) ==> - mv = (M_success x, s) /\ Q -Proof - rw [] \\ fs [] -QED - -Definition monad_eq_array_prop_def: - monad_eq_array_prop mv x s P = - (case mv of (M_success x', (s' : 'a state_refs)) => - x' = x /\ (?arr. s' = (s with <| heap_array := arr |>) /\ P arr) - | _ => F) -End - -Theorem monad_eq_array_prop_array_upd[local]: - monad_eq_array_prop mv x (heap_array_fupd f s) P = - monad_eq_array_prop mv x s P -Proof - simp [monad_eq_array_prop_def] -QED - -Theorem monad_eq_array_prop_eraseI: - (case mv of (M_success x', s') => - x' = x /\ (s' with <| heap_array := [] |>) = (s with <| heap_array := [] |>) /\ - P s'.heap_array - | _ => F) ==> - monad_eq_array_prop mv x s P -Proof - simp [monad_eq_array_prop_def] - \\ BasicProvers.EVERY_CASE_TAC \\ fs [] - \\ simp [fetch "-" "state_refs_component_equality"] -QED - -Theorem monad_eq_array_prop_exI: - (?s'. mv = (M_success x', s') /\ - x' = x /\ (s' with <| heap_array := [] |>) = (s with <| heap_array := [] |>) /\ - P s'.heap_array) ==> - monad_eq_array_prop mv x s P -Proof - rw [] \\ irule monad_eq_array_prop_eraseI - \\ simp [] -QED - -Theorem monad_eq_array_prop_bindI: - monad_eq_array_prop (m (st : 'a state_refs)) y (bd_st : 'a state_refs) Q /\ - (! upd_st arr. Q upd_st.heap_array /\ bd_st = (upd_st with <| heap_array := arr |>) ==> - monad_eq_array_prop (f y upd_st) x st' P) - ==> - monad_eq_array_prop (st_ex_bind m f st) x st' P -Proof - rw [] \\ irule monad_eq_array_prop_exI - \\ simp [monad_simps] - \\ Cases_on `FST (m st)` \\ Cases_on `m st` \\ fs [monad_eq_array_prop_def] - \\ rw [] - \\ first_x_assum (qspecl_then [`bd_st with heap_array := arr`, `bd_st.heap_array`] mp_tac) - \\ rpt (TOP_CASE_TAC \\ fs []) - \\ simp [fetch "-" "state_refs_component_equality"] -QED - -Theorem monad_eq_array_prop_bindI_rdonly: - monad_eq_array_prop (m st) y st ((=) st.heap_array) /\ - monad_eq_array_prop (f y st) x st' P - ==> - monad_eq_array_prop (st_ex_bind m f st) x st' P -Proof - rw [] \\ irule monad_eq_array_prop_bindI - \\ last_assum (irule_at Any) - \\ rw [] - \\ fs [] - \\ subgoal `(upd_st with heap_array := upd_st.heap_array) = upd_st` - \\ fs [] - \\ simp [fetch "-" "state_refs_component_equality"] -QED - -Theorem heap_array_sub_bind_eq: - i < LENGTH st.heap_array ==> - st_ex_bind (heap_array_sub i) f st = - f (EL i st.heap_array) st -Proof - rw [] - \\ fs [ml_monadBaseTheory.st_ex_bind_def] - \\ simp [ml_monadBaseTheory.exc_case_eq, pair_case_eq] - \\ simp [monad_simps] -QED - -Theorem sz_array_sub_bind_eq: - i < LENGTH st.sz_array ==> - st_ex_bind (sz_array_sub i) f st = - f (EL i st.sz_array) st -Proof - rw [] - \\ fs [ml_monadBaseTheory.st_ex_bind_def] - \\ simp [ml_monadBaseTheory.exc_case_eq, pair_case_eq] - \\ simp [monad_simps] -QED - -Theorem update_sz_array_prop: - i < LENGTH st.sz_array ==> - monad_eq_array_prop (update_sz_array i x st) () - (st with <| sz_array := LUPDATE x i st.sz_array |>) - ((=) st.heap_array) -Proof - rw [] \\ irule monad_eq_array_prop_exI - \\ simp [monad_simps] -QED - -Theorem update_heap_array_prop: - array_chunks_end_in ((i, [prev_x]) :: others) st.heap_array ==> - monad_eq_array_prop (update_heap_array i x st) () st - (array_chunks_end_in ((i, [x]) :: others)) -Proof - rw [] \\ irule monad_eq_array_prop_exI - \\ simp [monad_simps] - \\ imp_res_tac array_chunks_end_in_EL_each_LAST - \\ fs [] - \\ drule_then irule array_chunks_end_in_LUPDATE -QED - -Theorem monad_eq_array_prop_postcondI: - monad_eq_array_prop mv x s P /\ (!arr. P arr ==> Q arr) ==> - monad_eq_array_prop mv x s Q -Proof - rw [monad_eq_array_prop_def] - \\ EVERY_CASE_TAC \\ fs [] - \\ irule_at Any EQ_REFL \\ simp [] -QED - -Theorem array_chunks_end_in_bag_eq_IMP[local]: - array_chunks_end_in xs arr /\ - LIST_TO_BAG xs = LIST_TO_BAG ys ==> - array_chunks_end_in ys arr -Proof - metis_tac [array_chunks_end_in_bag_eq] -QED - -val chunks_const = ``array_chunks_end_in`` - -fun chunk_select_conv pat tm = let - val (f, xs) = strip_comb tm - val _ = same_const chunks_const f orelse - failwith "not array_chunks_end_in" - val _ = not (null xs) orelse failwith "array_chunks_end_in no args" - val cs = hd xs - val ts = find_terms (fn t => listSyntax.is_cons t - andalso can (match_term pat) (rand (rator t))) cs - val _ = not (null ts) orelse failwith ("no chunk matches") - val cs2 = Term.subst [hd ts |-> rand (hd ts)] cs - val cs3 = listSyntax.mk_cons (rand (rator (hd ts)), cs2) - val rhs = list_mk_comb (f, cs3 :: tl xs) - val _ = not (aconv tm rhs) orelse failwith "chunk_select_conv: done" - val eq = mk_eq (tm, list_mk_comb (f, cs3 :: tl xs)) - in prove (eq, TRY AP_THM_TAC - \\ irule array_chunks_end_in_bag_eq - \\ fsrw_tac [bagSimps.BAG_AC_ss] [BAG_INSERT_UNION]) - end - -fun chunk_select_tac pat = POP_ASSUM_LIST (fn asms => let - fun do_conv asm = if can (find_term (same_const chunks_const)) (concl asm) - then let - val asm2 = CONV_RULE (ONCE_DEPTH_CONV (chunk_select_conv pat)) asm - in (asm2, aconv (concl asm2) (concl asm)) end - else (asm, true) - val conv_asms = map do_conv asms - val (no_upd, upd) = partition snd conv_asms - in MAP_EVERY (ASSUME_TAC o fst) (rev (upd @ no_upd)) - >> CONV_TAC (ONCE_DEPTH_CONV (chunk_select_conv pat)) end) - -fun select_chunk_goal pat = CONV_TAC (DEPTH_CONV (chunk_select_conv pat)) - -fun select_chunk_asm pat = qpat_x_assum `array_chunks_end_in _ _` - (assume_tac o CONV_RULE (chunk_select_conv pat)) - -(* chunks ends variant *) -Theorem insert_into_sfx_heap_eq: - ! ht i st t others. - array_chunks_end_in ((i, bs_tree_to_list ht t) :: others) st.heap_array /\ - ht > 0 /\ - tree_balanced_height ht t ==> - monad_eq_array_prop (insert_into_sfx_heap R i ht x st) () st - (array_chunks_end_in ((i, bs_tree_to_list ht (insert_tree_inv R t x)) :: others)) -Proof - Induct - \\ simp [tree_balanced_height_def, ADD1] - \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] - \\ rw [] - >- ( - Cases_on `ht` \\ fs [tree_balanced_height_pos, tree_balanced_height_0] - \\ irule monad_eq_array_prop_exI - \\ simp [monad_simps] - \\ imp_res_tac array_chunks_end_in_EL_each_LAST - \\ fs [LENGTH_bs_tree_to_list, two_exp_min_1_pos] - \\ fs [array_chunks_end_in_tree_split, bs_tree_to_list_def, - insert_tree_inv_def, array_chunks_end_in_null] - \\ drule_then irule array_chunks_end_in_LUPDATE - ) - >- ( - (* unfold tree once *) - fs [Once tree_balanced_height_pos] - (* split array chunks once *) - \\ gs [array_chunks_end_in_tree_split] - (* then expand the tree further to get top node vals *) - \\ gs [tree_balanced_height_pos] - \\ simp [sfx_heap_left_def, to_two_exp_min_1] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ imp_res_tac array_chunks_end_in_EL_each_LAST - \\ gs [LENGTH_bs_tree_to_list, LAST_bs_tree_to_list, two_exp_min_1_pos] - \\ simp [return_bind_eq, heap_array_sub_bind_eq] - \\ rpt TOP_CASE_TAC \\ simp [] - >- ( - simp [Once array_chunks_end_in_tree_split_fun] - \\ chunk_select_tac ``(_, [_])`` - \\ drule_then irule update_heap_array_prop - ) - >- ( - simp [st_ex_ignore_bind_simp] - \\ simp [Once array_chunks_end_in_tree_split_fun] - \\ chunk_select_tac ``(_, [_])`` - \\ irule monad_eq_array_prop_bindI - \\ dxrule_then (irule_at Any) update_heap_array_prop - \\ rw [] - \\ chunk_select_tac ``(_ - 1n, _)`` - \\ first_x_assum dxrule - \\ simp [monad_eq_array_prop_array_upd] - ) - >- ( - simp [st_ex_ignore_bind_simp] - \\ simp [Once array_chunks_end_in_tree_split_fun] - \\ chunk_select_tac ``(_, [_])`` - \\ irule monad_eq_array_prop_bindI - \\ dxrule_then (irule_at Any) update_heap_array_prop - \\ rw [] - \\ chunk_select_tac ``(_ - (_ + 1n), _)`` - \\ first_x_assum dxrule - \\ simp [monad_eq_array_prop_array_upd] - ) - ) -QED - -Definition bs_tree_list_chunks_def: - bs_tree_list_chunks i [] = [] /\ - bs_tree_list_chunks i ((t, ht) :: ts) = - ((i, bs_tree_to_list ht t) :: bs_tree_list_chunks (i - two_exp_min_1 ht) ts) -End - -Theorem insert_into_sfx_heap_list_eq: - ! j ts R i x others st. - array_chunks_end_in ((i, bs_tree_list_to_list ts) :: others) st.heap_array /\ - TAKE j st.sz_array = MAP SND (REVERSE ts) /\ - j <= LENGTH st.sz_array ==> - 0 < j /\ EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> - monad_eq_array_prop (insert_into_sfx_heap_list R i j x st) () st - (array_chunks_end_in ((i, bs_tree_list_to_list (insert_trees_inv R ts x)) :: others)) -Proof - Induct - \\ simp [] - \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_list_def] - \\ rpt strip_tac - \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [] - \\ gs [ADD1, TAKE_SUM] - \\ simp [insert_trees_inv_def] - \\ rw [] - >- ( - Cases_on `j` \\ fs [] - \\ gs [tree_balanced_height_pos, bs_tree_list_to_list_rec] - \\ simp [sz_array_sub_bind_eq] - \\ irule insert_into_sfx_heap_eq - \\ simp [tree_balanced_height_pos] - ) - >- ( - gs [bs_tree_list_to_list_rec, tree_balanced_height_pos, ADD1, - array_chunks_end_in_chunk_append] - \\ simp [sz_array_sub_bind_eq, return_bind_eq] - \\ imp_res_tac array_chunks_end_in_EL_each_LAST - \\ gs [EL_TAKE, EL_APPEND, array_chunks_end_in_tree_split, - LENGTH_bs_tree_to_list, two_exp_min_1_pos, APPEND] - \\ simp [to_two_exp_min_1] - \\ qpat_x_assum `0 < LENGTH (bs_tree_list_to_list _) ==> _` mp_tac - \\ impl_keep_tac - >- ( - Cases_on `HD t` \\ Cases_on `t` \\ fs [] - \\ gs [bs_tree_list_to_list_rec, tree_balanced_height_pos] - \\ simp [bs_tree_to_list_tree_rec] - ) - \\ rw [] - \\ Cases_on `HD t` \\ Cases_on `t` \\ fs [] - \\ gs [tree_balanced_height_pos] - \\ simp [heap_array_sub_bind_eq] - \\ irule monad_eq_array_prop_bindI_rdonly - \\ qmatch_goalsub_abbrev_tac `bs_tree_list_to_list (COND tree_conds _ _)` - \\ qexists_tac `tree_conds` - \\ conj_tac - >- ( - Cases_on `j` \\ fs [ADD1, TAKE_SUM] - \\ fs [markerTheory.Abbrev_def, bs_tree_list_to_list_rec, - bs_tree_to_list_tree_rec] - \\ reverse (rw []) - >- ( - gs [] - \\ irule monad_eq_array_prop_exI - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ gs [tree_balanced_height_eq_0] - ) - >- ( - gs [tree_balanced_height_pos] - \\ fs [array_chunks_end_in_chunk_append] - \\ chunk_select_tac ``(_, _ ++ _)`` - \\ fs [array_chunks_end_in_chunk_append] - \\ simp [sfx_heap_left_def, to_two_exp_min_1] - \\ imp_res_tac array_chunks_end_in_EL_each_LAST - \\ gs [LENGTH_bs_tree_to_list, two_exp_min_1_pos] - \\ simp [heap_array_sub_bind_eq, LAST_bs_tree_to_list] - \\ irule monad_eq_array_prop_exI - \\ simp [ml_monadBaseTheory.monad_eqs] - ) - ) - >- ( - qpat_x_assum `Abbrev _` (K all_tac) - \\ rw [] - >- ( - fs [st_ex_ignore_bind_simp, bs_tree_to_list_tree_rec] - \\ chunk_select_tac ``(_, _ ++ _)`` - \\ fs [array_chunks_end_in_chunk_append] - \\ chunk_select_tac ``(_, [_])`` - \\ irule monad_eq_array_prop_bindI - \\ dxrule_then (irule_at Any) update_heap_array_prop - \\ rw [] - \\ simp [bs_tree_list_to_list_rec] - \\ dep_rewrite.DEP_REWRITE_TAC [array_chunks_end_in_chunk_append_fun] - \\ fs [LENGTH_bs_tree_to_list, LENGTH_list_of_insert_trees] - \\ simp [monad_eq_array_prop_array_upd] - \\ first_x_assum irule - \\ simp [tree_balanced_height_def] - \\ chunk_select_tac ``(_, bs_tree_to_list _ (Node _ _ _))`` - \\ simp [array_chunks_end_in_tree_split] - \\ chunk_select_tac ``(_, [_])`` - \\ gs [bs_tree_list_to_list_rec, bs_tree_to_list_tree_rec] - ) - >- ( - ONCE_REWRITE_TAC [bs_tree_list_to_list_rec] - \\ simp [array_chunks_end_in_chunk_append_fun, LENGTH_bs_tree_to_list] - \\ chunk_select_tac ``(_, bs_tree_to_list _ _)`` - \\ irule insert_into_sfx_heap_eq - \\ simp [tree_balanced_height_def] - ) - ) - ) -QED - -Theorem add_to_sfx_heaps_step1_eq: - array_chunks_end_in ((i, [x]) :: (i - 1, bs_tree_list_to_list ts) :: others) st.heap_array /\ - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - 0 < i /\ - TAKE j st.sz_array = MAP SND (REVERSE ts) /\ - j = LENGTH ts /\ j + 1 < LENGTH st.sz_array ==> - let ts2 = add_trees_step1 ts x; - xs = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in - monad_eq_array_prop (add_to_sfx_heaps_step1 i j st) l2 - (st with <| sz_array := MAP SND (REVERSE ts2) ++ DROP l2 st.sz_array |>) - (array_chunks_end_in ((i, bs_tree_list_to_list ts2) :: others)) -Proof - rw [] - \\ simp [add_to_sfx_heaps_step1_def, add_trees_step1_def] - \\ irule monad_eq_array_prop_bindI_rdonly - \\ qexists_tac `case ts of (_, n1) :: (_, n2) :: _ => n1 = n2 | _ => F` - \\ conj_tac - >- ( - Cases_on `ts` \\ fs [] - \\ simp [monad_eq_array_prop_exI, ml_monadBaseTheory.monad_eqs] - \\ fs [ADD1, TAKE_SUM] - \\ Cases_on `t` \\ fs [] - \\ simp [monad_eq_array_prop_exI, ml_monadBaseTheory.monad_eqs] - \\ fs [ADD1, TAKE_SUM] - \\ simp [sz_array_sub_bind_eq] - \\ rpt (pairarg_tac \\ fs []) - \\ simp [monad_eq_array_prop_exI, ml_monadBaseTheory.monad_eqs] - ) - \\ rw [] - >- ( - (* merge case *) - rpt (TOP_CASE_TAC \\ fs [ADD1, TAKE_SUM]) - \\ simp [sz_array_sub_bind_eq, st_ex_ignore_bind_simp] - \\ irule monad_eq_array_prop_bindI - \\ irule_at Any update_sz_array_prop - \\ rw [] - \\ simp [monad_eq_array_prop_array_upd] - \\ qspec_then `st.sz_array` mp_tac LESS_LENGTH - \\ disch_then (qspec_then `LENGTH t'` mp_tac) - \\ rw [] - \\ fs [EL_APPEND, TAKE_APPEND1, LUPDATE_APPEND, LUPDATE_def] - \\ rw [] - \\ gs [TAKE_LENGTH_TOO_LONG, DROP_APPEND2, monad_eq_array_prop_array_upd] - \\ irule monad_eq_array_prop_exI - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ fs [bs_tree_list_to_list_rec, bs_tree_to_list_tree_rec] - \\ ONCE_REWRITE_TAC [array_chunks_end_in_chunk_append] - \\ fs [] - \\ chunk_select_tac ``(_ - 1n, _)`` - \\ simp [] - \\ fs [array_chunks_end_in_chunk_append] - \\ gs [LENGTH_bs_tree_to_list, two_exp_min_1_less_rec] - ) - >- ( - (* no merge case *) - simp [st_ex_ignore_bind_simp] - \\ qmatch_goalsub_abbrev_tac `bs_tree_list_to_list upd_trees` - \\ subgoal `upd_trees = (Node x Empty_Tree Empty_Tree, 1) :: ts` - >- ( - every_case_tac \\ fs [] - ) - \\ simp [] - \\ irule monad_eq_array_prop_bindI - \\ irule_at Any update_sz_array_prop - \\ rw [] - \\ fs [ADD1] - \\ qspec_then `st.sz_array` mp_tac LESS_LENGTH - \\ disch_then (qspec_then `LENGTH ts` mp_tac) - \\ rw [] - \\ fs [LUPDATE_APPEND, LUPDATE_DEF, TAKE_APPEND1] - \\ gs [TAKE_LENGTH_TOO_LONG, DROP_APPEND2, monad_eq_array_prop_array_upd] - \\ irule monad_eq_array_prop_exI - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ simp [bs_tree_list_to_list_rec, bs_tree_to_list_tree_rec] - \\ chunk_select_tac ``(_ - 1n, _)`` - \\ simp [array_chunks_end_in_chunk_append] - \\ fs [array_chunks_end_in_def] - ) -QED - -Theorem add_to_sfx_heaps_eq: - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - 0 < i /\ - array_chunks_end_in ((i, [x]) :: (i - 1, bs_tree_list_to_list ts) :: others) st.heap_array /\ - TAKE j st.sz_array = MAP SND (REVERSE ts) /\ - j = LENGTH ts /\ j + 1 < LENGTH st.sz_array ==> - (let ts2 = add_trees R ts x; xs = bs_tree_list_to_list ts2; l2 = LENGTH ts2 in - monad_eq_array_prop (add_to_sfx_heaps R i j x st) l2 - (st with <| sz_array := MAP SND (REVERSE ts2) ++ DROP l2 st.sz_array |>) - (array_chunks_end_in ((i, bs_tree_list_to_list ts2) :: others)) - ) - -Proof - - simp [add_to_sfx_heaps_def, add_trees_def, st_ex_ignore_bind_simp] - \\ rpt strip_tac - \\ irule monad_eq_array_prop_bindI - \\ dxrule_then (irule_at Any) (SIMP_RULE bool_ss [LET_THM] add_to_sfx_heaps_step1_eq) - \\ fs [] - \\ rw [] - \\ irule monad_eq_array_prop_bindI - \\ dxrule_then (irule_at Any) insert_into_sfx_heap_list_eq - \\ simp [LENGTH_add_tree_step1_facts] - - \\ - \\ simp [ - - - -Definition extract_tree_def: - extract_tree 0 i arr = Empty_Tree /\ - extract_tree (SUC ht) i arr = Node (EL (i + (two_exp_min_1 (SUC ht) - 1)) arr) - (extract_tree ht i arr) (extract_tree ht (i + two_exp_min_1 ht) arr) -End - -Theorem extract_tree_less_rec[local]: - 0 < ht ==> extract_tree ht i arr = Node (EL (i + (two_exp_min_1 ht - 1)) arr) - (extract_tree (ht - 1) i arr) (extract_tree (ht - 1) (i + two_exp_min_1 (ht - 1)) arr) -Proof - Cases_on `ht` \\ simp [extract_tree_def] -QED - -Definition update_range_def: - update_range i j f xs = TAKE i xs ++ GENLIST f j ++ DROP (i + j) xs -End - -Theorem EL_update_range: - k < LENGTH xs ==> - EL k (update_range i j f xs) = (if k < i \/ k >= i + j - then EL k xs else f (k - i)) -Proof - simp [update_range_def] - \\ rw [] - \\ simp [EL_APPEND, LENGTH_TAKE_EQ] - \\ rw [] - \\ fs [EL_TAKE, EL_DROP] -QED - -Theorem insert_into_sfx_heap_eq: - - ! t R i ht x st. - t = extract_tree ht (i - two_exp_min_1 ht) st.heap_array /\ - i + 1 <= LENGTH st.heap_array /\ - two_exp_min_1 ht <= i + 1 /\ - ht > 0 ==> - ? arr upd_f. - arr = update_range ((i + 1) - two_exp_min_1 ht) (two_exp_min_1 ht) upd_f st.heap_array /\ - insert_into_sfx_heap R i ht x st = (M_success (), st with <| heap_array := arr |>) /\ - extract_tree ht ((i + 1) - two_exp_min_1 ht) arr = - insert_tree_inv R t x - -Proof - - Induct - \\ csimp [extract_tree_less_rec] - \\ rw [] - \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] - \\ subgoal `?base. i = base + (two_exp_min_1 ht - 1)` - >- ( - qexists_tac `(i + 1) - (two_exp_min_1 ht)` - \\ fs [two_exp_min_1_less_rec, two_exp_min_1_pos] - ) - \\ rw [] \\ fs [] - >- ( - Cases_on `ht = 1` \\ fs [extract_tree_def] - \\ fs [two_exp_min_1_rec, two_exp_min_1_less_rec] - \\ simp [monad_simps, fetch "-" "state_refs_component_equality"] - \\ simp [insert_tree_inv_def] - \\ simp [EL_update_range] - (* this is somewhat annoying *) - - \\ cheat - ) - - >- ( - fs [two_exp_min_1_less_rec, sfx_heap_left_two_exp_min_1] - \\ simp [monad_simps] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ simp [extract_tree_less_rec, two_exp_min_1_less_rec] - \\ rw [] \\ fs [] +val sort_via_sfx_trees_run_worker_v_thm = sort_via_sfx_trees_run_worker_def + |> fix_state_type |> m_translate_run; - \\ simp [monad_simps, tree_len_simps, sfx_heap_left_two_exp_min_1] - \\ simp [EL_APPEND, tree_len_simps, LEFT_ADD_DISTRIB] - \\ rpt TOP_CASE_TAC \\ simp [ml_monadBaseTheory.monad_eqs] - >- ( - simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ simp [insert_tree_inv_def, tree_len_simps] - ) - >- ( - simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ simp [tree_len_simps] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] - \\ simp_tac bool_ss [GSYM APPEND_ASSOC, APPEND] - ) - >- ( - simp [tree_len_simps, LUPDATE_APPEND, LUPDATE_DEF] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ simp [tree_len_simps] - \\ simp [tree_len_simps, TAKE_APPEND2, TAKE_APPEND1, DROP_APPEND1, DROP_APPEND2] - ) - ) -QED +val sort_via_sfx_trees_v_thm = sort_via_sfx_trees_def |> translate; From 0d29e0c419db63ed70510a9abd39fe1499137c6b Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 26 Feb 2026 17:36:44 +1100 Subject: [PATCH 14/39] Prove remaining cheats --- basis/heap_sort_monadicScript.sml | 134 +++++++++++++++++++----------- 1 file changed, 84 insertions(+), 50 deletions(-) diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml index f0a00fb60f..0ac6cceb39 100644 --- a/basis/heap_sort_monadicScript.sml +++ b/basis/heap_sort_monadicScript.sml @@ -652,7 +652,7 @@ Theorem mk_st_node_split_r: mk_st ((Node x l r, ht) :: hps, oths) szs = mk_st ((r, ht - 1) :: (l, ht - 1) :: hps, x :: oths) szs Proof - cheat + simp [mk_st_def, tree_to_list_unfold] QED Theorem mk_st_node_split_l: @@ -660,7 +660,7 @@ Theorem mk_st_node_split_l: mk_st ((Node x l r, ht) :: hps, oths) szs = mk_st ((l, ht - 1) :: hps, bs_tree_to_list (ht - 1) r ++ x :: oths) szs Proof - cheat + simp [mk_st_def, tree_to_list_unfold] QED Theorem mk_st_move_others: @@ -669,52 +669,97 @@ Theorem mk_st_move_others: mk_st hps_pair (n :: szs, sz_oths) = mk_st hps_pair (szs, n :: sz_oths) Proof - cheat + simp [mk_st_def, tree_to_list_unfold] QED -Theorem heap_array_sub_left: +Theorem LENGTH_bs_tree_list_to_list_eq_SUM[local]: + LENGTH (bs_tree_list_to_list ts) = SUM (MAP two_exp_min_1 (MAP SND ts)) +Proof + simp [bs_tree_list_to_list_def, LENGTH_FLAT, MAP_MAP_o, o_DEF] + \\ simp [UNCURRY, LENGTH_bs_tree_to_list, MAP_REVERSE, SUM_REVERSE] +QED + +Theorem heap_array_sub_curr_bind_eq: + is_last_ix (ht :: MAP SND hps) i /\ 0 < ht ==> + st_ex_bind (heap_array_sub i) f + (mk_st ((Node x l r, ht) :: hps, oths) szs) = + f x (mk_st ((Node x l r, ht) :: hps, oths) szs) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "heap_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, tree_to_list_unfold, LENGTH_bs_tree_to_list] + \\ fs [is_last_ix_def, LENGTH_bs_tree_list_to_list_eq_SUM, two_exp_min_1_less_rec, + EL_APPEND1, EL_APPEND2, LENGTH_bs_tree_to_list, EL_CONS_IF] +QED + +Theorem is_last_ix_imps: + is_last_ix (ht :: hts) i ==> + (1 < ht ==> is_last_ix (ht - 1 :: hts) (sfx_heap_left i ht)) /\ + (1 < ht ==> is_last_ix (ht - 1 :: ht - 1 :: hts) (i - 1)) /\ + (0 < LENGTH hts /\ 0 < HD hts ==> is_last_ix hts (i - two_exp_min_1 ht)) +Proof + fs [is_last_ix_def] + \\ rw [] + \\ fs [sfx_heap_left_def, to_two_exp_min_1, two_exp_min_1_less_rec] + \\ Cases_on `hts` \\ fs [] + \\ fs [sfx_heap_left_def, to_two_exp_min_1, two_exp_min_1_less_rec] +QED + +Theorem heap_array_sub_left_bind_eq: is_last_ix (ht :: MAP SND hps) i /\ 1 < ht ==> st_ex_bind (heap_array_sub (sfx_heap_left i ht)) f (mk_st ((Node x (Node lx ll lr) r, ht) :: hps, oths) szs) = f lx (mk_st ((Node x (Node lx ll lr) r, ht) :: hps, oths) szs) Proof - cheat + rw [] + \\ imp_res_tac is_last_ix_imps + \\ fs [] + \\ simp [Once mk_st_node_split_l] + \\ simp [heap_array_sub_curr_bind_eq] + \\ simp [mk_st_node_split_l] QED -Theorem heap_array_sub_right: +Theorem heap_array_sub_right_bind_eq: is_last_ix (ht :: MAP SND hps) i /\ 1 < ht ==> st_ex_bind (heap_array_sub (i - 1)) f (mk_st ((Node x l (Node rx rl rr), ht) :: hps, oths) szs) = f rx (mk_st ((Node x l (Node rx rl rr), ht) :: hps, oths) szs) Proof - cheat -QED - -Theorem heap_array_sub_curr: - is_last_ix (ht :: MAP SND hps) i /\ 0 < ht ==> - st_ex_bind (heap_array_sub i) f - (mk_st ((Node x l r, ht) :: hps, oths) szs) = - f x (mk_st ((Node x l r, ht) :: hps, oths) szs) -Proof - cheat + rw [] + \\ imp_res_tac is_last_ix_imps + \\ fs [] + \\ simp [Once mk_st_node_split_r] + \\ simp [heap_array_sub_curr_bind_eq] + \\ simp [mk_st_node_split_r] QED -Theorem heap_array_sub_prev: +Theorem heap_array_sub_prev_bind_eq: is_last_ix (ht :: MAP SND hps) i /\ 0 < LENGTH hps /\ EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) hps ==> st_ex_bind (heap_array_sub (i - two_exp_min_1 ht)) f (mk_st ((t, ht) :: hps, oths) szs) = f (case hps of (Node x _ _, _) :: _ => x) (mk_st ((t, ht) :: hps, oths) szs) Proof - cheat + rw [] + \\ imp_res_tac is_last_ix_imps + \\ fs [] + \\ simp [mk_st_move_others] + \\ Cases_on `HD hps` \\ Cases_on `hps` \\ fs [] + \\ gs [tree_balanced_height_pos] + \\ simp [heap_array_sub_curr_bind_eq] QED Theorem update_heap_array_mk_st_eq: - is_last_ix (n :: MAP SND hps) i ==> - update_heap_array i x (mk_st ((Node x_dc l r, n) :: hps, oths) szs) = - (M_success (), mk_st ((Node x l r, n) :: hps, oths) szs) + is_last_ix (ht :: MAP SND hps) i /\ 0 < ht ==> + update_heap_array i x (mk_st ((Node x_dc l r, ht) :: hps, oths) szs) = + (M_success (), mk_st ((Node x l r, ht) :: hps, oths) szs) Proof - cheat + simp [fetch "-" "update_heap_array_def", ml_monadBaseTheory.monad_eqs] + \\ rw [is_last_ix_def, mk_st_def] + \\ fs [tree_to_list_unfold, LENGTH_bs_tree_to_list, + LENGTH_bs_tree_list_to_list_eq_SUM, LUPDATE_APPEND, + two_exp_min_1_less_rec, LUPDATE_DEF] QED Theorem return_bind_eq: @@ -723,25 +768,15 @@ Proof simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] QED -Theorem is_last_ix_imps: - is_last_ix (ht :: hts) i ==> - (1 < ht ==> is_last_ix (ht - 1 :: hts) (sfx_heap_left i ht)) /\ - (1 < ht ==> is_last_ix (ht - 1 :: ht - 1 :: hts) (i - 1)) /\ - (0 < ht /\ 0 < LENGTH hts /\ 0 < HD hts ==> is_last_ix hts (i - two_exp_min_1 ht)) -Proof - fs [is_last_ix_def] - \\ rw [] - \\ fs [sfx_heap_left_def, to_two_exp_min_1, two_exp_min_1_less_rec] - \\ Cases_on `hts` \\ fs [] - \\ fs [sfx_heap_left_def, to_two_exp_min_1, two_exp_min_1_less_rec] -QED - Theorem sz_array_sub_bind_eq: i < LENGTH szs ==> st_ex_bind (sz_array_sub i) f (mk_st hps (szs, oths)) = f (EL (LENGTH szs - (i + 1)) szs) (mk_st hps (szs, oths)) Proof - cheat + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "sz_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, EL_APPEND1, EL_REVERSE, PRE_SUB1] QED Theorem update_sz_array_eq: @@ -749,14 +784,13 @@ Theorem update_sz_array_eq: update_sz_array i x (mk_st hps (szs, oths)) = (M_success (), mk_st hps (LUPDATE x (LENGTH szs - (i + 1)) szs, oths)) Proof - cheat -QED - -Theorem LENGTH_bs_tree_list_to_list_eq_SUM[local]: - LENGTH (bs_tree_list_to_list ts) = SUM (MAP two_exp_min_1 (MAP SND ts)) -Proof - simp [bs_tree_list_to_list_def, LENGTH_FLAT, MAP_MAP_o, o_DEF] - \\ simp [UNCURRY, LENGTH_bs_tree_to_list, MAP_REVERSE, SUM_REVERSE] + rw [] + \\ simp [fetch "-" "update_sz_array_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def] + \\ qspecl_then [`REVERSE szs`, `i`] mp_tac LESS_LENGTH + \\ simp [listTheory.SWAP_REVERSE_SYM] + \\ rw [] + \\ simp [LUPDATE_APPEND1, LUPDATE_APPEND2, LUPDATE_DEF] QED (* 3.3: Proofs of equivalence *) @@ -783,7 +817,7 @@ Proof \\ ONCE_REWRITE_TAC [insert_tree_inv_def] \\ drule_then assume_tac is_last_ix_imps \\ gs [] - \\ simp [heap_array_sub_left, heap_array_sub_right] + \\ simp [heap_array_sub_left_bind_eq, heap_array_sub_right_bind_eq] \\ rpt TOP_CASE_TAC \\ simp [update_heap_array_mk_st_eq, st_ex_ignore_bind_simp] >- ( @@ -826,7 +860,7 @@ Proof ) \\ simp [sz_array_sub_bind_eq, return_bind_eq] \\ simp [ADD1] - \\ simp [to_two_exp_min_1, heap_array_sub_prev] + \\ simp [to_two_exp_min_1, heap_array_sub_prev_bind_eq] \\ irule bind_success_rdonly_eqI \\ qexists_tac `case t of ((Node t2x _ _, _) :: _) => ~ R t2x x /\ ~ (case q of Node _ (Node lx _ _) _ => R t2x lx | _ => F) /\ @@ -837,7 +871,7 @@ Proof \\ rw [] >- ( gs [tree_balanced_height_pos] - \\ simp [heap_array_sub_left, heap_array_sub_right] + \\ simp [heap_array_sub_left_bind_eq, heap_array_sub_right_bind_eq] \\ simp [ml_monadBaseTheory.monad_eqs] ) >- ( @@ -1003,7 +1037,7 @@ Proof \\ simp [st_ex_ignore_bind_simp] \\ irule_at Any bind_success_eqI \\ simp [update_sz_array_eq] - \\ dep_rewrite.DEP_REWRITE_TAC [heap_array_sub_curr] + \\ dep_rewrite.DEP_REWRITE_TAC [heap_array_sub_curr_bind_eq] \\ conj_asm1_tac >- ( fs [markerTheory.Abbrev_def] @@ -1016,7 +1050,7 @@ Proof >- ( rw [] \\ simp [return_bind_eq, to_two_exp_min_1] - \\ simp [heap_array_sub_prev |> Q.GEN `i` |> Q.SPEC `i - 1` + \\ simp [heap_array_sub_prev_bind_eq |> Q.GEN `i` |> Q.SPEC `i - 1` |> SIMP_RULE (srw_ss ()) [GSYM SUB_PLUS, ADD_COMM]] \\ simp [ml_monadBaseTheory.monad_eqs] \\ every_case_tac \\ fs [markerTheory.Abbrev_def] @@ -1062,7 +1096,7 @@ Proof \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [bs_tree_list_to_list_rec] \\ simp [sz_array_sub_bind_eq, ADD1] \\ gs [tree_balanced_height_pos, bs_tree_to_list_tree_rec, ADD1] - \\ simp [heap_array_sub_curr] + \\ simp [heap_array_sub_curr_bind_eq] (* \\ drule inv_trees_less_via_exp \\ simp [GSYM MAP_DROP] From 20ecc346f5d6a87a5844328bbc61ef6936c5c5dc Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 26 Feb 2026 21:55:21 +1100 Subject: [PATCH 15/39] Start cleaning up "pure" part --- ..._funScript.sml => heap_list_sortScript.sml} | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) rename basis/pure/{heap_sort_in_funScript.sml => heap_list_sortScript.sml} (98%) diff --git a/basis/pure/heap_sort_in_funScript.sml b/basis/pure/heap_list_sortScript.sml similarity index 98% rename from basis/pure/heap_sort_in_funScript.sml rename to basis/pure/heap_list_sortScript.sml index 807b694f81..62c3a2b8b9 100644 --- a/basis/pure/heap_sort_in_funScript.sml +++ b/basis/pure/heap_list_sortScript.sml @@ -1,13 +1,21 @@ (* - Heap-sort in an array, where the array is represented by a function. - Used to verify a stateful heap sort which uses a mutable array to - hold the heap contents during sorting, e.g. one written in CakeML. + A heap-sort variant that builds a list of exactly-balanced heaps. - Could potentially move out of CakeML to HOL4 sorting theories. + This is prototyped and verified as a standard recursive functional program. + + It is also presented as an in-array algorithm, where the list of heaps are + placed in segments of an array. + + This allows the one algorithm to be evaluated either via its pure functional + instance or as an in-place algorithm in CakeML. + + The heap segments all point in the correct direction, so, unlike a standard + in-array heap-sort, sorting a sorted array requires linear-time comparisons + and no data moves. *) -Theory heap_sort_in_fun +Theory heap_list_sort Ancestors list rich_list sorting container bag From 9228966c30b1924aa43ba6eab30044c7ed33c7dc Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Fri, 27 Feb 2026 12:17:46 +1100 Subject: [PATCH 16/39] Move monadic defs and equiv to basis/monadic --- basis/monadic/Holmakefile | 14 + basis/monadic/README.md | 7 + .../monadic/heap_list_sort_monadicScript.sml | 1150 +++++++++++++++++ basis/monadic/readmePrefix | 4 + basis/pure/heap_list_sortScript.sml | 589 ++------- 5 files changed, 1260 insertions(+), 504 deletions(-) create mode 100644 basis/monadic/Holmakefile create mode 100644 basis/monadic/README.md create mode 100644 basis/monadic/heap_list_sort_monadicScript.sml create mode 100644 basis/monadic/readmePrefix diff --git a/basis/monadic/Holmakefile b/basis/monadic/Holmakefile new file mode 100644 index 0000000000..9c77a7efce --- /dev/null +++ b/basis/monadic/Holmakefile @@ -0,0 +1,14 @@ +INCLUDES = $(CAKEMLDIR)/misc \ + $(CAKEMLDIR)/translator/monadic/monad_base/ + +all: $(DEFAULT_TARGETS) README.md +.PHONY: all + +README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml) +DIRS = $(wildcard */) +README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES) + $(CAKEMLDIR)/developers/readme_gen $(README_SOURCES) + +ifdef POLY +HOLHEAP = $(CAKEMLDIR)/misc/cakeml-heap +endif diff --git a/basis/monadic/README.md b/basis/monadic/README.md new file mode 100644 index 0000000000..d2732039d3 --- /dev/null +++ b/basis/monadic/README.md @@ -0,0 +1,7 @@ +Monadic definitions of stateful functions used in the basis + +These functions are generated and verified using a monad type, and are then +translated to imperative CakeML code by the monadic translator. + +[heap_list_sort_monadicScript.sml](heap_list_sort_monadicScript.sml): +Using the monadic translator to translate heap sorting functions. diff --git a/basis/monadic/heap_list_sort_monadicScript.sml b/basis/monadic/heap_list_sort_monadicScript.sml new file mode 100644 index 0000000000..528785fda0 --- /dev/null +++ b/basis/monadic/heap_list_sort_monadicScript.sml @@ -0,0 +1,1150 @@ +(* + Monadic variants of the heap-list sort functions, and proofs of equivalence. +*) + +Theory heap_list_sort_monadic +Ancestors + heap_list_sort ml_monadBase +Libs + preamble ml_monadBaseLib + +(* Part 1: Setup of types and infrastructure. *) + +(* The data type of the state. *) +Datatype: + state_refs = <| + heap_array : ( 'a ) list; + sz_array : num list; + |> +End + +(* Data type for the exceptions. Seems to be standard. *) +Datatype: + state_exn = Fail string | Subscript +End + +(* Setup to use monad translator constants and monad syntax. *) +val acc_fun_defs = define_monad_access_funs ``: 'a state_refs`` + +val acc_fun_unfolds = LIST_CONJ (flatten (map (fn (_, t1, t2) => [t1, t2]) acc_fun_defs)) + +val mr_manip_funs = define_MRarray_manip_funs acc_fun_defs ``Subscript`` ``Subscript`` + +val _ = ParseExtras.temp_tight_equality (); +val _ = monadsyntax.temp_add_monadsyntax (); + +Overload "monad_bind"[local] = ``st_ex_bind`` +Overload "monad_unitbind"[local] = ``st_ex_ignore_bind`` +Overload "monad_ignore_bind"[local] = ``st_ex_ignore_bind`` +Overload "return"[local] = ``st_ex_return`` + +(* Part 2: Definition of heap-list sort via "suffix encoded" balanced trees. + Every heap/tree is of power-of-two-minus-one size, with the largest element + at the end, and two equal-sized smaller trees before it. *) + +(* Positions of the left child in a suffix encoded balanced tree + of height ht. *) +Definition sfx_heap_left_def: + sfx_heap_left i ht = (i - (2 EXP (ht - 1))) +End + +(* Insert a value into a balanced suffix heap of height ht, replacing the + current top element which is at index i. *) +Definition insert_into_sfx_heap_def: + insert_into_sfx_heap R i ht x = if ht <= 1 + then update_heap_array i x + else do + l <- return (sfx_heap_left i ht); + r <- return (i - 1); + lx <- heap_array_sub l; + rx <- heap_array_sub r; + if R lx x /\ R rx x + then update_heap_array i x + else if R lx rx + then do + update_heap_array i rx; + insert_into_sfx_heap R r (ht - 1) x + od + else do + update_heap_array i lx; + insert_into_sfx_heap R l (ht - 1) x + od + od +End + +(* Insert a value into a sequence of balanced suffix heaps, heights stored + in positions [0 ..< j] of the sz_array. Replace the top elements of the + final heap, which is at index i. *) +Definition insert_into_sfx_heap_list_def: + insert_into_sfx_heap_list R i j x = + if j <= 1 then do + ht <- sz_array_sub (j - 1); + insert_into_sfx_heap R i ht x + od + else do + ht <- sz_array_sub (j - 1); + i2 <- return ((i + 1) - (2 EXP ht)); + t2x <- heap_array_sub i2; + cond1 <- return (~ R t2x x); + cond <- if cond1 /\ (1 < ht) + then do + l <- return (sfx_heap_left i ht); + r <- return (i - 1); + lx <- heap_array_sub l; + rx <- heap_array_sub r; + return (~ R t2x lx /\ ~ R t2x rx) + od + else return cond1; + if cond + then do + update_heap_array i t2x; + insert_into_sfx_heap_list R i2 (j - 1) x + od + else insert_into_sfx_heap R i ht x + od +End + +(* Expand the total size of a sequence of balanced suffix heaps from i to + i + 1 total elements, starting with j total heaps. *) +Definition add_to_sfx_heaps_step1_def: + add_to_sfx_heaps_step1 j = do + merge <- if j <= 1 + then return F + else do + n1 <- sz_array_sub (j - 1); + n2 <- sz_array_sub (j - 2); + return (n1 = n2); + od; + if merge + then do + n <- sz_array_sub (j - 2); + update_sz_array (j - 2) (n + 1); + return (j - 1); + od + else do + update_sz_array j 1; + return (j + 1); + od + od +End + +(* Expand from i to i + 1 elements, set the new element, and preserve the heap + invariants. *) +Definition add_to_sfx_heaps_def: + add_to_sfx_heaps R i j x = do + j' <- add_to_sfx_heaps_step1 j; + insert_into_sfx_heap_list R i j' x; + return j' + od +End + +(* Extend a list of suffix heaps by a list of values. *) +Definition add_all_to_sfx_heaps_def: + (add_all_to_sfx_heaps R i j [] = return (i, j)) /\ + (add_all_to_sfx_heaps R i j (x :: xs) = do + j <- add_to_sfx_heaps R i j x; + add_all_to_sfx_heaps R (i + 1) j xs; + od) +End + +(* Take an intact heap in the correct position and add it to the heap sequence, + i.e. ensure its top element is the overall top element. *) +Definition reinsert_tree_def: + reinsert_tree R i j ht = + do + update_sz_array j ht; + x <- heap_array_sub (i - 1); + upd <- if 0 < j then do + i2 <- return (i - (2 EXP ht)); + t2x <- heap_array_sub i2; + return (~ (R t2x x)) + od else return F; + if upd + then insert_into_sfx_heap_list R (i - 1) (j + 1) x + else return (); + od +End + +(* Reduce a sequence of suffix-encoded heaps to a list. *) +Definition sfx_trees_to_list_def: + sfx_trees_to_list R i j acc = + if i = 0 then return acc + else do + ht <- sz_array_sub (j - 1); + x <- heap_array_sub (i - 1); + if ht <= 1 then sfx_trees_to_list R (i - 1) (j - 1) (x :: acc) + else do + l <- return (sfx_heap_left i ht); + reinsert_tree R l (j - 1) (ht - 1); + reinsert_tree R (i - 1) j (ht - 1); + sfx_trees_to_list R (i - 1) (j + 1) (x :: acc) + od + od +End + +(* Compute an overapproximation of the base-2 logarithm of v *) +Definition above_log2_def: + above_log2 i v n = if n = 0n \/ v <= n + then i + else above_log2 (i + 1n) v (n * 2) +Termination + WF_REL_TAC `measure (\(i, v, n). (v - n))` +End + +(* Top-level sort function for now. This is then given a functional interface + by a "run" wrapper once more monadic translation apparatus is in place. *) +Definition sort_via_sfx_trees_worker_def: + sort_via_sfx_trees_worker R x xs = do + sz <- return (LENGTH xs); + alloc_heap_array (sz + 1) x; + sz_log <- return (above_log2 0 (sz + 1) 1); + alloc_sz_array (sz_log + 5) 0; + (i, j) <- add_all_to_sfx_heaps R 0 0 xs; + sfx_trees_to_list R i j [] + od +End + +(* Part 3. Proof that this monadic encoding computes the same as the pure heap + list sort implementation. *) + +(* 3.1: More setup *) + +Definition bs_tree_to_list_def: + (bs_tree_to_list 0 t = []) /\ + (bs_tree_to_list (SUC ht) t = + bs_tree_to_list ht (case t of Node _ l r => l | _ => t) ++ + bs_tree_to_list ht (case t of Node _ l r => r | _ => t) ++ + [case t of Node x l r => x] + ) +End + +Theorem bs_tree_to_list_tree_rec[local]: + (i = 0 ==> bs_tree_to_list i Empty_Tree = []) /\ + (0 < i ==> bs_tree_to_list i (Node x l r) = + bs_tree_to_list (i - 1) l ++ + bs_tree_to_list (i - 1) r ++ + [x]) +Proof + Cases_on `i` \\ simp [bs_tree_to_list_def] +QED + +Definition two_exp_min_1_def: + two_exp_min_1 i = (2n EXP i) - 1 +End + +Theorem two_exp_min_1_less_rec[local]: + 0 < i ==> two_exp_min_1 i = two_exp_min_1 (i - 1) + two_exp_min_1 (i - 1) + 1 +Proof + Cases_on `i` + \\ fs [two_exp_min_1_def, EXP] + \\ rw [SUB_RIGHT_ADD] +QED + +Theorem two_exp_min_1_rec[local]: + two_exp_min_1 0 = 0 /\ + two_exp_min_1 (SUC i) = two_exp_min_1 i + two_exp_min_1 i + 1 +Proof + simp [two_exp_min_1_less_rec] \\ simp [two_exp_min_1_def] +QED + +Theorem to_two_exp_min_1[local]: + (2n EXP i) = (two_exp_min_1 i + 1) +Proof + rw [two_exp_min_1_def, SUB_RIGHT_ADD] +QED + +Theorem LENGTH_bs_tree_to_list[local]: + ! i t. LENGTH (bs_tree_to_list i t) = two_exp_min_1 i +Proof + Induct + \\ simp [bs_tree_to_list_def, two_exp_min_1_rec] +QED + +Theorem LAST_bs_tree_to_list[local]: + 0 < ht ==> LAST (bs_tree_to_list ht t) = ( + case t of Node x _ _ => x) +Proof + Cases_on `ht` \\ simp [bs_tree_to_list_def, two_exp_min_1_rec] +QED + +Definition tree_balanced_height_def: + (tree_balanced_height i Empty_Tree = (i = 0n)) /\ + (tree_balanced_height i (Node x l r) = ( + (i > 0) /\ tree_balanced_height (i - 1) l /\ + tree_balanced_height (i - 1) r) + ) +End + +Theorem tree_balanced_height_0[local]: + (tree_balanced_height 0 t = (t = Empty_Tree)) +Proof + Cases_on `t` \\ simp [tree_balanced_height_def] +QED + +Theorem tree_balanced_height_eq_0[local]: + ht = 0 ==> (tree_balanced_height ht t = (t = Empty_Tree)) +Proof + Cases_on `t` \\ simp [tree_balanced_height_def] +QED + +Theorem tree_balanced_height_pos[local]: + 0 < ht ==> tree_balanced_height ht t = + (?x l r. t = Node x l r /\ tree_balanced_height (ht - 1) l /\ + tree_balanced_height (ht - 1) r) +Proof + Cases_on `t` \\ simp [tree_balanced_height_def] +QED + +Definition bs_tree_list_to_list_def: + bs_tree_list_to_list ts = + FLAT (MAP (\(t, i). bs_tree_to_list i t) (REVERSE ts)) +End + +Theorem bs_tree_list_to_list_rec[local]: + bs_tree_list_to_list (t_i :: ts) = ( + bs_tree_list_to_list ts ++ bs_tree_to_list (SND t_i) (FST t_i) + ) /\ + bs_tree_list_to_list [] = [] +Proof + simp [bs_tree_list_to_list_def] + \\ rpt (pairarg_tac \\ fs[]) +QED + +Theorem st_ex_ignore_bind_simp[local]: + st_ex_ignore_bind f g = st_ex_bind f (\_. g) +Proof + simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_ignore_bind_def] +QED + +(* +Theorem monad_simps[local] = LIST_CONJ + [fetch "-" "update_heap_array_def", fetch "-" "heap_array_sub_def", + ml_monadBaseTheory.monad_eqs, st_ex_ignore_bind_simp, + fetch "-" "update_sz_array_def", fetch "-" "sz_array_sub_def"] + +Theorem tree_len_simps_no_less[local] = LIST_CONJ + [tree_balanced_height_def, tree_balanced_height_0, + two_exp_min_1_rec, + LENGTH_bs_tree_to_list, bs_tree_to_list_def, + bs_tree_to_list_tree_rec, bs_tree_list_to_list_rec] + +Theorem tree_len_simps[local] = LIST_CONJ [tree_len_simps_no_less, + two_exp_min_1_less_rec] + +Theorem TAKE_DROP_eq_imp[local]: + !xs i j. TAKE i (DROP j xs) = ys ==> + i <= LENGTH ys ==> + ys = [] \/ (?xs_pre xs_post. xs = xs_pre ++ ys ++ xs_post /\ + j = LENGTH xs_pre /\ i = LENGTH ys) +Proof + Cases_on `ys = []` \\ simp [] + \\ rw [] + \\ qexists_tac `TAKE j xs` + \\ qexists_tac `DROP (i + j) xs` + \\ fs [GSYM TAKE_SUM] + \\ fs [LENGTH_TAKE_EQ] +QED + +Theorem TAKE_DROP_last_eq_imp[local]: + TAKE l (DROP ((i + 1) - l) xs) = ys /\ + i + 1 <= LENGTH xs /\ l <= i + 1 /\ + l <= LENGTH ys /\ 0 < l ==> + ?xs_pre xs_post. xs = xs_pre ++ ys ++ xs_post /\ + l = LENGTH ys /\ i = LENGTH xs_pre + (LENGTH ys - 1) +Proof + rpt strip_tac + \\ dxrule TAKE_DROP_eq_imp + \\ Cases_on `ys = []` \\ fs [] + \\ rw [] + \\ irule_at Any EQ_REFL + \\ simp [] +QED +*) + +Theorem two_exp_min_1_pos[local]: + (0 < two_exp_min_1 r) = (0 < r) +Proof + Cases_on `r` \\ simp [two_exp_min_1_rec] +QED + +Theorem MAP_SND_insert_trees_inv[local]: + !ts. MAP SND (insert_trees_inv R ts x) = MAP SND ts +Proof + Induct \\ simp [pairTheory.FORALL_PROD, insert_trees_inv_def] + \\ rw [] + \\ rpt (TOP_CASE_TAC \\ simp []) + \\ simp [] +QED + +Theorem MAP_LENGTH_insert_trees_inv[local]: + MAP (LENGTH o (\(t, n). bs_tree_to_list n t)) + (insert_trees_inv R ts x) = + MAP (LENGTH o (\(t, n). bs_tree_to_list n t)) ts +Proof + qspec_then `ts` (mp_tac o Q.AP_TERM `MAP two_exp_min_1`) MAP_SND_insert_trees_inv + \\ simp [MAP_MAP_o, o_DEF, UNCURRY, bs_tree_list_to_list_rec, LENGTH_bs_tree_to_list] +QED + +Theorem LENGTH_insert_trees_inv[local] = + Q.AP_TERM `LENGTH` (SPEC_ALL MAP_LENGTH_insert_trees_inv) + |> REWRITE_RULE [LENGTH_MAP] + +Theorem LENGTH_list_of_insert_trees[local]: + LENGTH (bs_tree_list_to_list (insert_trees_inv R ts x)) = + LENGTH (bs_tree_list_to_list ts) +Proof + simp [bs_tree_list_to_list_def, LENGTH_FLAT, MAP_MAP_o, MAP_REVERSE] + \\ simp [MAP_LENGTH_insert_trees_inv] +QED + +Theorem tree_to_list_unfold = LIST_CONJ [ + bs_tree_list_to_list_rec, bs_tree_to_list_tree_rec] + +Theorem LENGTH_add_to_heaps_step1_facts[local]: + 0 < LENGTH (add_to_heaps_step1 ts x) /\ + LENGTH (bs_tree_list_to_list (add_to_heaps_step1 ts x)) = + LENGTH (bs_tree_list_to_list ts) + 1 /\ + LENGTH (add_to_heaps_step1 ts x) <= LENGTH ts + 1 /\ + (MAP SND (add_to_heaps_step1 ts x) = MAP SND (add_to_heaps_step1 ts y)) = T /\ + (LENGTH (add_to_heaps_step1 ts x) = LENGTH (add_to_heaps_step1 ts y)) = T +Proof + simp [add_to_heaps_step1_def] + \\ rpt (TOP_CASE_TAC \\ fs [tree_to_list_unfold]) +QED + +Theorem inv_add_tree_step1[local]: + (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (add_to_heaps_step1 ts x) + ) /\ + (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) ==> + SORTED ($<=) (TAKE 2 (MAP SND (add_to_heaps_step1 ts x))) /\ + SORTED ($<) (MAP SND (DROP 1 (add_to_heaps_step1 ts x))) + ) +Proof + simp [add_to_heaps_step1_def] + \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def]) + \\ rpt (pairarg_tac \\ fs []) + \\ rw [] + \\ fs [] + \\ imp_res_tac SORTED_TL \\ fs [] + \\ Cases_on `t'` \\ fs [] +QED + +Theorem insert_trees_adj_with_inv[local]: + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> + insert_trees_inv R ((Node x_dc l r, n) :: ts) x = + insert_trees_inv R ((Node y_dc l r, n) :: ts) x +Proof + simp [insert_trees_inv_def] + \\ rpt (TOP_CASE_TAC \\ fs []) \\ rw [] \\ fs [tree_balanced_height_def] + \\ simp [insert_tree_inv_def] +QED + +Theorem insert_trees_adj_step1[local]: + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> + insert_trees_inv R (add_to_heaps_step1 ts x_dc) x = + insert_trees_inv R (add_to_heaps_step1 ts y_dc) x +Proof + simp [add_to_heaps_step1_def] + \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def]) + \\ rw [] + \\ irule insert_trees_adj_with_inv + \\ simp [] +QED + +Theorem LENGTH_to_list_add_to_heaps[local]: + LENGTH (bs_tree_list_to_list (add_to_heaps R ts x)) = + LENGTH (bs_tree_list_to_list ts) + 1 +Proof + simp [add_to_heaps_def, LENGTH_list_of_insert_trees, + LENGTH_add_to_heaps_step1_facts] +QED + +Theorem insert_tree_inv_balance_inv[local]: + !t ht. tree_balanced_height ht t ==> + tree_balanced_height ht (insert_tree_inv R t x) +Proof + Induct \\ simp [insert_tree_inv_def] + \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def]) +QED + +Theorem insert_trees_inv_balance_inv[local]: + !ts x. EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (insert_trees_inv R ts x) +Proof + Induct \\ simp [pairTheory.FORALL_PROD, insert_trees_inv_def] + \\ rw [] + \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def, insert_tree_inv_balance_inv]) +QED + +Theorem inv_add_to_heaps[local]: + (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (add_to_heaps R ts x) + ) /\ + (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) ==> + SORTED ($<=) (TAKE 2 (MAP SND (add_to_heaps R ts x))) /\ + SORTED ($<) (MAP SND (DROP 1 (add_to_heaps R ts x))) + ) +Proof + simp [add_to_heaps_def, MAP_SND_insert_trees_inv, MAP_DROP] + \\ simp [GSYM MAP_DROP, inv_add_tree_step1, insert_trees_inv_balance_inv] +QED + +Theorem sum_lengths_greater_equal_exp[local]: + ! ts n. EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED $< (MAP SND ts) /\ + ts <> [] /\ n <= SND (HD ts) /\ 1 <= n ==> + ((2 EXP (LENGTH ts + (n - 1))) - 1) <= LENGTH (bs_tree_list_to_list ts) +Proof + Induct \\ rw [] + \\ fs [tree_to_list_unfold, LENGTH_bs_tree_to_list] + \\ pairarg_tac \\ fs [] + \\ first_x_assum (qspec_then `SUC n` mp_tac) + \\ imp_res_tac SORTED_TL + \\ simp [EXP] + \\ Cases_on `ts` \\ fs [] + >- ( + simp [tree_to_list_unfold] + \\ simp [two_exp_min_1_def, LEFT_SUB_DISTRIB] + \\ simp [GSYM EXP, ADD1] + \\ rw [SUB_RIGHT_ADD] + ) + >- ( + rw [] + \\ gs [ADD1] + ) +QED + +Theorem inv_trees_less_via_exp[local]: + EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED $< (DROP 1 (MAP SND ts)) /\ + LENGTH (bs_tree_list_to_list ts) < 2 ** lg /\ + lg + i + 2 <= bd ==> + LENGTH ts + i < bd +Proof + rw [] + \\ fs [GSYM MAP_DROP] + \\ drule_at (Pat `SORTED _ _`) sum_lengths_greater_equal_exp + \\ simp [EVERY_DROP] + \\ disch_then (qspec_then `1` mp_tac) + \\ Cases_on `LENGTH ts <= 1` \\ fs [] + \\ impl_tac + >- ( + fs [HD_DROP, EVERY_EL, UNCURRY] + \\ first_x_assum (qspec_then `1` mp_tac) + \\ simp [] + ) + \\ disch_tac + \\ subgoal `2n ** (LENGTH ts - 1) < 2 ** lg` + >- ( + drule_then irule LESS_EQ_LESS_TRANS + \\ Cases_on `ts` \\ fs [tree_to_list_unfold] + \\ pairarg_tac \\ fs [] + \\ gs [tree_balanced_height_pos, tree_to_list_unfold] + ) + \\ fs [] +QED + +Theorem LENGTH_add_heap_to_heaps_facts[local]: + tree_balanced_height ht t /\ 0 < ht ==> + LENGTH (add_heap_to_heaps R ts t ht) = LENGTH ts + 1 + /\ + MAP SND (add_heap_to_heaps R ts t ht) = ht :: MAP SND ts + /\ + LENGTH (bs_tree_list_to_list (add_heap_to_heaps R ts t ht)) = + LENGTH (bs_tree_list_to_list ts) + LENGTH (bs_tree_to_list ht t) /\ + (EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) (add_heap_to_heaps R ts t ht) + ) +Proof + rw [add_heap_to_heaps_def] + \\ fs [tree_to_list_unfold, tree_balanced_height_pos] + \\ BasicProvers.EVERY_CASE_TAC \\ fs [] + \\ simp [LENGTH_insert_trees_inv, MAP_SND_insert_trees_inv, + LENGTH_list_of_insert_trees, tree_to_list_unfold, tree_balanced_height_def, + insert_trees_inv_balance_inv] +QED + +Theorem above_log2_is_above_ind[local]: + ! i v n. n = 2 EXP i ==> v <= 2 ** (above_log2 i v n) +Proof + recInduct above_log2_ind + \\ rw [] \\ fs [] + \\ ONCE_REWRITE_TAC [above_log2_def] + \\ rw [] \\ fs [EXP_ADD] +QED + +Theorem add_values_to_heaps_facts[local]: + !xs ts. + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> + LENGTH (bs_tree_list_to_list (add_values_to_heaps R ts xs)) = + LENGTH (bs_tree_list_to_list ts) + LENGTH xs /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) (add_values_to_heaps R ts xs) /\ + (SORTED $< (MAP SND (DROP 1 ts)) /\ SORTED $<= (TAKE 2 (MAP SND ts)) ==> + SORTED $< (MAP SND (DROP 1 (add_values_to_heaps R ts xs))) /\ + SORTED $<= (TAKE 2 (MAP SND (add_values_to_heaps R ts xs)))) +Proof + Induct \\ simp [tree_to_list_unfold, add_values_to_heaps_def] + \\ rw [] + \\ simp [inv_add_to_heaps, LENGTH_to_list_add_to_heaps] + \\ fs [IMP_CONJ_THM, FORALL_AND_THM] +QED + +(* 3.2: State/Heap-list equivalence setup. *) + +Definition mk_st_def: + mk_st hps szs = + (<| + sz_array := REVERSE (FST szs) ++ SND szs; + heap_array := bs_tree_list_to_list (FST hps) ++ SND hps + |> : 'a state_refs) +End + +Definition is_last_ix_def: + is_last_ix szs i = (SUM (MAP two_exp_min_1 szs) = i + 1) +End + +Theorem is_last_ix_eq_min_1: + is_last_ix szs i ==> i = SUM (MAP two_exp_min_1 szs) - 1 +Proof + simp [is_last_ix_def] +QED + +Theorem bind_success_eqI: + m st = (M_success v, st2) /\ f v st2 = rhs ==> + st_ex_bind m f st = rhs +Proof + simp [ml_monadBaseTheory.st_ex_bind_def] +QED + +Theorem bind_success_rdonly_eqI = + Q.INST [`st2` |-> `st`] bind_success_eqI + +Theorem mk_st_node_split_r: + 0 < ht ==> + mk_st ((Node x l r, ht) :: hps, oths) szs = + mk_st ((r, ht - 1) :: (l, ht - 1) :: hps, x :: oths) szs +Proof + simp [mk_st_def, tree_to_list_unfold] +QED + +Theorem mk_st_node_split_l: + 0 < ht ==> + mk_st ((Node x l r, ht) :: hps, oths) szs = + mk_st ((l, ht - 1) :: hps, bs_tree_to_list (ht - 1) r ++ x :: oths) szs +Proof + simp [mk_st_def, tree_to_list_unfold] +QED + +Theorem mk_st_move_others: + mk_st ((t, ht) :: hps, oths) szs_pair = + mk_st (hps, bs_tree_to_list ht t ++ oths) szs_pair /\ + mk_st hps_pair (n :: szs, sz_oths) = + mk_st hps_pair (szs, n :: sz_oths) +Proof + simp [mk_st_def, tree_to_list_unfold] +QED + +Theorem LENGTH_bs_tree_list_to_list_eq_SUM[local]: + LENGTH (bs_tree_list_to_list ts) = SUM (MAP two_exp_min_1 (MAP SND ts)) +Proof + simp [bs_tree_list_to_list_def, LENGTH_FLAT, MAP_MAP_o, o_DEF] + \\ simp [UNCURRY, LENGTH_bs_tree_to_list, MAP_REVERSE, SUM_REVERSE] +QED + +Theorem heap_array_sub_curr_bind_eq: + is_last_ix (ht :: MAP SND hps) i /\ 0 < ht ==> + st_ex_bind (heap_array_sub i) f + (mk_st ((Node x l r, ht) :: hps, oths) szs) = + f x (mk_st ((Node x l r, ht) :: hps, oths) szs) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "heap_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, tree_to_list_unfold, LENGTH_bs_tree_to_list] + \\ fs [is_last_ix_def, LENGTH_bs_tree_list_to_list_eq_SUM, two_exp_min_1_less_rec, + EL_APPEND1, EL_APPEND2, LENGTH_bs_tree_to_list, EL_CONS_IF] +QED + +Theorem is_last_ix_imps: + is_last_ix (ht :: hts) i ==> + (1 < ht ==> is_last_ix (ht - 1 :: hts) (sfx_heap_left i ht)) /\ + (1 < ht ==> is_last_ix (ht - 1 :: ht - 1 :: hts) (i - 1)) /\ + (0 < LENGTH hts /\ 0 < HD hts ==> is_last_ix hts (i - two_exp_min_1 ht)) +Proof + fs [is_last_ix_def] + \\ rw [] + \\ fs [sfx_heap_left_def, to_two_exp_min_1, two_exp_min_1_less_rec] + \\ Cases_on `hts` \\ fs [] + \\ fs [sfx_heap_left_def, to_two_exp_min_1, two_exp_min_1_less_rec] +QED + +Theorem heap_array_sub_left_bind_eq: + is_last_ix (ht :: MAP SND hps) i /\ 1 < ht ==> + st_ex_bind (heap_array_sub (sfx_heap_left i ht)) f + (mk_st ((Node x (Node lx ll lr) r, ht) :: hps, oths) szs) = + f lx (mk_st ((Node x (Node lx ll lr) r, ht) :: hps, oths) szs) +Proof + rw [] + \\ imp_res_tac is_last_ix_imps + \\ fs [] + \\ simp [Once mk_st_node_split_l] + \\ simp [heap_array_sub_curr_bind_eq] + \\ simp [mk_st_node_split_l] +QED + +Theorem heap_array_sub_right_bind_eq: + is_last_ix (ht :: MAP SND hps) i /\ 1 < ht ==> + st_ex_bind (heap_array_sub (i - 1)) f + (mk_st ((Node x l (Node rx rl rr), ht) :: hps, oths) szs) = + f rx (mk_st ((Node x l (Node rx rl rr), ht) :: hps, oths) szs) +Proof + rw [] + \\ imp_res_tac is_last_ix_imps + \\ fs [] + \\ simp [Once mk_st_node_split_r] + \\ simp [heap_array_sub_curr_bind_eq] + \\ simp [mk_st_node_split_r] +QED + +Theorem heap_array_sub_prev_bind_eq: + is_last_ix (ht :: MAP SND hps) i /\ 0 < LENGTH hps /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) hps ==> + st_ex_bind (heap_array_sub (i - two_exp_min_1 ht)) f + (mk_st ((t, ht) :: hps, oths) szs) = + f (case hps of (Node x _ _, _) :: _ => x) (mk_st ((t, ht) :: hps, oths) szs) +Proof + rw [] + \\ imp_res_tac is_last_ix_imps + \\ fs [] + \\ simp [mk_st_move_others] + \\ Cases_on `HD hps` \\ Cases_on `hps` \\ fs [] + \\ gs [tree_balanced_height_pos] + \\ simp [heap_array_sub_curr_bind_eq] +QED + +Theorem update_heap_array_mk_st_eq: + is_last_ix (ht :: MAP SND hps) i /\ 0 < ht ==> + update_heap_array i x (mk_st ((Node x_dc l r, ht) :: hps, oths) szs) = + (M_success (), mk_st ((Node x l r, ht) :: hps, oths) szs) +Proof + simp [fetch "-" "update_heap_array_def", ml_monadBaseTheory.monad_eqs] + \\ rw [is_last_ix_def, mk_st_def] + \\ fs [tree_to_list_unfold, LENGTH_bs_tree_to_list, + LENGTH_bs_tree_list_to_list_eq_SUM, LUPDATE_APPEND, + two_exp_min_1_less_rec, LUPDATE_DEF] +QED + +Theorem return_bind_eq: + st_ex_bind (return v) f = f v +Proof + simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] +QED + +Theorem sz_array_sub_bind_eq: + i < LENGTH szs ==> + st_ex_bind (sz_array_sub i) f (mk_st hps (szs, oths)) = + f (EL (LENGTH szs - (i + 1)) szs) (mk_st hps (szs, oths)) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "sz_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, EL_APPEND1, EL_REVERSE, PRE_SUB1] +QED + +Theorem update_sz_array_eq: + i < LENGTH szs ==> + update_sz_array i x (mk_st hps (szs, oths)) = + (M_success (), mk_st hps (LUPDATE x (LENGTH szs - (i + 1)) szs, oths)) +Proof + rw [] + \\ simp [fetch "-" "update_sz_array_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def] + \\ qspecl_then [`REVERSE szs`, `i`] mp_tac LESS_LENGTH + \\ simp [listTheory.SWAP_REVERSE_SYM] + \\ rw [] + \\ simp [LUPDATE_APPEND1, LUPDATE_APPEND2, LUPDATE_DEF] +QED + +(* 3.3: Proofs of equivalence *) + +Theorem insert_into_sfx_heap_eq: + ! ht hps oths t R i x st. + is_last_ix (ht :: MAP SND hps) i /\ ht > 0 /\ + tree_balanced_height ht t ==> + insert_into_sfx_heap R i ht x (mk_st ((t, ht) :: hps, oths) szs) = + (M_success (), (mk_st ((insert_tree_inv R t x, ht) :: hps, oths) szs)) +Proof + Induct + \\ simp [ADD1] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] + \\ simp [tree_balanced_height_pos] + \\ rw [] + >- ( + Cases_on `ht` \\ fs [tree_balanced_height_0] + \\ simp [insert_tree_inv_def, update_heap_array_mk_st_eq] + ) + >- ( + simp [return_bind_eq] + \\ gs [tree_balanced_height_pos] + \\ ONCE_REWRITE_TAC [insert_tree_inv_def] + \\ drule_then assume_tac is_last_ix_imps + \\ gs [] + \\ simp [heap_array_sub_left_bind_eq, heap_array_sub_right_bind_eq] + \\ rpt TOP_CASE_TAC + \\ simp [update_heap_array_mk_st_eq, st_ex_ignore_bind_simp] + >- ( + simp [st_ex_ignore_bind_simp] + \\ irule bind_success_eqI + \\ simp [update_heap_array_mk_st_eq] + \\ simp [Once mk_st_node_split_r] + \\ simp [mk_st_node_split_r] + ) + >- ( + simp [st_ex_ignore_bind_simp] + \\ irule bind_success_eqI + \\ simp [update_heap_array_mk_st_eq] + \\ simp [Once mk_st_node_split_l] + \\ simp [mk_st_node_split_l] + ) + ) +QED + +Theorem insert_into_sfx_heap_list_eq: + ! j ts R i x oths szs. + j = LENGTH ts /\ + is_last_ix (MAP SND ts) i /\ + 0 < j /\ EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> + insert_into_sfx_heap_list R i j x (mk_st (ts, oths) (MAP SND ts, szs)) = + (M_success (), mk_st (insert_trees_inv R ts x, oths) (MAP SND ts, szs)) +Proof + Induct + \\ simp [] + \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_list_def] + \\ rpt strip_tac + \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [] + \\ gs [ADD1, TAKE_SUM] + \\ simp [insert_trees_inv_def] + \\ rw [] + >- ( + Cases_on `t` \\ fs [] + \\ simp [sz_array_sub_bind_eq, return_bind_eq] + \\ simp [insert_into_sfx_heap_eq] + ) + \\ simp [sz_array_sub_bind_eq, return_bind_eq] + \\ simp [ADD1] + \\ simp [to_two_exp_min_1, heap_array_sub_prev_bind_eq] + \\ irule bind_success_rdonly_eqI + \\ qexists_tac `case t of ((Node t2x _ _, _) :: _) => + ~ R t2x x /\ ~ (case q of Node _ (Node lx _ _) _ => R t2x lx | _ => F) /\ + ~ (case q of Node _ _ (Node rx _ _) => R t2x rx | _ => F) | _ => F` + \\ conj_tac + >- ( + Cases_on `HD t` \\ Cases_on `t` \\ fs [] + \\ rw [] + >- ( + gs [tree_balanced_height_pos] + \\ simp [heap_array_sub_left_bind_eq, heap_array_sub_right_bind_eq] + \\ simp [ml_monadBaseTheory.monad_eqs] + ) + >- ( + simp [ml_monadBaseTheory.monad_eqs] + \\ gs [tree_balanced_height_pos, tree_balanced_height_eq_0] + ) + ) + \\ simp [] + \\ TOP_CASE_TAC + >- ( + gs [tree_balanced_height_pos] + \\ simp [st_ex_ignore_bind_simp] + \\ irule bind_success_eqI + \\ simp [update_heap_array_mk_st_eq] + \\ simp [mk_st_move_others] + \\ drule_then assume_tac is_last_ix_imps + \\ gs [] + \\ Cases_on `HD t` \\ Cases_on `t` \\ fs [] + \\ gs [tree_balanced_height_pos] + \\ simp [insert_trees_inv_def, mk_st_move_others] + ) + >- ( + simp [insert_into_sfx_heap_eq] + \\ Cases_on `HD t` \\ Cases_on `t` \\ fs [] + \\ gs [tree_balanced_height_pos] + ) +QED + +Theorem add_to_sfx_heaps_step1_eq: + j = LENGTH ts /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + 0 < LENGTH oth_szs ==> + ? oth_szs2. + let ts2 = add_to_heaps_step1 ts x in + add_to_sfx_heaps_step1 j (mk_st (ts, x :: oths) (MAP SND ts, oth_szs)) = + (M_success (LENGTH ts2), mk_st (ts2, oths) (MAP SND ts2, oth_szs2)) /\ + LENGTH ts2 + LENGTH oth_szs2 = LENGTH ts + LENGTH oth_szs +Proof + rw [] + \\ simp [add_to_sfx_heaps_step1_def, add_to_heaps_step1_def] + \\ irule_at Any bind_success_rdonly_eqI + \\ qexists_tac `case ts of (_, n1) :: (_, n2) :: _ => n1 = n2 | _ => F` + \\ simp [GSYM PULL_EXISTS] + \\ conj_tac + >- ( + every_case_tac \\ fs [] + \\ simp [sz_array_sub_bind_eq, ADD1] + \\ simp [ml_monadBaseTheory.monad_eqs] + ) + \\ TOP_CASE_TAC + >- ( + every_case_tac \\ fs [] + \\ simp [sz_array_sub_bind_eq, ADD1, st_ex_ignore_bind_simp] + \\ irule_at Any bind_success_eqI + \\ simp [update_sz_array_eq, ml_monadBaseTheory.monad_eqs] + \\ simp [ADD1, LUPDATE_DEF] + \\ simp [mk_st_node_split_r, mk_st_move_others] + \\ irule_at Any EQ_REFL + \\ simp [] + ) + >- ( + simp [st_ex_ignore_bind_simp] + \\ irule_at Any bind_success_eqI + \\ Cases_on `oth_szs` \\ fs [] + \\ simp [GSYM mk_st_move_others] + \\ simp [update_sz_array_eq, ml_monadBaseTheory.monad_eqs] + \\ simp [ADD1, LUPDATE_DEF] + \\ every_case_tac \\ fs [] + \\ simp [mk_st_move_others, bs_tree_to_list_tree_rec] + \\ REWRITE_TAC [GSYM APPEND_ASSOC, APPEND] + \\ irule_at Any EQ_REFL + \\ simp [] + ) +QED + +Theorem add_to_sfx_heaps_eq: + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + 0 < LENGTH oth_szs /\ 0 < LENGTH oths ==> + let ts2 = add_to_heaps R ts x in + ? oth_szs2. + add_to_sfx_heaps R i j x (mk_st (ts, oths) (MAP SND ts, oth_szs)) = + (M_success (LENGTH ts2), mk_st (ts2, TL oths) (MAP SND ts2, oth_szs2)) /\ + LENGTH ts2 + LENGTH oth_szs2 = LENGTH ts + LENGTH oth_szs +Proof + rpt strip_tac + \\ qspecl_then [`HD oths`, `TL oths`] mp_tac (Q.GENL [`x`, `oths`] add_to_sfx_heaps_step1_eq) + \\ Cases_on `oths` \\ fs [] + \\ rw [] + \\ simp [add_to_sfx_heaps_def, add_to_heaps_def] + \\ irule_at Any bind_success_eqI + \\ simp [st_ex_ignore_bind_simp] + \\ irule_at Any bind_success_eqI + \\ simp [ml_monadBaseTheory.monad_eqs, LENGTH_insert_trees_inv] + \\ dep_rewrite.DEP_REWRITE_TAC [insert_into_sfx_heap_list_eq] + \\ simp [LENGTH_add_to_heaps_step1_facts, inv_add_tree_step1, is_last_ix_def, + GSYM LENGTH_bs_tree_list_to_list_eq_SUM] + \\ simp [MAP_SND_insert_trees_inv] + \\ irule_at Any (Q.prove (`a = b /\ c = d ==> mk_st a c = mk_st b d`, simp [])) + \\ simp [] + \\ metis_tac [insert_trees_adj_step1, LENGTH_add_to_heaps_step1_facts] +QED + +Theorem add_all_to_sfx_heaps_eq: + !xs i j ts oths oth_szs. + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ + lg + 3 <= LENGTH ts + LENGTH oth_szs /\ + i + LENGTH xs < 2 EXP lg ==> + LENGTH xs <= LENGTH oths ==> + let ts2 = add_values_to_heaps R ts xs in + ? oth_szs2. + add_all_to_sfx_heaps R i j xs (mk_st (ts, oths) (MAP SND ts, oth_szs)) = + (M_success (LENGTH (bs_tree_list_to_list ts2), LENGTH ts2), + mk_st (ts2, DROP (LENGTH xs) oths) (MAP SND ts2, oth_szs2)) /\ + LENGTH ts2 + LENGTH oth_szs2 = LENGTH ts + LENGTH oth_szs +Proof + Induct + \\ simp [add_all_to_sfx_heaps_def, add_values_to_heaps_def] + >- ( + simp [ml_monadBaseTheory.monad_eqs] + \\ metis_tac [] + ) + \\ rpt strip_tac + \\ irule_at Any bind_success_eqI + \\ qmatch_goalsub_abbrev_tac `add_to_sfx_heaps R i j x` + \\ mp_tac add_to_sfx_heaps_eq + \\ fs [markerTheory.Abbrev_def] + \\ impl_keep_tac + >- ( + (* exponential argument that there is space in szs array *) + drule inv_trees_less_via_exp + \\ disch_then (qspecl_then [`lg`, `1`] mp_tac) + \\ simp [GSYM MAP_DROP] + \\ disch_then dxrule + \\ simp [] + ) + \\ rw [] \\ simp [] + \\ qmatch_goalsub_abbrev_tac `mk_st (ts2, _)` + \\ first_x_assum (qspecl_then [`ts2`, `TL oths`, `oth_szs2`] mp_tac) + \\ fs [markerTheory.Abbrev_def] + \\ simp [LENGTH_to_list_add_to_heaps, inv_add_to_heaps] + \\ rw [] \\ simp [] + \\ Cases_on `oths` \\ fs [] + \\ irule_at Any EQ_REFL + \\ simp [] +QED + +Theorem reinsert_tree_eq: + j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ((t, ht) :: ts)) /\ + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ + 0 < ht /\ tree_balanced_height ht t ==> + reinsert_tree R i j ht (mk_st ((t, ht) :: ts, oths) (dc :: MAP SND ts, oth_szs)) = + (let ts2 = add_heap_to_heaps R ts t ht in + (M_success (), mk_st (ts2, oths) (MAP SND ts2, oth_szs))) +Proof + simp [reinsert_tree_def, add_heap_to_heaps_def] + \\ rw [] + \\ gs [tree_balanced_height_pos] + \\ qmatch_goalsub_abbrev_tac `mk_st (COND tree_cond _ _, _)` + \\ simp [st_ex_ignore_bind_simp] + \\ irule_at Any bind_success_eqI + \\ simp [update_sz_array_eq] + \\ dep_rewrite.DEP_REWRITE_TAC [heap_array_sub_curr_bind_eq] + \\ conj_asm1_tac + >- ( + fs [markerTheory.Abbrev_def] + \\ simp [is_last_ix_def, LENGTH_bs_tree_list_to_list_eq_SUM] + \\ fs [two_exp_min_1_less_rec] + ) + \\ irule_at Any bind_success_rdonly_eqI + \\ qexists_tac `~ tree_cond` + \\ conj_tac + >- ( + rw [] + \\ simp [return_bind_eq, to_two_exp_min_1] + \\ simp [heap_array_sub_prev_bind_eq |> Q.GEN `i` |> Q.SPEC `i - 1` + |> SIMP_RULE (srw_ss ()) [GSYM SUB_PLUS, ADD_COMM]] + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ every_case_tac \\ fs [markerTheory.Abbrev_def] + \\ gs [tree_balanced_height_pos] + ) + \\ rw [] + >- ( + simp [ADD1, LUPDATE_DEF] + \\ qmatch_goalsub_abbrev_tac `mk_st (tt :: ts, _)` + \\ qspecl_then [`j`, `tt :: ts`] (mp_tac o Q.GEN `j`) insert_into_sfx_heap_list_eq + \\ fs [markerTheory.Abbrev_def, tree_balanced_height_def, ADD1] + \\ simp [MAP_SND_insert_trees_inv] + ) + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ simp [ADD1, LUPDATE_DEF] +QED + +Theorem sfx_trees_to_list_eq: + !i j acc ts oths oth_szs. + EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ + SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ + LENGTH ts = j /\ LENGTH (bs_tree_list_to_list ts) = i /\ + lg + 4 <= LENGTH ts + LENGTH oth_szs /\ + i < 2 EXP lg ==> + ?st'. sfx_trees_to_list R i j acc (mk_st (ts, oths) (MAP SND ts, oth_szs)) = + (M_success (heaps_to_list R ts acc), st') +Proof + Induct + \\ REWRITE_TAC [] + \\ ONCE_REWRITE_TAC [sfx_trees_to_list_def] + >- ( + rw [] + \\ Cases_on `ts` \\ fs [] + \\ simp [ml_monadBaseTheory.monad_eqs, heaps_to_list_def] + \\ rpt (pairarg_tac \\ fs []) \\ gs [tree_to_list_unfold, tree_balanced_height_pos] + ) + \\ rw [] + \\ subgoal `is_last_ix (MAP SND ts) i` + >- ( + fs [is_last_ix_def, ADD1] + \\ fs [LENGTH_bs_tree_list_to_list_eq_SUM] + ) + \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [bs_tree_list_to_list_rec] + \\ simp [sz_array_sub_bind_eq, ADD1] + \\ gs [tree_balanced_height_pos, bs_tree_to_list_tree_rec, ADD1] + \\ simp [heap_array_sub_curr_bind_eq] +(* + \\ drule inv_trees_less_via_exp + \\ simp [GSYM MAP_DROP] + \\ disch_then (qspecl_then [`lg`, `2`] mp_tac) +*) + \\ subgoal `SORTED $<= (TAKE 2 (MAP SND t)) ∧ SORTED $< (DROP 1 (MAP SND t))` + >- ( + Cases_on `TL t` \\ Cases_on `t` \\ fs [] + ) + \\ rw [] + >- ( + gs [tree_balanced_height_eq_0] + \\ simp [mk_st_move_others, bs_tree_to_list_tree_rec, heaps_to_list_def, + add_heap_to_heaps_def] + \\ first_x_assum irule + \\ fs [bs_tree_to_list_tree_rec, MAP_DROP] + ) + >- ( + simp [st_ex_ignore_bind_simp, return_bind_eq] + \\ simp [mk_st_node_split_l] + \\ simp [ml_monadBaseTheory.monad_eqs] + \\ dep_rewrite.DEP_REWRITE_TAC [reinsert_tree_eq] + \\ qpat_x_assum `_ = _ + 1n` (assume_tac o GSYM) + \\ simp [MAP_DROP, sfx_heap_left_def, bs_tree_list_to_list_rec, + LENGTH_bs_tree_to_list, to_two_exp_min_1] + \\ Cases_on `oth_szs` + >- ( + (* log/exp proof there is still a spare sz slot *) + gs [] + \\ drule inv_trees_less_via_exp + \\ disch_then (qspecl_then [`lg`, `2`] mp_tac) + \\ simp [] + \\ disch_then drule + \\ simp [] + ) + \\ simp [GSYM mk_st_move_others] + \\ dep_rewrite.DEP_REWRITE_TAC [reinsert_tree_eq] + \\ simp [LENGTH_add_heap_to_heaps_facts, MAP_DROP, bs_tree_list_to_list_rec] + \\ conj_tac + >- ( + Cases_on `t` \\ fs [] + ) + \\ qmatch_goalsub_abbrev_tac `sfx_trees_to_list _ _ _ acc2 (mk_st (ts, oths2) (_, oth_szs2))` + \\ first_x_assum (qspecl_then [`acc2`, `ts`, `oths2`, `oth_szs2`] mp_tac) + \\ fs [markerTheory.Abbrev_def, LENGTH_add_heap_to_heaps_facts, ADD1, MAP_DROP] + \\ impl_tac + >- ( + Cases_on `t` \\ fs [] + ) + \\ rw [] \\ simp [] + \\ simp [heaps_to_list_def] + ) +QED + +Theorem sort_via_sfx_trees_worker_eq: + FST (sort_via_sfx_trees_worker R x xs st) = M_success (heap_list_sort R xs) +Proof + simp [sort_via_sfx_trees_worker_def] + \\ simp [FST_EQ_EQUIV, st_ex_ignore_bind_simp, return_bind_eq] + \\ simp [fetch "-" "alloc_heap_array_def", fetch "-" "alloc_sz_array_def", + ml_monadBaseTheory.monad_eqs, st_ex_ignore_bind_simp] + \\ qmatch_goalsub_abbrev_tac `add_all_to_sfx_heaps _ _ _ xs st` + \\ qspecl_then [`above_log2 0 (LENGTH xs + 1) 1`, `xs`, + `0`, `0`, `[]`, `st.heap_array`, `st.sz_array`] + mp_tac (add_all_to_sfx_heaps_eq |> Q.GEN `lg`) + \\ qspecl_then [`0`, `LENGTH xs + 1`, `1`] assume_tac above_log2_is_above_ind + \\ gs [markerTheory.Abbrev_def, bs_tree_list_to_list_rec, ADD1] + \\ simp [mk_st_def |> Q.SPEC `([], x)`, bs_tree_list_to_list_rec] + \\ rw [] \\ simp [] + \\ simp [heap_list_sort_def] + \\ irule sfx_trees_to_list_eq + \\ simp [add_values_to_heaps_facts] + \\ drule_at_then Any (irule_at Any) LESS_LESS_EQ_TRANS + \\ simp [tree_to_list_unfold] +QED + diff --git a/basis/monadic/readmePrefix b/basis/monadic/readmePrefix new file mode 100644 index 0000000000..12720152a8 --- /dev/null +++ b/basis/monadic/readmePrefix @@ -0,0 +1,4 @@ +Monadic definitions of stateful functions used in the basis + +These functions are generated and verified using a monad type, and are then +translated to imperative CakeML code by the monadic translator. diff --git a/basis/pure/heap_list_sortScript.sml b/basis/pure/heap_list_sortScript.sml index 62c3a2b8b9..3ba0d30459 100644 --- a/basis/pure/heap_list_sortScript.sml +++ b/basis/pure/heap_list_sortScript.sml @@ -19,444 +19,6 @@ Theory heap_list_sort Ancestors list rich_list sorting container bag - -Definition heap_inv_def: - heap_inv R sz hp = (! i. 1n < i /\ i <= sz ==> R (hp (i DIV 2)) (hp i)) -End - -Theorem heap_inv_thm = hd (RES_CANON heap_inv_def) - -Theorem div_2_idem_lemma[local]: - (i = i DIV 2) = (i = 0) -Proof - qspec_then `i` assume_tac arithmeticTheory.ODD_OR_EVEN - \\ fs [] -QED - -Theorem heap_inv_min: - heap_inv R sz hp ==> - transitive R ==> - reflexive R ==> - 1 <= i /\ i <= sz ==> - R (hp 1) (hp i) -Proof - measureInduct_on `I i` - \\ rw [] - \\ fs [] - \\ Cases_on `i = 1` - \\ fs [relationTheory.reflexive_def] - \\ fs [relationTheory.transitive_def] - \\ first_x_assum irule - \\ qexists_tac `hp (i DIV 2)` - \\ drule_then (simp o single) heap_inv_thm - \\ first_x_assum irule - \\ simp [arithmeticTheory.X_LE_DIV] -QED - -Theorem heap_inv_upd: - heap_inv R sz hp ==> - 0 < i ==> - (1 < i ==> R (hp (i DIV 2)) x) ==> - (i * 2 <= sz ==> R x (hp (i * 2))) ==> - (i * 2 + 1 <= sz ==> R x (hp (i * 2 + 1))) ==> - heap_inv R sz (hp(|i |-> x|)) -Proof - rw [heap_inv_def] - \\ first_x_assum (qspec_then `i'` assume_tac) - \\ fs [combinTheory.UPDATE_def] - \\ rw [] \\ gs [div_2_idem_lemma] - \\ qspec_then `i'` assume_tac arithmeticTheory.ODD_OR_EVEN - \\ gs [] -QED - -Definition heap_contents_def: - heap_contents sz hp = LIST_TO_BAG (GENLIST (hp o ((+) 1)) sz) -End - -Theorem heap_contents_mem: - 0 < i /\ i <= sz ==> BAG_IN (hp i) (heap_contents sz hp) -Proof - rw [heap_contents_def, IN_LIST_TO_BAG, MEM_GENLIST] - \\ qexists_tac `i - 1` - \\ simp [] -QED - -Theorem heap_contents_upd: - heap_contents sz (hp(|i |-> x|)) = (if 0 < i /\ i <= sz - then BAG_UNION (heap_contents sz hp) {|x|} - {|hp i|} - else heap_contents sz hp) -Proof - simp [heap_contents_def] - \\ rw [] - >- ( - qspecl_then [`hp`, `sz - (i - 1)`, `i - 1`] - (mp_tac o Q.GEN `hp`) GENLIST_APPEND - \\ rw [LIST_TO_BAG_APPEND] - \\ subgoal `sz + 1 - i = SUC (sz - i)` - \\ simp [GENLIST_CONS, BAG_UNION_INSERT] - \\ ONCE_REWRITE_TAC [BAG_INSERT_commutes] - \\ simp [] - \\ irule (Q.prove (`(a = c) /\ (b = d) ==> (BAG_UNION a b = BAG_UNION c d)`, metis_tac [])) - \\ rw [] - \\ AP_TERM_TAC - \\ irule GENLIST_CONG - \\ simp [combinTheory.UPDATE_APPLY] - ) - >- ( - AP_TERM_TAC - \\ irule GENLIST_CONG - \\ simp [combinTheory.UPDATE_APPLY] - ) -QED - -Definition heap_insert_larger_def: - heap_insert_larger R sz i x hp = (if i = 0 then hp - else if (i * 2) + 1 <= sz /\ R (hp ((i * 2) + 1)) x /\ R (hp ((i * 2) + 1)) (hp (i * 2)) - then heap_insert_larger R sz ((i * 2) + 1) x (hp(|i |-> hp ((i * 2) + 1)|)) - else if i * 2 <= sz /\ R (hp (i * 2)) x /\ ((i * 2) + 1 <= sz ==> R (hp (i * 2)) (hp ((i * 2) + 1))) - then heap_insert_larger R sz (i * 2) x (hp(|i |-> hp (i * 2)|)) - else hp(| i |-> x |)) -Termination - qexists_tac `measure (\(_, sz, i, _). sz - i)` - \\ simp [] -End - -Theorem total_lemma[local]: - total R ==> ~ R x y ==> R y x -Proof - metis_tac [relationTheory.total_def] -QED - -Theorem transitive_lemma[local] = hd (RES_CANON relationTheory.transitive_def) - -Theorem heap_insert_larger_inv: - heap_inv R sz hp ==> R (hp i) x ==> 0 < i ==> i <= sz ==> - reflexive R ==> transitive R ==> total R ==> - heap_inv R sz (heap_insert_larger R sz i x hp) -Proof - qid_spec_tac `hp` - \\ measureInduct_on `(\i. sz - i) i` - \\ rw [] \\ fs [] - \\ drule_then (qspec_then `i` mp_tac) heap_inv_thm - \\ drule_then (qspec_then `i * 2` mp_tac) heap_inv_thm - \\ drule_then (qspec_then `i * 2 + 1` mp_tac) heap_inv_thm - \\ ONCE_REWRITE_TAC [heap_insert_larger_def] - \\ rw [] \\ fs [] - \\ TRY (first_x_assum irule) - \\ irule_at Any heap_inv_upd - \\ fs [relationTheory.reflexive_def, combinTheory.UPDATE_APPLY] - \\ rw [] - \\ drule_then (fsrw_tac [SFY_ss] o single) transitive_lemma - \\ drule_then (simp o single) total_lemma - \\ metis_tac [transitive_lemma, total_lemma] -QED - -Theorem heap_insert_larger_contents: - heap_contents sz (heap_insert_larger R sz i x hp) = - heap_contents sz (hp (|i |-> x|)) -Proof - qid_spec_tac `hp` - \\ measureInduct_on `(\i. sz - i) i` - \\ rw [] - \\ ONCE_REWRITE_TAC [heap_insert_larger_def] - \\ mp_tac heap_contents_mem - \\ rw [] \\ fs [] - \\ simp [heap_contents_upd, combinTheory.UPDATE_APPLY] - \\ simp [BAG_UNION_INSERT] - \\ fs [GSYM BAG_DIFF_INSERT_SUB_BAG] - \\ metis_tac [BAG_DIFF_INSERT_SUB_BAG, BAG_INSERT_commutes, - BAG_DIFF_2L, COMM_BAG_UNION, BAG_DIFF_INSERT_same, - BAG_DIFF_EMPTY] -QED - -Definition heap_pop_def: - heap_pop R sz hp = (hp 1, heap_insert_larger R (sz - 1) 1 (hp sz) hp) -End - -Theorem heap_pop_inv: - heap_inv R sz hp ==> 0 < sz ==> - reflexive R ==> transitive R ==> total R ==> - heap_inv R (sz - 1) (SND (heap_pop R sz hp)) -Proof - rw [heap_pop_def] - \\ Cases_on `sz = 1` - >- ( - simp [heap_inv_def] - ) - \\ irule heap_insert_larger_inv - \\ simp [] - \\ drule_then (irule_at Any) heap_inv_min - \\ simp [] - \\ fs [heap_inv_def] -QED - -Theorem heap_pop_contents: - (heap_pop R sz hp = (x, hp2)) ==> - 0 < sz ==> - (BAG_UNION {|x|} (heap_contents (sz - 1) hp2) = - heap_contents sz hp) -Proof - simp [heap_pop_def] - \\ rw [] - \\ simp [heap_insert_larger_contents, heap_contents_upd] - \\ Cases_on `sz = 1` \\ fs [] - \\ simp [heap_contents_def] - \\ Cases_on `sz` \\ fs [] - \\ simp [GENLIST, SNOC_APPEND, LIST_TO_BAG_APPEND] - \\ Cases_on `n` \\ fs [] - \\ simp [GENLIST_CONS] - \\ simp [GENLIST_CONS, BAG_UNION_INSERT] - \\ simp [arithmeticTheory.SUC_ONE_ADD] -QED - -Theorem heap_pop_min: - (heap_pop R sz hp = (x, hp2)) ==> - heap_inv R sz hp ==> 0 < sz ==> - reflexive R ==> transitive R ==> - (x = hp 1) /\ (0 < (sz - 1) ==> R x (hp2 1)) -Proof - rpt disch_tac - \\ subgoal `0 < sz - 1 ==> BAG_IN (hp2 1) (heap_contents sz hp)` - >- ( - drule heap_pop_contents - \\ simp [] - \\ disch_then (simp o single o GSYM) - \\ simp [heap_contents_def] - \\ Cases_on `sz - 1` \\ simp [] - \\ simp [GENLIST_CONS] - ) - \\ fs [heap_pop_def] - \\ rw [] - \\ fs [heap_contents_def, IN_LIST_TO_BAG, MEM_GENLIST] - \\ drule_then irule heap_inv_min - \\ simp [] -QED - -Definition heap_insert_smaller_def: - heap_insert_smaller R sz i x hp = (if i <= 1 then hp(| i |-> x |) - else if R x (hp (i DIV 2)) - then heap_insert_smaller R sz (i DIV 2) x (hp(|i |-> hp (i DIV 2)|)) - else hp(| i |-> x |)) -End - -Theorem heap_insert_smaller_inv: - heap_inv R sz hp ==> (i < sz ==> R x (hp i)) ==> 0 < i ==> i <= sz ==> - reflexive R ==> transitive R ==> total R ==> - heap_inv R sz (heap_insert_smaller R sz i x hp) -Proof - qid_spec_tac `hp` - \\ measureInduct_on `I i` - \\ rw [] \\ fs [] - \\ drule_then (qspec_then `i` mp_tac) heap_inv_thm - \\ drule_then (qspec_then `i * 2` mp_tac) heap_inv_thm - \\ drule_then (qspec_then `i * 2 + 1` mp_tac) heap_inv_thm - \\ ONCE_REWRITE_TAC [heap_insert_smaller_def] - \\ rw [] \\ fs [] - \\ TRY (first_x_assum irule) - \\ irule_at Any heap_inv_upd - \\ fs [relationTheory.reflexive_def, combinTheory.UPDATE_APPLY, div_2_idem_lemma] - \\ rw [] - \\ fs [dividesTheory.DIV_POS] - \\ drule_then (fsrw_tac [SFY_ss] o single) transitive_lemma - \\ drule_then (simp o single) total_lemma -QED - -Theorem heap_insert_smaller_contents: - 0 < i ==> i <= sz ==> - (heap_contents sz (heap_insert_smaller R sz i x hp) = heap_contents sz (hp (|i |-> x|))) -Proof - qid_spec_tac `hp` - \\ measureInduct_on `I i` - \\ rw [] \\ fs [] - \\ ONCE_REWRITE_TAC [heap_insert_smaller_def] - \\ rw [] - \\ fs [dividesTheory.DIV_POS] - \\ simp [heap_contents_upd, dividesTheory.DIV_POS, combinTheory.UPDATE_APPLY, div_2_idem_lemma] - \\ mp_tac heap_contents_mem - \\ rw [] \\ fs [] - >- ( - simp [BAG_UNION_INSERT] - \\ fs [GSYM BAG_DIFF_INSERT_SUB_BAG] - \\ metis_tac [BAG_DIFF_INSERT_SUB_BAG, BAG_INSERT_commutes, - BAG_DIFF_2L, COMM_BAG_UNION, BAG_DIFF_INSERT_same, - BAG_DIFF_EMPTY] - ) - \\ qspec_then `i` assume_tac arithmeticTheory.ODD_OR_EVEN - \\ gs [] -QED - -Definition heap_add_def: - heap_add R sz hp x = heap_insert_smaller R (sz + 1) (sz + 1) x - (hp(| sz + 1 |-> hp((sz + 1) DIV 2)|)) -End - -Theorem heap_add_inv: - heap_inv R sz hp ==> - reflexive R ==> transitive R ==> total R ==> - heap_inv R (sz + 1) (heap_add R sz hp x) -Proof - rw [heap_add_def] - \\ irule heap_insert_smaller_inv - \\ rw [heap_inv_def] - \\ drule_then (qspec_then `i` mp_tac) heap_inv_thm - \\ rw [] \\ gs [] - \\ rw [combinTheory.UPDATE_def] - \\ fs [div_2_idem_lemma, relationTheory.reflexive_def] - \\ qspec_then `i` assume_tac arithmeticTheory.ODD_OR_EVEN - \\ gs [] -QED - -Theorem heap_add_contents: - heap_contents (sz + 1) (heap_add R sz hp x) = - BAG_UNION {|x|} (heap_contents sz hp) -Proof - simp [heap_add_def, heap_insert_smaller_contents] - \\ simp [heap_contents_upd] - \\ simp [heap_contents_def] - \\ simp [GSYM arithmeticTheory.ADD1] - \\ simp [GENLIST, SNOC_APPEND, LIST_TO_BAG_APPEND] - \\ simp [arithmeticTheory.ADD1] - \\ simp [BAG_UNION_INSERT] - \\ ONCE_REWRITE_TAC [BAG_INSERT_commutes] - \\ simp [] -QED - -Definition heap_add_all_def: - (heap_add_all R sz [] hp = hp) /\ - (heap_add_all R sz (x :: xs) hp = - heap_add_all R (sz + 1) xs (heap_add R sz hp x)) -End - -Theorem heap_add_all_inv: - heap_inv R sz hp ==> - reflexive R ==> transitive R ==> total R ==> - (sz2 = sz + LENGTH xs) ==> - heap_inv R sz2 (heap_add_all R sz xs hp) -Proof - qid_spec_tac `hp` - \\ qid_spec_tac `sz` - \\ qid_spec_tac `sz2` - \\ Induct_on `xs` - \\ simp [heap_add_all_def] - \\ rw [] - \\ simp_tac bool_ss [arithmeticTheory.SUC_ONE_ADD, arithmeticTheory.ADD_ASSOC] - \\ first_x_assum irule - \\ simp [] - \\ irule heap_add_inv - \\ simp [] -QED - -Theorem heap_add_all_contents: - (sz2 = sz + LENGTH xs) ==> - (heap_contents sz2 (heap_add_all R sz xs hp) = - BAG_UNION (heap_contents sz hp) (LIST_TO_BAG xs)) -Proof - qid_spec_tac `hp` - \\ qid_spec_tac `sz` - \\ qid_spec_tac `sz2` - \\ Induct_on `xs` - \\ simp [heap_add_all_def] - \\ rw [] - \\ asm_simp_tac bool_ss [arithmeticTheory.SUC_ONE_ADD, arithmeticTheory.ADD_ASSOC] - \\ simp [heap_add_contents] - \\ simp [BAG_INSERT_UNION] - \\ simp [ASSOC_BAG_UNION] - \\ simp [COMM_BAG_UNION] -QED - -Definition heap_pop_all_def: - heap_pop_all R sz xs hp = (if sz = 0 then xs - else let (x, hp2) = heap_pop R sz hp in - heap_pop_all R (sz - 1) (x :: xs) hp2) -End - -Theorem heap_pop_all_sorted: - heap_inv R sz hp ==> - reflexive R ==> transitive R ==> total R ==> - SORTED (\x y. R y x) xs ==> - (xs <> [] ==> 0 < sz ==> R (HD xs) (hp 1)) ==> - (R2 = (\x y. R y x)) ==> - SORTED R2 (heap_pop_all R sz xs hp) -Proof - qid_spec_tac `hp` - \\ qid_spec_tac `xs` - \\ qid_spec_tac `R2` - \\ Induct_on `sz` - \\ ONCE_REWRITE_TAC [heap_pop_all_def] - \\ simp [] - \\ rw [] - \\ pairarg_tac - \\ drule heap_pop_inv - \\ simp [] - \\ rw [] - \\ fs [] - \\ first_x_assum (drule_then irule) - \\ simp [] - \\ drule heap_pop_min - \\ rw [] - \\ Cases_on `xs` \\ fs [] -QED - -Theorem heap_pop_all_contents: - LIST_TO_BAG (heap_pop_all R sz xs hp) = - BAG_UNION (LIST_TO_BAG xs) (heap_contents sz hp) -Proof - qid_spec_tac `hp` - \\ qid_spec_tac `xs` - \\ Induct_on `sz` - \\ ONCE_REWRITE_TAC [heap_pop_all_def] - \\ simp [] - >- ( - simp [heap_contents_def] - ) - >- ( - rw [] - \\ pairarg_tac \\ fs [] - \\ drule_then (mp_tac o GSYM) heap_pop_contents - \\ simp [] - \\ simp [BAG_INSERT_UNION, COMM_BAG_UNION] - \\ metis_tac [ASSOC_BAG_UNION, COMM_BAG_UNION] - ) -QED - -Definition heap_sort_def: - heap_sort R xs = (case xs of [] => [] - | (x :: _) => (let R2 = (\x y. R y x); - hp = heap_add_all R2 0 xs (K x) in - heap_pop_all R2 (LENGTH xs) [] hp)) -End - -Theorem heap_sort_sorted: - reflexive R ==> transitive R ==> total R ==> - SORTED R (heap_sort R xs) -Proof - rw [heap_sort_def] - \\ Cases_on `xs` \\ fs [] - \\ irule heap_pop_all_sorted - \\ simp [] - \\ irule_at Any heap_add_all_inv - \\ simp [] - \\ simp [heap_inv_def, FUN_EQ_THM] - \\ fs [relationTheory.reflexive_def, relationTheory.total_def] - \\ fs [relationTheory.transitive_def] - \\ metis_tac [] -QED - -Theorem heap_sort_contents: - LIST_TO_BAG (heap_sort R xs) = LIST_TO_BAG xs -Proof - simp [heap_sort_def] - \\ Cases_on `xs` \\ simp [] - \\ simp [heap_pop_all_contents, heap_add_all_contents] - \\ simp [heap_contents_def] -QED - -Theorem heap_sort_perm: - PERM (heap_sort R xs) xs -Proof - simp [GSYM PERM_LIST_TO_BAG, heap_sort_contents] -QED - Datatype: simple_tree = Empty_Tree | Node 'a simple_tree simple_tree End @@ -466,6 +28,7 @@ Definition tree_top_less_def: tree_top_less R (Node x _ _) y = R x y End +(* Invariant that a tree encodes a heap. *) Definition heap_tree_inv_def: (heap_tree_inv R n Empty_Tree = (n = 0)) /\ (heap_tree_inv R n (Node y l r) = (n > 0 /\ @@ -480,6 +43,7 @@ Proof Cases_on `t` \\ simp [heap_tree_inv_def] QED +(* Invariant for a list of trees. *) Definition heaps_tree_inv_def: heaps_tree_inv R xs = (EVERY (\(t, n). heap_tree_inv R n t /\ n > 0) xs /\ SORTED (\(t1, _) (t2, _). case t1 of Empty_Tree => F | Node x _ _ => @@ -508,7 +72,8 @@ Definition tree_to_bag_def: tree_to_bag (Node x l r) = BAG_INSERT x (BAG_UNION (tree_to_bag l) (tree_to_bag r)) End -(* Insert into a balanced heap/tree maintaining the invariant. *) +(* Insert a value, replacing the top value of a balanced heap/tree, and moving + the new value down the heap as necessary to maintain the invariant. *) Definition insert_tree_inv_def: insert_tree_inv R Empty_Tree x = Empty_Tree /\ insert_tree_inv R (Node _ l r) x = (case l of Empty_Tree => Node x l r @@ -528,7 +93,7 @@ Proof \\ BasicProvers.EVERY_CASE_TAC \\ simp [] QED -(* Insert into a chain of heap/trees. *) +(* Insert similarly into a list of heap/trees. *) Definition insert_trees_inv_def: (insert_trees_inv R [] x = []) /\ (insert_trees_inv R ((t1, n1) :: ts) x = (case ts of @@ -562,8 +127,9 @@ QED Theorem insert_trees_inv_length = Q.AP_TERM `LENGTH` insert_trees_inv_size |> REWRITE_RULE [LENGTH_MAP] -Definition add_trees_step1_def: - add_trees_step1 ts x = (case ts of +(* Add a new value, assembling two heaps into a larger heap if needed. *) +Definition add_to_heaps_step1_def: + add_to_heaps_step1 ts x = (case ts of (t1, n1) :: (t2, n2) :: ts2 => if n1 = n2 then (Node x t2 t1, n1 + 1) :: ts2 else (Node x Empty_Tree Empty_Tree, 1) :: ts @@ -571,17 +137,18 @@ Definition add_trees_step1_def: ) End -Definition add_trees_def: - add_trees R ts x = insert_trees_inv R (add_trees_step1 ts x) x +Definition add_to_heaps_def: + add_to_heaps R ts x = insert_trees_inv R (add_to_heaps_step1 ts x) x End -Definition build_trees_def: - build_trees R ts [] = ts /\ - build_trees R ts (x :: xs) = build_trees R (add_trees R ts x) xs +Definition add_values_to_heaps_def: + add_values_to_heaps R ts [] = ts /\ + add_values_to_heaps R ts (x :: xs) = + add_values_to_heaps R (add_to_heaps R ts x) xs End -Definition extend_trees_def: - extend_trees R ts t n = (case t of +Definition add_heap_to_heaps_def: + add_heap_to_heaps R ts t n = (case t of Empty_Tree => ts | Node x l r => (let ord = (case ts of ((Node y _ _, _) :: _) => R y x | _ => T) in if ord then (t, n) :: ts @@ -589,30 +156,30 @@ Definition extend_trees_def: )) End -Theorem extend_trees_size: - SUM (MAP (\t_n. simple_tree_size (K 0) (FST t_n)) (extend_trees R ts t n)) = +Theorem add_heap_to_heaps_size: + SUM (MAP (\t_n. simple_tree_size (K 0) (FST t_n)) (add_heap_to_heaps R ts t n)) = simple_tree_size (K 0) t + SUM (MAP (\t_n. simple_tree_size (K 0) (FST t_n)) ts) Proof - simp [extend_trees_def] + simp [add_heap_to_heaps_def] \\ BasicProvers.EVERY_CASE_TAC \\ simp [] \\ simp [REWRITE_RULE [combinTheory.o_DEF] insert_trees_inv_size] QED -Definition pull_trees_def: - pull_trees R [] acc = acc /\ - pull_trees R ((Empty_Tree, _) :: ts) acc = acc /\ - pull_trees R ((Node x l r, n) :: ts) acc = - let ts2 = extend_trees R ts l (n - 1); - ts3 = extend_trees R ts2 r (n - 1) - in pull_trees R ts3 (x :: acc) +Definition heaps_to_list_def: + heaps_to_list R [] acc = acc /\ + heaps_to_list R ((Empty_Tree, _) :: ts) acc = acc /\ + heaps_to_list R ((Node x l r, n) :: ts) acc = + let ts2 = add_heap_to_heaps R ts l (n - 1); + ts3 = add_heap_to_heaps R ts2 r (n - 1) + in heaps_to_list R ts3 (x :: acc) Termination WF_REL_TAC `measure (\(R, ts, acc). SUM (MAP (simple_tree_size (K 0) o FST) ts))` \\ rw [] - \\ simp [extend_trees_size] + \\ simp [add_heap_to_heaps_size] End -Definition another_heap_sort_def: - another_heap_sort R xs = pull_trees R (build_trees R [] xs) [] +Definition heap_list_sort_def: + heap_list_sort R xs = heaps_to_list R (add_values_to_heaps R [] xs) [] End (* Invariant preservation. *) @@ -627,6 +194,14 @@ Proof \\ simp [tree_top_less_def] QED +Theorem total_lemma[local]: + total R ==> ~ R x y ==> R y x +Proof + metis_tac [relationTheory.total_def] +QED + +Theorem transitive_lemma[local] = hd (RES_CANON relationTheory.transitive_def) + Theorem insert_tree_inv: heap_tree_inv R n t ==> transitive R ==> total R ==> @@ -781,16 +356,16 @@ Proof \\ rw [insert_tree_inv_def] QED -Theorem build_trees_contents: +Theorem add_values_to_heaps_contents: EVERY (\p. FST p <> Empty_Tree) ts ==> - FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) (build_trees R ts xs)) = + FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) (add_values_to_heaps R ts xs)) = BAG_UNION (LIST_TO_BAG xs) (FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) ts)) /\ - EVERY (\p. FST p <> Empty_Tree) (build_trees R ts xs) + EVERY (\p. FST p <> Empty_Tree) (add_values_to_heaps R ts xs) Proof qid_spec_tac `ts` \\ Induct_on `xs` - \\ rw [build_trees_def] - \\ simp [add_trees_def, add_trees_step1_def] + \\ rw [add_values_to_heaps_def] + \\ simp [add_to_heaps_def, add_to_heaps_step1_def] \\ BasicProvers.EVERY_CASE_TAC \\ simp [] \\ fs [] \\ simp [insert_trees_inv_contents, insert_trees_non_empty, tree_to_bag_def] @@ -875,15 +450,15 @@ Proof ) QED -Theorem build_trees_inv: +Theorem add_values_to_heaps_inv: heaps_tree_inv R ts ==> transitive R ==> total R ==> reflexive R ==> - heaps_tree_inv R (build_trees R ts xs) + heaps_tree_inv R (add_values_to_heaps R ts xs) Proof qid_spec_tac `ts` \\ Induct_on `xs` - \\ rw [build_trees_def] - \\ simp [add_trees_def, add_trees_step1_def] + \\ rw [add_values_to_heaps_def] + \\ simp [add_to_heaps_def, add_to_heaps_step1_def] \\ BasicProvers.EVERY_CASE_TAC \\ simp [] \\ simp [] \\ first_x_assum irule @@ -892,33 +467,33 @@ Proof \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def, tree_top_less_def] QED -Theorem extend_trees_contents[local]: +Theorem add_heap_to_heaps_contents[local]: EVERY (\p. FST p <> Empty_Tree) ts ==> - FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) (extend_trees R ts t n)) = + FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) (add_heap_to_heaps R ts t n)) = BAG_UNION (tree_to_bag t) (FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) ts)) Proof - simp [extend_trees_def] + simp [add_heap_to_heaps_def] \\ BasicProvers.EVERY_CASE_TAC \\ simp [] \\ simp [tree_to_bag_def] \\ simp [insert_trees_inv_contents, insert_trees_non_empty, tree_to_bag_def] QED -Theorem extend_trees_not_empty[local]: +Theorem add_heap_to_heaps_not_empty[local]: EVERY (\p. FST p <> Empty_Tree) ts ==> - EVERY (\p. FST p <> Empty_Tree) (extend_trees R ts t n) + EVERY (\p. FST p <> Empty_Tree) (add_heap_to_heaps R ts t n) Proof - simp [extend_trees_def] + simp [add_heap_to_heaps_def] \\ BasicProvers.EVERY_CASE_TAC \\ simp [] \\ simp [insert_trees_non_empty] QED -Theorem extend_trees_inv[local]: +Theorem add_heap_to_heaps_inv[local]: (t <> Empty_Tree ==> heap_tree_inv R n t) ==> heaps_tree_inv R ts ==> total R /\ transitive R /\ reflexive R ==> - heaps_tree_inv R (extend_trees R ts t n) + heaps_tree_inv R (add_heap_to_heaps R ts t n) Proof - simp [extend_trees_def] + simp [add_heap_to_heaps_def] \\ BasicProvers.EVERY_CASE_TAC \\ simp [] \\ csimp [heaps_tree_inv_rec_def, heap_tree_inv_def, tree_top_less_def] \\ rw [] @@ -926,16 +501,16 @@ Proof \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def] QED -Theorem extend_trees_less[local]: +Theorem add_heap_to_heaps_less[local]: (ts <> [] ==> tree_top_less R (FST (HD ts)) x) ==> tree_top_less R t x ==> total R ==> transitive R ==> - (extend_trees R ts t n <> []) ==> + (add_heap_to_heaps R ts t n <> []) ==> heaps_tree_inv R ts ==> heap_tree_inv R n t ==> - tree_top_less R (FST (HD (extend_trees R ts t n))) x + tree_top_less R (FST (HD (add_heap_to_heaps R ts t n))) x Proof - simp [extend_trees_def] + simp [add_heap_to_heaps_def] \\ BasicProvers.EVERY_CASE_TAC \\ simp [] \\ rw [] \\ irule insert_trees_inv_less @@ -947,54 +522,60 @@ Proof \\ gs [heaps_tree_inv_rec_def, heap_tree_inv_def] QED -Theorem pull_trees_contents: +Theorem heaps_to_list_contents: ! R ts acc. EVERY (\p. FST p <> Empty_Tree) ts ==> - LIST_TO_BAG (pull_trees R ts acc) = + LIST_TO_BAG (heaps_to_list R ts acc) = BAG_UNION (FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) ts)) (LIST_TO_BAG acc) Proof - recInduct pull_trees_ind + recInduct heaps_to_list_ind \\ rw [] - \\ simp [pull_trees_def, tree_to_bag_def] - \\ simp [extend_trees_contents, extend_trees_not_empty] + \\ simp [heaps_to_list_def, tree_to_bag_def] + \\ simp [add_heap_to_heaps_contents, add_heap_to_heaps_not_empty] \\ simp [BAG_UNION_INSERT] \\ simp [BAG_INSERT_commutes, ASSOC_BAG_UNION, COMM_BAG_UNION] QED -Theorem pull_trees_sorted: +Theorem heaps_to_list_sorted: ! R ts acc. heaps_tree_inv R ts ==> transitive R ==> total R ==> reflexive R ==> SORTED R acc ==> ((ts <> []) ==> (acc <> []) ==> tree_top_less R (FST (HD ts)) (HD acc)) ==> - SORTED R (pull_trees R ts acc) + SORTED R (heaps_to_list R ts acc) Proof - recInduct pull_trees_ind + recInduct heaps_to_list_ind \\ rw [] \\ fs [] - \\ simp [pull_trees_def] + \\ simp [heaps_to_list_def] \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def, tree_top_less_def] \\ gs [] \\ first_x_assum irule - \\ simp [extend_trees_inv] + \\ simp [add_heap_to_heaps_inv] \\ rw [] - \\ simp [extend_trees_less, extend_trees_inv] + \\ simp [add_heap_to_heaps_less, add_heap_to_heaps_inv] \\ Cases_on `acc` \\ fs [] QED -Theorem another_heap_sort_sorted: +Theorem heap_list_sort_sorted: reflexive R ==> transitive R ==> total R ==> - SORTED R (another_heap_sort R xs) + SORTED R (heap_list_sort R xs) Proof - rw [another_heap_sort_def] - \\ irule pull_trees_sorted + rw [heap_list_sort_def] + \\ irule heaps_to_list_sorted \\ simp [] - \\ irule build_trees_inv + \\ irule add_values_to_heaps_inv \\ simp [heaps_tree_inv_def] QED -Theorem another_heap_sort_contents: - LIST_TO_BAG (another_heap_sort R xs) = LIST_TO_BAG xs +Theorem heap_list_sort_contents: + LIST_TO_BAG (heap_list_sort R xs) = LIST_TO_BAG xs +Proof + rw [heap_list_sort_def] + \\ simp [heaps_to_list_contents, add_values_to_heaps_contents] +QED + +Theorem heap_list_sort_PERM: + PERM (heap_list_sort R xs) xs Proof - rw [another_heap_sort_def] - \\ simp [pull_trees_contents, build_trees_contents] + simp [GSYM PERM_LIST_TO_BAG, heap_list_sort_contents] QED From 92e1535e1266974b906711e2be71959426f0b1c1 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Tue, 3 Mar 2026 19:58:28 +1100 Subject: [PATCH 17/39] Connect heap-list-sort into ListProg After a lot of false steps, the process seems to work. The monadic constants are defined and verified in the monadic sub-theory. The real monadic translation is set up in ListProgScript, together with a bit of a hack for rewriting the accessor constants from the sub-theory to the ones the translator setup builds. The final "sort" function is derived from that, and can be trivially proven to be the pure version (and thus a sorting function) in ListProof. --- basis/Holmakefile | 2 +- basis/ListProgScript.sml | 153 +++++++++++++----- basis/ListProofScript.sml | 16 ++ basis/monadic/Holmakefile | 2 +- basis/monadic/README.md | 8 +- .../monadic/heap_list_sort_monadicScript.sml | 16 +- 6 files changed, 144 insertions(+), 53 deletions(-) diff --git a/basis/Holmakefile b/basis/Holmakefile index ae036ef13b..31bfbf0884 100644 --- a/basis/Holmakefile +++ b/basis/Holmakefile @@ -1,7 +1,7 @@ INCLUDES = $(CAKEMLDIR)/developers $(CAKEMLDIR)/misc\ $(CAKEMLDIR)/semantics $(CAKEMLDIR)/characteristic\ $(CAKEMLDIR)/translator $(CAKEMLDIR)/translator/monadic\ - $(CAKEMLDIR)/compiler/printing pure + $(CAKEMLDIR)/compiler/printing pure monadic all: $(DEFAULT_TARGETS) README.md basis_ffi.o .PHONY: all diff --git a/basis/ListProgScript.sml b/basis/ListProgScript.sml index 109f43cf90..60aaef5f09 100644 --- a/basis/ListProgScript.sml +++ b/basis/ListProgScript.sml @@ -3,9 +3,10 @@ *) Theory ListProg Ancestors - mergesort std_prelude mllist ml_translator OptionProg + mergesort std_prelude mllist ml_translator OptionProg heap_list_sort_monadic Libs preamble ml_translatorLib ml_progLib cfLib basisFunctionsLib + ml_monad_translator_interfaceLib val _ = translation_extends "OptionProg" @@ -341,59 +342,127 @@ val _ = translate mllistTheory.list_compare_def; val _ = ml_prog_update open_local_block; -val result = translate sort2_tail_def; -val result = translate sort3_tail_def; -val result = translate REV_DEF; -val result = translate merge_tail_def; -val result = translate DIV2_def; -val result = translate DROP_def; -val result = translate_no_ind mergesortN_tail_def; +(* Config to use monadic translator temporarily. *) +val _ = ml_translatorLib.use_sub_check true; -Theorem mergesortn_tail_ind[local]: - mergesortn_tail_ind (:'a) +val tvar = ``: 'state``; + +val state_type = ``: ( ^tvar ) heap_list_state``; + +val subs = ``Heap_List_Subscript`` + +val exn_type = type_of subs; + +val config = local_state_config |> + with_state state_type |> + with_exception exn_type |> + with_resizeable_arrays [ + ("heap_array", listSyntax.mk_list ([], tvar), subs, subs), + ("sz_array", ``[] : num list``, subs, subs) + ]; + +val _ = start_translation config; + +(* Some clunking around to translate the accessors as auto-defined in + heap_list_sort_monadicTheory using their counterparts auto-defined above. *) +val heap_list_acc_def_names = ["heap_array_sub_def", "update_heap_array_def", + "alloc_heap_array_def", "sz_array_sub_def", "update_sz_array_def", + "alloc_sz_array_def"] + +val configured_acc_defs = map (fetch "-") heap_list_acc_def_names; +val previous_acc_defs = map (fetch "heap_list_sort_monadic") heap_list_acc_def_names; +val redefs = previous_acc_defs + |> map (REWRITE_RULE (map GSYM configured_acc_defs)) +val do_redef = REWRITE_RULE redefs + +Definition comp_exp_def: + comp_exp m x 0 = x /\ + comp_exp (m : num) x (SUC i) = comp_exp m (x * m) i +End + +Theorem comp_exp_eq_ind[local]: + !i x. comp_exp m x i = x * (m EXP i) +Proof + Induct \\ simp [comp_exp_def, EXP] +QED + +Theorem use_comp_exp: + (m EXP i) = comp_exp m 1 i Proof - once_rewrite_tac [fetch "-" "mergesortn_tail_ind_def"] - \\ rpt gen_tac - \\ rpt (disch_then strip_assume_tac) - \\ match_mp_tac (latest_ind ()) - \\ rpt strip_tac - \\ last_x_assum match_mp_tac - \\ rpt strip_tac - \\ gvs [FORALL_PROD, DIV2_def] + simp [comp_exp_eq_ind] QED -val result = mergesortn_tail_ind |> update_precondition; +val comp_exp_v_thm = comp_exp_def |> translate; + +val sfx_heap_left_v_thm = sfx_heap_left_def + |> REWRITE_RULE [use_comp_exp] |> translate; + +val insert_into_sfx_heap_v_thm = insert_into_sfx_heap_def + |> do_redef |> m_translate; + +val insert_into_sfx_heap_list_v_thm = insert_into_sfx_heap_list_def + |> REWRITE_RULE [use_comp_exp] + |> do_redef |> m_translate; -Theorem mergesortn_tail_side[local]: - !w x y z. mergesortn_tail_side w x y z +Theorem bind_assoc[local]: + (st_ex_bind (st_ex_bind f g) h) = + (st_ex_bind f (\x. st_ex_bind (g x) h)) Proof - completeInduct_on `y` - \\ once_rewrite_tac[(fetch "-" "mergesortn_tail_side_def")] - \\ rpt gen_tac \\ rename1 `SUC x1` - \\ rw[DIV2_def] - >- ( - first_x_assum match_mp_tac - \\ fs[] - \\ qspecl_then [`2`,`SUC x1`] assume_tac dividesTheory.DIV_POS - \\ gvs[] - ) - >- ( - qspecl_then [`SUC x1`, `2`] assume_tac arithmeticTheory.DIV_LESS - \\ `0 < SUC x1` by fs[] - \\ `SUC x1 DIV 2 < SUC x1` suffices_by rw[] - \\ first_x_assum match_mp_tac - \\ fs[] - ) + rw [ml_monadBaseTheory.st_ex_bind_def, FUN_EQ_THM] + \\ rpt (TOP_CASE_TAC \\ fs []) QED -val result = mergesortn_tail_side |> update_precondition; -val result = translate mergesort_tail_def +val add_to_sfx_heaps_v_thm = add_to_sfx_heaps_def + |> SIMP_RULE bool_ss [add_to_sfx_heaps_step1_def, bind_assoc] + |> do_redef |> m_translate; + +val add_all_to_sfx_heaps_v_thm = add_all_to_sfx_heaps_def + |> do_redef |> m_translate; + +val reinsert_tree_v_thm = reinsert_tree_def + |> REWRITE_RULE [use_comp_exp] + |> do_redef |> m_translate; + +val sfx_trees_to_list_v_thm = sfx_trees_to_list_def + |> do_redef |> m_translate; + +val above_log2_v_thm = above_log2_def |> translate; + +val sort_via_sfx_trees_worker_v_thm = sort_via_sfx_trees_worker_def + |> do_redef |> m_translate; + +val run_init_heap_list_state_def = define_run state_type [] "init_heap_list_state"; + +Definition sort_via_sfx_trees_run_worker_def: + sort_via_sfx_trees_run_worker R x xs = + run_init_heap_list_state (sort_via_sfx_trees_worker R x xs) + (init_heap_list_state [] []) +End + +val run_init_heap_list_state_v_thm = sort_via_sfx_trees_run_worker_def + |> m_translate_run; + +Definition sort_via_sfx_trees_def: + sort_via_sfx_trees R xs = (case xs of [] => [] + | x :: _ => (case sort_via_sfx_trees_run_worker R x xs of + M_success ys => ys + | _ => []) + ) +End + +val sort_via_sfx_trees_v_thm = sort_via_sfx_trees_def |> translate; + +(* Done monadic translation. *) + +val _ = ml_translatorLib.use_sub_check false; val _ = ml_prog_update open_local_in_block; -val _ = next_ml_names := ["sort"]; +Definition sort_def: + sort R xs = sort_via_sfx_trees R xs +End -val result = translate sort_def; +val sort_v_thm = sort_def |> translate; val _ = ml_prog_update close_local_blocks; val _ = ml_prog_update (close_module NONE); diff --git a/basis/ListProofScript.sml b/basis/ListProofScript.sml index 800b730cb3..8bf1ab0c64 100644 --- a/basis/ListProofScript.sml +++ b/basis/ListProofScript.sml @@ -41,3 +41,19 @@ Theorem app_spec = Q.prove( |> Q.SPEC`0` |> SIMP_RULE(srw_ss())[] |> Q.GENL[`eff`,`fv`] +Theorem sort_is_heap_list_sort: + ListProg$sort R xs = heap_list_sort R xs +Proof + simp [sort_def, sort_via_sfx_trees_def] + \\ Cases_on `xs` \\ simp [EVAL ``(heap_list_sort R [])``] + \\ simp [sort_via_sfx_trees_run_worker_def, + run_init_heap_list_state_def, ml_monadBaseTheory.run_def] + \\ simp [heap_list_sort_monadicTheory.sort_via_sfx_trees_worker_eq] +QED + +Theorem sort_sorted = heap_list_sortTheory.heap_list_sort_sorted + |> REWRITE_RULE [GSYM sort_is_heap_list_sort] + +Theorem sort_contents = heap_list_sortTheory.heap_list_sort_contents + |> REWRITE_RULE [GSYM sort_is_heap_list_sort] + diff --git a/basis/monadic/Holmakefile b/basis/monadic/Holmakefile index 9c77a7efce..478702053b 100644 --- a/basis/monadic/Holmakefile +++ b/basis/monadic/Holmakefile @@ -1,5 +1,5 @@ INCLUDES = $(CAKEMLDIR)/misc \ - $(CAKEMLDIR)/translator/monadic/monad_base/ + $(CAKEMLDIR)/translator/monadic/ $(CAKEMLDIR)/translator/ all: $(DEFAULT_TARGETS) README.md .PHONY: all diff --git a/basis/monadic/README.md b/basis/monadic/README.md index d2732039d3..f255cc6f50 100644 --- a/basis/monadic/README.md +++ b/basis/monadic/README.md @@ -3,5 +3,11 @@ Monadic definitions of stateful functions used in the basis These functions are generated and verified using a monad type, and are then translated to imperative CakeML code by the monadic translator. +[experiment1Script.sml](experiment1Script.sml): +Monadic variants of the heap-list sort functions, and proofs of equivalence. + +[experiment2Script.sml](experiment2Script.sml): +Try to load experiment1 and translate some + [heap_list_sort_monadicScript.sml](heap_list_sort_monadicScript.sml): -Using the monadic translator to translate heap sorting functions. +Monadic variants of the heap-list sort functions, and proofs of equivalence. diff --git a/basis/monadic/heap_list_sort_monadicScript.sml b/basis/monadic/heap_list_sort_monadicScript.sml index 528785fda0..df33035f9f 100644 --- a/basis/monadic/heap_list_sort_monadicScript.sml +++ b/basis/monadic/heap_list_sort_monadicScript.sml @@ -12,23 +12,23 @@ Libs (* The data type of the state. *) Datatype: - state_refs = <| + heap_list_state = <| heap_array : ( 'a ) list; sz_array : num list; |> End -(* Data type for the exceptions. Seems to be standard. *) +(* Equivalent to unit, but we need to construct a type so that the translation + can construct a new exception type. *) Datatype: - state_exn = Fail string | Subscript + heap_list_subscript_exn = Heap_List_Subscript End (* Setup to use monad translator constants and monad syntax. *) -val acc_fun_defs = define_monad_access_funs ``: 'a state_refs`` +val acc_fun_defs = define_monad_access_funs ``: 'a heap_list_state`` -val acc_fun_unfolds = LIST_CONJ (flatten (map (fn (_, t1, t2) => [t1, t2]) acc_fun_defs)) - -val mr_manip_funs = define_MRarray_manip_funs acc_fun_defs ``Subscript`` ``Subscript`` +val mr_manip_funs = define_MRarray_manip_funs acc_fun_defs + ``Heap_List_Subscript`` ``Heap_List_Subscript`` val _ = ParseExtras.temp_tight_equality (); val _ = monadsyntax.temp_add_monadsyntax (); @@ -599,7 +599,7 @@ Definition mk_st_def: (<| sz_array := REVERSE (FST szs) ++ SND szs; heap_array := bs_tree_list_to_list (FST hps) ++ SND hps - |> : 'a state_refs) + |>) End Definition is_last_ix_def: From ed1e54d8143d5dc095ab31306737604cfab4e8b9 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Wed, 4 Mar 2026 17:31:24 +1100 Subject: [PATCH 18/39] list sort: use a more sensible variable type Along the way, we seem to have made the monadic translator resistant to type variables with names other than 'a or 'state. --- basis/ListProgScript.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ListProgScript.sml b/basis/ListProgScript.sml index 60aaef5f09..b502ac09f2 100644 --- a/basis/ListProgScript.sml +++ b/basis/ListProgScript.sml @@ -345,7 +345,7 @@ val _ = ml_prog_update open_local_block; (* Config to use monadic translator temporarily. *) val _ = ml_translatorLib.use_sub_check true; -val tvar = ``: 'state``; +val tvar = ``: 'el``; val state_type = ``: ( ^tvar ) heap_list_state``; From 3e1e5e6e6db3415a66c490ff0f0f989f8b2cc08c Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Wed, 4 Mar 2026 21:58:36 +1100 Subject: [PATCH 19/39] list sort: flip translation/definition of sort Change around the translation. Prove the "monadic-sort = functional-sort" theorem, and use its symmetric version as the definition to translate the functional algorithm. The point is that the translation and EVAL calculations will now both do the correct thing with the one constant. --- basis/ListProgScript.sml | 16 ++++++++++++---- basis/ListProofScript.sml | 16 ---------------- 2 files changed, 12 insertions(+), 20 deletions(-) diff --git a/basis/ListProgScript.sml b/basis/ListProgScript.sml index b502ac09f2..8971b16159 100644 --- a/basis/ListProgScript.sml +++ b/basis/ListProgScript.sml @@ -458,11 +458,19 @@ val _ = ml_translatorLib.use_sub_check false; val _ = ml_prog_update open_local_in_block; -Definition sort_def: - sort R xs = sort_via_sfx_trees R xs -End +Theorem heap_list_sort_eq_sort_via_sfx_trees: + heap_list_sort R xs = sort_via_sfx_trees R xs +Proof + simp [sort_via_sfx_trees_def] + \\ Cases_on `xs` \\ simp [EVAL ``(heap_list_sort R [])``] + \\ simp [sort_via_sfx_trees_run_worker_def, + run_init_heap_list_state_def, ml_monadBaseTheory.run_def] + \\ simp [heap_list_sort_monadicTheory.sort_via_sfx_trees_worker_eq] +QED + +val _ = next_ml_names := ["sort"]; -val sort_v_thm = sort_def |> translate; +val sort_v_thm = heap_list_sort_eq_sort_via_sfx_trees |> translate; val _ = ml_prog_update close_local_blocks; val _ = ml_prog_update (close_module NONE); diff --git a/basis/ListProofScript.sml b/basis/ListProofScript.sml index 8bf1ab0c64..800b730cb3 100644 --- a/basis/ListProofScript.sml +++ b/basis/ListProofScript.sml @@ -41,19 +41,3 @@ Theorem app_spec = Q.prove( |> Q.SPEC`0` |> SIMP_RULE(srw_ss())[] |> Q.GENL[`eff`,`fv`] -Theorem sort_is_heap_list_sort: - ListProg$sort R xs = heap_list_sort R xs -Proof - simp [sort_def, sort_via_sfx_trees_def] - \\ Cases_on `xs` \\ simp [EVAL ``(heap_list_sort R [])``] - \\ simp [sort_via_sfx_trees_run_worker_def, - run_init_heap_list_state_def, ml_monadBaseTheory.run_def] - \\ simp [heap_list_sort_monadicTheory.sort_via_sfx_trees_worker_eq] -QED - -Theorem sort_sorted = heap_list_sortTheory.heap_list_sort_sorted - |> REWRITE_RULE [GSYM sort_is_heap_list_sort] - -Theorem sort_contents = heap_list_sortTheory.heap_list_sort_contents - |> REWRITE_RULE [GSYM sort_is_heap_list_sort] - From 3babd6fce1909ad1b42e3b2f0fba59bf41a1fae8 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Wed, 4 Mar 2026 22:30:55 +1100 Subject: [PATCH 20/39] Add basis/monadic to build-sequence --- developers/build-sequence | 1 + 1 file changed, 1 insertion(+) diff --git a/developers/build-sequence b/developers/build-sequence index 3ed8f687f1..ee1b21d944 100644 --- a/developers/build-sequence +++ b/developers/build-sequence @@ -33,6 +33,7 @@ translator/monadic/monad_base profiler # basis library +basis/monadic basis # compiler From 58c966962282f05f6675c266a71bb99af8566112 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 5 Mar 2026 15:58:14 +1100 Subject: [PATCH 21/39] monad translator: fix up store_inv confusion In the monadic translation, the state type represents all the stateful stuff for the purposes of the monadic model. It doesn't directly exist as any type in the CakeML translation, instead its fields are placed into reference and array objects states and the FFI oracle and whatnot. A previous patch was confused about this. This patch restores the previous behaviour, including the pretty awful re-parsing of strings to fetch constants and overloads that were defined before, though puts a little defensive programming around some of it. Hopefully fixes the breakage of the IO-based monadic translation examples. --- .../ml_monad_translator_interfaceLib.sml | 46 +++++++++++++++---- 1 file changed, 37 insertions(+), 9 deletions(-) diff --git a/translator/monadic/ml_monad_translator_interfaceLib.sml b/translator/monadic/ml_monad_translator_interfaceLib.sml index 737e9d5ba8..a7669c24ef 100644 --- a/translator/monadic/ml_monad_translator_interfaceLib.sml +++ b/translator/monadic/ml_monad_translator_interfaceLib.sml @@ -351,6 +351,24 @@ fun extract_rarrays_manip_funs (name, init, get, set, len, sub, upd, alloc) = fun extract_farrays_manip_funs (name, init, get, set, len, sub, upd) = (name, get, set, len, sub, upd); +fun get_store_inv_name state_type = let + val _ = is_type state_type orelse (print_type state_type; + failwith ("get_store_inv_name: not a type constructor") + ) + val (nm, _) = dest_type state_type + in + nm ^ "_STORE_INV" + end + +fun get_store_inv state_type = let + val nm = get_store_inv_name state_type + (* This is a bit of a hack. The call to start_translation will call to the + store library (ml_monadStoreLib) to define the store inv. We then fetch + it back via naming scheme to do follow-up proofs. *) + val def_thm = DB.fetch "-" (nm ^ "_def") + val const = left_const def_thm + in (const, def_thm) end + local val IMP_STAR_GC = Q.prove( @@ -367,10 +385,19 @@ in fun add_field_access_patterns (hprop_comb, field_name) = let val state_ty = ( !(#state_type internal_state) ) - val state_predicate = get_type_inv state_ty - val state_predicate_def = guess_const_def state_predicate - val field = Term [QUOTE field_name] - val st_field = Term [QUOTE "st.", QUOTE field_name] + val (store_inv, store_inv_def) = get_store_inv state_ty + + val liftM_const = left_const ml_monadBaseTheory.liftM_def + val field_gen = Term [QUOTE field_name] + val _ = same_const liftM_const (fst (strip_comb field_gen)) + orelse failwith ("add_field_access_patterns: " ^ + "syntax conflict with liftM: " ^ field_name) + + val st_var = mk_var ("st", state_ty) + val f_var = mk_var ("f", fst (dom_rng (type_of field_gen))) + val field = mk_icomb (mk_comb (field_gen, f_var), st_var) |> rator |> rator + val st_field = case strip_comb field of (_, [acc, _]) => mk_comb (acc, st_var) + | _ => failwith ("add_field_access_patterns: field format issue") val HPROP_COMB_STAR_COMM = Q.prove( `∀ p q . p * ^(hprop_comb) q = ^(hprop_comb) q * p`, @@ -384,13 +411,13 @@ in ⇒ (∀st. EvalM ro env st exp (MONAD ret_ty exc_ty (^field f)) - (^state_predicate, p:'ffi ffi_proj))`, + (^store_inv, p:'ffi ffi_proj))`, fs [ml_monad_translatorTheory.EvalM_def] >> rw [] >> first_x_assum (qspecl_then [`^st_field`,`s`] mp_tac) >> impl_tac >- ( fs [ml_monad_translatorBaseTheory.REFS_PRED_def] >> - fs [state_predicate_def] >> + fs [store_inv_def] >> qabbrev_tac `a = ^hprop_comb ^st_field` >> qabbrev_tac `b = GC` >> fs [AC set_sepTheory.STAR_ASSOC set_sepTheory.STAR_COMM] >> @@ -405,13 +432,14 @@ in Cases_on `f ^st_field` >> fs [] >> EVERY_CASE_TAC >> rveq >> fs [] >> - fs [state_predicate_def] >> + fs [store_inv_def] >> fs [ml_monadBaseTheory.liftM_def] >> rw [] >> rfs[] >> fs[HPROP_COMB_STAR_COMM, set_sepTheory.STAR_ASSOC] >> metis_tac[set_sepTheory.STAR_ASSOC] ) + val state_exn_ty = ( !(#exn_type internal_state) ) val state_exn_predicate = get_type_inv state_exn_ty @@ -469,7 +497,7 @@ fun start_translation (translator_config : config) = ((!(#refs c) ) |> map from_named_tuple_refs) ((!(#resizeable_arrays c) ) |> map from_named_tuple_rarray) ((!(#fixed_arrays c) ) |> map from_named_tuple_farray) - ((!(#state_type c) ) |> dest_type |> fst |> (fn s => s^"_STORE_INV")) + ((!(#state_type c) ) |> get_store_inv_name) ( !(#state_type c) ) ( !(#exn_type_def s) ) ((!(#exn_access_funs c) ) |> map from_named_tuple_exn) @@ -490,7 +518,7 @@ fun start_translation (translator_config : config) = map extract_rarrays_manip_funs) ((!(#fixed_arrays c) ) |> map from_named_tuple_farray |> map extract_farrays_manip_funs) - ((!(#state_type c) ) |> dest_type |> fst |> (fn s => s^"_STORE_INV")) + ((!(#state_type c) ) |> get_store_inv_name) ( !(#state_type c) ) ( !(#exn_type_def s) ) ((!(#exn_access_funs c) ) |> map from_named_tuple_exn) From 56b5b71fae159f3bf712684481758b793d9189d8 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 5 Mar 2026 22:50:59 +1100 Subject: [PATCH 22/39] mllist: use heap-list-sort Switch out the "sort" symbol of mllist to call the new heap-list-sort with all the same key logical theorems exported. This should cause the Candle kernel etc to call on the new sort and translate correctly. --- basis/pure/mllistScript.sml | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/basis/pure/mllistScript.sml b/basis/pure/mllistScript.sml index 1ffad092a0..93a4d9f36f 100644 --- a/basis/pure/mllistScript.sml +++ b/basis/pure/mllistScript.sml @@ -6,7 +6,7 @@ Libs preamble Ancestors indexedLists[qualified] toto[qualified] - sorting mergesort + sorting heap_list_sort mergesort (* ===== TODO: TO BE PORTED TO HOL (better theorems for mergesort_tail) ===== *) Theorem merge_tail_MEM: @@ -277,36 +277,44 @@ Proof QED (* ^^^^^ TO BE PORTED TO HOL ^^^^^ *) +Definition old_sort_def: + old_sort = mergesort$mergesort_tail +End + Definition sort_def: - sort = mergesort$mergesort_tail + sort = heap_list_sort$heap_list_sort End Theorem sort_thm: - !R l. sort R l = mergesort$mergesort_tail R l + !R l. sort R l = heap_list_sort$heap_list_sort R l Proof rw[sort_def] QED -Theorem sort_SORTED: - !R L. transitive R ∧ total R ==> sorting$SORTED R (sort R L) +Triviality total_reflexive: + total R ==> reflexive R Proof - simp[sort_def, mergesort_tail_def, mergesortN_correct, mergesortN_sorted] + simp [total_def, reflexive_def] + \\ metis_tac [] QED -Theorem sort_MEM[simp]: - !R L. MEM x (sort R L) ⇔ MEM x L +Theorem sort_SORTED: + !R L. transitive R ∧ total R ==> sorting$SORTED R (sort R L) Proof - simp[sort_def, mergesort_tail_MEM] + simp[sort_def, heap_list_sort_sorted, total_reflexive] QED Theorem sort_PERM: !R L. sorting$PERM L (sort R L) Proof - simp[sort_def, mergesort_tail_def] - \\ rpt strip_tac - \\ `L = TAKE (LENGTH L) L` by rw[] - \\ pop_assum (fn x => pure_rewrite_tac [Once $ x]) - \\ rw[mergesortN_tail_PERM] + simp[sort_def] + \\ metis_tac [sortingTheory.PERM_SYM, heap_list_sort_PERM] +QED + +Theorem sort_MEM[simp]: + !R L. MEM x (sort R L) ⇔ MEM x L +Proof + metis_tac [sort_PERM, PERM_MEM_EQ] QED Theorem sort_LENGTH[simp]: From d5f75a536548ac9cd1b028122150d6ae4278cee9 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Fri, 6 Mar 2026 11:03:39 +1100 Subject: [PATCH 23/39] Rename Triviality->Theorem[local] Oops. The linter really doesn't like that. --- basis/pure/mllistScript.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/pure/mllistScript.sml b/basis/pure/mllistScript.sml index 93a4d9f36f..7de1004027 100644 --- a/basis/pure/mllistScript.sml +++ b/basis/pure/mllistScript.sml @@ -291,7 +291,7 @@ Proof rw[sort_def] QED -Triviality total_reflexive: +Theorem total_reflexive[local]: total R ==> reflexive R Proof simp [total_def, reflexive_def] From b5feea59b071511e407fdbcc238fe0ed007c7473 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Fri, 6 Mar 2026 11:04:04 +1100 Subject: [PATCH 24/39] heap-list-sort: adjust translation steps Follow-up to the previous adjustment, we need to make sure that mllist$sort is translated in ListProg, not just something equal to it, so everything is pointing at the one sort instance. --- basis/ListProgScript.sml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/basis/ListProgScript.sml b/basis/ListProgScript.sml index 8971b16159..a72772d550 100644 --- a/basis/ListProgScript.sml +++ b/basis/ListProgScript.sml @@ -456,8 +456,6 @@ val sort_via_sfx_trees_v_thm = sort_via_sfx_trees_def |> translate; val _ = ml_translatorLib.use_sub_check false; -val _ = ml_prog_update open_local_in_block; - Theorem heap_list_sort_eq_sort_via_sfx_trees: heap_list_sort R xs = sort_via_sfx_trees R xs Proof @@ -468,9 +466,13 @@ Proof \\ simp [heap_list_sort_monadicTheory.sort_via_sfx_trees_worker_eq] QED +val heap_list_sort_v_thm = heap_list_sort_eq_sort_via_sfx_trees |> translate; + +val _ = ml_prog_update open_local_in_block; + val _ = next_ml_names := ["sort"]; -val sort_v_thm = heap_list_sort_eq_sort_via_sfx_trees |> translate; +val sort_v_thm = mllistTheory.sort_thm |> translate; val _ = ml_prog_update close_local_blocks; val _ = ml_prog_update (close_module NONE); From c36ecf9d4266ebbdbedd0139bb46ee35d75faf0c Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Fri, 6 Mar 2026 16:54:57 +1100 Subject: [PATCH 25/39] cleanup: remove previous version --- basis/heap_sort_monadicScript.sml | 1266 ----------------------------- 1 file changed, 1266 deletions(-) delete mode 100644 basis/heap_sort_monadicScript.sml diff --git a/basis/heap_sort_monadicScript.sml b/basis/heap_sort_monadicScript.sml deleted file mode 100644 index 0ac6cceb39..0000000000 --- a/basis/heap_sort_monadicScript.sml +++ /dev/null @@ -1,1266 +0,0 @@ -(* - Using the monadic translator to translate heap sorting functions. - - Bit of an experiment, may move to ListProg if useful. -*) - -Theory heap_sort_monadic -Ancestors - heap_sort_in_fun ml_translator ml_monad_translator -Libs - preamble ml_translatorLib ml_monad_translator_interfaceLib - -(* Part 1. Translator Setup. *) - -(* Set up translator to not check subtractions never underflow. *) -val _ = ml_translatorLib.use_sub_check true; - -val _ = set_up_monadic_translator (); - -(* The type variable used as parameter to the state type. It seems very - important that this is used consistently. Strangely `'a` seems to work (for - the current code) though it created problems in a previous iteration. *) -val tvar = ``: 'state``; - -(* Create the data type to handle the references *) -Datatype: - state_refs = <| - heap_array : ( ^tvar ) list; - sz_array : num list; - |> -End - -(* Data type for the exceptions. Seems to be standard. *) -Datatype: - state_exn = Fail string | Subscript -End - -val state_type = ``: ( ^tvar ) state_refs``; - -val config = local_state_config |> - with_state state_type |> - with_exception ``:state_exn`` |> - with_resizeable_arrays [ - ("heap_array", listSyntax.mk_list ([], tvar), ``Subscript``, ``Subscript``), - ("sz_array", ``[] : num list``, ``Subscript``, ``Subscript``) - ]; - -val _ = start_translation config; - -val run_init_state_def = define_run state_type [] "init_state"; - -(* It seems important to turn this on last, or something turns it off again? *) -val _ = ParseExtras.tight_equality(); - -(* Part 2. Definition of heap-list sort via "suffix encoded" balanced trees. - Every heap/tree is of power-of-two-minus-one size, with the largest element - at the end, and two equal-sized smaller trees before it. *) - -(* Positions of the left child in a suffix encoded balanced tree - of height ht. *) -Definition sfx_heap_left_def: - sfx_heap_left i ht = (i - (2 EXP (ht - 1))) -End - -(* Insert a value into a balanced suffix heap of height ht, replacing the - current top element which is at index i. *) -Definition insert_into_sfx_heap_def: - insert_into_sfx_heap R i ht x = if ht <= 1 - then update_heap_array i x - else do - l <- return (sfx_heap_left i ht); - r <- return (i - 1); - lx <- heap_array_sub l; - rx <- heap_array_sub r; - if R lx x /\ R rx x - then update_heap_array i x - else if R lx rx - then do - update_heap_array i rx; - insert_into_sfx_heap R r (ht - 1) x - od - else do - update_heap_array i lx; - insert_into_sfx_heap R l (ht - 1) x - od - od -End - -(* Insert a value into a sequence of balanced suffix heaps, heights stored - in positions [0 ..< j] of the sz_array. Replace the top elements of the - final heap, which is at index i. *) -Definition insert_into_sfx_heap_list_def: - insert_into_sfx_heap_list R i j x = - if j <= 1 then do - ht <- sz_array_sub (j - 1); - insert_into_sfx_heap R i ht x - od - else do - ht <- sz_array_sub (j - 1); - i2 <- return ((i + 1) - (2 EXP ht)); - t2x <- heap_array_sub i2; - cond1 <- return (~ R t2x x); - cond <- if cond1 /\ (1 < ht) - then do - l <- return (sfx_heap_left i ht); - r <- return (i - 1); - lx <- heap_array_sub l; - rx <- heap_array_sub r; - return (~ R t2x lx /\ ~ R t2x rx) - od - else return cond1; - if cond - then do - update_heap_array i t2x; - insert_into_sfx_heap_list R i2 (j - 1) x - od - else insert_into_sfx_heap R i ht x - od -End - -(* Expand the total size of a sequence of balanced suffix heaps from i to - i + 1 total elements, starting with j total heaps. *) -Definition add_to_sfx_heaps_step1_def: - add_to_sfx_heaps_step1 j = do - merge <- if j <= 1 - then return F - else do - n1 <- sz_array_sub (j - 1); - n2 <- sz_array_sub (j - 2); - return (n1 = n2); - od; - if merge - then do - n <- sz_array_sub (j - 2); - update_sz_array (j - 2) (n + 1); - return (j - 1); - od - else do - update_sz_array j 1; - return (j + 1); - od - od -End - -(* Expand from i to i + 1 elements, set the new element, and preserve the heap - invariants. *) -Definition add_to_sfx_heaps_def: - add_to_sfx_heaps R i j x = do - j' <- add_to_sfx_heaps_step1 j; - insert_into_sfx_heap_list R i j' x; - return j' - od -End - -(* Extend a list of suffix heaps by a list of values. *) -Definition add_all_to_sfx_heaps_def: - (add_all_to_sfx_heaps R i j [] = return (i, j)) /\ - (add_all_to_sfx_heaps R i j (x :: xs) = do - j <- add_to_sfx_heaps R i j x; - add_all_to_sfx_heaps R (i + 1) j xs; - od) -End - -(* Take an intact heap in the correct position and add it to the heap sequence, - i.e. ensure its top element is the overall top element. *) -Definition reinsert_tree_def: - reinsert_tree R i j ht = - do - update_sz_array j ht; - x <- heap_array_sub (i - 1); - upd <- if 0 < j then do - i2 <- return (i - (2 EXP ht)); - t2x <- heap_array_sub i2; - return (~ (R t2x x)) - od else return F; - if upd - then insert_into_sfx_heap_list R (i - 1) (j + 1) x - else return (); - od -End - -(* Reduce a sequence of suffix-encoded heaps to a list. *) -Definition sfx_trees_to_list_def: - sfx_trees_to_list R i j acc = - if i = 0 then return acc - else do - ht <- sz_array_sub (j - 1); - x <- heap_array_sub (i - 1); - if ht <= 1 then sfx_trees_to_list R (i - 1) (j - 1) (x :: acc) - else do - l <- return (sfx_heap_left i ht); - reinsert_tree R l (j - 1) (ht - 1); - reinsert_tree R (i - 1) j (ht - 1); - sfx_trees_to_list R (i - 1) (j + 1) (x :: acc) - od - od -End - -(* Compute an overapproximation of the base-2 logarithm of v *) -Definition above_log2_def: - above_log2 i v n = if n = 0n \/ v <= n - then i - else above_log2 (i + 1n) v (n * 2) -Termination - WF_REL_TAC `measure (\(i, v, n). (v - n))` -End - -Definition sort_via_sfx_trees_worker_def: - sort_via_sfx_trees_worker R x xs = do - sz <- return (LENGTH xs); - alloc_heap_array (sz + 1) x; - sz_log <- return (above_log2 0 (sz + 1) 1); - alloc_sz_array (sz_log + 5) 0; - (i, j) <- add_all_to_sfx_heaps R 0 0 xs; - sfx_trees_to_list R i j [] - od -End - -Definition sort_via_sfx_trees_run_worker_def: - sort_via_sfx_trees_run_worker R x xs = - run_init_state (sort_via_sfx_trees_worker R x xs) - (init_state [] []) -End - -Definition sort_via_sfx_trees_def: - sort_via_sfx_trees R xs = (case xs of [] => [] - | x :: _ => (case sort_via_sfx_trees_run_worker R x xs of - M_success ys => ys - | _ => []) - ) -End - -(* Part 3. Proof that this monadic encoding computes the same as the pure heap - list sort implementation. *) - -(* 3.1: Setup *) - -Definition bs_tree_to_list_def: - (bs_tree_to_list 0 t = []) /\ - (bs_tree_to_list (SUC ht) t = - bs_tree_to_list ht (case t of Node _ l r => l | _ => t) ++ - bs_tree_to_list ht (case t of Node _ l r => r | _ => t) ++ - [case t of Node x l r => x] - ) -End - -Theorem bs_tree_to_list_tree_rec[local]: - (i = 0 ==> bs_tree_to_list i Empty_Tree = []) /\ - (0 < i ==> bs_tree_to_list i (Node x l r) = - bs_tree_to_list (i - 1) l ++ - bs_tree_to_list (i - 1) r ++ - [x]) -Proof - Cases_on `i` \\ simp [bs_tree_to_list_def] -QED - -Definition two_exp_min_1_def: - two_exp_min_1 i = (2n EXP i) - 1 -End - -Theorem two_exp_min_1_less_rec[local]: - 0 < i ==> two_exp_min_1 i = two_exp_min_1 (i - 1) + two_exp_min_1 (i - 1) + 1 -Proof - Cases_on `i` - \\ fs [two_exp_min_1_def, EXP] - \\ rw [SUB_RIGHT_ADD] -QED - -Theorem two_exp_min_1_rec[local]: - two_exp_min_1 0 = 0 /\ - two_exp_min_1 (SUC i) = two_exp_min_1 i + two_exp_min_1 i + 1 -Proof - simp [two_exp_min_1_less_rec] \\ simp [two_exp_min_1_def] -QED - -Theorem to_two_exp_min_1[local]: - (2n EXP i) = (two_exp_min_1 i + 1) -Proof - rw [two_exp_min_1_def, SUB_RIGHT_ADD] -QED - -Theorem LENGTH_bs_tree_to_list[local]: - ! i t. LENGTH (bs_tree_to_list i t) = two_exp_min_1 i -Proof - Induct - \\ simp [bs_tree_to_list_def, two_exp_min_1_rec] -QED - -Theorem LAST_bs_tree_to_list[local]: - 0 < ht ==> LAST (bs_tree_to_list ht t) = ( - case t of Node x _ _ => x) -Proof - Cases_on `ht` \\ simp [bs_tree_to_list_def, two_exp_min_1_rec] -QED - -Definition tree_balanced_height_def: - (tree_balanced_height i Empty_Tree = (i = 0n)) /\ - (tree_balanced_height i (Node x l r) = ( - (i > 0) /\ tree_balanced_height (i - 1) l /\ - tree_balanced_height (i - 1) r) - ) -End - -Theorem tree_balanced_height_0[local]: - (tree_balanced_height 0 t = (t = Empty_Tree)) -Proof - Cases_on `t` \\ simp [tree_balanced_height_def] -QED - -Theorem tree_balanced_height_eq_0[local]: - ht = 0 ==> (tree_balanced_height ht t = (t = Empty_Tree)) -Proof - Cases_on `t` \\ simp [tree_balanced_height_def] -QED - -Theorem tree_balanced_height_pos[local]: - 0 < ht ==> tree_balanced_height ht t = - (?x l r. t = Node x l r /\ tree_balanced_height (ht - 1) l /\ - tree_balanced_height (ht - 1) r) -Proof - Cases_on `t` \\ simp [tree_balanced_height_def] -QED - -Definition bs_tree_list_to_list_def: - bs_tree_list_to_list ts = - FLAT (MAP (\(t, i). bs_tree_to_list i t) (REVERSE ts)) -End - -Theorem bs_tree_list_to_list_rec[local]: - bs_tree_list_to_list (t_i :: ts) = ( - bs_tree_list_to_list ts ++ bs_tree_to_list (SND t_i) (FST t_i) - ) /\ - bs_tree_list_to_list [] = [] -Proof - simp [bs_tree_list_to_list_def] - \\ rpt (pairarg_tac \\ fs[]) -QED - -Theorem st_ex_ignore_bind_simp[local]: - st_ex_ignore_bind f g = st_ex_bind f (\_. g) -Proof - simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_ignore_bind_def] -QED - -(* -Theorem monad_simps[local] = LIST_CONJ - [fetch "-" "update_heap_array_def", fetch "-" "heap_array_sub_def", - ml_monadBaseTheory.monad_eqs, st_ex_ignore_bind_simp, - fetch "-" "update_sz_array_def", fetch "-" "sz_array_sub_def"] - -Theorem tree_len_simps_no_less[local] = LIST_CONJ - [tree_balanced_height_def, tree_balanced_height_0, - two_exp_min_1_rec, - LENGTH_bs_tree_to_list, bs_tree_to_list_def, - bs_tree_to_list_tree_rec, bs_tree_list_to_list_rec] - -Theorem tree_len_simps[local] = LIST_CONJ [tree_len_simps_no_less, - two_exp_min_1_less_rec] - -Theorem TAKE_DROP_eq_imp[local]: - !xs i j. TAKE i (DROP j xs) = ys ==> - i <= LENGTH ys ==> - ys = [] \/ (?xs_pre xs_post. xs = xs_pre ++ ys ++ xs_post /\ - j = LENGTH xs_pre /\ i = LENGTH ys) -Proof - Cases_on `ys = []` \\ simp [] - \\ rw [] - \\ qexists_tac `TAKE j xs` - \\ qexists_tac `DROP (i + j) xs` - \\ fs [GSYM TAKE_SUM] - \\ fs [LENGTH_TAKE_EQ] -QED - -Theorem TAKE_DROP_last_eq_imp[local]: - TAKE l (DROP ((i + 1) - l) xs) = ys /\ - i + 1 <= LENGTH xs /\ l <= i + 1 /\ - l <= LENGTH ys /\ 0 < l ==> - ?xs_pre xs_post. xs = xs_pre ++ ys ++ xs_post /\ - l = LENGTH ys /\ i = LENGTH xs_pre + (LENGTH ys - 1) -Proof - rpt strip_tac - \\ dxrule TAKE_DROP_eq_imp - \\ Cases_on `ys = []` \\ fs [] - \\ rw [] - \\ irule_at Any EQ_REFL - \\ simp [] -QED -*) - -Theorem two_exp_min_1_pos[local]: - (0 < two_exp_min_1 r) = (0 < r) -Proof - Cases_on `r` \\ simp [two_exp_min_1_rec] -QED - -Theorem MAP_SND_insert_trees_inv[local]: - !ts. MAP SND (insert_trees_inv R ts x) = MAP SND ts -Proof - Induct \\ simp [pairTheory.FORALL_PROD, insert_trees_inv_def] - \\ rw [] - \\ rpt (TOP_CASE_TAC \\ simp []) - \\ simp [] -QED - -Theorem MAP_LENGTH_insert_trees_inv[local]: - MAP (LENGTH o (\(t, n). bs_tree_to_list n t)) - (insert_trees_inv R ts x) = - MAP (LENGTH o (\(t, n). bs_tree_to_list n t)) ts -Proof - qspec_then `ts` (mp_tac o Q.AP_TERM `MAP two_exp_min_1`) MAP_SND_insert_trees_inv - \\ simp [MAP_MAP_o, o_DEF, UNCURRY, bs_tree_list_to_list_rec, LENGTH_bs_tree_to_list] -QED - -Theorem LENGTH_insert_trees_inv[local] = - Q.AP_TERM `LENGTH` (SPEC_ALL MAP_LENGTH_insert_trees_inv) - |> REWRITE_RULE [LENGTH_MAP] - -Theorem LENGTH_list_of_insert_trees[local]: - LENGTH (bs_tree_list_to_list (insert_trees_inv R ts x)) = - LENGTH (bs_tree_list_to_list ts) -Proof - simp [bs_tree_list_to_list_def, LENGTH_FLAT, MAP_MAP_o, MAP_REVERSE] - \\ simp [MAP_LENGTH_insert_trees_inv] -QED - -Theorem tree_to_list_unfold = LIST_CONJ [ - bs_tree_list_to_list_rec, bs_tree_to_list_tree_rec] - -Theorem LENGTH_add_tree_step1_facts[local]: - 0 < LENGTH (add_trees_step1 ts x) /\ - LENGTH (bs_tree_list_to_list (add_trees_step1 ts x)) = - LENGTH (bs_tree_list_to_list ts) + 1 /\ - LENGTH (add_trees_step1 ts x) <= LENGTH ts + 1 /\ - (MAP SND (add_trees_step1 ts x) = MAP SND (add_trees_step1 ts y)) = T /\ - (LENGTH (add_trees_step1 ts x) = LENGTH (add_trees_step1 ts y)) = T -Proof - simp [add_trees_step1_def] - \\ rpt (TOP_CASE_TAC \\ fs [tree_to_list_unfold]) -QED - -Theorem inv_add_tree_step1[local]: - (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> - EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (add_trees_step1 ts x) - ) /\ - (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ - SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) ==> - SORTED ($<=) (TAKE 2 (MAP SND (add_trees_step1 ts x))) /\ - SORTED ($<) (MAP SND (DROP 1 (add_trees_step1 ts x))) - ) -Proof - simp [add_trees_step1_def] - \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def]) - \\ rpt (pairarg_tac \\ fs []) - \\ rw [] - \\ fs [] - \\ imp_res_tac SORTED_TL \\ fs [] - \\ Cases_on `t'` \\ fs [] -QED - -Theorem insert_trees_adj_with_inv[local]: - EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> - insert_trees_inv R ((Node x_dc l r, n) :: ts) x = - insert_trees_inv R ((Node y_dc l r, n) :: ts) x -Proof - simp [insert_trees_inv_def] - \\ rpt (TOP_CASE_TAC \\ fs []) \\ rw [] \\ fs [tree_balanced_height_def] - \\ simp [insert_tree_inv_def] -QED - -Theorem insert_trees_adj_add_trees_with_inv[local]: - EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> - insert_trees_inv R (add_trees_step1 ts x_dc) x = - insert_trees_inv R (add_trees_step1 ts y_dc) x -Proof - simp [add_trees_step1_def] - \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def]) - \\ rw [] - \\ irule insert_trees_adj_with_inv - \\ simp [] -QED - -Theorem LENGTH_to_list_add_trees[local]: - LENGTH (bs_tree_list_to_list (add_trees R ts x)) = - LENGTH (bs_tree_list_to_list ts) + 1 -Proof - simp [add_trees_def, LENGTH_list_of_insert_trees, LENGTH_add_tree_step1_facts] -QED - -Theorem insert_tree_inv_balance_inv[local]: - !t ht. tree_balanced_height ht t ==> - tree_balanced_height ht (insert_tree_inv R t x) -Proof - Induct \\ simp [insert_tree_inv_def] - \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def]) -QED - -Theorem insert_trees_inv_balance_inv[local]: - !ts x. EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> - EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (insert_trees_inv R ts x) -Proof - Induct \\ simp [pairTheory.FORALL_PROD, insert_trees_inv_def] - \\ rw [] - \\ rpt (TOP_CASE_TAC \\ fs [tree_balanced_height_def, insert_tree_inv_balance_inv]) -QED - -Theorem inv_add_trees[local]: - (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts ==> - EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) (add_trees R ts x) - ) /\ - (EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ - SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) ==> - SORTED ($<=) (TAKE 2 (MAP SND (add_trees R ts x))) /\ - SORTED ($<) (MAP SND (DROP 1 (add_trees R ts x))) - ) -Proof - simp [add_trees_def, MAP_SND_insert_trees_inv, MAP_DROP] - \\ simp [GSYM MAP_DROP, inv_add_tree_step1, insert_trees_inv_balance_inv] -QED - -Theorem sum_lengths_greater_equal_exp[local]: - ! ts n. EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ - SORTED $< (MAP SND ts) /\ - ts <> [] /\ n <= SND (HD ts) /\ 1 <= n ==> - ((2 EXP (LENGTH ts + (n - 1))) - 1) <= LENGTH (bs_tree_list_to_list ts) -Proof - Induct \\ rw [] - \\ fs [tree_to_list_unfold, LENGTH_bs_tree_to_list] - \\ pairarg_tac \\ fs [] - \\ first_x_assum (qspec_then `SUC n` mp_tac) - \\ imp_res_tac SORTED_TL - \\ simp [EXP] - \\ Cases_on `ts` \\ fs [] - >- ( - simp [tree_to_list_unfold] - \\ simp [two_exp_min_1_def, LEFT_SUB_DISTRIB] - \\ simp [GSYM EXP, ADD1] - \\ rw [SUB_RIGHT_ADD] - ) - >- ( - rw [] - \\ gs [ADD1] - ) -QED - -Theorem inv_trees_less_via_exp[local]: - EVERY (\(t,n). 0 < n /\ tree_balanced_height n t) ts /\ - SORTED $< (DROP 1 (MAP SND ts)) /\ - LENGTH (bs_tree_list_to_list ts) < 2 ** lg /\ - lg + i + 2 <= bd ==> - LENGTH ts + i < bd -Proof - rw [] - \\ fs [GSYM MAP_DROP] - \\ drule_at (Pat `SORTED _ _`) sum_lengths_greater_equal_exp - \\ simp [EVERY_DROP] - \\ disch_then (qspec_then `1` mp_tac) - \\ Cases_on `LENGTH ts <= 1` \\ fs [] - \\ impl_tac - >- ( - fs [HD_DROP, EVERY_EL, UNCURRY] - \\ first_x_assum (qspec_then `1` mp_tac) - \\ simp [] - ) - \\ disch_tac - \\ subgoal `2n ** (LENGTH ts - 1) < 2 ** lg` - >- ( - drule_then irule LESS_EQ_LESS_TRANS - \\ Cases_on `ts` \\ fs [tree_to_list_unfold] - \\ pairarg_tac \\ fs [] - \\ gs [tree_balanced_height_pos, tree_to_list_unfold] - ) - \\ fs [] -QED - -Theorem LENGTH_extend_trees_facts[local]: - tree_balanced_height ht t /\ 0 < ht ==> - LENGTH (extend_trees R ts t ht) = LENGTH ts + 1 - /\ - MAP SND (extend_trees R ts t ht) = ht :: MAP SND ts - /\ - LENGTH (bs_tree_list_to_list (extend_trees R ts t ht)) = - LENGTH (bs_tree_list_to_list ts) + LENGTH (bs_tree_to_list ht t) /\ - (EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) (extend_trees R ts t ht) - ) -Proof - rw [extend_trees_def] - \\ fs [tree_to_list_unfold, tree_balanced_height_pos] - \\ BasicProvers.EVERY_CASE_TAC \\ fs [] - \\ simp [LENGTH_insert_trees_inv, MAP_SND_insert_trees_inv, - LENGTH_list_of_insert_trees, tree_to_list_unfold, tree_balanced_height_def, - insert_trees_inv_balance_inv] -QED - -Theorem above_log2_is_above_ind[local]: - ! i v n. n = 2 EXP i ==> v <= 2 ** (above_log2 i v n) -Proof - recInduct above_log2_ind - \\ rw [] \\ fs [] - \\ ONCE_REWRITE_TAC [above_log2_def] - \\ rw [] \\ fs [EXP_ADD] -QED - -Theorem build_trees_facts[local]: - !xs ts. - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> - LENGTH (bs_tree_list_to_list (build_trees R ts xs)) = - LENGTH (bs_tree_list_to_list ts) + LENGTH xs /\ - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) (build_trees R ts xs) /\ - (SORTED $< (MAP SND (DROP 1 ts)) /\ SORTED $<= (TAKE 2 (MAP SND ts)) ==> - SORTED $< (MAP SND (DROP 1 (build_trees R ts xs))) /\ - SORTED $<= (TAKE 2 (MAP SND (build_trees R ts xs)))) -Proof - Induct \\ simp [tree_to_list_unfold, build_trees_def] - \\ rw [] - \\ simp [inv_add_trees, LENGTH_to_list_add_trees] - \\ fs [IMP_CONJ_THM, FORALL_AND_THM] -QED - -(* 3.2: State/Heap-list equivalence setup. *) - -Definition mk_st_def: - mk_st hps szs = - (<| - sz_array := REVERSE (FST szs) ++ SND szs; - heap_array := bs_tree_list_to_list (FST hps) ++ SND hps - |> : 'a state_refs) -End - -Definition is_last_ix_def: - is_last_ix szs i = (SUM (MAP two_exp_min_1 szs) = i + 1) -End - -Theorem is_last_ix_eq_min_1: - is_last_ix szs i ==> i = SUM (MAP two_exp_min_1 szs) - 1 -Proof - simp [is_last_ix_def] -QED - -Theorem bind_success_eqI: - m st = (M_success v, st2) /\ f v st2 = rhs ==> - st_ex_bind m f st = rhs -Proof - simp [ml_monadBaseTheory.st_ex_bind_def] -QED - -Theorem bind_success_rdonly_eqI = - Q.INST [`st2` |-> `st`] bind_success_eqI - -Theorem mk_st_node_split_r: - 0 < ht ==> - mk_st ((Node x l r, ht) :: hps, oths) szs = - mk_st ((r, ht - 1) :: (l, ht - 1) :: hps, x :: oths) szs -Proof - simp [mk_st_def, tree_to_list_unfold] -QED - -Theorem mk_st_node_split_l: - 0 < ht ==> - mk_st ((Node x l r, ht) :: hps, oths) szs = - mk_st ((l, ht - 1) :: hps, bs_tree_to_list (ht - 1) r ++ x :: oths) szs -Proof - simp [mk_st_def, tree_to_list_unfold] -QED - -Theorem mk_st_move_others: - mk_st ((t, ht) :: hps, oths) szs_pair = - mk_st (hps, bs_tree_to_list ht t ++ oths) szs_pair /\ - mk_st hps_pair (n :: szs, sz_oths) = - mk_st hps_pair (szs, n :: sz_oths) -Proof - simp [mk_st_def, tree_to_list_unfold] -QED - -Theorem LENGTH_bs_tree_list_to_list_eq_SUM[local]: - LENGTH (bs_tree_list_to_list ts) = SUM (MAP two_exp_min_1 (MAP SND ts)) -Proof - simp [bs_tree_list_to_list_def, LENGTH_FLAT, MAP_MAP_o, o_DEF] - \\ simp [UNCURRY, LENGTH_bs_tree_to_list, MAP_REVERSE, SUM_REVERSE] -QED - -Theorem heap_array_sub_curr_bind_eq: - is_last_ix (ht :: MAP SND hps) i /\ 0 < ht ==> - st_ex_bind (heap_array_sub i) f - (mk_st ((Node x l r, ht) :: hps, oths) szs) = - f x (mk_st ((Node x l r, ht) :: hps, oths) szs) -Proof - rw [] - \\ irule bind_success_eqI - \\ simp [fetch "-" "heap_array_sub_def", ml_monadBaseTheory.monad_eqs] - \\ simp [mk_st_def, tree_to_list_unfold, LENGTH_bs_tree_to_list] - \\ fs [is_last_ix_def, LENGTH_bs_tree_list_to_list_eq_SUM, two_exp_min_1_less_rec, - EL_APPEND1, EL_APPEND2, LENGTH_bs_tree_to_list, EL_CONS_IF] -QED - -Theorem is_last_ix_imps: - is_last_ix (ht :: hts) i ==> - (1 < ht ==> is_last_ix (ht - 1 :: hts) (sfx_heap_left i ht)) /\ - (1 < ht ==> is_last_ix (ht - 1 :: ht - 1 :: hts) (i - 1)) /\ - (0 < LENGTH hts /\ 0 < HD hts ==> is_last_ix hts (i - two_exp_min_1 ht)) -Proof - fs [is_last_ix_def] - \\ rw [] - \\ fs [sfx_heap_left_def, to_two_exp_min_1, two_exp_min_1_less_rec] - \\ Cases_on `hts` \\ fs [] - \\ fs [sfx_heap_left_def, to_two_exp_min_1, two_exp_min_1_less_rec] -QED - -Theorem heap_array_sub_left_bind_eq: - is_last_ix (ht :: MAP SND hps) i /\ 1 < ht ==> - st_ex_bind (heap_array_sub (sfx_heap_left i ht)) f - (mk_st ((Node x (Node lx ll lr) r, ht) :: hps, oths) szs) = - f lx (mk_st ((Node x (Node lx ll lr) r, ht) :: hps, oths) szs) -Proof - rw [] - \\ imp_res_tac is_last_ix_imps - \\ fs [] - \\ simp [Once mk_st_node_split_l] - \\ simp [heap_array_sub_curr_bind_eq] - \\ simp [mk_st_node_split_l] -QED - -Theorem heap_array_sub_right_bind_eq: - is_last_ix (ht :: MAP SND hps) i /\ 1 < ht ==> - st_ex_bind (heap_array_sub (i - 1)) f - (mk_st ((Node x l (Node rx rl rr), ht) :: hps, oths) szs) = - f rx (mk_st ((Node x l (Node rx rl rr), ht) :: hps, oths) szs) -Proof - rw [] - \\ imp_res_tac is_last_ix_imps - \\ fs [] - \\ simp [Once mk_st_node_split_r] - \\ simp [heap_array_sub_curr_bind_eq] - \\ simp [mk_st_node_split_r] -QED - -Theorem heap_array_sub_prev_bind_eq: - is_last_ix (ht :: MAP SND hps) i /\ 0 < LENGTH hps /\ - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) hps ==> - st_ex_bind (heap_array_sub (i - two_exp_min_1 ht)) f - (mk_st ((t, ht) :: hps, oths) szs) = - f (case hps of (Node x _ _, _) :: _ => x) (mk_st ((t, ht) :: hps, oths) szs) -Proof - rw [] - \\ imp_res_tac is_last_ix_imps - \\ fs [] - \\ simp [mk_st_move_others] - \\ Cases_on `HD hps` \\ Cases_on `hps` \\ fs [] - \\ gs [tree_balanced_height_pos] - \\ simp [heap_array_sub_curr_bind_eq] -QED - -Theorem update_heap_array_mk_st_eq: - is_last_ix (ht :: MAP SND hps) i /\ 0 < ht ==> - update_heap_array i x (mk_st ((Node x_dc l r, ht) :: hps, oths) szs) = - (M_success (), mk_st ((Node x l r, ht) :: hps, oths) szs) -Proof - simp [fetch "-" "update_heap_array_def", ml_monadBaseTheory.monad_eqs] - \\ rw [is_last_ix_def, mk_st_def] - \\ fs [tree_to_list_unfold, LENGTH_bs_tree_to_list, - LENGTH_bs_tree_list_to_list_eq_SUM, LUPDATE_APPEND, - two_exp_min_1_less_rec, LUPDATE_DEF] -QED - -Theorem return_bind_eq: - st_ex_bind (return v) f = f v -Proof - simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] -QED - -Theorem sz_array_sub_bind_eq: - i < LENGTH szs ==> - st_ex_bind (sz_array_sub i) f (mk_st hps (szs, oths)) = - f (EL (LENGTH szs - (i + 1)) szs) (mk_st hps (szs, oths)) -Proof - rw [] - \\ irule bind_success_eqI - \\ simp [fetch "-" "sz_array_sub_def", ml_monadBaseTheory.monad_eqs] - \\ simp [mk_st_def, EL_APPEND1, EL_REVERSE, PRE_SUB1] -QED - -Theorem update_sz_array_eq: - i < LENGTH szs ==> - update_sz_array i x (mk_st hps (szs, oths)) = - (M_success (), mk_st hps (LUPDATE x (LENGTH szs - (i + 1)) szs, oths)) -Proof - rw [] - \\ simp [fetch "-" "update_sz_array_def", ml_monadBaseTheory.monad_eqs] - \\ simp [mk_st_def] - \\ qspecl_then [`REVERSE szs`, `i`] mp_tac LESS_LENGTH - \\ simp [listTheory.SWAP_REVERSE_SYM] - \\ rw [] - \\ simp [LUPDATE_APPEND1, LUPDATE_APPEND2, LUPDATE_DEF] -QED - -(* 3.3: Proofs of equivalence *) - -Theorem insert_into_sfx_heap_eq: - ! ht hps oths t R i x st. - is_last_ix (ht :: MAP SND hps) i /\ ht > 0 /\ - tree_balanced_height ht t ==> - insert_into_sfx_heap R i ht x (mk_st ((t, ht) :: hps, oths) szs) = - (M_success (), (mk_st ((insert_tree_inv R t x, ht) :: hps, oths) szs)) -Proof - Induct - \\ simp [ADD1] - \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_def] - \\ simp [tree_balanced_height_pos] - \\ rw [] - >- ( - Cases_on `ht` \\ fs [tree_balanced_height_0] - \\ simp [insert_tree_inv_def, update_heap_array_mk_st_eq] - ) - >- ( - simp [return_bind_eq] - \\ gs [tree_balanced_height_pos] - \\ ONCE_REWRITE_TAC [insert_tree_inv_def] - \\ drule_then assume_tac is_last_ix_imps - \\ gs [] - \\ simp [heap_array_sub_left_bind_eq, heap_array_sub_right_bind_eq] - \\ rpt TOP_CASE_TAC - \\ simp [update_heap_array_mk_st_eq, st_ex_ignore_bind_simp] - >- ( - simp [st_ex_ignore_bind_simp] - \\ irule bind_success_eqI - \\ simp [update_heap_array_mk_st_eq] - \\ simp [Once mk_st_node_split_r] - \\ simp [mk_st_node_split_r] - ) - >- ( - simp [st_ex_ignore_bind_simp] - \\ irule bind_success_eqI - \\ simp [update_heap_array_mk_st_eq] - \\ simp [Once mk_st_node_split_l] - \\ simp [mk_st_node_split_l] - ) - ) -QED - -Theorem insert_into_sfx_heap_list_eq: - ! j ts R i x oths szs. - j = LENGTH ts /\ - is_last_ix (MAP SND ts) i /\ - 0 < j /\ EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts ==> - insert_into_sfx_heap_list R i j x (mk_st (ts, oths) (MAP SND ts, szs)) = - (M_success (), mk_st (insert_trees_inv R ts x, oths) (MAP SND ts, szs)) -Proof - Induct - \\ simp [] - \\ ONCE_REWRITE_TAC [insert_into_sfx_heap_list_def] - \\ rpt strip_tac - \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [] - \\ gs [ADD1, TAKE_SUM] - \\ simp [insert_trees_inv_def] - \\ rw [] - >- ( - Cases_on `t` \\ fs [] - \\ simp [sz_array_sub_bind_eq, return_bind_eq] - \\ simp [insert_into_sfx_heap_eq] - ) - \\ simp [sz_array_sub_bind_eq, return_bind_eq] - \\ simp [ADD1] - \\ simp [to_two_exp_min_1, heap_array_sub_prev_bind_eq] - \\ irule bind_success_rdonly_eqI - \\ qexists_tac `case t of ((Node t2x _ _, _) :: _) => - ~ R t2x x /\ ~ (case q of Node _ (Node lx _ _) _ => R t2x lx | _ => F) /\ - ~ (case q of Node _ _ (Node rx _ _) => R t2x rx | _ => F) | _ => F` - \\ conj_tac - >- ( - Cases_on `HD t` \\ Cases_on `t` \\ fs [] - \\ rw [] - >- ( - gs [tree_balanced_height_pos] - \\ simp [heap_array_sub_left_bind_eq, heap_array_sub_right_bind_eq] - \\ simp [ml_monadBaseTheory.monad_eqs] - ) - >- ( - simp [ml_monadBaseTheory.monad_eqs] - \\ gs [tree_balanced_height_pos, tree_balanced_height_eq_0] - ) - ) - \\ simp [] - \\ TOP_CASE_TAC - >- ( - gs [tree_balanced_height_pos] - \\ simp [st_ex_ignore_bind_simp] - \\ irule bind_success_eqI - \\ simp [update_heap_array_mk_st_eq] - \\ simp [mk_st_move_others] - \\ drule_then assume_tac is_last_ix_imps - \\ gs [] - \\ Cases_on `HD t` \\ Cases_on `t` \\ fs [] - \\ gs [tree_balanced_height_pos] - \\ simp [insert_trees_inv_def, mk_st_move_others] - ) - >- ( - simp [insert_into_sfx_heap_eq] - \\ Cases_on `HD t` \\ Cases_on `t` \\ fs [] - \\ gs [tree_balanced_height_pos] - ) -QED - -Theorem add_to_sfx_heaps_step1_eq: - j = LENGTH ts /\ - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - 0 < LENGTH oth_szs ==> - ? oth_szs2. - let ts2 = add_trees_step1 ts x in - add_to_sfx_heaps_step1 j (mk_st (ts, x :: oths) (MAP SND ts, oth_szs)) = - (M_success (LENGTH ts2), mk_st (ts2, oths) (MAP SND ts2, oth_szs2)) /\ - LENGTH ts2 + LENGTH oth_szs2 = LENGTH ts + LENGTH oth_szs -Proof - rw [] - \\ simp [add_to_sfx_heaps_step1_def, add_trees_step1_def] - \\ irule_at Any bind_success_rdonly_eqI - \\ qexists_tac `case ts of (_, n1) :: (_, n2) :: _ => n1 = n2 | _ => F` - \\ simp [GSYM PULL_EXISTS] - \\ conj_tac - >- ( - every_case_tac \\ fs [] - \\ simp [sz_array_sub_bind_eq, ADD1] - \\ simp [ml_monadBaseTheory.monad_eqs] - ) - \\ TOP_CASE_TAC - >- ( - every_case_tac \\ fs [] - \\ simp [sz_array_sub_bind_eq, ADD1, st_ex_ignore_bind_simp] - \\ irule_at Any bind_success_eqI - \\ simp [update_sz_array_eq, ml_monadBaseTheory.monad_eqs] - \\ simp [ADD1, LUPDATE_DEF] - \\ simp [mk_st_node_split_r, mk_st_move_others] - \\ irule_at Any EQ_REFL - \\ simp [] - ) - >- ( - simp [st_ex_ignore_bind_simp] - \\ irule_at Any bind_success_eqI - \\ Cases_on `oth_szs` \\ fs [] - \\ simp [GSYM mk_st_move_others] - \\ simp [update_sz_array_eq, ml_monadBaseTheory.monad_eqs] - \\ simp [ADD1, LUPDATE_DEF] - \\ every_case_tac \\ fs [] - \\ simp [mk_st_move_others, bs_tree_to_list_tree_rec] - \\ REWRITE_TAC [GSYM APPEND_ASSOC, APPEND] - \\ irule_at Any EQ_REFL - \\ simp [] - ) -QED - -Theorem add_to_sfx_heaps_eq: - j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - 0 < LENGTH oth_szs /\ 0 < LENGTH oths ==> - let ts2 = add_trees R ts x in - ? oth_szs2. - add_to_sfx_heaps R i j x (mk_st (ts, oths) (MAP SND ts, oth_szs)) = - (M_success (LENGTH ts2), mk_st (ts2, TL oths) (MAP SND ts2, oth_szs2)) /\ - LENGTH ts2 + LENGTH oth_szs2 = LENGTH ts + LENGTH oth_szs -Proof - rpt strip_tac - \\ qspecl_then [`HD oths`, `TL oths`] mp_tac (Q.GENL [`x`, `oths`] add_to_sfx_heaps_step1_eq) - \\ Cases_on `oths` \\ fs [] - \\ rw [] - \\ simp [add_to_sfx_heaps_def, add_trees_def] - \\ irule_at Any bind_success_eqI - \\ simp [st_ex_ignore_bind_simp] - \\ irule_at Any bind_success_eqI - \\ simp [ml_monadBaseTheory.monad_eqs, LENGTH_insert_trees_inv] - \\ dep_rewrite.DEP_REWRITE_TAC [insert_into_sfx_heap_list_eq] - \\ simp [LENGTH_add_tree_step1_facts, inv_add_tree_step1, is_last_ix_def, - GSYM LENGTH_bs_tree_list_to_list_eq_SUM] - \\ simp [MAP_SND_insert_trees_inv] - \\ irule_at Any (Q.prove (`a = b /\ c = d ==> mk_st a c = mk_st b d`, simp [])) - \\ simp [] - \\ metis_tac [insert_trees_adj_add_trees_with_inv, LENGTH_add_tree_step1_facts] -QED - -Theorem add_all_to_sfx_heaps_eq: - !xs i j ts oths oth_szs. - j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ts) /\ - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ - lg + 3 <= LENGTH ts + LENGTH oth_szs /\ - i + LENGTH xs < 2 EXP lg ==> - LENGTH xs <= LENGTH oths ==> - let ts2 = build_trees R ts xs in - ? oth_szs2. - add_all_to_sfx_heaps R i j xs (mk_st (ts, oths) (MAP SND ts, oth_szs)) = - (M_success (LENGTH (bs_tree_list_to_list ts2), LENGTH ts2), - mk_st (ts2, DROP (LENGTH xs) oths) (MAP SND ts2, oth_szs2)) /\ - LENGTH ts2 + LENGTH oth_szs2 = LENGTH ts + LENGTH oth_szs -Proof - Induct - \\ simp [add_all_to_sfx_heaps_def, build_trees_def] - >- ( - simp [ml_monadBaseTheory.monad_eqs] - \\ metis_tac [] - ) - \\ rpt strip_tac - \\ irule_at Any bind_success_eqI - \\ qmatch_goalsub_abbrev_tac `add_to_sfx_heaps R i j x` - \\ mp_tac add_to_sfx_heaps_eq - \\ fs [markerTheory.Abbrev_def] - \\ impl_keep_tac - >- ( - (* exponential argument that there is space in szs array *) - drule inv_trees_less_via_exp - \\ disch_then (qspecl_then [`lg`, `1`] mp_tac) - \\ simp [GSYM MAP_DROP] - \\ disch_then dxrule - \\ simp [] - ) - \\ rw [] \\ simp [] - \\ qmatch_goalsub_abbrev_tac `mk_st (ts2, _)` - \\ first_x_assum (qspecl_then [`ts2`, `TL oths`, `oth_szs2`] mp_tac) - \\ fs [markerTheory.Abbrev_def] - \\ simp [LENGTH_to_list_add_trees, inv_add_trees] - \\ rw [] \\ simp [] - \\ Cases_on `oths` \\ fs [] - \\ irule_at Any EQ_REFL - \\ simp [] -QED - -Theorem reinsert_tree_eq: - j = LENGTH ts /\ i = LENGTH (bs_tree_list_to_list ((t, ht) :: ts)) /\ - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ - 0 < ht /\ tree_balanced_height ht t ==> - reinsert_tree R i j ht (mk_st ((t, ht) :: ts, oths) (dc :: MAP SND ts, oth_szs)) = - (let ts2 = extend_trees R ts t ht in - (M_success (), mk_st (ts2, oths) (MAP SND ts2, oth_szs))) -Proof - simp [reinsert_tree_def, extend_trees_def] - \\ rw [] - \\ gs [tree_balanced_height_pos] - \\ qmatch_goalsub_abbrev_tac `mk_st (COND tree_cond _ _, _)` - \\ simp [st_ex_ignore_bind_simp] - \\ irule_at Any bind_success_eqI - \\ simp [update_sz_array_eq] - \\ dep_rewrite.DEP_REWRITE_TAC [heap_array_sub_curr_bind_eq] - \\ conj_asm1_tac - >- ( - fs [markerTheory.Abbrev_def] - \\ simp [is_last_ix_def, LENGTH_bs_tree_list_to_list_eq_SUM] - \\ fs [two_exp_min_1_less_rec] - ) - \\ irule_at Any bind_success_rdonly_eqI - \\ qexists_tac `~ tree_cond` - \\ conj_tac - >- ( - rw [] - \\ simp [return_bind_eq, to_two_exp_min_1] - \\ simp [heap_array_sub_prev_bind_eq |> Q.GEN `i` |> Q.SPEC `i - 1` - |> SIMP_RULE (srw_ss ()) [GSYM SUB_PLUS, ADD_COMM]] - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ every_case_tac \\ fs [markerTheory.Abbrev_def] - \\ gs [tree_balanced_height_pos] - ) - \\ rw [] - >- ( - simp [ADD1, LUPDATE_DEF] - \\ qmatch_goalsub_abbrev_tac `mk_st (tt :: ts, _)` - \\ qspecl_then [`j`, `tt :: ts`] (mp_tac o Q.GEN `j`) insert_into_sfx_heap_list_eq - \\ fs [markerTheory.Abbrev_def, tree_balanced_height_def, ADD1] - \\ simp [MAP_SND_insert_trees_inv] - ) - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ simp [ADD1, LUPDATE_DEF] -QED - -Theorem sfx_trees_to_list_eq: - !i j acc ts oths oth_szs. - EVERY (\(t, n). 0 < n /\ tree_balanced_height n t) ts /\ - SORTED ($<=) (TAKE 2 (MAP SND ts)) /\ SORTED ($<) (MAP SND (DROP 1 ts)) /\ - LENGTH ts = j /\ LENGTH (bs_tree_list_to_list ts) = i /\ - lg + 4 <= LENGTH ts + LENGTH oth_szs /\ - i < 2 EXP lg ==> - ?st'. sfx_trees_to_list R i j acc (mk_st (ts, oths) (MAP SND ts, oth_szs)) = - (M_success (pull_trees R ts acc), st') -Proof - Induct - \\ REWRITE_TAC [] - \\ ONCE_REWRITE_TAC [sfx_trees_to_list_def] - >- ( - rw [] - \\ Cases_on `ts` \\ fs [] - \\ simp [ml_monadBaseTheory.monad_eqs, pull_trees_def] - \\ rpt (pairarg_tac \\ fs []) \\ gs [tree_to_list_unfold, tree_balanced_height_pos] - ) - \\ rw [] - \\ subgoal `is_last_ix (MAP SND ts) i` - >- ( - fs [is_last_ix_def, ADD1] - \\ fs [LENGTH_bs_tree_list_to_list_eq_SUM] - ) - \\ Cases_on `HD ts` \\ Cases_on `ts` \\ fs [bs_tree_list_to_list_rec] - \\ simp [sz_array_sub_bind_eq, ADD1] - \\ gs [tree_balanced_height_pos, bs_tree_to_list_tree_rec, ADD1] - \\ simp [heap_array_sub_curr_bind_eq] -(* - \\ drule inv_trees_less_via_exp - \\ simp [GSYM MAP_DROP] - \\ disch_then (qspecl_then [`lg`, `2`] mp_tac) -*) - \\ subgoal `SORTED $<= (TAKE 2 (MAP SND t)) ∧ SORTED $< (DROP 1 (MAP SND t))` - >- ( - Cases_on `TL t` \\ Cases_on `t` \\ fs [] - ) - \\ rw [] - >- ( - gs [tree_balanced_height_eq_0] - \\ simp [mk_st_move_others, bs_tree_to_list_tree_rec, pull_trees_def, - extend_trees_def] - \\ first_x_assum irule - \\ fs [bs_tree_to_list_tree_rec, MAP_DROP] - ) - >- ( - simp [st_ex_ignore_bind_simp, return_bind_eq] - \\ simp [mk_st_node_split_l] - \\ simp [ml_monadBaseTheory.monad_eqs] - \\ dep_rewrite.DEP_REWRITE_TAC [reinsert_tree_eq] - \\ qpat_x_assum `_ = _ + 1n` (assume_tac o GSYM) - \\ simp [MAP_DROP, sfx_heap_left_def, bs_tree_list_to_list_rec, - LENGTH_bs_tree_to_list, to_two_exp_min_1] - \\ Cases_on `oth_szs` - >- ( - (* log/exp proof there is still a spare sz slot *) - gs [] - \\ drule inv_trees_less_via_exp - \\ disch_then (qspecl_then [`lg`, `2`] mp_tac) - \\ simp [] - \\ disch_then drule - \\ simp [] - ) - \\ simp [GSYM mk_st_move_others] - \\ dep_rewrite.DEP_REWRITE_TAC [reinsert_tree_eq] - \\ simp [LENGTH_extend_trees_facts, MAP_DROP, bs_tree_list_to_list_rec] - \\ conj_tac - >- ( - Cases_on `t` \\ fs [] - ) - \\ qmatch_goalsub_abbrev_tac `sfx_trees_to_list _ _ _ acc2 (mk_st (ts, oths2) (_, oth_szs2))` - \\ first_x_assum (qspecl_then [`acc2`, `ts`, `oths2`, `oth_szs2`] mp_tac) - \\ fs [markerTheory.Abbrev_def, LENGTH_extend_trees_facts, ADD1, MAP_DROP] - \\ impl_tac - >- ( - Cases_on `t` \\ fs [] - ) - \\ rw [] \\ simp [] - \\ simp [pull_trees_def] - ) -QED - -Theorem sort_via_sfx_trees_eq: - sort_via_sfx_trees R xs = another_heap_sort R xs -Proof - simp [sort_via_sfx_trees_def, another_heap_sort_def] - \\ Cases_on `xs` - >- ( - simp [build_trees_def, pull_trees_def] - ) - \\ simp [sort_via_sfx_trees_run_worker_def] - \\ simp [run_init_state_def, ml_monadBaseTheory.run_def, sort_via_sfx_trees_worker_def] - \\ simp [ml_monadBaseTheory.exc_case_eq, pairTheory.FST_EQ_EQUIV] - \\ DISJ1_TAC - \\ simp [fetch "-" "alloc_heap_array_def", fetch "-" "alloc_sz_array_def", - ml_monadBaseTheory.monad_eqs, st_ex_ignore_bind_simp] - \\ qmatch_goalsub_abbrev_tac `add_all_to_sfx_heaps _ _ _ xs st` - \\ qspecl_then [`above_log2 0 (LENGTH xs + 1) 1`, `xs`, - `0`, `0`, `[]`, `st.heap_array`, `st.sz_array`] - mp_tac (add_all_to_sfx_heaps_eq |> Q.GEN `lg`) - \\ qspecl_then [`0`, `LENGTH xs + 1`, `1`] assume_tac above_log2_is_above_ind - \\ gs [markerTheory.Abbrev_def, bs_tree_list_to_list_rec, ADD1] - \\ simp [mk_st_def |> Q.SPEC `([], x)`, bs_tree_list_to_list_rec] - \\ rw [] \\ simp [] - \\ dep_rewrite.DEP_REWRITE_TAC [sfx_trees_to_list_eq |> Q.GEN `lg`] - \\ simp [build_trees_facts] - \\ simp [ADD1, bs_tree_list_to_list_rec] - \\ drule_at_then Any (irule_at Any) LESS_LESS_EQ_TRANS - \\ simp [] -QED - -(* Part 4: translation of the sfx variants. *) - -fun fix_state_type thm = let - val types_in_thm = thm |> concl |> all_atoms - |> HOLset.listItems |> map type_of - |> map (fn t => fst (strip_fun t) @ [snd (strip_fun t)]) - |> List.concat - val state_matching_types = types_in_thm - |> filter (can (match_type state_type)) - |> HOLset.fromList Type.compare |> HOLset.listItems - val substs = map (fn t => match_type t state_type) state_matching_types - in case substs of - [] => thm - | [s] => INST_TYPE s thm - | _ => failwith "fix_state_type: multiple!" - end - -Definition comp_exp_def: - comp_exp m x 0 = x /\ - comp_exp (m : num) x (SUC i) = comp_exp m (x * m) i -End - -Theorem comp_exp_eq_ind[local]: - !i x. comp_exp m x i = x * (m EXP i) -Proof - Induct \\ simp [comp_exp_def, EXP] -QED - -Theorem use_comp_exp: - (m EXP i) = comp_exp m 1 i -Proof - simp [comp_exp_eq_ind] -QED - -val comp_exp_v_thm = comp_exp_def |> translate; - -val sfx_heap_left_v_thm = sfx_heap_left_def - |> REWRITE_RULE [use_comp_exp] |> translate; - -val insert_into_sfx_heap_v_thm = insert_into_sfx_heap_def - |> fix_state_type |> m_translate; - -val insert_into_sfx_heap_list_v_thm = insert_into_sfx_heap_list_def - |> REWRITE_RULE [use_comp_exp] - |> fix_state_type |> m_translate; - -Theorem bind_assoc[local]: - st_ex_bind (st_ex_bind f g) h = do - x <- f; - y <- g x; - h y - od -Proof - rw [ml_monadBaseTheory.st_ex_bind_def, FUN_EQ_THM] - \\ rpt (TOP_CASE_TAC \\ fs []) -QED - -val add_to_sfx_heaps_v_thm = add_to_sfx_heaps_def - |> SIMP_RULE bool_ss [add_to_sfx_heaps_step1_def, bind_assoc] - |> fix_state_type |> m_translate; - -val add_all_to_sfx_heaps_v_thm = add_all_to_sfx_heaps_def - |> fix_state_type |> m_translate; - -val reinsert_tree_v_thm = reinsert_tree_def - |> REWRITE_RULE [use_comp_exp] - |> fix_state_type |> m_translate; - -val sfx_trees_to_list_v_thm = sfx_trees_to_list_def - |> fix_state_type |> m_translate; - -val length_v_thm = LENGTH |> translate; - -val above_log2_v_thm = above_log2_def |> translate; - -val sort_via_sfx_trees_worker_v_thm = sort_via_sfx_trees_worker_def - |> fix_state_type |> m_translate; - -val sort_via_sfx_trees_run_worker_v_thm = sort_via_sfx_trees_run_worker_def - |> fix_state_type |> m_translate_run; - -val sort_via_sfx_trees_v_thm = sort_via_sfx_trees_def |> translate; - - From bf242a163f0e4356f1a7fbe847c50e26846bc2fb Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Sun, 8 Mar 2026 10:56:59 +1100 Subject: [PATCH 26/39] sort: derive sort [x] = [x] a different way The bignum proof needs to know that "sort R [x] = [x]" for some reason. This was done by supplying its definitional theorems. It's now derived from PERM instead, which is likely to be more stable. It also occurs to me that EVAL might be fairly safe. --- compiler/backend/proofs/word_bignumProofScript.sml | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/compiler/backend/proofs/word_bignumProofScript.sml b/compiler/backend/proofs/word_bignumProofScript.sml index ad6ff6adb8..ae99ba47e5 100644 --- a/compiler/backend/proofs/word_bignumProofScript.sml +++ b/compiler/backend/proofs/word_bignumProofScript.sml @@ -353,14 +353,15 @@ Proof \\ rw [] QED +Theorem sort_singleton[local] = + sort_PERM |> Q.SPECL [`R`, `[x]`] + |> SIMP_RULE std_ss [sortingTheory.PERM_SING] + Theorem env_to_list_insert_0_LN[local]: env_to_list (insert 0 ret_val LN) p = ([0,ret_val],(\n. p (n+1))) Proof fs [env_to_list_def,toAList_def,Once insert_def,foldi_def] - \\ fs [sort_def, - mergesortTheory.mergesort_tail_def, - Once $ mergesortTheory.mergesortN_tail_def - ] + \\ simp [sort_singleton] \\ fs [list_rearrange_def] \\ rw [] \\ fs [BIJ_DEF,EVAL ``count 1``,INJ_DEF,SURJ_DEF] QED From dfc332937c0e1571841b439ff4e9fa5fee33f91b Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Tue, 10 Mar 2026 17:51:49 +1100 Subject: [PATCH 27/39] heap-list-sort: make CV-friendly definitions This includes a variant of one of the sort workers that keeps a "fuel" parameter to make termination obvious, which in turn means that translation to CV can be done by auto-methods. I also tried a more direct approach, and it was horrible, so I think the silly fuel parameter is being kept. --- basis/pure/heap_list_sortScript.sml | 76 +++++++++++++++++++++++----- cv_translator/backend_cvScript.sml | 77 ++++------------------------- 2 files changed, 75 insertions(+), 78 deletions(-) diff --git a/basis/pure/heap_list_sortScript.sml b/basis/pure/heap_list_sortScript.sml index 3ba0d30459..4b13332655 100644 --- a/basis/pure/heap_list_sortScript.sml +++ b/basis/pure/heap_list_sortScript.sml @@ -96,7 +96,7 @@ QED (* Insert similarly into a list of heap/trees. *) Definition insert_trees_inv_def: (insert_trees_inv R [] x = []) /\ - (insert_trees_inv R ((t1, n1) :: ts) x = (case ts of + (insert_trees_inv R (tup :: ts) x = (case tup of (t1, n1) => (case ts of | [] => [(insert_tree_inv R t1 x, n1)] | (t2, n2) :: tl_ts => (case t1 of Empty_Tree => @@ -108,7 +108,7 @@ Definition insert_trees_inv_def: ~ (case r of Empty_Tree => F | Node rx _ _ => R t2x rx) then (Node t2x l r, n1) :: insert_trees_inv R ts x else (insert_tree_inv R t1 x, n1) :: ts - )))) + ))))) End Theorem insert_trees_inv_size: @@ -157,31 +157,82 @@ Definition add_heap_to_heaps_def: End Theorem add_heap_to_heaps_size: - SUM (MAP (\t_n. simple_tree_size (K 0) (FST t_n)) (add_heap_to_heaps R ts t n)) = - simple_tree_size (K 0) t + SUM (MAP (\t_n. simple_tree_size (K 0) (FST t_n)) ts) + SUM (MAP (simple_tree_size (K 0) o FST) (add_heap_to_heaps R ts t n)) = + simple_tree_size (K 0) t + SUM (MAP (simple_tree_size (K 0) o FST) ts) Proof simp [add_heap_to_heaps_def] \\ BasicProvers.EVERY_CASE_TAC \\ simp [] - \\ simp [REWRITE_RULE [combinTheory.o_DEF] insert_trees_inv_size] + \\ simp [insert_trees_inv_size] QED +(* This variant has a "fuel" parameter to make termination obvious, which + later helps with CV-translation of the sort function. *) +Definition heaps_to_list_metric_def: + heaps_to_list_metric R 0n ts acc = acc /\ + heaps_to_list_metric R n_bound orig_ts acc = (case orig_ts of + ((Node x l r, n) :: ts) => + let ts2 = add_heap_to_heaps R ts l (n - 1); + ts3 = add_heap_to_heaps R ts2 r (n - 1) + in heaps_to_list_metric R (n_bound - 1) ts3 (x :: acc) + | _ => acc) +End + +(* This variant doesn't have the fuel parameter. Defining one in terms of the + other seems to be too tricky. *) Definition heaps_to_list_def: heaps_to_list R [] acc = acc /\ - heaps_to_list R ((Empty_Tree, _) :: ts) acc = acc /\ - heaps_to_list R ((Node x l r, n) :: ts) acc = + heaps_to_list R (tup :: ts) acc = (case tup of + (Node x l r, n) => let ts2 = add_heap_to_heaps R ts l (n - 1); ts3 = add_heap_to_heaps R ts2 r (n - 1) in heaps_to_list R ts3 (x :: acc) + | _ => acc) Termination - WF_REL_TAC `measure (\(R, ts, acc). SUM (MAP (simple_tree_size (K 0) o FST) ts))` + WF_REL_TAC `measure (\(_, ts, _). SUM (MAP (simple_tree_size (K 0) o FST) ts))` + \\ simp [REWRITE_RULE [combinTheory.o_DEF] add_heap_to_heaps_size] +End + +Theorem heaps_to_list_metric_eq: + !n acc. (SUM (MAP (simple_tree_size (K 0) o FST) ts)) <= n ==> + heaps_to_list_metric R n ts acc = heaps_to_list R ts acc +Proof + measureInduct_on `SUM (MAP (simple_tree_size (K 0) o FST) ts)` + \\ simp [] + \\ Cases \\ rw [] + \\ simp [heaps_to_list_def] + \\ Cases_on `n` + \\ simp [heaps_to_list_metric_def] + \\ Cases_on `FST h` \\ Cases_on `h` \\ fs [] \\ simp [add_heap_to_heaps_size] -End +QED Definition heap_list_sort_def: heap_list_sort R xs = heaps_to_list R (add_values_to_heaps R [] xs) [] End +(* Equivalence of metric version. *) +Theorem add_values_to_heaps_size: + !xs hps. SUM (MAP (simple_tree_size (K 0) ∘ FST) (add_values_to_heaps R hps xs)) = + SUM (MAP (simple_tree_size (K 0) ∘ FST) hps) + LENGTH xs +Proof + Induct + \\ simp [add_values_to_heaps_def, add_to_heaps_def, + insert_trees_inv_size, add_to_heaps_step1_def] + \\ rw [] + \\ BasicProvers.EVERY_CASE_TAC \\ simp [] +QED + +Theorem heap_list_sort_metric_eq: + heap_list_sort R xs = heaps_to_list_metric R (LENGTH xs) + (add_values_to_heaps R [] xs) [] +Proof + simp [heap_list_sort_def] + \\ irule EQ_SYM + \\ irule heaps_to_list_metric_eq + \\ simp [add_values_to_heaps_size] +QED + (* Invariant preservation. *) Theorem insert_tree_inv_less[local]: (case t of Node _ l r => tree_top_less R l y /\ tree_top_less R r y | _ => T) ==> @@ -528,9 +579,11 @@ Theorem heaps_to_list_contents: BAG_UNION (FOLDR BAG_UNION {||} (MAP (tree_to_bag o FST) ts)) (LIST_TO_BAG acc) Proof recInduct heaps_to_list_ind + \\ simp [heaps_to_list_def] \\ rw [] - \\ simp [heaps_to_list_def, tree_to_bag_def] + \\ BasicProvers.EVERY_CASE_TAC \\ fs [] \\ simp [add_heap_to_heaps_contents, add_heap_to_heaps_not_empty] + \\ simp [tree_to_bag_def] \\ simp [BAG_UNION_INSERT] \\ simp [BAG_INSERT_commutes, ASSOC_BAG_UNION, COMM_BAG_UNION] QED @@ -543,8 +596,9 @@ Theorem heaps_to_list_sorted: SORTED R (heaps_to_list R ts acc) Proof recInduct heaps_to_list_ind - \\ rw [] \\ fs [] \\ simp [heaps_to_list_def] + \\ rw [] + \\ BasicProvers.EVERY_CASE_TAC \\ fs [] \\ fs [heaps_tree_inv_rec_def, heap_tree_inv_def, tree_top_less_def] \\ gs [] \\ first_x_assum irule diff --git a/cv_translator/backend_cvScript.sml b/cv_translator/backend_cvScript.sml index 5bb42bc9a8..85cf2f06be 100644 --- a/cv_translator/backend_cvScript.sml +++ b/cv_translator/backend_cvScript.sml @@ -6,7 +6,7 @@ Libs preamble cv_transLib Ancestors mllist mergesort cv_std backend to_data_cv export unify_cv - infer_cv basis_cv + infer_cv basis_cv heap_list_sort val _ = cv_memLib.use_long_names := true; @@ -834,80 +834,23 @@ val _ = word_allocTheory.canonize_moves_aux_def |> cv_trans; val _ = word_allocTheory.heu_max_all_def |> cv_auto_trans; val _ = word_allocTheory.heu_merge_call_def |> cv_trans; -val tm = word_allocTheory.canonize_moves_def +(* A little detour to specialise the sort functions to this order relation. *) +val sort_rel = word_allocTheory.canonize_moves_def |> concl |> find_term (can (match_term “sort _”)) |> rand; Definition sort_canonize_def: sort_canonize ls = - sort ^tm ls + sort ^sort_rel ls End -Definition merge_tail_canonize_def: - merge_tail_canonize b ls accl accr = - merge_tail b ^tm ls accl accr -End - -val merge_tail_eq = merge_tail_def - |> CONJUNCTS |> map SPEC_ALL |> LIST_CONJ - |> Q.GEN ‘R’ |> ISPEC tm |> SRULE [GSYM merge_tail_canonize_def] - |> GEN_ALL |> SRULE [FORALL_PROD] |> SPEC_ALL - -val pre = cv_trans_pre "" merge_tail_eq; - -Theorem merge_tail_canonize_pre[cv_pre]: - ∀negate v0 v acc. merge_tail_canonize_pre negate v0 v acc -Proof - Induct_on`v` \\ rw[] - >- simp[Once pre] - \\ qid_spec_tac`acc` - \\ Induct_on`v0` \\ rw[] - >- simp[Once pre] - \\ simp[Once pre] - \\ rw[] - \\ metis_tac[] -QED - -Definition mergesortN_tail_canonize_def: - mergesortN_tail_canonize b n ls = - mergesortN_tail b ^tm n ls -End - -val mergesortN_tail_eq = mergesortN_tail_def - |> CONJUNCTS |> map SPEC_ALL |> LIST_CONJ - |> Q.GEN ‘R’ |> ISPEC tm |> SRULE [GSYM mergesortN_tail_canonize_def, GSYM merge_tail_canonize_def] - |> GEN_ALL |> SRULE [FORALL_PROD] |> SPEC_ALL; - -Theorem c2b_b2c[local]: - cv$c2b (b2c b) = b -Proof - fs[cvTheory.b2c_if,cvTheory.c2b_def] - \\ rw[] -QED - -val _ = cv_trans DIV2_def; - -val pre = cv_auto_trans_pre_rec "" mergesortN_tail_eq - (WF_REL_TAC ‘measure (cv_size o FST o SND)’ \\ rw [] - \\ rename1`_ < cv_size cvv` - \\ Cases_on`cvv` - \\ simp[GSYM (fetch "-" "cv_arithmetic_DIV2_thm")] - \\ rw[DIV2_def] - \\ cv_termination_tac - \\ fs[c2b_b2c] - \\ intLib.ARITH_TAC); - -Theorem mergesortN_tail_canonize_pre[cv_pre]: - ∀negate n l. mergesortN_tail_canonize_pre negate n l -Proof - completeInduct_on`n`>> - rw[Once pre,DIV2_def]>> - first_x_assum irule>> - intLib.ARITH_TAC -QED +val sort_metric_def = sort_canonize_def + |> REWRITE_RULE [sort_def, heap_list_sort_metric_eq] -val pre = cv_auto_trans (sort_canonize_def |> SRULE [sort_def,mergesort_tail_def,GSYM mergesortN_tail_canonize_def]); +val _ = sort_metric_def |> cv_auto_trans -val res = word_allocTheory.canonize_moves_def |> SRULE[GSYM sort_canonize_def] |> cv_auto_trans +val res = word_allocTheory.canonize_moves_def + |> REWRITE_RULE [GSYM sort_canonize_def] + |> cv_auto_trans val _ = cv_trans backendTheory.set_oracle_def; From 97e313fb340d6e93f21deee928a900ebfd780440 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Mon, 16 Mar 2026 15:35:18 +1100 Subject: [PATCH 28/39] Commit README.md update in basis --- basis/README.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/basis/README.md b/basis/README.md index 39a74be5fb..8d0b21e33a 100644 --- a/basis/README.md +++ b/basis/README.md @@ -149,6 +149,9 @@ Logical model of filesystem and I/O streams [mlbasicsProgScript.sml](mlbasicsProgScript.sml): Translates a variety of basic constructs. +[monadic](monadic): +Monadic definitions of stateful functions used in the basis + [pure](pure): HOL definitions of the pure functions used in the CakeML basis. From 5343be733bbbed8f6ba47671d9e3bb08dfc72931 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Thu, 19 Mar 2026 23:46:11 +1100 Subject: [PATCH 29/39] candle: use the previous mergesort The Candle proofs include a pass across the translated CakeML AST to check for problematic effects. The array-based sort complicates this, so instead, restore the previous mergesort translation, call it from Candle, and tweak some proofs to refer to the correct one. --- basis/ListProgScript.sml | 64 ++++++++++++++++ basis/pure/mllistScript.sml | 4 +- .../overloading/monadic/holKernelScript.sml | 2 +- candle/prover/candle_kernel_permsScript.sml | 6 +- .../standard/monadic/holKernelProofScript.sml | 73 +++++++++++-------- candle/standard/monadic/holKernelScript.sml | 2 +- 6 files changed, 115 insertions(+), 36 deletions(-) diff --git a/basis/ListProgScript.sml b/basis/ListProgScript.sml index a72772d550..3020187689 100644 --- a/basis/ListProgScript.sml +++ b/basis/ListProgScript.sml @@ -475,6 +475,70 @@ val _ = next_ml_names := ["sort"]; val sort_v_thm = mllistTheory.sort_thm |> translate; val _ = ml_prog_update close_local_blocks; + +(* Translation of the more conventional merge-sort, needed by Candle. + + * (The Candle proofs include a static check of the sources for various + * issues, and the monadic code above would require additional work.) + *) +val _ = ml_prog_update open_local_block; + +val result = translate sort2_tail_def; +val result = translate sort3_tail_def; +val result = translate REV_DEF; +val result = translate merge_tail_def; +val result = translate DIV2_def; +val result = translate DROP_def; + +val result = translate_no_ind mergesortN_tail_def; + +Theorem mergesortn_tail_ind[local]: + mergesortn_tail_ind (:'a) +Proof + once_rewrite_tac [fetch "-" "mergesortn_tail_ind_def"] + \\ rpt gen_tac + \\ rpt (disch_then strip_assume_tac) + \\ match_mp_tac (latest_ind ()) + \\ rpt strip_tac + \\ last_x_assum match_mp_tac + \\ rpt strip_tac + \\ gvs [FORALL_PROD, DIV2_def] +QED + +val result = mergesortn_tail_ind |> update_precondition; + +Theorem mergesortn_tail_side[local]: + !w x y z. mergesortn_tail_side w x y z +Proof + completeInduct_on `y` + \\ once_rewrite_tac[(fetch "-" "mergesortn_tail_side_def")] + \\ rpt gen_tac \\ rename1 `SUC x1` + \\ rw[DIV2_def] + >- ( + first_x_assum match_mp_tac + \\ fs[] + \\ qspecl_then [`2`,`SUC x1`] assume_tac dividesTheory.DIV_POS + \\ gvs[] + ) + >- ( + qspecl_then [`SUC x1`, `2`] assume_tac arithmeticTheory.DIV_LESS + \\ `0 < SUC x1` by fs[] + \\ `SUC x1 DIV 2 < SUC x1` suffices_by rw[] + \\ first_x_assum match_mp_tac + \\ fs[] + ) +QED + +val result = mergesortn_tail_side |> update_precondition; +val result = translate mergesort_tail_def + +val _ = ml_prog_update open_local_in_block; + +val _ = next_ml_names := ["mergesort"]; +val result = translate mergesort_def; + +val _ = ml_prog_update close_local_blocks; + val _ = ml_prog_update (close_module NONE); (* finite maps -- depend on lists *) diff --git a/basis/pure/mllistScript.sml b/basis/pure/mllistScript.sml index 7de1004027..24dd7bbc2d 100644 --- a/basis/pure/mllistScript.sml +++ b/basis/pure/mllistScript.sml @@ -277,8 +277,8 @@ Proof QED (* ^^^^^ TO BE PORTED TO HOL ^^^^^ *) -Definition old_sort_def: - old_sort = mergesort$mergesort_tail +Definition mergesort_def: + mergesort = mergesort$mergesort_tail End Definition sort_def: diff --git a/candle/overloading/monadic/holKernelScript.sml b/candle/overloading/monadic/holKernelScript.sml index 161ef8bcd4..3caf91a74c 100644 --- a/candle/overloading/monadic/holKernelScript.sml +++ b/candle/overloading/monadic/holKernelScript.sml @@ -1347,7 +1347,7 @@ Definition new_basic_type_definition_def: do (P,x) <- try dest_comb c (strlit "new_basic_type_definition: Not a combination") ; if ~(freesin [] P) then failwith (strlit "new_basic_type_definition: Predicate is not closed") else - let tyvars = MAP Tyvar (MAP implode (sort string_le (MAP explode (type_vars_in_term P)))) in + let tyvars = MAP Tyvar (MAP implode (mergesort string_le (MAP explode (type_vars_in_term P)))) in do rty <- type_of x ; add_type (tyname, LENGTH tyvars) ; aty <- mk_type(tyname,tyvars) ; diff --git a/candle/prover/candle_kernel_permsScript.sml b/candle/prover/candle_kernel_permsScript.sml index 9ba3b2f817..f57d555027 100644 --- a/candle/prover/candle_kernel_permsScript.sml +++ b/candle/prover/candle_kernel_permsScript.sml @@ -133,10 +133,10 @@ Proof \\ rw[] QED -Theorem perms_ok_sort_v[simp]: - perms_ok ps ListProg$sort_v +Theorem perms_ok_mergesort_v[simp]: + perms_ok ps ListProg$mergesort_v Proof - rw[perms_ok_def, ListProgTheory.sort_v_def, astTheory.pat_bindings_def, perms_ok_env_def] + rw[perms_ok_def, ListProgTheory.mergesort_v_def, astTheory.pat_bindings_def, perms_ok_env_def] \\ pop_assum mp_tac \\ eval_nsLookup_tac \\ rw[] QED diff --git a/candle/standard/monadic/holKernelProofScript.sml b/candle/standard/monadic/holKernelProofScript.sml index e398c8d97a..f3de688047 100644 --- a/candle/standard/monadic/holKernelProofScript.sml +++ b/candle/standard/monadic/holKernelProofScript.sml @@ -1685,32 +1685,50 @@ Proof \\ IMP_RES_TAC TERM_Var \\ FULL_SIMP_TAC std_ss [pred_setTheory.IN_UNION] QED -Theorem sort_type_vars_in_term[local]: +Overload candle_sort[local] = ``mllist$mergesort`` + +Theorem string_le_ok[local]: + total string_le /\ antisymmetric string_le /\ transitive string_le +Proof + simp[relationTheory.total_def, relationTheory.transitive_def, + relationTheory.antisymmetric_def, stringTheory.string_le_def] >> + METIS_TAC[stringTheory.string_lt_cases, stringTheory.string_lt_antisym, + stringTheory.string_lt_trans] +QED + +Theorem candle_sort_ok[local]: + SORTED string_le (candle_sort string_le xs) /\ + (PERM (candle_sort string_le xs) ys = PERM xs ys) +Proof + simp [mllistTheory.mergesort_def, mergesortTheory.mergesort_tail_correct, + string_le_ok, mergesortTheory.mergesort_sorted] + \\ metis_tac [mergesortTheory.mergesort_perm, sortingTheory.PERM_TRANS, + sortingTheory.PERM_SYM] +QED + +Theorem LENGTH_candle_sort[local]: + LENGTH (candle_sort string_le xs) = LENGTH xs +Proof + irule sortingTheory.PERM_LENGTH + \\ simp [candle_sort_ok] +QED + +Theorem candle_sort_type_vars_in_term[local]: TERM defs P ==> - (sort $<= (MAP explode (type_vars_in_term P)) = STRING_SORT (MAP explode (tvars P))) + (candle_sort $<= (MAP explode (type_vars_in_term P)) = STRING_SORT (MAP explode (tvars P))) Proof - REPEAT STRIP_TAC \\ - MATCH_MP_TAC (MP_CANON sortingTheory.SORTED_PERM_EQ) \\ - qexists_tac`$<=` >> - conj_asm1_tac >- ( - simp[relationTheory.transitive_def,relationTheory.antisymmetric_def,stringTheory.string_le_def] >> - METIS_TAC[stringTheory.string_lt_antisym,stringTheory.string_lt_trans] ) >> - conj_tac >- ( - MATCH_MP_TAC sort_SORTED >> - simp[relationTheory.total_def,stringTheory.string_le_def] >> - METIS_TAC[stringTheory.string_lt_cases] ) >> - conj_tac >- ( + rw [] + \\ irule sortingTheory.SORTED_PERM_EQ + \\ irule_at Any (hd (BODY_CONJUNCTS candle_sort_ok)) + \\ simp [string_le_ok, candle_sort_ok] + \\ reverse conj_tac >- ( MATCH_MP_TAC sortingTheory.SORTED_weaken >> qexists_tac`$<` >> simp[STRING_SORT_SORTED,stringTheory.string_le_def] ) >> - MATCH_MP_TAC (MP_CANON sortingTheory.PERM_ALL_DISTINCT) >> - conj_tac >- ( - METIS_TAC[sortingTheory.ALL_DISTINCT_PERM - ,sort_PERM - ,ALL_DISTINCT_type_vars_in_term - ,ALL_DISTINCT_MAP_explode] ) >> - simp[ALL_DISTINCT_STRING_SORT] >> - METIS_TAC[MEM_type_vars_in_term,MEM_MAP] + irule sortingTheory.PERM_ALL_DISTINCT + \\ simp [ALL_DISTINCT_MAP_explode, ALL_DISTINCT_type_vars_in_term] + \\ simp [MEM_MAP] + \\ metis_tac [MEM_type_vars_in_term] QED (* ------------------------------------------------------------------------- *) @@ -2673,7 +2691,7 @@ Proof impl_tac >- METIS_TAC[STATE_def,TERM_Comb,THM] >> simp[] >> disch_then kall_tac >> simp[Once st_ex_bind_def] >> - Q.PAT_ABBREV_TAC`vs:string list = sort R X` >> + Q.PAT_ABBREV_TAC`vs:string list = candle_sort R X` >> simp[add_type_def,can_def,otherwise_def,st_ex_return_def] >> ntac 2 (simp[Once st_ex_bind_def]) >> simp[Once st_ex_bind_def,get_the_type_constants_def] >> @@ -2685,6 +2703,7 @@ Proof `get_type_arity tyname s1 = (M_success (LENGTH vs), s1)` by ( simp[get_type_arity_def,st_ex_bind_def,Abbr`s1`] >> simp[Abbr`vs`]>> + simp[LENGTH_candle_sort]>> EVAL_TAC)>> simp[mk_type_def,try_def,otherwise_def,raise_Failure_def,st_ex_return_def,Once st_ex_bind_def] >> @@ -2730,15 +2749,11 @@ Proof imp_res_tac freesin_IMP >> rfs[TERM_def] >> METIS_TAC[]) >> imp_res_tac THM >> rfs[TERM_Comb] >> - imp_res_tac sort_type_vars_in_term >> + imp_res_tac candle_sort_type_vars_in_term >> imp_res_tac THM_term_ok_bool >> fs[term_ok_def] >> rfs[WELLTYPED] >> simp[Abbr`s2`,Abbr`s1`,Abbr`vs`,Abbr`l1`] >> - CONJ_TAC >- ( - qpat_x_assum`_ = STRING_SORT _` (mp_tac o Q.AP_TERM`LENGTH`)>> - qpat_x_assum`_ = STRING_SORT _` (mp_tac o Q.AP_TERM`LENGTH`)>> - simp[LENGTH_QSORT,LENGTH_STRING_SORT,LENGTH_MAP,tvars_ALL_DISTINCT]) >> METIS_TAC[term_type]) >> qmatch_assum_abbrev_tac`Abbrev(l1 = [(absname,absty);(repname,repty)])` >> `mk_const (repname,[]) s2 = (M_success (Const repname repty), s2)` by ( @@ -2914,7 +2929,7 @@ Proof \\ conj_tac >- METIS_TAC[STATE_def,CONTEXT_def,extends_theory_ok,init_theory_ok] \\ simp [Abbr`s2`,conexts_of_upd_def] - \\ imp_res_tac sort_type_vars_in_term + \\ imp_res_tac candle_sort_type_vars_in_term \\ simp [equation_def,Abbr`vs`,MAP_MAP_o,combinTheory.o_DEF,ETA_AX]) \\ conj_tac >- @@ -2922,7 +2937,7 @@ Proof \\ conj_tac >- METIS_TAC[STATE_def,CONTEXT_def,extends_theory_ok,init_theory_ok] \\ simp [Abbr`s2`,conexts_of_upd_def] - \\ imp_res_tac sort_type_vars_in_term + \\ imp_res_tac candle_sort_type_vars_in_term \\ simp [equation_def,Abbr`vs`,MAP_MAP_o,combinTheory.o_DEF,ETA_AX]) \\ Cases \\ once_rewrite_tac [THM_def] diff --git a/candle/standard/monadic/holKernelScript.sml b/candle/standard/monadic/holKernelScript.sml index 747be946a5..c5c77e1554 100644 --- a/candle/standard/monadic/holKernelScript.sml +++ b/candle/standard/monadic/holKernelScript.sml @@ -1226,7 +1226,7 @@ Definition new_basic_type_definition_def: do (P,x) <- try dest_comb c (strlit "new_basic_type_definition: Not a combination") ; if ~(freesin [] P) then failwith (strlit "new_basic_type_definition: Predicate is not closed") else - let tyvars = MAP Tyvar (MAP implode (sort string_le (MAP explode (type_vars_in_term P)))) in + let tyvars = MAP Tyvar (MAP implode (mergesort string_le (MAP explode (type_vars_in_term P)))) in do rty <- type_of x ; add_type (tyname, LENGTH tyvars) ; aty <- mk_type(tyname,tyvars) ; From 8651497dddf2366ee5404dbc51a90b2dea0e8ec8 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Fri, 20 Mar 2026 09:36:18 +1100 Subject: [PATCH 30/39] candle: same sort change in "overloading" Mostly duplicating the change made to the "standard" theories. --- .../monadic/holKernelProofScript.sml | 77 ++++++++++++------- 1 file changed, 48 insertions(+), 29 deletions(-) diff --git a/candle/overloading/monadic/holKernelProofScript.sml b/candle/overloading/monadic/holKernelProofScript.sml index 3def9242e8..27872aa9fe 100644 --- a/candle/overloading/monadic/holKernelProofScript.sml +++ b/candle/overloading/monadic/holKernelProofScript.sml @@ -1684,31 +1684,50 @@ Proof \\ IMP_RES_TAC TERM_Var \\ FULL_SIMP_TAC std_ss [pred_setTheory.IN_UNION] QED -Theorem sort_type_vars_in_term: - (sort $<= (MAP explode (type_vars_in_term P)) = STRING_SORT (MAP explode (tvars P))) +Overload candle_sort[local] = ``mllist$mergesort`` + +Theorem string_le_ok[local]: + total string_le /\ antisymmetric string_le /\ transitive string_le Proof - REPEAT STRIP_TAC \\ - MATCH_MP_TAC (MP_CANON sortingTheory.SORTED_PERM_EQ) \\ - qexists_tac`$<=` >> - conj_asm1_tac >- ( - simp[relationTheory.transitive_def,relationTheory.antisymmetric_def,stringTheory.string_le_def] >> - METIS_TAC[stringTheory.string_lt_antisym,stringTheory.string_lt_trans] ) >> - conj_tac >- ( - MATCH_MP_TAC sort_SORTED >> - simp[relationTheory.total_def,stringTheory.string_le_def] >> - METIS_TAC[stringTheory.string_lt_cases] ) >> - conj_tac >- ( + simp[relationTheory.total_def, relationTheory.transitive_def, + relationTheory.antisymmetric_def, stringTheory.string_le_def] >> + METIS_TAC[stringTheory.string_lt_cases, stringTheory.string_lt_antisym, + stringTheory.string_lt_trans] +QED + +Theorem candle_sort_ok[local]: + SORTED string_le (candle_sort string_le xs) /\ + (PERM (candle_sort string_le xs) ys = PERM xs ys) +Proof + simp [mllistTheory.mergesort_def, mergesortTheory.mergesort_tail_correct, + string_le_ok, mergesortTheory.mergesort_sorted] + \\ metis_tac [mergesortTheory.mergesort_perm, sortingTheory.PERM_TRANS, + sortingTheory.PERM_SYM] +QED + +Theorem LENGTH_candle_sort[local]: + LENGTH (candle_sort string_le xs) = LENGTH xs +Proof + irule sortingTheory.PERM_LENGTH + \\ simp [candle_sort_ok] +QED + +Theorem candle_sort_type_vars_in_term[local]: + TERM defs P ==> + (candle_sort $<= (MAP explode (type_vars_in_term P)) = STRING_SORT (MAP explode (tvars P))) +Proof + rw [] + \\ irule sortingTheory.SORTED_PERM_EQ + \\ irule_at Any (hd (BODY_CONJUNCTS candle_sort_ok)) + \\ simp [string_le_ok, candle_sort_ok] + \\ reverse conj_tac >- ( MATCH_MP_TAC sortingTheory.SORTED_weaken >> qexists_tac`$<` >> simp[STRING_SORT_SORTED,stringTheory.string_le_def] ) >> - MATCH_MP_TAC (MP_CANON sortingTheory.PERM_ALL_DISTINCT) >> - conj_tac >- ( - METIS_TAC[sortingTheory.ALL_DISTINCT_PERM - ,sort_PERM - ,ALL_DISTINCT_type_vars_in_term - ,ALL_DISTINCT_MAP_explode] ) >> - simp[ALL_DISTINCT_STRING_SORT] >> - METIS_TAC[MEM_type_vars_in_term,MEM_MAP] + irule sortingTheory.PERM_ALL_DISTINCT + \\ simp [ALL_DISTINCT_MAP_explode, ALL_DISTINCT_type_vars_in_term] + \\ simp [MEM_MAP] + \\ metis_tac [MEM_type_vars_in_term] QED (* ------------------------------------------------------------------------- *) @@ -3545,7 +3564,7 @@ Proof impl_tac >- METIS_TAC[STATE_def,TERM_Comb,THM] >> simp[] >> disch_then kall_tac >> simp[Once st_ex_bind_def] >> - Q.PAT_ABBREV_TAC`vs:string list = sort R X` >> + Q.PAT_ABBREV_TAC`vs:string list = candle_sort R X` >> simp[add_type_def,can_def,otherwise_def,st_ex_return_def] >> ntac 2 (simp[Once st_ex_bind_def]) >> simp[Once st_ex_bind_def,get_the_type_constants_def] >> @@ -3556,6 +3575,7 @@ Proof `get_type_arity tyname s1 = (M_success (LENGTH vs), s1)` by ( simp[get_type_arity_def,st_ex_bind_def,Abbr`s1`] >> simp[Abbr`vs`]>> + simp[LENGTH_candle_sort]>> EVAL_TAC)>> simp[mk_type_def,try_def,otherwise_def,raise_Fail_def,st_ex_return_def,Once st_ex_bind_def] >> simp[mk_fun_ty_def] >> @@ -3601,12 +3621,10 @@ Proof rfs[TERM_def] >> METIS_TAC[]) >> imp_res_tac THM >> rfs[TERM_Comb] >> imp_res_tac THM_term_ok_bool >> - fs[term_ok_def,sort_type_vars_in_term] >> + fs[term_ok_def, candle_sort_type_vars_in_term] >> rfs[WELLTYPED] >> simp[Abbr`s2`,Abbr`s1`,Abbr`vs`,Abbr`l1`] >> - CONJ_TAC >- ( - qspec_then ‘P’ (mp_tac o Q.AP_TERM ‘LENGTH’) (GEN_ALL sort_type_vars_in_term) >> - simp[sort_LENGTH])>> + fsrw_tac [SFY_ss] [candle_sort_type_vars_in_term, sort_LENGTH] >> METIS_TAC[term_type]) >> qmatch_assum_abbrev_tac`Abbrev(l1 = [(absname,absty);(repname,repty)])` >> `mk_const (repname,[]) s2 = (M_success (Const repname repty), s2)` by ( @@ -3782,15 +3800,16 @@ Proof \\ conj_tac >- METIS_TAC[STATE_def,CONTEXT_def,extends_theory_ok,init_theory_ok] \\ simp [Abbr`s2`,conexts_of_upd_def] - \\ imp_res_tac sort_type_vars_in_term - \\ simp [equation_def,Abbr`vs`,MAP_MAP_o,combinTheory.o_DEF,ETA_AX,sort_type_vars_in_term]) + \\ imp_res_tac candle_sort_type_vars_in_term + \\ simp [equation_def,Abbr`vs`,MAP_MAP_o,combinTheory.o_DEF,ETA_AX]) \\ conj_tac >- (match_mp_tac (List.nth(CONJUNCTS proves_rules,9)) \\ conj_tac >- METIS_TAC[STATE_def,CONTEXT_def,extends_theory_ok,init_theory_ok] \\ simp [Abbr`s2`,conexts_of_upd_def] - \\ simp [sort_type_vars_in_term,equation_def,Abbr`vs`,MAP_MAP_o,combinTheory.o_DEF,ETA_AX]) + \\ fsrw_tac [SFY_ss] [candle_sort_type_vars_in_term] + \\ simp [equation_def,Abbr`vs`,MAP_MAP_o,combinTheory.o_DEF,ETA_AX]) \\ Cases \\ once_rewrite_tac [THM_def] \\ strip_tac From 9aec59ec566b9df659fa47539b03571397c97b8f Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Fri, 27 Mar 2026 23:43:21 +1100 Subject: [PATCH 31/39] run-finding merge-sort verification A merge-sort implementation that first scans for increasing/decreasing runs, and merges them trying to merge even-size runs along roughly the design of "timsort". May replace the standard mergesort. --- basis/pure/README.md | 6 + basis/pure/merge_run_sortScript.sml | 958 ++++++++++++++++++++++++++++ 2 files changed, 964 insertions(+) create mode 100644 basis/pure/merge_run_sortScript.sml diff --git a/basis/pure/README.md b/basis/pure/README.md index e4f9eb8d1d..9b0e0c73ca 100644 --- a/basis/pure/README.md +++ b/basis/pure/README.md @@ -6,6 +6,12 @@ from these by the translator. [basis_cvScript.sml](basis_cvScript.sml): Translation of basis types and functions for use with cv_compute. +[heap_list_sortScript.sml](heap_list_sortScript.sml): +A heap-sort variant that builds a list of exactly-balanced heaps. + +[merge_run_sortScript.sml](merge_run_sortScript.sml): +Verified run-finding (natural) merge sort. + [mlintScript.sml](mlintScript.sml): Pure functions for the Int module. diff --git a/basis/pure/merge_run_sortScript.sml b/basis/pure/merge_run_sortScript.sml new file mode 100644 index 0000000000..06bf359b63 --- /dev/null +++ b/basis/pure/merge_run_sortScript.sml @@ -0,0 +1,958 @@ +(* + Verified run-finding (natural) merge sort. + + This is a bottom-up adaptive merge sort that: + 1. Finds natural ascending/descending runs in the input + 2. Merges adjacent pairs of runs, prioritising merges of similar-sized lists. + + Proven to be a permutation, to sort and to be stable. +*) + +Theory merge_run_sort +Ancestors + pred_set arithmetic list rich_list option pair relation sorting mergesort + +Libs + BasicProvers permLib + +val every_case_tac = BasicProvers.EVERY_CASE_TAC; + +(* ======== Section 1: find_run and its helpers ======== *) + +Definition find_run_desc_def: + find_run_desc R prev [] acc = (prev::acc, []) /\ + find_run_desc R prev (h::t) acc = + if ~ R prev h then find_run_desc R h t (prev::acc) + else (prev::acc, h::t) +End + +Definition find_run_asc_def: + find_run_asc R prev [] acc = (REVERSE (prev::acc), []) /\ + find_run_asc R prev (h::t) acc = + if R prev h + then find_run_asc R h t (prev::acc) + else (REVERSE (prev::acc), h::t) +End + +Definition find_run_def: + find_run R [] = ([], []) /\ + find_run R [x] = ([x], []) /\ + find_run R (a::b::rest) = + if ~ R a b then find_run_desc R b rest [a] + else find_run_asc R b rest [a] +End + +(* -- Helper -- *) + +Theorem PERM_cons_REVERSE[local]: + !x l. PERM (x::l) (REVERSE l ++ [x]) +Proof + rpt gen_tac + \\ once_rewrite_tac [GSYM REVERSE_DEF] + \\ rw [PERM_REVERSE] +QED + +(* -- find_run_desc lemmas -- *) + +Theorem find_run_desc_perm: + !R prev tl acc run rest. + find_run_desc R prev tl acc = (run, rest) ==> + PERM (run ++ rest) (REVERSE acc ++ [prev] ++ tl) +Proof + Induct_on `tl` + \\ simp [Once find_run_desc_def] + >- rw [PERM_cons_REVERSE] + \\ rpt gen_tac \\ strip_tac + \\ every_case_tac \\ gvs [] + >- ( + first_x_assum drule + \\ simp [] + \\ rewrite_tac [GSYM APPEND_ASSOC, APPEND] + ) + >- ( + ONCE_REWRITE_TAC [GSYM APPEND] + \\ rewrite_tac [APPEND_ASSOC] + \\ irule PERM_CONG + \\ simp [] + \\ irule PERM_TRANS + \\ irule_at Any PERM_REVERSE + \\ rewrite_tac [REVERSE_DEF] + \\ simp [] + ) +QED + +Theorem find_run_desc_length: + !R prev tl acc run rest. + find_run_desc R prev tl acc = (run, rest) ==> + LENGTH rest <= LENGTH tl +Proof + Induct_on `tl` + \\ simp [Once find_run_desc_def] + \\ rpt gen_tac \\ strip_tac + \\ every_case_tac \\ gvs [] + \\ Q.PAT_X_ASSUM `!R prev acc run rest. _` + (mp_tac o Q.SPECL [`R`, `h`, `prev::acc`, `run`, `rest`]) + \\ simp [] +QED + +Theorem sorted_cons_lemma[local]: + SORTED R xs /\ (xs <> [] ==> R x (HD xs)) ==> SORTED R (x :: xs) +Proof + Cases_on `xs` \\ fs [SORTED_DEF] +QED + +Theorem find_run_desc_strict_sorted: + !R prev tl acc run rest. + find_run_desc R prev tl acc = (run, rest) /\ + transitive R /\ + SORTED (\x y. ~ R y x) acc /\ (acc <> [] ==> ~ R (HD acc) prev) ==> + SORTED (\x y. ~ R y x) run +Proof + Induct_on `tl` + \\ simp [Once find_run_desc_def] + \\ simp [sorted_cons_lemma] + \\ rw [] + \\ simp [sorted_cons_lemma] + \\ first_x_assum (drule_then irule) + \\ simp [sorted_cons_lemma] + \\ fs [total_def] + \\ metis_tac [] +QED + +Theorem find_run_desc_sorted: + !R prev tl acc run rest. + find_run_desc R prev tl acc = (run, rest) /\ + transitive R /\ total R /\ + SORTED (\x y. ~ R y x) acc /\ (acc <> [] ==> ~ R (HD acc) prev) ==> + SORTED R run +Proof + rw [] + \\ irule SORTED_weaken + \\ drule_then (irule_at Any) find_run_desc_strict_sorted + \\ fs [total_def] + \\ metis_tac [] +QED + +Theorem mem_sorted_append[local]: + !R l1 l2 x y. + transitive R /\ SORTED R (l1 ++ l2) /\ MEM x l1 /\ MEM y l2 ==> R x y +Proof + Induct_on `l1` \\ rw [] + \\ imp_res_tac SORTED_EQ + >- (first_x_assum irule \\ simp [MEM_APPEND]) + \\ first_x_assum irule \\ fs [SORTED_EQ] + \\ qexists_tac `l2` \\ simp [] +QED + +(* -- find_run_asc lemmas -- *) + +Theorem find_run_asc_partition: + !R prev tl acc run rest. + find_run_asc R prev tl acc = (run, rest) ==> + run ++ rest = REVERSE acc ++ [prev] ++ tl +Proof + Induct_on `tl` + \\ simp [Once find_run_asc_def] + \\ rpt gen_tac \\ strip_tac + \\ every_case_tac \\ gvs [] + \\ Q.PAT_X_ASSUM `!R prev acc run rest. _` + (mp_tac o Q.SPECL [`R`, `h`, `prev::acc`, `run`, `rest`]) + \\ simp [Once REVERSE_DEF] +QED + +Theorem find_run_asc_length: + !R prev tl acc run rest. + find_run_asc R prev tl acc = (run, rest) ==> + LENGTH rest <= LENGTH tl +Proof + Induct_on `tl` + \\ simp [Once find_run_asc_def] + \\ rpt gen_tac \\ strip_tac + \\ every_case_tac \\ gvs [] + \\ TRY ( + Q.PAT_X_ASSUM `!R prev acc run rest. _` + (mp_tac o Q.SPECL [`R`, `h`, `prev::acc`, `run`, `rest`]) + \\ simp [] \\ NO_TAC) +QED + +Theorem find_run_asc_sorted: + !R prev tl acc run rest. + transitive R /\ total R /\ + SORTED R (REVERSE (prev::acc)) /\ + find_run_asc R prev tl acc = (run, rest) ==> + SORTED R run +Proof + Induct_on `tl` + \\ simp [Once find_run_asc_def] + \\ rpt gen_tac \\ strip_tac + \\ every_case_tac \\ gvs [] + \\ Q.PAT_X_ASSUM `!R prev acc run rest. _` + (mp_tac o Q.SPECL [`R`, `h`, `prev::acc`, `run`, `rest`]) + \\ impl_tac + >- ( + rw [] \\ once_rewrite_tac [REVERSE_DEF] \\ rw [] + \\ irule SORTED_APPEND_IMP + \\ fs [SORTED_DEF] + \\ `R prev h` by metis_tac [relationTheory.total_def] + \\ `!x. MEM x acc ==> R x prev` by + metis_tac [mem_sorted_append, MEM_REVERSE, MEM] + \\ rw [] \\ metis_tac [relationTheory.transitive_def] + ) + \\ simp [] +QED + +(* -- find_run lemmas -- *) + +Theorem find_run_perm: + !R l run rest. + find_run R l = (run, rest) ==> PERM (run ++ rest) l +Proof + rpt gen_tac \\ strip_tac + \\ Cases_on `l` \\ gvs [Once find_run_def] + \\ Cases_on `t` \\ gvs [Once find_run_def] + \\ every_case_tac \\ gvs [] + >- (imp_res_tac find_run_desc_perm + \\ rewrite_tac [GSYM APPEND_ASSOC, APPEND] \\ fs []) + \\ imp_res_tac find_run_asc_partition + \\ rewrite_tac [GSYM APPEND_ASSOC, APPEND] \\ fs [] +QED + +Theorem find_run_length: + !R l run rest. + find_run R l = (run, rest) /\ l <> [] ==> LENGTH rest < LENGTH l +Proof + rpt gen_tac \\ strip_tac + \\ Cases_on `l` \\ gvs [] + \\ Cases_on `t` \\ gvs [Once find_run_def] + \\ every_case_tac \\ gvs [] + \\ imp_res_tac find_run_desc_length + \\ imp_res_tac find_run_asc_length + \\ fs [] +QED + +Theorem find_run_sorted: + !R l run rest. + total R /\ transitive R /\ find_run R l = (run, rest) ==> SORTED R run +Proof + rpt gen_tac \\ strip_tac + \\ Cases_on `l` \\ gvs [Once find_run_def, SORTED_DEF] + \\ Cases_on `t` \\ gvs [Once find_run_def, SORTED_DEF] + \\ every_case_tac \\ gvs [] + >- (match_mp_tac find_run_desc_sorted + \\ qexists_tac `h'` \\ qexists_tac `t'` + \\ qexists_tac `[h]` \\ qexists_tac `rest` + \\ simp [SORTED_DEF]) + \\ match_mp_tac find_run_asc_sorted + \\ qexists_tac `h'` \\ qexists_tac `t'` + \\ qexists_tac `[h]` \\ qexists_tac `rest` + \\ simp [SORTED_DEF] + \\ metis_tac [relationTheory.total_def] +QED + +(* An alternative (used in the monadic variant). *) + +Definition count_while_2_def: + count_while_2 P [] = 0n /\ + count_while_2 P [x] = 1 /\ + count_while_2 P (x :: y :: zs) = if P x y + then count_while_2 P (y :: zs) + 1 + else 1 +End + +Theorem find_run_asc_eq_count: + !R x xs acc. + find_run_asc R x xs acc = + let n = count_while_2 R (x :: xs) + in (REVERSE acc ++ TAKE n (x :: xs), DROP n (x :: xs)) +Proof + Induct_on `xs` + \\ simp [find_run_asc_def, count_while_2_def] + \\ rw [] +QED + +Theorem find_run_desc_eq_count: + !R x xs acc. + find_run_desc R x xs acc = + let n = count_while_2 (\x y. ~ R x y) (x :: xs) + in (REVERSE (TAKE n (x :: xs)) ++ acc, DROP n (x :: xs)) +Proof + Induct_on `xs` + \\ simp [find_run_desc_def, count_while_2_def] + \\ rw [] +QED + +Theorem find_run_eq_count: + find_run R (x :: y :: zs) = + let n = count_while_2 (\x' y'. R x' y' = R x y) (y :: zs) in + ((if R x y then I else REVERSE) (x :: TAKE n (y :: zs)), DROP n (y :: zs)) +Proof + simp [find_run_def, find_run_asc_eq_count, find_run_desc_eq_count] + \\ rw [] \\ fs [] + \\ srw_tac [ETA_ss] [] +QED + +Theorem count_while_2_length: + ! R xs. + count_while_2 R xs <= LENGTH xs /\ + (0 < LENGTH xs ==> 0 < count_while_2 R xs) +Proof + recInduct count_while_2_ind + \\ rw [count_while_2_def] +QED + +Theorem find_run_length_fst: + ! R xs. + LENGTH (FST (find_run R xs)) <= LENGTH xs +Proof + rw [] + \\ Cases_on `TL xs` \\ Cases_on `xs` \\ fs [] + \\ simp [find_run_eq_count] + \\ simp [find_run_def] + \\ rw [LENGTH_TAKE_EQ] +QED + +Theorem find_run_length_eq_sub: + LENGTH (SND (find_run R xs)) = LENGTH xs - LENGTH (FST (find_run R xs)) +Proof + Cases_on `TL xs` \\ Cases_on `xs` \\ fs [] + \\ simp [find_run_eq_count] + \\ simp [find_run_def] + \\ rw [LENGTH_TAKE_EQ] +QED + +(* ======== Section 2: find_runs (depends on find_run_length) ======== *) + +Definition find_runs_def: + find_runs R [] = [] /\ + find_runs R l = + let (run, rest) = find_run R l in + run :: find_runs R rest +Termination + WF_REL_TAC `measure (LENGTH o SND)` + \\ metis_tac [find_run_length, listTheory.NOT_NIL_CONS, PAIR_EQ] +End + +Theorem find_runs_perm: + !R l. PERM l (FLAT (find_runs R l)) +Proof + ho_match_mp_tac find_runs_ind + \\ rw [Once find_runs_def] + \\ Cases_on `find_run R (v2::v3)` \\ gvs [] + \\ imp_res_tac find_run_perm + \\ TRY (irule PERM_TRANS + \\ qexists_tac `q ++ r` + \\ conj_tac >- metis_tac [PERM_SYM] + \\ irule PERM_CONG \\ simp [] \\ NO_TAC) + \\ simp [Once find_runs_def] +QED + +Theorem find_runs_every_sorted: + !R l. + total R /\ transitive R ==> + EVERY (SORTED R) (find_runs R l) +Proof + ho_match_mp_tac find_runs_ind + \\ rw [Once find_runs_def] + \\ Cases_on `find_run R (v2::v3)` \\ gvs [] + >- simp [Once find_runs_def] + \\ metis_tac [find_run_sorted] +QED + +(* ======== Section 3: merging into sized runs ======== *) + +Definition merge_sizes_def: + merge_sizes do_merge R [] sz_run = [sz_run] /\ + merge_sizes do_merge R (sz_run2 :: acc) sz_run = ( + if do_merge (FST sz_run) (FST sz_run2) + then merge_sizes do_merge R acc + (let (sz, run) = sz_run; (sz2, run2) = sz_run2 + in (sz + sz2, merge R run2 run)) + else sz_run :: sz_run2 :: acc + ) +End + +(* +Definition merge_sizes_def: + merge_sizes R acc run = (case acc of + [] => [(LENGTH run, run)] + | (x :: xs) => let + l = LENGTH run; + (l2, run2) = x in + if l * 2 < l2 + then (l, run) :: x :: xs + else (l + l2, merge R run2 run) :: xs + ) +End +*) + +(* When merging in a new run, of length l, perform two kinds of merge. + Firstly, merge smaller existing runs until their length reaches l. + Secondly, merge in this run repeatedly unless there would be an + "unbalanced" merge with a much longer run. This will preserve the invariant + that the run lengths are at least exponential, and avoid unbalanced merges + where possible. *) +Definition merge_in_run_def: + merge_in_run R xs run = + let l = LENGTH run in + if l = 0 then xs + else let ys = (case xs of (t1 :: t2 :: ts) => if FST t2 < l + then merge_sizes (\sz sz2. sz2 < l) R (t2 :: ts) t1 + else xs + | _ => xs) in + merge_sizes (\sz sz2. ~ (sz * 2 < sz2)) R ys (l, run) +End + +Definition first_pass_def: + first_pass R xs = FOLDL (merge_in_run R) [] (find_runs R xs) +End + +Theorem merge_sizes_perm[local]: + !xs run. PERM (FLAT (MAP SND (merge_sizes f R xs run))) + (FLAT (MAP SND xs) ++ SND run) +Proof + Induct + \\ rw [merge_sizes_def] + \\ rpt (pairarg_tac \\ fs []) + >- ( + irule PERM_TRANS + \\ first_x_assum (irule_at Any) + \\ simp [] + \\ REWRITE_TAC [GSYM APPEND_ASSOC, sortingTheory.PERM_TO_APPEND_SIMPS] + \\ ONCE_REWRITE_TAC [PERM_SYM] + \\ irule PERM_TRANS \\ irule_at (Pat `PERM _ (merge _ _ _)`) merge_perm + \\ simp [PERM_APPEND] + ) + \\ metis_tac [PERM_APPEND, APPEND_ASSOC] +QED + +Theorem merge_in_run_perm: + !run acc. PERM (FLAT (MAP SND (merge_in_run R acc run))) + (FLAT (MAP SND acc) ++ run) +Proof + rw [merge_in_run_def] + \\ irule PERM_TRANS \\ irule_at Any merge_sizes_perm + \\ simp [] + \\ irule PERM_CONG + \\ simp [] + \\ every_case_tac \\ simp [] + \\ irule PERM_TRANS \\ irule_at Any merge_sizes_perm + \\ simp [] + \\ irule PERM_TRANS \\ irule_at Any PERM_APPEND + \\ simp [] +QED + +Theorem FOLDL_merge_in_run_perm[local]: + !rs acc. PERM (FLAT (MAP SND (FOLDL (merge_in_run R) acc rs))) + (FLAT (MAP SND acc ++ rs)) +Proof + Induct + \\ rw [] + \\ irule PERM_TRANS \\ pop_assum (irule_at Any) + \\ simp [] + \\ irule PERM_CONG + \\ simp [] + \\ irule merge_in_run_perm +QED + +Theorem first_pass_perm: + !R xs. PERM (FLAT (MAP SND (first_pass R xs))) xs +Proof + rw [first_pass_def] + \\ irule PERM_TRANS \\ irule_at Any FOLDL_merge_in_run_perm + \\ simp [] + \\ ONCE_REWRITE_TAC [PERM_SYM] + \\ irule find_runs_perm +QED + +Theorem merge_sizes_every_sorted[local]: + !sz_run acc. + total R /\ transitive R /\ + EVERY (SORTED R) (MAP SND acc) /\ SORTED R (SND sz_run) ==> + EVERY (SORTED R) (MAP SND (merge_sizes f R acc sz_run)) +Proof + Induct_on `acc` + \\ rw [merge_sizes_def] + \\ first_x_assum irule + \\ simp [] + \\ rpt (pairarg_tac \\ fs []) + \\ rw [merge_sorted] +QED + +Theorem merge_in_run_every_sorted[local]: + !run acc. + total R /\ transitive R /\ + EVERY (SORTED R) (MAP SND acc) /\ SORTED R run ==> + EVERY (SORTED R) (MAP SND (merge_in_run R acc run)) +Proof + rw [merge_in_run_def] + \\ every_case_tac \\ fs [] + \\ simp [merge_sizes_every_sorted] +QED + +Theorem FOLDL_merge_in_run_every_sorted[local]: + !rs acc. + total R /\ transitive R /\ + EVERY (SORTED R) (MAP SND acc) /\ EVERY (SORTED R) rs ==> + EVERY (SORTED R) (MAP SND (FOLDL (merge_in_run R) acc rs)) +Proof + Induct + \\ rw [] + \\ first_x_assum irule + \\ simp [merge_in_run_every_sorted] +QED + +Theorem first_pass_every_sorted: + !R xs. + total R /\ transitive R ==> + EVERY (SORTED R) (MAP SND (first_pass R xs)) +Proof + rw [first_pass_def] + \\ irule FOLDL_merge_in_run_every_sorted + \\ simp [find_runs_every_sorted] +QED + +Theorem merge_sizes_neq_nil[local]: + !acc sz_run. merge_sizes f R acc sz_run <> [] +Proof + Induct + \\ rw [merge_sizes_def] +QED + +Theorem merge_sizes_eq_cons_lemma[local]: + !acc sz_run. + merge_sizes f R acc sz_run = hd :: tl ==> + ?n. tl = DROP n acc /\ + (tl <> [] ==> ~ f (FST hd) (FST (HD tl))) +Proof + Induct + \\ rw [merge_sizes_def] + >- ( + first_x_assum drule + \\ rw [] + \\ qexists_tac `n + 1` + \\ simp [] + ) + >- ( + qexists_tac `0` + \\ simp [] + ) +QED + +Theorem merge_length[local]: + LENGTH (merge R xs ys) = LENGTH xs + LENGTH ys +Proof + qspecl_then [`R`, `xs`, `ys`] mp_tac merge_perm + \\ rw [] + \\ imp_res_tac PERM_LENGTH + \\ fs [] +QED + +Theorem merge_sizes_eq_length_inv: + ! acc sz_run. + EVERY (\(sz, xs). sz = LENGTH xs /\ ~ NULL xs) acc /\ + FST sz_run = LENGTH (SND sz_run) /\ ~ NULL (SND sz_run) ==> + EVERY (\(sz, xs). sz = LENGTH xs /\ ~ NULL xs) (merge_sizes f R acc sz_run) +Proof + Induct_on `acc` + \\ simp [merge_sizes_def, FORALL_PROD] + \\ rw [] + \\ first_x_assum irule + \\ fs [merge_length, GSYM rich_listTheory.LENGTH_NOT_NULL] +QED + +Theorem merge_in_run_eq_length_inv: + EVERY (\(sz, xs). sz = LENGTH xs /\ ~ NULL xs) acc ==> + EVERY (\(sz, xs). sz = LENGTH xs /\ ~ NULL xs) (merge_in_run R acc r) +Proof + rw [merge_in_run_def] + \\ Cases_on `HD acc` \\ Cases_on `acc` + \\ fs [merge_sizes_def, merge_empty, GSYM NULL_EQ] + \\ irule merge_sizes_eq_length_inv + \\ simp [] + \\ every_case_tac \\ fs [] + \\ irule merge_sizes_eq_length_inv + \\ simp [] + \\ rpt (pairarg_tac \\ fs []) + \\ fs [merge_length, GSYM rich_listTheory.LENGTH_NOT_NULL] +QED + +Theorem SORTED_DROP_IMP[local]: + !n xs. SORTED R xs ==> SORTED R (DROP n xs) +Proof + Induct + \\ simp [] + \\ Cases \\ simp [] + \\ metis_tac [SORTED_TL] +QED + +Theorem SORTED_merge_sizes_lemma[local]: + SORTED R2 acc /\ (!sz r sz2 r2. ~ f sz sz2 ==> R2 (sz, r) (sz2, r2)) ==> + SORTED R2 (merge_sizes f R acc sz_run) +Proof + rw [] + \\ subgoal `!t t2. ~ f (FST t) (FST t2) ==> R2 t t2` + >- simp [FORALL_PROD] + \\ Cases_on `merge_sizes f R acc sz_run` \\ simp [] + \\ drule merge_sizes_eq_cons_lemma + \\ rw [] + \\ irule sorted_cons_lemma + \\ fs [SORTED_DROP_IMP] +QED + +Theorem neq_nil_IMP: + x <> [] ==> (?y ys. x = y :: ys) +Proof + Cases_on `x` \\ simp [] +QED + +(* The interesting case of the size invariant proof. The existing + sizes go up in at-least-exponential strides, and are to be merged. + The initial two are less than 'n'. The first may already have been + merged, so it is merely less than the second. Merging continues until + 'n' is passed, and we need to know it does not overshoot so far that + it would not itself be merged in the next pass. *) +Theorem merge_sizes_hd_lim[local]: + !xs sz_run. + merge_sizes (\sz sz2. sz2 < n) R xs sz_run = hd :: tl /\ + tl <> [] /\ FST sz_run < 2 * n /\ + SORTED (\sz sz2. sz * 2 < sz2) (MAP FST xs) /\ + (xs <> [] ==> FST sz_run < FST (HD xs)) ==> + FST hd < 2 * n +Proof + Induct + \\ simp [merge_sizes_def] + \\ rw [] + \\ imp_res_tac SORTED_TL + \\ simp [] + \\ first_x_assum (drule_then irule) + \\ simp [] + \\ rpt (pairarg_tac \\ fs []) + \\ rw [] + \\ imp_res_tac neq_nil_IMP \\ fs [] +QED + +(* Not strictly needed for the verification of this variant. *) +Theorem merge_in_run_size_invariant: + SORTED (\sz sz2. sz * 2 < sz2) (MAP FST acc) /\ + EVERY (\(sz, xs). sz = LENGTH xs /\ ~ NULL xs) acc ==> + SORTED (\sz sz2. sz * 2 < sz2) (MAP FST (merge_in_run R acc r_add)) +Proof + strip_tac + \\ rw [merge_in_run_def] + \\ fs [sorted_map] + \\ Cases_on `HD acc` \\ Cases_on `acc` + \\ simp [merge_sizes_def, merge_empty] + \\ fs [] + \\ imp_res_tac SORTED_TL + \\ rw [] \\ fs [] + \\ every_case_tac \\ fs [] + \\ simp [SORTED_merge_sizes_lemma, sorted_map] + (* The tricky case that remains is the one where the invariant + might not hold at the head of the intermediate constructed list. *) + \\ rpt (pairarg_tac \\ fs []) + \\ qmatch_asmsub_rename_tac `EVERY _ xs` + \\ qmatch_goalsub_abbrev_tac `SORTED _ (merge_sizes _ _ merge1 _)` + \\ Cases_on `merge1` + \\ fs [merge_sizes_neq_nil] + \\ imp_res_tac merge_sizes_eq_cons_lemma + \\ imp_res_tac SORTED_TL + \\ rw [merge_sizes_def] + >- ( + rpt (pairarg_tac \\ fs []) + \\ simp [SORTED_merge_sizes_lemma, SORTED_DROP_IMP] + ) + >- ( + irule sorted_cons_lemma + \\ simp [SORTED_DROP_IMP] + \\ rw [] + \\ gs [] + \\ drule merge_sizes_hd_lim + \\ simp [sorted_map] + \\ rw [] + \\ imp_res_tac neq_nil_IMP \\ fs [] + ) +QED + +(* Not strictly needed for the verification of this variant. *) +Theorem FOLDL_merge_in_run_size_invariant: + !rs acc. + SORTED (\sz sz2. sz * 2 < sz2) (MAP FST acc) /\ + EVERY (\(sz, xs). sz = LENGTH xs /\ ~ NULL xs) acc ==> + SORTED (\sz sz2. sz * 2 < sz2) + (MAP FST (FOLDL (merge_in_run R) acc rs)) /\ + EVERY (\(sz, xs). sz = LENGTH xs /\ ~ NULL xs) + (FOLDL (merge_in_run R) acc rs) +Proof + Induct + \\ simp [] + \\ rpt gen_tac + \\ strip_tac + \\ fs [] + \\ first_x_assum irule + \\ simp [merge_in_run_eq_length_inv, + SIMP_RULE arith_ss [] merge_in_run_size_invariant] +QED + +Theorem first_pass_size_invariant: + SORTED (\sz sz2. sz * 2 < sz2) + (MAP FST (first_pass R xs)) /\ + EVERY (\(sz, xs). sz = LENGTH xs /\ ~ NULL xs) + (first_pass R xs) +Proof + REWRITE_TAC [first_pass_def] + \\ irule FOLDL_merge_in_run_size_invariant + \\ simp [] +QED + +(* ======== Section 4: merge_run_sort (top-level) ======== *) + +Definition merge_run_sort_def: + merge_run_sort R xs = FLAT (MAP SND (merge_sizes (\_ _. T) R + (first_pass R xs) (0, []))) +End + +(* +Theorem PERM_FLAT_MAP_REVERSE: + !xs. PERM (FLAT (MAP REVERSE xs)) (FLAT xs) +Proof + Induct \\ simp [] + \\ simp [PERM_CONG] +QED +*) + +Theorem merge_run_sort_perm: + !R l. PERM l (merge_run_sort R l) +Proof + rw [merge_run_sort_def] + \\ ONCE_REWRITE_TAC [PERM_SYM] + \\ irule PERM_TRANS \\ irule_at Any merge_sizes_perm + \\ simp [first_pass_perm] +QED + +Theorem SORTED_FLAT_1_lemma[local]: + LENGTH xs <= 1 /\ EVERY (SORTED R) xs ==> + SORTED R (FLAT xs) +Proof + Cases_on `TL xs` \\ Cases_on `xs` \\ fs [ADD1] +QED + +Theorem merge_sizes_T_length[local]: + !acc sz_run. (!sz sz2. f sz sz2) ==> + LENGTH (merge_sizes f R acc sz_run) <= 1 +Proof + Induct + \\ simp [merge_sizes_def] +QED + +Theorem merge_run_sort_sorted: + !R l. total R /\ transitive R ==> SORTED R (merge_run_sort R l) +Proof + rw [merge_run_sort_def] + \\ irule SORTED_FLAT_1_lemma + \\ simp [merge_sizes_every_sorted, first_pass_every_sorted] + \\ simp [merge_sizes_T_length] +QED + +Theorem merge_run_sort_SORTS: + !R. total R /\ transitive R ==> SORTS merge_run_sort R +Proof + rw [SORTS_DEF] \\ metis_tac [merge_run_sort_perm, merge_run_sort_sorted] +QED + +(* ======== Section 5: Stability ======== *) + +(* Stability for find_run_asc is easy. For find_run_desc, which reverses, + this will be OK because each strictly descending run can have at most + one element that satisfies the special predicate p. *) + +Theorem find_run_asc_append_eq[local]: + !R prev tl acc run rest. + find_run_asc R prev tl acc = (run, rest) ==> + REVERSE acc ++ [prev] ++ tl = run ++ rest +Proof + Induct_on `tl` + \\ simp [Once find_run_asc_def] + \\ rw [] + \\ simp [] + \\ res_tac + \\ fs [] +QED + +Theorem find_run_desc_append_eq[local]: + !R prev tl acc run rest. + find_run_desc R prev tl acc = (run, rest) ==> + REVERSE acc ++ [prev] ++ tl = REVERSE run ++ rest +Proof + Induct_on `tl` + \\ simp [Once find_run_desc_def] + \\ rw [] + \\ simp [] + \\ res_tac + \\ fs [] +QED + +Theorem find_run_append_eq[local]: + !R xs run rest. + find_run R xs = (run, rest) ==> + run ++ rest = xs \/ REVERSE run ++ rest = xs +Proof + recInduct find_run_ind + \\ simp [find_run_def] + \\ rw [] + \\ imp_res_tac find_run_desc_append_eq + \\ imp_res_tac find_run_asc_append_eq + \\ fs [] +QED + +Theorem stable_refl[local] = stable_def |> Q.SPECL [`R`, `xs`, `xs`] + |> REWRITE_RULE [] + +Theorem not_R_transitive[local]: + transitive R /\ total R ==> + transitive (\x y. ~ R y x) +Proof + simp [transitive_def, total_def] + \\ metis_tac [] +QED + +Theorem strict_desc_stable_reverse_lemma[local]: + !xs. + transitive R /\ total R /\ SORTED (\x y. ~ R y x) xs /\ + (!x y. p x /\ p y ==> R x y) ==> + FILTER p (REVERSE xs) = FILTER p xs +Proof + Induct + \\ rw [] + \\ imp_res_tac SORTED_TL + \\ simp [FILTER_APPEND] + \\ Cases_on `FILTER p xs = []` + \\ fs [FILTER_NEQ_NIL] + \\ gs [SORTED_EQ, not_R_transitive] + \\ metis_tac [] +QED + +Theorem find_run_stable: + !R l run rest. + transitive R /\ total R /\ + find_run R l = (run, rest) ==> + stable R l (run ++ rest) +Proof + recInduct find_run_ind + \\ simp [find_run_def] + \\ rw [stable_refl] + \\ imp_res_tac find_run_desc_append_eq + \\ imp_res_tac find_run_asc_append_eq + \\ fs [stable_refl] + \\ irule stable_cong + \\ rw [stable_def] + \\ drule_then irule strict_desc_stable_reverse_lemma + \\ simp [] + \\ drule_then irule find_run_desc_strict_sorted + \\ simp [] +QED + +Theorem find_runs_stable: + !R l. + transitive R /\ total R ==> + stable R l (FLAT (find_runs R l)) +Proof + ho_match_mp_tac find_runs_ind + \\ rw [Once find_runs_def] + >- simp [Once find_runs_def, stable_def] + \\ Cases_on `find_run R (v2::v3)` \\ gvs [] + \\ irule stable_trans + \\ qexists_tac `q ++ FLAT (find_runs R r)` + \\ conj_tac + >- (irule stable_trans + \\ qexists_tac `q ++ r` + \\ conj_tac >- metis_tac [find_run_stable] + \\ irule stable_cong \\ rw [stable_def]) + \\ rewrite_tac [GSYM APPEND_ASSOC] + \\ irule stable_cong \\ rw [stable_def] +QED + +Theorem merge_sizes_stable[local]: + !acc sz_run. transitive R /\ EVERY (SORTED R) (MAP SND acc) ==> + stable R (FLAT (REVERSE (MAP SND acc)) ++ SND sz_run) + (FLAT (REVERSE (MAP SND (merge_sizes f R acc sz_run)))) +Proof + Induct + \\ rw [merge_sizes_def, stable_refl] + \\ irule stable_trans + \\ first_x_assum (irule_at Any) + \\ rpt (pairarg_tac \\ fs []) + \\ REWRITE_TAC [GSYM APPEND_ASSOC] + \\ irule stable_cong + \\ simp [stable_refl, merge_stable] +QED + +Theorem merge_in_run_stable[local]: + !acc sz_run. transitive R /\ total R /\ EVERY (SORTED R) (MAP SND acc) ==> + stable R (FLAT (REVERSE (MAP SND acc)) ++ r) + (FLAT (REVERSE (MAP SND (merge_in_run R acc r)))) +Proof + rw [merge_in_run_def, stable_refl] + \\ irule stable_trans + \\ irule_at (Pat `stable _ _ (FLAT _)`) merge_sizes_stable + \\ simp [] + \\ every_case_tac \\ simp [stable_refl] + \\ fs [merge_sizes_every_sorted] + \\ irule stable_cong + \\ simp [stable_refl] + \\ irule stable_trans + \\ irule_at (Pat `stable _ _ (FLAT _)`) merge_sizes_stable + \\ simp [stable_refl] +QED + +Theorem FOLDL_merge_in_run_stable[local]: + !rs acc. total R /\ transitive R /\ + EVERY (SORTED R) (MAP SND acc) /\ EVERY (SORTED R) rs ==> + stable R (FLAT (REVERSE (MAP SND acc) ++ rs)) + (FLAT (REVERSE (MAP SND (FOLDL (merge_in_run R) acc rs)))) +Proof + Induct + \\ simp [stable_refl] + \\ rw [] + \\ irule stable_trans + \\ first_x_assum (irule_at Any) + \\ simp [merge_in_run_every_sorted] + \\ irule stable_cong + \\ simp [stable_refl, merge_in_run_stable] +QED + +Theorem first_pass_stable: + !R rs. + total R /\ transitive R ==> + stable R rs (FLAT (REVERSE (MAP SND (first_pass R rs)))) +Proof + rw [first_pass_def] + \\ irule stable_trans + \\ irule_at Any FOLDL_merge_in_run_stable + \\ simp [find_runs_every_sorted, find_runs_stable] +QED + +Theorem stable_FLAT_1_lemma[local]: + stable R l (FLAT (REVERSE xs)) /\ LENGTH xs <= 1 ==> + stable R l (FLAT xs) +Proof + Cases_on `TL xs` \\ Cases_on `xs` \\ fs [] +QED + +Theorem merge_run_sort_stable: + !R l. total R /\ transitive R ==> stable R l (merge_run_sort R l) +Proof + rw [merge_run_sort_def] + \\ irule stable_FLAT_1_lemma + \\ simp [merge_sizes_T_length] + \\ irule stable_trans + \\ irule_at Any (merge_sizes_stable) + \\ simp [MAP_REVERSE, first_pass_every_sorted, first_pass_stable] +QED + +Theorem merge_run_sort_STABLE_SORT: + !R. transitive R /\ total R ==> STABLE merge_run_sort R +Proof + rw [STABLE_DEF] + \\ metis_tac [merge_run_sort_SORTS, merge_run_sort_stable, stable_def] +QED + From d141430320ed9259a526bcf1c2b3b556b88474d2 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Mon, 30 Mar 2026 10:06:37 +1100 Subject: [PATCH 32/39] monadic (array) variant of sort and equiv proof This proof is still a bit involved, but less so than the heap version. It probably helps that the data representation, in which the list chunks are all placed in order, has less moving parts than the flattened-heap variant. --- .../monadic/merge_run_sort_monadicScript.sml | 1277 +++++++++++++++++ 1 file changed, 1277 insertions(+) create mode 100644 basis/monadic/merge_run_sort_monadicScript.sml diff --git a/basis/monadic/merge_run_sort_monadicScript.sml b/basis/monadic/merge_run_sort_monadicScript.sml new file mode 100644 index 0000000000..38225079d1 --- /dev/null +++ b/basis/monadic/merge_run_sort_monadicScript.sml @@ -0,0 +1,1277 @@ +(* + Monadic variants of the merge-run-sort functions, and proofs of equivalence. +*) + +Theory merge_run_sort_monadic +Ancestors + merge_run_sort ml_monadBase mergesort +Libs + preamble ml_monadBaseLib + +(* Part 1: Setup of types and infrastructure. *) + +(* The data type of the state. *) +Datatype: + merge_run_state = <| + main_array : ( 'a ) list; + copy_array : ( 'a ) list; + sz_array : num list; + |> +End + +(* Equivalent to unit, but we need to construct a type so that the translation + can construct a new exception type. *) +Datatype: + heap_list_subscript_exn = MR_Subscript +End + +(* Setup to use monad translator constants and monad syntax. *) +val acc_fun_defs = define_monad_access_funs ``: 'a merge_run_state`` + +val mr_manip_funs = define_MRarray_manip_funs acc_fun_defs + ``MR_Subscript`` ``MR_Subscript`` + +val _ = ParseExtras.temp_tight_equality (); +val _ = monadsyntax.temp_add_monadsyntax (); + +Overload "monad_bind"[local] = ``st_ex_bind`` +Overload "monad_unitbind"[local] = ``st_ex_ignore_bind`` +Overload "monad_ignore_bind"[local] = ``st_ex_ignore_bind`` +Overload "return"[local] = ``st_ex_return`` + +(* Part 2: Definition of sort functions with runs held in an array. *) + +Definition merge_runs_def: + merge_runs R xi xlen yi ylen base = if xi >= xlen + then (* no more xs, ys are in correct place *) + return () + else if yi >= ylen + then do (* no more ys, copy xs to correct place *) + x <- copy_array_sub xi; + update_main_array (base + yi + xi) x; + merge_runs R (xi + 1) xlen yi ylen base + od + else do + x <- copy_array_sub xi; + y <- main_array_sub (base + xlen + yi); + b <- return (R x y); + update_main_array (base + yi + xi) (if b then x else y); + merge_runs R (xi + (if b then 1 else 0)) xlen + (yi + (if b then 0 else 1)) ylen base + od +Termination + WF_REL_TAC `measure (\(R, xi, xlen, yi, ylen, base). (xlen - xi) + (ylen - yi))` +End + +Definition copy_to_copy_def: + copy_to_copy base xi xlen = if xi >= xlen + then return () + else do + x <- main_array_sub (base + xi); + update_copy_array xi x; + copy_to_copy base (xi + 1) xlen + od +Termination + WF_REL_TAC `measure (\(base, xi, xlen). (xlen - xi))` +End + +Definition do_merge_array_def: + do_merge_array R ri arri = do + xsz <- sz_array_sub (ri + 1); + ysz <- sz_array_sub ri; + update_sz_array (ri + 1) (xsz + ysz); + base <- return (arri - (xsz + ysz)); + copy_to_copy base 0 xsz; + merge_runs R 0 xsz 0 ysz base + od +End + +Definition merge_sizes_gen_array_def: + merge_sizes_gen_array R f ri rlen arri = + if ri + 1 >= rlen + then return ri + else do + sz <- sz_array_sub ri; + sz2 <- sz_array_sub (ri + 1); + if f sz sz2 + then do + do_merge_array R ri arri; + merge_sizes_gen_array R f (ri + 1) rlen arri + od + else return ri + od +Termination + WF_REL_TAC `measure (\(R, f, ri, rlen, arri). (rlen - ri))` +End + +Definition merge_smaller_array_def: + merge_smaller_array R n ri rlen arri = + if ri + 1 >= rlen + then return ri + else do + sz2 <- sz_array_sub (ri + 1); + if sz2 < n + then do + do_merge_array R ri arri; + merge_smaller_array R n (ri + 1) rlen arri + od + else return ri + od +Termination + WF_REL_TAC `measure (\(R, n, ri, rlen, arri). (rlen - ri))` +End + +Definition merge_similar_array_def: + merge_similar_array R ri rlen arri = + if ri + 1 >= rlen + then return ri + else do + sz <- sz_array_sub ri; + sz2 <- sz_array_sub (ri + 1); + if sz * 2 < sz2 + then return ri + else do + do_merge_array R ri arri; + merge_similar_array R (ri + 1) rlen arri + od + od +Termination + WF_REL_TAC `measure (\(R, ri, rlen, arri). (rlen - ri))` +End + +Definition merge_every_array_def: + merge_every_array R ri rlen arri = + if ri + 1 >= rlen + then return ri + else do + do_merge_array R ri arri; + merge_every_array R (ri + 1) rlen arri + od +Termination + WF_REL_TAC `measure (\(R, ri, rlen, arri). (rlen - ri))` +End + +Definition merge_in_run_array_def: + merge_in_run_array R ri rlen arri l = do + ri2 <- if ri + 1 < rlen + then do + l2 <- sz_array_sub (ri + 1); + if l2 < l then merge_smaller_array R l ri rlen arri + else return ri + od else return ri; + ri3 <- return (ri2 - 1); + update_sz_array ri3 l; + merge_similar_array R ri3 rlen (arri + l) + od +End + +Definition find_known_run_array_def: + find_known_run_array R x b n i arrlen = if i >= arrlen then return n + else do + y <- main_array_sub i; + if R x y = b + then find_known_run_array R y b (n + 1n) (i + 1n) arrlen + else return n + od +Termination + WF_REL_TAC `measure (\(R, x, b, n, i, arrlen). arrlen - i)` +End + +Definition reverse_run_def: + reverse_run i l = if l < 2 + then return () + else let l2 = l - 2 in do + x <- main_array_sub i; + j <- return (i + l2 + 1); + y <- main_array_sub j; + update_main_array i y; + update_main_array j x; + reverse_run (i + 1) l2 + od +End + +Definition find_run_array_def: + find_run_array R i arrlen = if i + 1 >= arrlen + then return (arrlen - i) + else do + x <- main_array_sub i; + y <- main_array_sub (i + 1); + b <- return (R x y); + l <- find_known_run_array R y b 2 (i + 2) arrlen; + if ~ b + then reverse_run i l + else return (); + return l + od +End + +Definition first_pass_array_def: + first_pass_array R ri rlen i arrlen = + if i >= arrlen + then return ri + else do + l <- find_run_array R i arrlen; + ri2 <- merge_in_run_array R ri rlen i l; + first_pass_array R ri2 rlen (i + (if l = 0 then 1n else l)) arrlen + od +Termination + WF_REL_TAC `measure (\(R, ri, rlen, i, arrlen). arrlen - i)` +End + +(* Top-level of the monadic worker. Needs to be wrapped in a "run" function + that sets up the array and fetches the final list again. *) +Definition merge_run_sort_monadic_def: + merge_run_sort_monadic R rlen arrlen = do + ri <- first_pass_array R rlen rlen 0 arrlen; + merge_every_array R ri rlen arrlen; + return () + od +End + +(* Compute an overapproximation of the base-2 logarithm of v *) +Definition above_log2_def: + above_log2 i v n = if n = 0n \/ v <= n + then i + else above_log2 (i + 1n) v (n * 2) +Termination + WF_REL_TAC `measure (\(i, v, n). (v - n))` +End + +Definition copy_into_array_def: + copy_into_array i [] = return () + /\ + copy_into_array i (x :: xs) = do + update_main_array i x; + copy_into_array (i + 1) xs + od +End + +Definition copy_from_array_def: + copy_from_array i acc = if i = 0 + then return acc + else let j = i - 1 in do + x <- main_array_sub j; + copy_from_array j (x :: acc) + od +End + +Definition merge_run_sort_worker_def: + merge_run_sort_worker R x xs = do + l <- return (LENGTH xs); + sz_log <- return (above_log2 0 (l + 1) 1 + 2); + alloc_main_array l x; + alloc_copy_array l x; + alloc_sz_array sz_log 0; + copy_into_array 0 xs; + merge_run_sort_monadic R sz_log l; + copy_from_array l []; + od +End + +(* Get straight to the key proof. Can we show that do_merge_array is merge + and that merge_smaller_array is merge_sizes? *) + +Definition mk_st_def: + mk_st xs sz_junk junk copy = + (<| + sz_array := sz_junk ++ (MAP LENGTH xs); + main_array := FLAT (REVERSE xs) ++ junk; + copy_array := copy + |>) +End + +Theorem return_bind_eq[local]: + st_ex_bind (return v) f = f v +Proof + simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_return_def, FUN_EQ_THM] +QED + +Theorem st_ex_ignore_bind_simp[local]: + st_ex_ignore_bind f g = st_ex_bind f (\_. g) +Proof + simp [ml_monadBaseTheory.st_ex_bind_def, ml_monadBaseTheory.st_ex_ignore_bind_def] +QED + +Theorem bind_success_eqI: + m st = (M_success v, st2) /\ f v st2 = rhs ==> + st_ex_bind m f st = rhs +Proof + simp [ml_monadBaseTheory.st_ex_bind_def] +QED + +Theorem copy_array_sub_eq[local]: + i < LENGTH c ==> + st_ex_bind (copy_array_sub i) f + (mk_st xs szj j c) = + f (EL i c) (mk_st xs szj j c) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "copy_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def] +QED + +Theorem update_copy_array_eq[local]: + i < LENGTH c ==> + st_ex_bind (update_copy_array i x) f (mk_st xss szj j c) = + f () (mk_st xss szj j (LUPDATE x i c)) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "update_copy_array_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def] +QED + +Theorem main_array_sub_hd_app_cons_eq[local]: + i = LENGTH xs + SUM (MAP LENGTH pre) ==> + st_ex_bind (main_array_sub i) f + (mk_st ((xs ++ y :: ys) :: pre) szj j c) = + f y (mk_st ((xs ++ y :: ys) :: pre) szj j c) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "main_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, LENGTH_FLAT, MAP_REVERSE, SUM_REVERSE, + EL_APPEND1, EL_APPEND2] +QED + +Theorem main_array_sub_extra_EL[local]: + SUM (MAP LENGTH pre) <= i /\ i < LENGTH ys + SUM (MAP LENGTH pre) ==> + st_ex_bind (main_array_sub i) f + (mk_st pre szj ys c) = + f (EL (i - SUM (MAP LENGTH pre)) ys) (mk_st pre szj ys c) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "main_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, LENGTH_FLAT, MAP_REVERSE, SUM_REVERSE, + EL_APPEND1, EL_APPEND2] +QED + +Theorem main_array_sub_extra[local]: + !xs. i = LENGTH xs + SUM (MAP LENGTH pre) ==> + st_ex_bind (main_array_sub i) f + (mk_st pre szj (xs ++ y :: ys) c) = + f y (mk_st pre szj (xs ++ y :: ys) c) +Proof + simp [main_array_sub_extra_EL, EL_APPEND2] +QED + +Theorem update_main_array_hd_app_cons_eq[local]: + i = LENGTH xs + SUM (MAP LENGTH pre) ==> + st_ex_bind (update_main_array i x) f + (mk_st ((xs ++ y :: ys) :: pre) szj j c) = + f () (mk_st ((xs ++ x :: ys) :: pre) szj j c) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "update_main_array_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, LENGTH_FLAT, MAP_REVERSE, SUM_REVERSE, + LUPDATE_APPEND1, LUPDATE_APPEND2, LUPDATE_DEF] +QED + +Theorem update_main_array_extra_LUPDATE[local]: + SUM (MAP LENGTH pre) <= i /\ i < LENGTH ys + SUM (MAP LENGTH pre) ==> + st_ex_bind (update_main_array i x) f + (mk_st pre szj ys c) = + f () (mk_st pre szj (LUPDATE x (i - SUM (MAP LENGTH pre)) ys) c) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "update_main_array_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, LENGTH_FLAT, MAP_REVERSE, SUM_REVERSE, + LUPDATE_APPEND1, LUPDATE_APPEND2, LUPDATE_DEF] +QED + +Definition mk_st_eq_def: + mk_st_eq xs szs j cxs st = (st = mk_st xs szs j cxs) +End + +val mk_st_unfold = qpat_x_assum `mk_st_eq _ _ _ _ _` + (assume_tac o REWRITE_RULE [mk_st_eq_def]) + \\ full_simp_tac bool_ss [] + +Theorem mk_st_eqI[local]: + xs = xs2 /\ szs = szs2 /\ j = j2 /\ cxs = cxs2 ==> + mk_st_eq xs szs j cxs (mk_st xs2 szs2 j2 cxs2) +Proof + simp [mk_st_eq_def] +QED + +Theorem mk_st_eq_mk_stI[local] = + REWRITE_RULE [mk_st_eq_def] mk_st_eqI + +Theorem merge_runs_empty_ys_eq_lemma: + ! xs xi csp sp fin st. + xi + LENGTH xs = xlen /\ + base = SUM (MAP LENGTH pre) /\ LENGTH sp = LENGTH xs /\ + xi = LENGTH csp /\ LENGTH fin = ylen + xi /\ + mk_st_eq ((fin ++ sp) :: pre) szj j (csp ++ xs ++ j2) st ==> + merge_runs R xi xlen ylen ylen base st = + (M_success (), (mk_st ((fin ++ xs) :: pre) szj j + (csp ++ xs ++ j2))) +Proof + Induct + \\ ONCE_REWRITE_TAC [merge_runs_def] + \\ rw [st_ex_ignore_bind_simp] + \\ mk_st_unfold + >- ( + simp [merge_empty, ml_monadBaseTheory.st_ex_return_def] + ) + >- ( + simp [copy_array_sub_eq, EL_APPEND1, EL_APPEND2] + \\ Cases_on `sp` \\ fs [] + \\ simp [update_main_array_hd_app_cons_eq] + \\ first_x_assum (qspec_then `spc ++ [x]` (assume_tac o Q.GENL [`spc`, `x`])) + \\ fs [] + \\ irule EQ_TRANS + \\ first_x_assum (irule_at Any) + \\ simp [] + \\ irule_at Any mk_st_eqI + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [] + ) +QED + +Theorem merge_runs_eq: + ! R xs ys xi yi csp sp fin st. + xi + LENGTH xs = xlen /\ yi + LENGTH ys = ylen /\ + base = SUM (MAP LENGTH pre) /\ LENGTH sp = LENGTH xs /\ + LENGTH csp = xi /\ LENGTH fin = xi + yi /\ + mk_st_eq ((fin ++ sp ++ ys) :: pre) szj j (csp ++ xs ++ j2) st ==> + merge_runs R xi xlen yi ylen base st = + (M_success (), (mk_st ((fin ++ merge R xs ys) :: pre) szj j + (csp ++ xs ++ j2))) +Proof + recInduct merge_ind + \\ rw [] + \\ mk_st_unfold + >- ( + ONCE_REWRITE_TAC [merge_runs_def] + \\ simp [merge_empty, ml_monadBaseTheory.st_ex_return_def] + ) + >- ( + simp [SIMP_RULE bool_ss [mk_st_eq_def] merge_runs_empty_ys_eq_lemma] + \\ simp [merge_empty] + ) + >- ( + ONCE_REWRITE_TAC [merge_runs_def] + \\ simp [merge_empty, ml_monadBaseTheory.st_ex_return_def] + ) + >- ( + ONCE_REWRITE_TAC [merge_runs_def] + \\ simp [copy_array_sub_eq, EL_APPEND1, EL_APPEND2] + \\ simp [st_ex_ignore_bind_simp, return_bind_eq] + \\ simp [main_array_sub_hd_app_cons_eq] + \\ Cases_on `sp` \\ fs [] + \\ REWRITE_TAC [GSYM APPEND_ASSOC, APPEND] + \\ simp [update_main_array_hd_app_cons_eq] + \\ TOP_CASE_TAC \\ fs [] + >- ( + first_x_assum (qspec_then `spc_z ++ [x_z]` + (assume_tac o Q.GENL [`spc_z`, `x_z`])) + \\ fs [] + \\ irule EQ_TRANS \\ first_x_assum (irule_at Any) + \\ simp [] + \\ irule_at Any mk_st_eqI + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [merge_def] + ) + >- ( + irule EQ_TRANS \\ first_x_assum (irule_at Any) + \\ simp [] + \\ irule_at Any mk_st_eqI + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [merge_def] + ) + ) +QED + +Theorem copy_to_copy_eq: + ! xs xi copied j2 st. + xi + LENGTH xs = xlen /\ + base = SUM (MAP LENGTH pre) /\ + LENGTH copied = xi /\ + LENGTH xs <= LENGTH j2 /\ + mk_st_eq ((copied ++ xs ++ oth) :: pre) szj j (copied ++ j2) st ==> + copy_to_copy base xi xlen st = + (M_success (), (mk_st ((copied ++ xs ++ oth) :: pre) szj j + (copied ++ xs ++ DROP (LENGTH xs) j2))) +Proof + Induct + \\ rw [] + \\ ONCE_REWRITE_TAC [copy_to_copy_def] + \\ rw [] + \\ mk_st_unfold + >- ( + simp [ml_monadBaseTheory.st_ex_return_def] + ) + >- ( + simp [st_ex_ignore_bind_simp, return_bind_eq] + \\ REWRITE_TAC [GSYM APPEND_ASSOC, APPEND] + \\ simp [main_array_sub_hd_app_cons_eq] + \\ simp [update_copy_array_eq] + \\ Cases_on `j2` \\ fs [] + \\ first_x_assum (qspec_then `spc ++ [x]` (assume_tac o Q.GENL [`spc`, `x`])) + \\ fs [] + \\ irule EQ_TRANS \\ first_x_assum (irule_at Any) + \\ simp [] + \\ irule_at Any mk_st_eqI + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [] + ) +QED + +Theorem sz_array_sub_bind_eq: + LENGTH szj <= i /\ i - LENGTH szj < LENGTH xss ==> + st_ex_bind (sz_array_sub i) f (mk_st xss szj j c) = + f (LENGTH (EL (i - LENGTH szj) xss)) (mk_st xss szj j c) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [fetch "-" "sz_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, EL_APPEND2, EL_MAP] +QED + +Theorem update_sz_array_append_eq: + i = LENGTH szj + 1 /\ n = LENGTH xs + LENGTH ys ==> + update_sz_array i n (mk_st (ys :: xs :: pre) szj j c) = + (M_success (), mk_st ((xs ++ ys) :: pre) (szj ++ [LENGTH ys]) j c) +Proof + rw [] + \\ simp [fetch "-" "update_sz_array_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, LUPDATE_APPEND1, LUPDATE_APPEND2, LUPDATE_DEF] +QED + +Theorem update_sz_array_append_bind_eq: + i = LENGTH szj + 1 /\ n = LENGTH xs + LENGTH ys ==> + st_ex_bind (update_sz_array i n) f (mk_st (ys :: xs :: pre) szj j c) = + f () (mk_st ((xs ++ ys) :: pre) (szj ++ [LENGTH ys]) j c) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [update_sz_array_append_eq] +QED + +Theorem update_sz_array_extend_eq: + i + 1 = LENGTH szj /\ n = LENGTH xs ==> + update_sz_array i n (mk_st xss szj (xs ++ j) c) = + (M_success (), mk_st (xs :: xss) (TAKE i szj) j c) +Proof + rw [] + \\ simp [fetch "-" "update_sz_array_def", ml_monadBaseTheory.monad_eqs] + \\ simp [mk_st_def, LUPDATE_APPEND1, LUPDATE_APPEND2, LUPDATE_DEF] + \\ irule LIST_EQ + \\ simp [EL_APPEND, EL_LUPDATE] + \\ rw [] + \\ simp [EL_TAKE] +QED + +Theorem update_sz_array_extend_bind_eq: + i + 1 = LENGTH szj /\ n = LENGTH xs ==> + st_ex_bind (update_sz_array i n) f (mk_st xss szj (xs ++ j) c) = + f () (mk_st (xs :: xss) (TAKE i szj) j c) +Proof + rw [] + \\ irule bind_success_eqI + \\ simp [update_sz_array_extend_eq] +QED + +Theorem do_merge_array_eq: + ri = LENGTH szj /\ + arri = LENGTH xs + LENGTH ys + SUM (MAP LENGTH pre) /\ + LENGTH xs <= LENGTH c ==> + do_merge_array R ri arri (mk_st (ys :: xs :: pre) szj j c) = + (M_success (), (mk_st (merge R xs ys :: pre) (szj ++ [LENGTH ys]) j + (xs ++ DROP (LENGTH xs) c))) +Proof + rw [do_merge_array_def] + \\ simp [st_ex_ignore_bind_simp, return_bind_eq] + \\ simp [sz_array_sub_bind_eq] + \\ simp [update_sz_array_append_bind_eq] + \\ irule bind_success_eqI + \\ irule_at Any copy_to_copy_eq + \\ irule_at Any mk_st_eqI + \\ csimp [APPEND_11_LENGTH] + \\ irule EQ_TRANS + \\ irule_at Any merge_runs_eq + \\ irule_at Any mk_st_eqI + \\ csimp [APPEND_11_LENGTH] +QED + +Definition add_lengths_def: + add_lengths xss = MAP (\xs. (LENGTH xs, xs)) xss +End + +Theorem add_lengths_simps[local]: + add_lengths [] = [] /\ + add_lengths (xs :: xss) = (LENGTH xs, xs) :: add_lengths xss /\ + MAP SND (add_lengths xss) = xss /\ + LENGTH (add_lengths xss) = LENGTH xss +Proof + simp [add_lengths_def, MAP_MAP_o, combinTheory.o_DEF] +QED + +Theorem add_lengths_MAP_SND_eq[local]: + EVERY (\(sz, xs). sz = LENGTH xs) xss ==> + add_lengths (MAP SND xss) = xss +Proof + rw [add_lengths_def, MAP_MAP_o] + \\ irule EQ_TRANS + \\ irule_at Any MAP_CONG + \\ simp [] + \\ qexists_tac `I` + \\ fs [EVERY_MEM, FORALL_PROD] +QED + +Definition is_eq_def: + is_eq x y = (x = y) +End + +Theorem is_eq_bind_successD: + is_eq (st_ex_bind f g st) r ==> + (?r'. is_eq (f st) r' /\ + (!x s. r' = (M_success x, s) ==> is_eq (g x s) r)) +Proof + rw [is_eq_def] + \\ simp [bind_success_eqI] +QED + +Theorem is_eq_bind_success_real_eqD: + is_eq (st_ex_bind f g st) r ==> + (!x s. f st = (M_success x, s) ==> is_eq (g x s) r) +Proof + rw [is_eq_def] + \\ simp [bind_success_eqI] +QED + +Theorem merge_length[local]: + LENGTH (merge R xs ys) = LENGTH xs + LENGTH ys +Proof + qspecl_then [`R`, `xs`, `ys`] mp_tac merge_perm + \\ rw [] + \\ imp_res_tac PERM_LENGTH + \\ fs [] +QED + +Theorem merge_sizes_gen_array_eq: + ! R f ri rlen arri xs xss szj j c r. + is_eq (merge_sizes_gen_array R f ri rlen arri + (mk_st (xs :: xss) szj j c)) r /\ + ri = LENGTH szj /\ ri + LENGTH xss + 1 = rlen /\ + arri = LENGTH xs + SUM (MAP LENGTH xss) /\ + arri <= LENGTH c ==> + ?szj2 c2. + let ys = merge_sizes f R (add_lengths xss) (LENGTH xs, xs) + in + r = (M_success (rlen - LENGTH ys), mk_st (MAP SND ys) (szj ++ szj2) j c2) /\ + LENGTH szj + LENGTH szj2 + LENGTH ys = rlen /\ LENGTH c2 = LENGTH c +Proof + recInduct merge_sizes_gen_array_ind + \\ rpt gen_tac \\ disch_tac + \\ ONCE_REWRITE_TAC [merge_sizes_gen_array_def] + \\ rw [] + >- ( + Cases_on `xss` \\ fs [] + \\ fs [is_eq_def, ml_monadBaseTheory.st_ex_return_def] + \\ rw [merge_sizes_def, add_lengths_simps] + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [] + ) + >- ( + Cases_on `xss` \\ fs [] + \\ fs [st_ex_ignore_bind_simp, return_bind_eq] + \\ fs [sz_array_sub_bind_eq] + \\ simp [merge_sizes_def, add_lengths_simps] + \\ rw [] \\ fs [] + >- ( + dxrule is_eq_bind_success_real_eqD + \\ simp [do_merge_array_eq] + \\ rw [] + \\ first_x_assum (drule_then drule) + \\ simp [merge_length] + \\ rw [] + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [] + ) + >- ( + fs [is_eq_def, ml_monadBaseTheory.st_ex_return_def] + \\ rw [] + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [merge_sizes_def, add_lengths_simps] + ) + ) +QED + +Theorem merge_smaller_array_eq: + ! R n ri rlen arri. + merge_smaller_array R n ri rlen arri = + merge_sizes_gen_array R (\sz sz2. sz2 < n) ri rlen arri +Proof + recInduct merge_smaller_array_ind + \\ rw [] + \\ ONCE_REWRITE_TAC [merge_smaller_array_def] + \\ ONCE_REWRITE_TAC [merge_sizes_gen_array_def] + \\ rw [] + \\ rw [FUN_EQ_THM] + \\ simp [st_ex_bind_def |> Q.ISPEC `sz_array_sub i`] + \\ every_case_tac + \\ fs [fetch "-" "sz_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ res_tac + \\ simp [] +QED + +Theorem merge_similar_array_eq: + ! R ri rlen arri. + merge_similar_array R ri rlen arri = + merge_sizes_gen_array R (\sz sz2. ~ (sz * 2 < sz2)) ri rlen arri +Proof + recInduct merge_similar_array_ind + \\ rw [] + \\ ONCE_REWRITE_TAC [merge_similar_array_def] + \\ ONCE_REWRITE_TAC [merge_sizes_gen_array_def] + \\ rw [FUN_EQ_THM] + \\ simp [st_ex_bind_def |> Q.ISPEC `sz_array_sub i`] + \\ every_case_tac +QED + +Theorem merge_every_array_eq: + ! R ri rlen arri. + merge_every_array R ri rlen arri = + merge_sizes_gen_array R (\sz sz2. T) ri rlen arri +Proof + recInduct merge_every_array_ind + \\ rw [] + \\ ONCE_REWRITE_TAC [merge_every_array_def] + \\ ONCE_REWRITE_TAC [merge_sizes_gen_array_def] + \\ rw [FUN_EQ_THM] + \\ simp [st_ex_bind_def |> Q.ISPEC `sz_array_sub i`] + \\ every_case_tac + \\ fs [fetch "-" "sz_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ simp [do_merge_array_def] + \\ simp [st_ex_ignore_bind_simp, st_ex_bind_def] + \\ every_case_tac + \\ fs [fetch "-" "sz_array_sub_def", ml_monadBaseTheory.monad_eqs] +QED + +Overload mk_st_ret_xs[local] = + ``\xss szj j c rlen. (M_success (rlen - LENGTH xss), + mk_st xss szj j c)`` + +Theorem merge_sizes_same_length: + !xss sz_run. + SUM (MAP LENGTH (MAP SND (merge_sizes f R xss sz_run))) = + LENGTH (SND sz_run) + SUM (MAP LENGTH (MAP SND xss)) +Proof + Induct + \\ simp [merge_sizes_def] + \\ rw [] + \\ rpt (pairarg_tac \\ fs[]) + \\ simp [merge_length] +QED + +Theorem merge_in_run_array_eq: + is_eq (merge_in_run_array R ri rlen arri l + (mk_st xss szj (xs ++ j) c)) r /\ + ri = LENGTH szj /\ ri + LENGTH xss = rlen /\ + arri = SUM (MAP LENGTH xss) /\ + arri + LENGTH xs <= LENGTH c /\ l = LENGTH xs /\ + EVERY ($~ o NULL) xss /\ + 0 < ri /\ 0 < l + ==> + ?szj2 c2. + r = mk_st_ret_xs (MAP SND (merge_in_run R (add_lengths xss) xs)) + szj2 j c2 rlen /\ + LENGTH szj2 + LENGTH (merge_in_run R (add_lengths xss) xs) = rlen /\ + LENGTH c2 = LENGTH c +Proof + rpt strip_tac + \\ fs [merge_in_run_array_def, merge_in_run_def] + \\ Cases_on `xs = []` \\ fs [] + \\ qmatch_goalsub_abbrev_tac `merge_sizes _ _ merge_smaller_step` + \\ subgoal `SUM (MAP LENGTH (MAP SND merge_smaller_step)) = + SUM (MAP LENGTH xss) /\ + add_lengths (MAP SND merge_smaller_step) = merge_smaller_step` + >- ( + fs [markerTheory.Abbrev_def] + \\ Cases_on `TL xss` \\ Cases_on `xss` \\ fs [add_lengths_simps] + \\ rw [] \\ fs [add_lengths_simps] + \\ simp [merge_sizes_same_length, add_lengths_simps] + \\ irule add_lengths_MAP_SND_eq + \\ irule MONO_EVERY + \\ irule_at Any (merge_sizes_eq_length_inv) + \\ simp [FORALL_PROD] + \\ simp [add_lengths_def, EVERY_MAP] + \\ fs [combinTheory.o_DEF] + ) + \\ dxrule is_eq_bind_successD + \\ strip_tac + \\ subgoal `?szj3 c3. r' = mk_st_ret_xs (MAP SND merge_smaller_step) + szj3 (xs ++ j) c3 rlen /\ + LENGTH szj3 + LENGTH merge_smaller_step = rlen /\ + 0 < LENGTH szj3 /\ LENGTH c3 = LENGTH c` + >- ( + Cases_on `LENGTH xss < 2 \/ LENGTH (EL 1 xss) >= LENGTH xs` + >- ( + Cases_on `TL xss` \\ Cases_on `xss` \\ fs [] + \\ fs [markerTheory.Abbrev_def] + \\ gs [add_lengths_simps, is_eq_def, ml_monadBaseTheory.st_ex_return_def] + \\ rw [] + \\ simp [sz_array_sub_bind_eq] + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [] + ) + \\ Cases_on `TL xss` \\ Cases_on `xss` \\ fs [] + \\ fs [markerTheory.Abbrev_def] + \\ gs [add_lengths_simps, sz_array_sub_bind_eq] + \\ fs [merge_smaller_array_eq] + \\ dxrule merge_sizes_gen_array_eq + \\ rw [] + \\ irule_at Any mk_st_eq_mk_stI + \\ gs [add_lengths_simps] + ) + \\ fs [] + \\ qpat_x_assum `is_eq _ (M_success _, _)` kall_tac + \\ qpat_x_assum `is_eq _ _` mp_tac + \\ simp [st_ex_ignore_bind_simp, return_bind_eq] + \\ simp [update_sz_array_extend_bind_eq] + \\ simp [merge_similar_array_eq] + \\ disch_tac \\ dxrule merge_sizes_gen_array_eq + \\ simp [add_lengths_simps] + \\ rw [] + \\ irule_at Any mk_st_eq_mk_stI + \\ gs [add_lengths_simps] +QED + +Theorem find_known_run_array_eq: + ! R x b n i arrlen xs xss szj ys c st. + n = LENGTH xs /\ i = LENGTH xs + SUM (MAP LENGTH xss) /\ + i + LENGTH ys = arrlen /\ + mk_st_eq xss szj (REVERSE xs ++ ys) c st ==> + find_known_run_array R x b n i arrlen st = + (M_success (n + count_while_2 (\x y. R x y = b) (x :: ys) - 1), + mk_st xss szj (REVERSE xs ++ ys) c) +Proof + recInduct find_known_run_array_ind + \\ rw [] + \\ ONCE_REWRITE_TAC [find_known_run_array_def] + \\ mk_st_unfold + \\ Cases_on `ys` \\ fs [] + >- ( + simp [ml_monadBaseTheory.st_ex_return_def] + \\ simp [count_while_2_def] + ) + >- ( + simp [main_array_sub_extra] + \\ TOP_CASE_TAC + >- ( + first_x_assum drule + \\ disch_then (qspec_then `z :: zs` (mp_tac o Q.GENL [`z`, `zs`])) + \\ simp [ADD1] + \\ disch_tac + \\ irule EQ_TRANS + \\ pop_assum (irule_at Any) + \\ simp [] + \\ irule_at Any mk_st_eqI + \\ simp [count_while_2_def] + \\ REWRITE_TAC [GSYM APPEND_ASSOC, APPEND] + ) + >- ( + simp [ml_monadBaseTheory.st_ex_return_def] + \\ simp [count_while_2_def] + ) + ) +QED + +Theorem find_known_run_array_eq_2[local] = + find_known_run_array_eq |> SPEC_ALL |> Q.GEN `xs` + |> Q.SPEC `[x; y]` |> GEN_ALL + +Theorem reverse_run_eq: + !i l xs ys st. + i = SUM (MAP LENGTH xss) + LENGTH xs /\ + l <= LENGTH ys /\ + mk_st_eq xss szj (xs ++ ys) c st ==> + reverse_run i l st = + (M_success (), mk_st xss szj (xs ++ REVERSE (TAKE l ys) ++ DROP l ys) c) +Proof + recInduct reverse_run_ind + \\ rw [] + \\ ONCE_REWRITE_TAC [reverse_run_def] + \\ mk_st_unfold + \\ rw [] + >- ( + simp [ml_monadBaseTheory.st_ex_return_def] + \\ irule mk_st_eq_mk_stI + \\ simp [] + \\ subgoal `REVERSE (TAKE l ys) = TAKE l ys` \\ simp [] + \\ Cases_on `TL ys` \\ Cases_on `ys` \\ fs [] + \\ rw [TAKE_def] + ) + >- ( + qspecl_then [`ys`, `l - 1`] mp_tac LESS_LENGTH + \\ rw [] + \\ simp [main_array_sub_extra_EL, return_bind_eq, EL_APPEND2, EL_APPEND1] + \\ simp [TAKE_APPEND1, DROP_APPEND2, TAKE_LENGTH_TOO_LONG, REVERSE_APPEND] + \\ Cases_on `ys1` \\ fs [] + \\ simp [st_ex_ignore_bind_simp] + \\ simp [update_main_array_extra_LUPDATE, LUPDATE_APPEND1, + LUPDATE_APPEND2, LUPDATE_DEF] + \\ first_x_assum (qspec_then `zs ++ [z]` (mp_tac o Q.GENL [`z`, `zs`])) + \\ rw [ADD1] + \\ irule EQ_TRANS \\ first_x_assum (irule_at Any) + \\ simp [] + \\ irule_at Any mk_st_eqI + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [DROP_APPEND1, TAKE_APPEND1, TAKE_LENGTH_TOO_LONG] + ) +QED + +Theorem count_while_2_length_trans[local]: + LENGTH xs <= n ==> + count_while_2 R xs <= n +Proof + metis_tac [count_while_2_length, LE_TRANS] +QED + +Theorem find_run_array_eq: + i = SUM (MAP LENGTH xss) /\ + i + LENGTH ys = arrlen /\ + mk_st_eq xss szj ys c st ==> + find_run_array R i arrlen st = + (M_success (LENGTH (FST (find_run R ys))), + mk_st xss szj (FST (find_run R ys) ++ SND (find_run R ys)) c) +Proof + rw [find_run_array_def] + \\ mk_st_unfold + >- ( + simp [ml_monadBaseTheory.st_ex_return_def] + \\ Cases_on `TL ys` \\ Cases_on `ys` \\ fs [ADD1] + \\ simp [find_run_def] + ) + \\ Cases_on `TL ys` \\ Cases_on `ys` \\ fs [ADD1] + \\ simp [main_array_sub_extra |> Q.SPEC `[]` |> SIMP_RULE list_ss [], + main_array_sub_extra |> Q.SPEC `[x]` |> SIMP_RULE list_ss []] + \\ simp [st_ex_ignore_bind_simp, return_bind_eq] + \\ irule bind_success_eqI + \\ irule_at Any find_known_run_array_eq_2 + \\ simp [] + \\ irule_at Any mk_st_eqI + \\ simp [] + \\ rw [] + >- ( + irule bind_success_eqI + \\ irule_at Any reverse_run_eq + \\ simp [ml_monadBaseTheory.st_ex_return_def] + \\ irule_at Any mk_st_eqI + \\ simp [] + \\ simp [find_run_eq_count, ADD1, LENGTH_TAKE_EQ] + \\ csimp [] + \\ simp [count_while_2_length_trans] + ) + >- ( + simp [return_bind_eq] + \\ simp [ml_monadBaseTheory.st_ex_return_def] + \\ simp [find_run_eq_count, ADD1, LENGTH_TAKE_EQ] + \\ simp [count_while_2_length_trans] + ) +QED + +Theorem FST_find_run_neq_nil[local]: + xs <> [] ==> FST (find_run R xs) <> [] +Proof + Cases_on `TL xs` \\ Cases_on `xs` \\ fs [] + \\ simp [find_run_eq_count] + \\ simp [find_run_def] + \\ rw [] +QED + +Theorem merge_in_run_total_length: + SUM (MAP (LENGTH o SND) (merge_in_run R xs r)) = + SUM (MAP (LENGTH o SND) xs) + LENGTH r +Proof + qspecl_then [`R`, `r`, `xs`] mp_tac (GEN_ALL merge_in_run_perm) + \\ rw [] + \\ imp_res_tac PERM_LENGTH + \\ fs [LENGTH_FLAT, MAP_MAP_o] +QED + +Theorem merge_in_run_MAP_SND_invs[local]: + EVERY ($¬ ∘ NULL) xss /\ SORTED (\a b. 2 * LENGTH a < LENGTH b) xss ==> + EVERY ($¬ ∘ NULL) (MAP SND (merge_in_run R (add_lengths xss) r)) /\ + SORTED (\a b. 2 * LENGTH a < LENGTH b) + (MAP SND (merge_in_run R (add_lengths xss) r)) +Proof + strip_tac + \\ qspecl_then [`r`, `add_lengths xss`, `R`] mp_tac + (GEN_ALL merge_in_run_eq_length_inv) + \\ impl_tac + >- ( + fs [add_lengths_def, EVERY_MAP, FORALL_PROD, o_DEF] + ) + \\ rw [] + >- ( + fs [EVERY_MEM, MEM_MAP, FORALL_PROD, EXISTS_PROD] + ) + >- ( + simp [sorted_map] + \\ irule SORTED_weaken + \\ irule_at Any (REWRITE_RULE [sorted_map] merge_in_run_size_invariant) + \\ simp [FORALL_PROD, EVERY_MAP, add_lengths_def, sorted_map, inv_image_def] + \\ fs [o_DEF] + \\ rw [] + \\ fs [EVERY_MEM, FORALL_PROD, add_lengths_def] + \\ res_tac + \\ simp [] + ) +QED + +Theorem find_runs_neq_nil_def[local]: + xs <> [] ==> + find_runs R xs = FST (find_run R xs) :: find_runs R (SND (find_run R xs)) +Proof + Cases_on `xs` + \\ simp [find_runs_def] + \\ pairarg_tac \\ simp [] +QED + +Theorem size_invariant_imp_sum_ineq: + SORTED (λa b. 2 * LENGTH a < LENGTH b) xss /\ + xss <> [] /\ HD xss <> [] ==> + 2 ** (LENGTH xss - 1) <= SUM (MAP LENGTH xss) +Proof + rw [] + \\ subgoal `!n. n < LENGTH xss ==> LENGTH (EL n xss) >= (2 ** n) * LENGTH (HD xss)` + >- ( + Induct + \\ rw [] + \\ fs [] + \\ imp_res_tac SORTED_EL_SUC + \\ fs [EXP] + ) + \\ qspec_then `xss` mp_tac SNOC_CASES + \\ first_x_assum (qspec_then `LENGTH xss - 1` mp_tac) + \\ Cases_on `HD xss` + \\ rw [] + \\ fs [MAP_SNOC, SUM_SNOC, EL_LENGTH_SNOC, ADD1] +QED + +Theorem first_pass_array_eq: + ! R ri rlen i_param arrlen i xss szj ys c r. + is_eq (first_pass_array R ri rlen i arrlen (mk_st xss szj ys c)) r /\ + is_eq ri (LENGTH szj) /\ is_eq (ri + LENGTH xss) rlen /\ + is_eq i (SUM (MAP LENGTH xss)) /\ + is_eq i_param i /\ + is_eq (i + LENGTH ys) arrlen /\ + LENGTH c = arrlen /\ + EVERY ($~ o NULL) xss /\ + SORTED (\a b. LENGTH a * 2 < LENGTH b) xss /\ + arrlen < 2 ** (rlen - 1) + ==> + ?szj2 c2. + r = mk_st_ret_xs (MAP SND (FOLDL (merge_in_run R) (add_lengths xss) (find_runs R ys))) + szj2 [] c2 rlen /\ + LENGTH szj2 + LENGTH (FOLDL (merge_in_run R) (add_lengths xss) (find_runs R ys)) = rlen /\ + LENGTH c2 = arrlen +Proof + recInduct first_pass_array_ind + \\ rpt gen_tac \\ disch_tac + \\ ONCE_REWRITE_TAC [first_pass_array_def] + \\ rw [] \\ fs [] + >- ( + fs [is_eq_def, ml_monadBaseTheory.st_ex_return_def] + \\ rw [] + \\ Cases_on `ys` \\ fs [] + \\ simp [find_runs_def, add_lengths_simps] + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [] + ) + \\ dxrule is_eq_bind_success_real_eqD + \\ rpt (qpat_x_assum `is_eq _ _` (assume_tac o REWRITE_RULE [is_eq_def])) + \\ dep_rewrite.DEP_REWRITE_TAC [find_run_array_eq] + \\ simp [mk_st_eqI] + \\ strip_tac + \\ dxrule is_eq_bind_successD + \\ strip_tac + \\ dxrule merge_in_run_array_eq + \\ simp [LENGTH_NOT_NULL, NULL_EQ, FST_find_run_neq_nil] + \\ Cases_on `ys = []` \\ fs [] + \\ impl_tac + >- ( + qspecl_then [`R`, `ys`] mp_tac find_run_length_fst + \\ rw [FST_find_run_neq_nil] + \\ CCONTR_TAC \\ fs [] + \\ gs [] + \\ imp_res_tac size_invariant_imp_sum_ineq + \\ Cases_on `xss` \\ fs [] + \\ gs [NULL_EQ] + ) + \\ strip_tac + \\ simp [find_runs_neq_nil_def] + \\ fs [] + \\ first_x_assum drule + \\ simp [is_eq_def, FST_find_run_neq_nil] + \\ disch_then (qspec_then `LENGTH (FST (find_run R ys))` mp_tac) + \\ simp [FST_find_run_neq_nil] + \\ impl_tac + >- ( + simp [merge_in_run_total_length, MAP_MAP_o] + \\ simp [GSYM MAP_MAP_o, add_lengths_simps] + \\ simp [merge_in_run_MAP_SND_invs] + \\ qspecl_then [`R`, `ys`] mp_tac find_run_length_fst + \\ simp [find_run_length_eq_sub] + ) + \\ rw [] + \\ simp [add_lengths_simps, add_lengths_MAP_SND_eq] + \\ dep_rewrite.DEP_REWRITE_TAC [add_lengths_MAP_SND_eq] + \\ conj_asm1_tac + >- ( + irule MONO_EVERY + \\ irule_at Any merge_in_run_eq_length_inv + \\ simp [FORALL_PROD] + \\ simp [add_lengths_def, EVERY_MAP] + \\ fs [o_DEF] + ) + \\ irule_at Any mk_st_eq_mk_stI + \\ fs [add_lengths_MAP_SND_eq] +QED + +Theorem merge_sizes_T_eq_sing[local]: + !xss sz_run. ?x. merge_sizes (\_ _. T) R xss sz_run = [x] +Proof + Induct + \\ simp [merge_sizes_def] +QED + +Theorem merge_run_sort_monadic_eq: + arrlen = LENGTH ys /\ rlen = LENGTH szj /\ LENGTH c = arrlen /\ + ys <> [] /\ LENGTH ys < 2 ** (LENGTH szj − 1) ==> + ?szj2 c2. + merge_run_sort_monadic R rlen arrlen + (mk_st [] szj ys c) = + (M_success (), mk_st [merge_run_sort R ys] szj2 [] c2) +Proof + rw [] + \\ qmatch_goalsub_abbrev_tac `res = (_, _)` + \\ subgoal `?r. is_eq res r` + >- ( + simp [is_eq_def] + ) + \\ first_assum (simp o single o REWRITE_RULE [is_eq_def]) + \\ gs [markerTheory.Abbrev_def] + \\ fs [merge_run_sort_monadic_def] + \\ dxrule is_eq_bind_successD + \\ rw [] + \\ dxrule first_pass_array_eq + \\ simp [is_eq_def] + \\ rw [] + \\ fs [st_ex_ignore_bind_simp, merge_every_array_eq] + \\ dxrule is_eq_bind_successD + \\ rw [] + \\ fs [add_lengths_simps] + \\ qspecl_then [`ys`, `R`] mp_tac (GEN_ALL first_pass_size_invariant) + \\ Cases_on `first_pass R ys` + >- ( + qspecl_then [`R`, `ys`] mp_tac first_pass_perm + \\ simp [first_pass_def] + ) + \\ fs [first_pass_def] + \\ rw [] + \\ dxrule merge_sizes_gen_array_eq + \\ simp [] + \\ impl_tac + >- ( + qspecl_then [`R`, `ys`] mp_tac first_pass_perm + \\ rw [first_pass_def] + \\ drule PERM_LENGTH + \\ simp [LENGTH_FLAT] + ) + \\ rw [] + \\ fs [is_eq_def, ml_monadBaseTheory.st_ex_return_def] + \\ rw [] + \\ irule_at Any mk_st_eq_mk_stI + \\ simp [merge_run_sort_def, first_pass_def, merge_sizes_def] + \\ dep_rewrite.DEP_REWRITE_TAC [add_lengths_MAP_SND_eq] + \\ simp [merge_empty] + \\ pairarg_tac \\ fs [] + \\ csimp [] + \\ drule_at_then Any (irule_at Any) MONO_EVERY + \\ simp [FORALL_PROD, merge_sizes_T_eq_sing] +QED + +Theorem copy_into_array_eq: + !xs i ys. + i + LENGTH xs = LENGTH ys ==> + copy_into_array i xs (mk_st [] szj ys c) = + (M_success (), mk_st [] szj (TAKE i ys ++ xs) c) +Proof + Induct + \\ simp [copy_into_array_def, ml_monadBaseTheory.st_ex_return_def] + \\ simp [st_ex_ignore_bind_simp] + \\ rw [] + \\ fs [ADD1] + \\ qspecl_then [`ys`, `i`] mp_tac LESS_LENGTH + \\ rw [] + \\ fs [] + \\ simp [update_main_array_extra_LUPDATE, LUPDATE_APPEND1, + LUPDATE_APPEND2, LUPDATE_DEF, TAKE_APPEND1, TAKE_APPEND2] + \\ irule mk_st_eq_mk_stI + \\ simp [] +QED + +Theorem copy_from_array_eq: + !i xs ys. + i <= LENGTH st.main_array ==> + copy_from_array i xs st = + (M_success (TAKE i st.main_array ++ xs), st) +Proof + recInduct copy_from_array_ind + \\ rw [] + \\ ONCE_REWRITE_TAC [copy_from_array_def] + \\ rw [] + \\ simp [ml_monadBaseTheory.st_ex_return_def] + \\ simp [fetch "-" "main_array_sub_def", ml_monadBaseTheory.monad_eqs] + \\ Cases_on `i` \\ fs [] + \\ simp [ADD1, TAKE_EL_SNOC] +QED + +Theorem above_log2_is_above_ind[local]: + ! i v n. n = 2 EXP i ==> v <= 2 ** (above_log2 i v n) +Proof + recInduct above_log2_ind + \\ rw [] \\ fs [] + \\ ONCE_REWRITE_TAC [above_log2_def] + \\ rw [] \\ fs [EXP_ADD] +QED + +Theorem merge_run_sort_worker_eq: + xs <> [] ==> + ?szj2 c2. + merge_run_sort_worker R x xs st = + (M_success (merge_run_sort R xs), mk_st [merge_run_sort R xs] szj2 [] c2) +Proof + rw [merge_run_sort_worker_def] + \\ simp [st_ex_ignore_bind_simp, return_bind_eq] + \\ simp [fetch "-" "alloc_main_array_def", fetch "-" "alloc_sz_array_def", + fetch "-" "alloc_copy_array_def", ml_monadBaseTheory.monad_eqs] + \\ simp [GSYM (mk_st_def |> Q.SPEC `[]` |> SIMP_RULE (srw_ss ()) [])] + \\ simp [copy_into_array_eq] + \\ qmatch_goalsub_abbrev_tac + `merge_run_sort_monadic R rlen arrlen (mk_st _ szj _ c)` + \\ qspec_then `xs` mp_tac (Q.GEN `ys` merge_run_sort_monadic_eq) + \\ fs [markerTheory.Abbrev_def] + \\ impl_tac + >- ( + qspecl_then [`0`, `LENGTH xs + 1`, `1`] assume_tac above_log2_is_above_ind + \\ fs [REWRITE_RULE [ADD1] EXP] + ) + \\ rw [] + \\ subgoal `LENGTH xs = LENGTH (merge_run_sort R xs)` + >- ( + irule PERM_LENGTH + \\ irule merge_run_sort_perm + ) + \\ simp [copy_from_array_eq, mk_st_def] +QED + + From f61480ad1c17a1ffe04df173dbbf07cb98ae9f8d Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Mon, 30 Mar 2026 10:08:14 +1100 Subject: [PATCH 33/39] merge_run sort: post-facto translation Exercise the same routine as for heap-list-sort, translating the sort function to CakeML AST in a separate theory to the monadic development, including a hack that re-defines the monadic elements. --- .../merge_run_sort_translationScript.sml | 169 ++++++++++++++++++ 1 file changed, 169 insertions(+) create mode 100644 basis/monadic/merge_run_sort_translationScript.sml diff --git a/basis/monadic/merge_run_sort_translationScript.sml b/basis/monadic/merge_run_sort_translationScript.sml new file mode 100644 index 0000000000..cd88cddd81 --- /dev/null +++ b/basis/monadic/merge_run_sort_translationScript.sml @@ -0,0 +1,169 @@ +(* + Post-translation of merge_run_sort +*) +Theory merge_run_sort_translation +Ancestors + mergesort std_prelude mllist ml_translator merge_run_sort_monadic +Libs + preamble ml_translatorLib ml_progLib + ml_monad_translator_interfaceLib + +val _ = ml_prog_update (open_module "Sort_Post_Translation"); + +val () = generate_sigs := true; + +(* Little bits of List translation that are needed. *) + +val r = translate NULL; + +val _ = ml_prog_update open_local_block; +val res = translate LENGTH_AUX_def; +val _ = ml_prog_update open_local_in_block; + +val result = next_ml_names := ["length"] +val res = translate LENGTH_AUX_THM; + +val _ = ml_prog_update close_local_block; + +val _ = ml_prog_update open_local_block; + +val tvar = ``: 'el``; + +val state_type = ``: ( ^tvar ) merge_run_state``; + +val subs = ``MR_Subscript`` + +val exn_type = type_of subs; + +val config = local_state_config |> + with_state state_type |> + with_exception exn_type |> + with_resizeable_arrays [ + ("main_array", listSyntax.mk_list ([], tvar), subs, subs), + ("copy_array", listSyntax.mk_list ([], tvar), subs, subs), + ("sz_array", ``[] : num list``, subs, subs) + ]; + +val _ = start_translation config; + +(* Some clunking around to translate the accessors as auto-defined in + heap_list_sort_monadicTheory using their counterparts auto-defined above. *) +val heap_list_acc_def_names = ["main_array_sub_def", "update_main_array_def", + "alloc_main_array_def", "sz_array_sub_def", "update_sz_array_def", + "alloc_sz_array_def", "copy_array_sub_def", "update_copy_array_def", + "alloc_copy_array_def"] + +val configured_acc_defs = map (fetch "-") heap_list_acc_def_names; +val previous_acc_defs = map (fetch "merge_run_sort_monadic") heap_list_acc_def_names; +val redefs = previous_acc_defs + |> map (REWRITE_RULE (map GSYM configured_acc_defs)) +val do_redef = REWRITE_RULE redefs + +(* Translate all monadic defs. *) + +val merge_runs_v_thm = merge_runs_def + |> do_redef |> m_translate; + +val copy_to_copy_v_thm = copy_to_copy_def + |> do_redef |> m_translate; + +(* Include a check in the translation of the subtraction in do_merge_array. + There is an invariant (arri = SUM (DROP ri) st.sz_array) that proves the + subtraction is safe, but that invariant would have to be maintained + through all the other functions here. *) +val _ = (ml_translatorLib.use_sub_check true); +val do_merge_array_v_thm = do_merge_array_def + |> do_redef |> m_translate; +val _ = (ml_translatorLib.use_sub_check false); + +val merge_smaller_array_v_thm = merge_smaller_array_def + |> do_redef |> m_translate; + +val merge_similar_array_v_thm = merge_similar_array_def + |> do_redef |> m_translate; + +val merge_every_array_v_thm = merge_every_array_def + |> do_redef |> m_translate; + +val merge_in_run_array_v_thm = merge_in_run_array_def + |> do_redef |> m_translate; + +val find_known_run_array_v_thm = find_known_run_array_def + |> do_redef |> m_translate; + +val reverse_run_v_thm = reverse_run_def + |> do_redef |> m_translate; + +val find_run_array_v_thm = find_run_array_def + |> do_redef |> m_translate; + +val first_pass_array_v_thm = first_pass_array_def + |> do_redef |> m_translate; + +val merge_run_sort_monadic_v_thm = merge_run_sort_monadic_def + |> do_redef |> m_translate; + +val above_log2_v_thm = above_log2_def + |> translate; + +val copy_into_array_v_thm = copy_into_array_def + |> do_redef |> m_translate; + +val copy_from_array_v_thm = copy_from_array_def + |> do_redef |> m_translate; + +val merge_run_sort_worker_v_thm = merge_run_sort_worker_def + |> do_redef |> m_translate; + +(* Set up the "run" mechanism. *) +val run_init_merge_run_state_def = + define_run state_type [] "init_merge_run_state"; + +Definition sort_via_merge_run_sort_worker_def: + sort_via_merge_run_sort_worker R x xs = + run_init_merge_run_state (merge_run_sort_worker R x xs) + (init_merge_run_state [] [] []) +End + +val run_v_thm = sort_via_merge_run_sort_worker_def + |> m_translate_run; + +Definition sort_via_array_merge_def: + sort_via_array_merge R xs = (case xs of [] => [] + | x :: _ => (case sort_via_merge_run_sort_worker R x xs of + M_success ys => ys + | _ => []) + ) +End + +val sort_via_array_merge_v_thm = sort_via_array_merge_def |> translate; + +(* Done monadic translation. *) + +val _ = ml_translatorLib.use_sub_check false; + +Theorem merge_run_sort_worker_eq_FST[local]: + xs <> [] ==> + FST (merge_run_sort_worker R x xs st) = + (M_success (merge_run_sort R xs)) +Proof + mp_tac merge_run_sort_worker_eq + \\ rw [] \\ fs [] +QED + +Theorem merge_run_sort_eq_sort_via_array_merge: + merge_run_sort R xs = sort_via_array_merge R xs +Proof + simp [sort_via_array_merge_def] + \\ Cases_on `xs` \\ simp [EVAL ``(merge_run_sort R [])``] + \\ simp [sort_via_merge_run_sort_worker_def, + run_init_merge_run_state_def, ml_monadBaseTheory.run_def] + \\ simp [merge_run_sort_worker_eq_FST] +QED + +val _ = ml_prog_update open_local_in_block; + +val merge_run_sort_v_thm = merge_run_sort_eq_sort_via_array_merge |> translate; + +val _ = ml_prog_update close_local_block; + From 88e8ec16b866de24fb7099cf7655e5754ec2e10d Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Mon, 30 Mar 2026 10:53:39 +1100 Subject: [PATCH 34/39] heap_list_sort: matching translation file --- basis/monadic/README.md | 13 +- .../heap_list_sort_translationScript.sml | 163 ++++++++++++++++++ .../merge_run_sort_translationScript.sml | 2 +- 3 files changed, 172 insertions(+), 6 deletions(-) create mode 100644 basis/monadic/heap_list_sort_translationScript.sml diff --git a/basis/monadic/README.md b/basis/monadic/README.md index f255cc6f50..ffdf792519 100644 --- a/basis/monadic/README.md +++ b/basis/monadic/README.md @@ -3,11 +3,14 @@ Monadic definitions of stateful functions used in the basis These functions are generated and verified using a monad type, and are then translated to imperative CakeML code by the monadic translator. -[experiment1Script.sml](experiment1Script.sml): +[heap_list_sort_monadicScript.sml](heap_list_sort_monadicScript.sml): Monadic variants of the heap-list sort functions, and proofs of equivalence. -[experiment2Script.sml](experiment2Script.sml): -Try to load experiment1 and translate some +[heap_list_sort_translationScript.sml](heap_list_sort_translationScript.sml): +Post-translation of heap_list_sort -[heap_list_sort_monadicScript.sml](heap_list_sort_monadicScript.sml): -Monadic variants of the heap-list sort functions, and proofs of equivalence. +[merge_run_sort_monadicScript.sml](merge_run_sort_monadicScript.sml): +Monadic variants of the merge-run-sort functions, and proofs of equivalence. + +[merge_run_sort_translationScript.sml](merge_run_sort_translationScript.sml): +Post-translation of merge_run_sort diff --git a/basis/monadic/heap_list_sort_translationScript.sml b/basis/monadic/heap_list_sort_translationScript.sml new file mode 100644 index 0000000000..c3a00ca180 --- /dev/null +++ b/basis/monadic/heap_list_sort_translationScript.sml @@ -0,0 +1,163 @@ +(* + Post-translation of heap_list_sort +*) +Theory heap_list_sort_translation +Ancestors + mergesort std_prelude mllist ml_translator heap_list_sort_monadic +Libs + preamble ml_translatorLib ml_progLib + ml_monad_translator_interfaceLib + +val _ = ml_prog_update (open_module "Sort_Post_Translation"); + +val () = generate_sigs := true; + +(* Little bits of List translation that might be needed. *) + +val r = translate NULL; + +val _ = ml_prog_update open_local_block; +val res = translate LENGTH_AUX_def; +val _ = ml_prog_update open_local_in_block; + +val result = next_ml_names := ["length"] +val res = translate LENGTH_AUX_THM; + +val _ = ml_prog_update close_local_block; + +val _ = ml_prog_update open_local_block; + +(* Config to use monadic translator temporarily. *) +val _ = ml_translatorLib.use_sub_check true; + +val tvar = ``: 'el``; + +val state_type = ``: ( ^tvar ) heap_list_state``; + +val subs = ``Heap_List_Subscript`` + +val exn_type = type_of subs; + +val config = local_state_config |> + with_state state_type |> + with_exception exn_type |> + with_resizeable_arrays [ + ("heap_array", listSyntax.mk_list ([], tvar), subs, subs), + ("sz_array", ``[] : num list``, subs, subs) + ]; + +val _ = start_translation config; + +(* Some clunking around to translate the accessors as auto-defined in + heap_list_sort_monadicTheory using their counterparts auto-defined above. *) +val heap_list_acc_def_names = ["heap_array_sub_def", "update_heap_array_def", + "alloc_heap_array_def", "sz_array_sub_def", "update_sz_array_def", + "alloc_sz_array_def"] + +val configured_acc_defs = map (fetch "-") heap_list_acc_def_names; +val previous_acc_defs = map (fetch "heap_list_sort_monadic") heap_list_acc_def_names; +val redefs = previous_acc_defs + |> map (REWRITE_RULE (map GSYM configured_acc_defs)) +val do_redef = REWRITE_RULE redefs + +Definition comp_exp_def: + comp_exp m x 0 = x /\ + comp_exp (m : num) x (SUC i) = comp_exp m (x * m) i +End + +Theorem comp_exp_eq_ind[local]: + !i x. comp_exp m x i = x * (m EXP i) +Proof + Induct \\ simp [comp_exp_def, EXP] +QED + +Theorem use_comp_exp: + (m EXP i) = comp_exp m 1 i +Proof + simp [comp_exp_eq_ind] +QED + +val comp_exp_v_thm = comp_exp_def |> translate; + +val sfx_heap_left_v_thm = sfx_heap_left_def + |> REWRITE_RULE [use_comp_exp] |> translate; + +val insert_into_sfx_heap_v_thm = insert_into_sfx_heap_def + |> do_redef |> m_translate; + +val insert_into_sfx_heap_list_v_thm = insert_into_sfx_heap_list_def + |> REWRITE_RULE [use_comp_exp] + |> do_redef |> m_translate; + +Theorem bind_assoc[local]: + (st_ex_bind (st_ex_bind f g) h) = + (st_ex_bind f (\x. st_ex_bind (g x) h)) +Proof + rw [ml_monadBaseTheory.st_ex_bind_def, FUN_EQ_THM] + \\ rpt (TOP_CASE_TAC \\ fs []) +QED + +val add_to_sfx_heaps_v_thm = add_to_sfx_heaps_def + |> SIMP_RULE bool_ss [add_to_sfx_heaps_step1_def, bind_assoc] + |> do_redef |> m_translate; + +val add_all_to_sfx_heaps_v_thm = add_all_to_sfx_heaps_def + |> do_redef |> m_translate; + +val reinsert_tree_v_thm = reinsert_tree_def + |> REWRITE_RULE [use_comp_exp] + |> do_redef |> m_translate; + +val sfx_trees_to_list_v_thm = sfx_trees_to_list_def + |> do_redef |> m_translate; + +val above_log2_v_thm = above_log2_def |> translate; + +val sort_via_sfx_trees_worker_v_thm = sort_via_sfx_trees_worker_def + |> do_redef |> m_translate; + +val run_init_heap_list_state_def = define_run state_type [] "init_heap_list_state"; + +Definition sort_via_sfx_trees_run_worker_def: + sort_via_sfx_trees_run_worker R x xs = + run_init_heap_list_state (sort_via_sfx_trees_worker R x xs) + (init_heap_list_state [] []) +End + +val run_init_heap_list_state_v_thm = sort_via_sfx_trees_run_worker_def + |> m_translate_run; + +Definition sort_via_sfx_trees_def: + sort_via_sfx_trees R xs = (case xs of [] => [] + | x :: _ => (case sort_via_sfx_trees_run_worker R x xs of + M_success ys => ys + | _ => []) + ) +End + +val sort_via_sfx_trees_v_thm = sort_via_sfx_trees_def |> translate; + +(* Done monadic translation. *) + +val _ = ml_translatorLib.use_sub_check false; + +Theorem heap_list_sort_eq_sort_via_sfx_trees: + heap_list_sort R xs = sort_via_sfx_trees R xs +Proof + simp [sort_via_sfx_trees_def] + \\ Cases_on `xs` \\ simp [EVAL ``(heap_list_sort R [])``] + \\ simp [sort_via_sfx_trees_run_worker_def, + run_init_heap_list_state_def, ml_monadBaseTheory.run_def] + \\ simp [heap_list_sort_monadicTheory.sort_via_sfx_trees_worker_eq] +QED + +val _ = ml_prog_update open_local_in_block; + +val heap_list_sort_v_thm = heap_list_sort_eq_sort_via_sfx_trees |> translate; + +val _ = next_ml_names := ["heap_list_sort"]; + +val _ = ml_prog_update close_local_blocks; + + + diff --git a/basis/monadic/merge_run_sort_translationScript.sml b/basis/monadic/merge_run_sort_translationScript.sml index cd88cddd81..5789d60dab 100644 --- a/basis/monadic/merge_run_sort_translationScript.sml +++ b/basis/monadic/merge_run_sort_translationScript.sml @@ -12,7 +12,7 @@ val _ = ml_prog_update (open_module "Sort_Post_Translation"); val () = generate_sigs := true; -(* Little bits of List translation that are needed. *) +(* Little bits of List translation that might be needed. *) val r = translate NULL; From 8def96b8ab2253e2ae0284cad6193b5be31c72d8 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Mon, 30 Mar 2026 13:11:55 +1100 Subject: [PATCH 35/39] array-sorts: move to translator/monadic/examples The heap-list-sort development was done on the assumption that it would become the basis List.sort function, which turns out to be premature. For now, move both in-array sorts (heap-list and merge-run) to be examples. If the merge-run sort turns out to be useful it may be moved back in. --- basis/pure/mllistScript.sml | 13 +++++++------ .../in_array_sorts}/heap_list_sortScript.sml | 0 .../heap_list_sort_monadicScript.sml | 0 .../heap_list_sort_translationScript.sml | 0 .../in_array_sorts}/merge_run_sortScript.sml | 0 .../merge_run_sort_monadicScript.sml | 0 .../merge_run_sort_translationScript.sml | 0 7 files changed, 7 insertions(+), 6 deletions(-) rename {basis/pure => translator/monadic/examples/in_array_sorts}/heap_list_sortScript.sml (100%) rename {basis/monadic => translator/monadic/examples/in_array_sorts}/heap_list_sort_monadicScript.sml (100%) rename {basis/monadic => translator/monadic/examples/in_array_sorts}/heap_list_sort_translationScript.sml (100%) rename {basis/pure => translator/monadic/examples/in_array_sorts}/merge_run_sortScript.sml (100%) rename {basis/monadic => translator/monadic/examples/in_array_sorts}/merge_run_sort_monadicScript.sml (100%) rename {basis/monadic => translator/monadic/examples/in_array_sorts}/merge_run_sort_translationScript.sml (100%) diff --git a/basis/pure/mllistScript.sml b/basis/pure/mllistScript.sml index 24dd7bbc2d..c3ff0b45f6 100644 --- a/basis/pure/mllistScript.sml +++ b/basis/pure/mllistScript.sml @@ -6,7 +6,7 @@ Libs preamble Ancestors indexedLists[qualified] toto[qualified] - sorting heap_list_sort mergesort + sorting mergesort (* ===== TODO: TO BE PORTED TO HOL (better theorems for mergesort_tail) ===== *) Theorem merge_tail_MEM: @@ -282,11 +282,11 @@ Definition mergesort_def: End Definition sort_def: - sort = heap_list_sort$heap_list_sort + sort = mergesort$mergesort_tail End Theorem sort_thm: - !R l. sort R l = heap_list_sort$heap_list_sort R l + !R l. sort R l = mergesort$mergesort_tail R l Proof rw[sort_def] QED @@ -301,14 +301,15 @@ QED Theorem sort_SORTED: !R L. transitive R ∧ total R ==> sorting$SORTED R (sort R L) Proof - simp[sort_def, heap_list_sort_sorted, total_reflexive] + simp [mergesort_tail_correct, sort_def, mergesort_sorted] QED Theorem sort_PERM: !R L. sorting$PERM L (sort R L) Proof - simp[sort_def] - \\ metis_tac [sortingTheory.PERM_SYM, heap_list_sort_PERM] + rw [sort_def, mergesort_tail_def] + \\ irule PERM_TRANS \\ irule_at Any mergesortN_tail_PERM + \\ simp [] QED Theorem sort_MEM[simp]: diff --git a/basis/pure/heap_list_sortScript.sml b/translator/monadic/examples/in_array_sorts/heap_list_sortScript.sml similarity index 100% rename from basis/pure/heap_list_sortScript.sml rename to translator/monadic/examples/in_array_sorts/heap_list_sortScript.sml diff --git a/basis/monadic/heap_list_sort_monadicScript.sml b/translator/monadic/examples/in_array_sorts/heap_list_sort_monadicScript.sml similarity index 100% rename from basis/monadic/heap_list_sort_monadicScript.sml rename to translator/monadic/examples/in_array_sorts/heap_list_sort_monadicScript.sml diff --git a/basis/monadic/heap_list_sort_translationScript.sml b/translator/monadic/examples/in_array_sorts/heap_list_sort_translationScript.sml similarity index 100% rename from basis/monadic/heap_list_sort_translationScript.sml rename to translator/monadic/examples/in_array_sorts/heap_list_sort_translationScript.sml diff --git a/basis/pure/merge_run_sortScript.sml b/translator/monadic/examples/in_array_sorts/merge_run_sortScript.sml similarity index 100% rename from basis/pure/merge_run_sortScript.sml rename to translator/monadic/examples/in_array_sorts/merge_run_sortScript.sml diff --git a/basis/monadic/merge_run_sort_monadicScript.sml b/translator/monadic/examples/in_array_sorts/merge_run_sort_monadicScript.sml similarity index 100% rename from basis/monadic/merge_run_sort_monadicScript.sml rename to translator/monadic/examples/in_array_sorts/merge_run_sort_monadicScript.sml diff --git a/basis/monadic/merge_run_sort_translationScript.sml b/translator/monadic/examples/in_array_sorts/merge_run_sort_translationScript.sml similarity index 100% rename from basis/monadic/merge_run_sort_translationScript.sml rename to translator/monadic/examples/in_array_sorts/merge_run_sort_translationScript.sml From b3560760a2dd026826bb63be8f45baad48372b15 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Mon, 30 Mar 2026 13:40:45 +1100 Subject: [PATCH 36/39] also detach heap_list_sort from ListProg --- basis/ListProgScript.sml | 149 +++------------------------------------ 1 file changed, 10 insertions(+), 139 deletions(-) diff --git a/basis/ListProgScript.sml b/basis/ListProgScript.sml index 3020187689..a20f56d9fc 100644 --- a/basis/ListProgScript.sml +++ b/basis/ListProgScript.sml @@ -3,7 +3,7 @@ *) Theory ListProg Ancestors - mergesort std_prelude mllist ml_translator OptionProg heap_list_sort_monadic + mergesort std_prelude mllist ml_translator OptionProg Libs preamble ml_translatorLib ml_progLib cfLib basisFunctionsLib ml_monad_translator_interfaceLib @@ -340,146 +340,13 @@ val result = translate LUPDATE_eq; val _ = (next_ml_names := ["compare"]); val _ = translate mllistTheory.list_compare_def; -val _ = ml_prog_update open_local_block; - -(* Config to use monadic translator temporarily. *) -val _ = ml_translatorLib.use_sub_check true; - -val tvar = ``: 'el``; - -val state_type = ``: ( ^tvar ) heap_list_state``; - -val subs = ``Heap_List_Subscript`` - -val exn_type = type_of subs; - -val config = local_state_config |> - with_state state_type |> - with_exception exn_type |> - with_resizeable_arrays [ - ("heap_array", listSyntax.mk_list ([], tvar), subs, subs), - ("sz_array", ``[] : num list``, subs, subs) - ]; - -val _ = start_translation config; - -(* Some clunking around to translate the accessors as auto-defined in - heap_list_sort_monadicTheory using their counterparts auto-defined above. *) -val heap_list_acc_def_names = ["heap_array_sub_def", "update_heap_array_def", - "alloc_heap_array_def", "sz_array_sub_def", "update_sz_array_def", - "alloc_sz_array_def"] - -val configured_acc_defs = map (fetch "-") heap_list_acc_def_names; -val previous_acc_defs = map (fetch "heap_list_sort_monadic") heap_list_acc_def_names; -val redefs = previous_acc_defs - |> map (REWRITE_RULE (map GSYM configured_acc_defs)) -val do_redef = REWRITE_RULE redefs - -Definition comp_exp_def: - comp_exp m x 0 = x /\ - comp_exp (m : num) x (SUC i) = comp_exp m (x * m) i -End - -Theorem comp_exp_eq_ind[local]: - !i x. comp_exp m x i = x * (m EXP i) -Proof - Induct \\ simp [comp_exp_def, EXP] -QED - -Theorem use_comp_exp: - (m EXP i) = comp_exp m 1 i -Proof - simp [comp_exp_eq_ind] -QED - -val comp_exp_v_thm = comp_exp_def |> translate; - -val sfx_heap_left_v_thm = sfx_heap_left_def - |> REWRITE_RULE [use_comp_exp] |> translate; - -val insert_into_sfx_heap_v_thm = insert_into_sfx_heap_def - |> do_redef |> m_translate; - -val insert_into_sfx_heap_list_v_thm = insert_into_sfx_heap_list_def - |> REWRITE_RULE [use_comp_exp] - |> do_redef |> m_translate; - -Theorem bind_assoc[local]: - (st_ex_bind (st_ex_bind f g) h) = - (st_ex_bind f (\x. st_ex_bind (g x) h)) -Proof - rw [ml_monadBaseTheory.st_ex_bind_def, FUN_EQ_THM] - \\ rpt (TOP_CASE_TAC \\ fs []) -QED - -val add_to_sfx_heaps_v_thm = add_to_sfx_heaps_def - |> SIMP_RULE bool_ss [add_to_sfx_heaps_step1_def, bind_assoc] - |> do_redef |> m_translate; - -val add_all_to_sfx_heaps_v_thm = add_all_to_sfx_heaps_def - |> do_redef |> m_translate; - -val reinsert_tree_v_thm = reinsert_tree_def - |> REWRITE_RULE [use_comp_exp] - |> do_redef |> m_translate; +(* Translation of conventional merge-sort. -val sfx_trees_to_list_v_thm = sfx_trees_to_list_def - |> do_redef |> m_translate; + * This is also List.sort, but is given the "mergesort" name too. -val above_log2_v_thm = above_log2_def |> translate; - -val sort_via_sfx_trees_worker_v_thm = sort_via_sfx_trees_worker_def - |> do_redef |> m_translate; - -val run_init_heap_list_state_def = define_run state_type [] "init_heap_list_state"; - -Definition sort_via_sfx_trees_run_worker_def: - sort_via_sfx_trees_run_worker R x xs = - run_init_heap_list_state (sort_via_sfx_trees_worker R x xs) - (init_heap_list_state [] []) -End - -val run_init_heap_list_state_v_thm = sort_via_sfx_trees_run_worker_def - |> m_translate_run; - -Definition sort_via_sfx_trees_def: - sort_via_sfx_trees R xs = (case xs of [] => [] - | x :: _ => (case sort_via_sfx_trees_run_worker R x xs of - M_success ys => ys - | _ => []) - ) -End - -val sort_via_sfx_trees_v_thm = sort_via_sfx_trees_def |> translate; - -(* Done monadic translation. *) - -val _ = ml_translatorLib.use_sub_check false; - -Theorem heap_list_sort_eq_sort_via_sfx_trees: - heap_list_sort R xs = sort_via_sfx_trees R xs -Proof - simp [sort_via_sfx_trees_def] - \\ Cases_on `xs` \\ simp [EVAL ``(heap_list_sort R [])``] - \\ simp [sort_via_sfx_trees_run_worker_def, - run_init_heap_list_state_def, ml_monadBaseTheory.run_def] - \\ simp [heap_list_sort_monadicTheory.sort_via_sfx_trees_worker_eq] -QED - -val heap_list_sort_v_thm = heap_list_sort_eq_sort_via_sfx_trees |> translate; - -val _ = ml_prog_update open_local_in_block; - -val _ = next_ml_names := ["sort"]; - -val sort_v_thm = mllistTheory.sort_thm |> translate; - -val _ = ml_prog_update close_local_blocks; - -(* Translation of the more conventional merge-sort, needed by Candle. - - * (The Candle proofs include a static check of the sources for various - * issues, and the monadic code above would require additional work.) + * (The mergesort name was used in an experiment to allow the Candle kernel + * to specifically request this sort, and not an array-based alternative whose + * use of stateful features clashes with the Candle proofs.) *) val _ = ml_prog_update open_local_block; @@ -537,6 +404,10 @@ val _ = ml_prog_update open_local_in_block; val _ = next_ml_names := ["mergesort"]; val result = translate mergesort_def; +val _ = next_ml_names := ["sort"]; + +val sort_v_thm = mllistTheory.sort_thm |> translate; + val _ = ml_prog_update close_local_blocks; val _ = ml_prog_update (close_module NONE); From fa6547659f447e83b7fee1d22d021fdd220de0e8 Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Mon, 6 Apr 2026 16:46:39 +1000 Subject: [PATCH 37/39] Add readme/README files to new dir --- .../monadic/examples/in_array_sorts/README.md | 24 +++++++++++++++++++ .../examples/in_array_sorts/readmePrefix | 6 +++++ 2 files changed, 30 insertions(+) create mode 100644 translator/monadic/examples/in_array_sorts/README.md create mode 100644 translator/monadic/examples/in_array_sorts/readmePrefix diff --git a/translator/monadic/examples/in_array_sorts/README.md b/translator/monadic/examples/in_array_sorts/README.md new file mode 100644 index 0000000000..aba5719085 --- /dev/null +++ b/translator/monadic/examples/in_array_sorts/README.md @@ -0,0 +1,24 @@ +Example applications of the monadic translator on in-array sort functions. + +These sort functions generally have a pure (datatype recursive) instance, a +monadic theory that provides an in-array version and proves that it simulates +the pure computation, and finally a translation theory that translates the +monadic code to CakeML AST. + +[heap_list_sortScript.sml](heap_list_sortScript.sml): +A heap-sort variant that builds a list of exactly-balanced heaps. + +[heap_list_sort_monadicScript.sml](heap_list_sort_monadicScript.sml): +Monadic variants of the heap-list sort functions, and proofs of equivalence. + +[heap_list_sort_translationScript.sml](heap_list_sort_translationScript.sml): +Post-translation of heap_list_sort + +[merge_run_sortScript.sml](merge_run_sortScript.sml): +Verified run-finding (natural) merge sort. + +[merge_run_sort_monadicScript.sml](merge_run_sort_monadicScript.sml): +Monadic variants of the merge-run-sort functions, and proofs of equivalence. + +[merge_run_sort_translationScript.sml](merge_run_sort_translationScript.sml): +Post-translation of merge_run_sort diff --git a/translator/monadic/examples/in_array_sorts/readmePrefix b/translator/monadic/examples/in_array_sorts/readmePrefix new file mode 100644 index 0000000000..59d119d672 --- /dev/null +++ b/translator/monadic/examples/in_array_sorts/readmePrefix @@ -0,0 +1,6 @@ +Example applications of the monadic translator on in-array sort functions. + +These sort functions generally have a pure (datatype recursive) instance, a +monadic theory that provides an in-array version and proves that it simulates +the pure computation, and finally a translation theory that translates the +monadic code to CakeML AST. From f35d3bc7140ec5288f0d4a996c4afbcae4b18e1b Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Tue, 14 Apr 2026 11:04:48 +0100 Subject: [PATCH 38/39] Also add Holmakefile --- .../monadic/examples/in_array_sorts/Holmakefile | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 translator/monadic/examples/in_array_sorts/Holmakefile diff --git a/translator/monadic/examples/in_array_sorts/Holmakefile b/translator/monadic/examples/in_array_sorts/Holmakefile new file mode 100644 index 0000000000..bcac575625 --- /dev/null +++ b/translator/monadic/examples/in_array_sorts/Holmakefile @@ -0,0 +1,13 @@ +INCLUDES = $(CAKEMLDIR)/translator $(CAKEMLDIR)/translator/monadic + +all: $(DEFAULT_TARGETS) README.md +.PHONY: all + +README_SOURCES = $(wildcard *Script.sml) $(wildcard *Lib.sml) $(wildcard *Syntax.sml) +DIRS = $(wildcard */) +README.md: $(CAKEMLDIR)/developers/readme_gen readmePrefix $(patsubst %,%readmePrefix,$(DIRS)) $(README_SOURCES) + $(protect $(CAKEMLDIR)/developers/readme_gen) $(README_SOURCES) + +ifdef POLY +HOLHEAP = $(CAKEMLDIR)/misc/cakeml-heap +endif From 9fc401ded057f089d4e095dde7ae5fa4ed25f3fe Mon Sep 17 00:00:00 2001 From: Thomas Sewell Date: Wed, 15 Apr 2026 10:09:10 +0100 Subject: [PATCH 39/39] Also add to build-sequence --- developers/build-sequence | 1 + 1 file changed, 1 insertion(+) diff --git a/developers/build-sequence b/developers/build-sequence index ee1b21d944..ad6f09053f 100644 --- a/developers/build-sequence +++ b/developers/build-sequence @@ -130,6 +130,7 @@ compiler/scheme/proofs characteristic/examples tutorial/solutions translator/monadic/examples +translator/monadic/examples/in_array_sorts examples examples/compilation