%-----------------------------------------------------------------------------% % Copyright (C) 1993-1995, 1997-2002 The University of Melbourne. % This file may only be copied under the terms of the GNU Library General % Public License - see the file COPYING.LIB in the Mercury distribution. %-----------------------------------------------------------------------------% % File: array.m % Main authors: fjh, bromage % Stability: medium-low % This module provides dynamically-sized one-dimensional arrays. % Array indices start at zero. % By default, the array__set and array__lookup procedures will check % for bounds errors. But for better performance, it is possible to % disable some of the checking by compiling with `--intermodule-optimization' % and with the C macro symbol `ML_OMIT_ARRAY_BOUNDS_CHECKS' % defined, e.g. by using `MCFLAGS=--intermodule-optimization' and % `CFLAGS=-DML_OMIT_ARRAY_BOUNDS_CHECKS' in your Mmakefile, % or by compiling with the command % `mmc --intermodule-optimization --cflags -DML_OMIT_ARRAY_BOUNDS_CHECKS'. % % For maximum performance, all bounds checking can be disabled by % recompiling this module using `CFLAGS=-DML_OMIT_ARRAY_BOUNDS_CHECKS' % or `mmc --cflags -DML_OMIT_ARRAY_BOUNDS_CHECKS' as above. You can % either recompile the entire library, or just copy `array.m' to your % application's source directory and link with it directly instead of as % part of the library. % % WARNING! % % Arrays are currently not unique objects - until this situation is % resolved it is up to the programmer to ensure that arrays are used % in such a way as to preserve correctness. In the absence of mode % reordering, one should therefore assume that evaluation will take % place in left-to-right order. For example, the following code will % probably not work as expected (f is a function, A an array, I an % index, and X an appropriate value): % % Y = f(A ^ elem(I) := X, A ^ elem(I)) % % The compiler is likely to compile this as % % V0 = A ^ elem(I) := X, % V1 = A ^ elem(I), % Y = f(V0, V1) % % and will be unaware that the first line should be ordered % *after* the second. The safest thing to do is write things out % by hand in the form % % A0I = A0 ^ elem(I), % A1 = A0 ^ elem(I) := X, % Y = f(A1, A0I) %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% :- module array. :- interface. :- import_module list, std_util, random. :- type array(T). :- inst array(I) = bound(array(I)). :- inst array == array(ground). :- inst array_skel == array(free). % XXX the current Mercury compiler doesn't support `ui' modes, % so to work-around that problem, we currently don't use % unique modes in this module. % :- inst uniq_array(I) = unique(array(I)). % :- inst uniq_array == uniq_array(unique). :- inst uniq_array(I) = bound(array(I)). % XXX work-around :- inst uniq_array == uniq_array(ground). % XXX work-around :- inst uniq_array_skel == uniq_array(free). :- mode array_di == di(uniq_array). :- mode array_uo == out(uniq_array). :- mode array_ui == in(uniq_array). % :- inst mostly_uniq_array(I) = mostly_unique(array(I)). % :- inst mostly_uniq_array == mostly_uniq_array(mostly_unique). :- inst mostly_uniq_array(I) = bound(array(I)). % XXX work-around :- inst mostly_uniq_array == mostly_uniq_array(ground). % XXX work-around :- inst mostly_uniq_array_skel == mostly_uniq_array(free). :- mode array_mdi == mdi(mostly_uniq_array). :- mode array_muo == out(mostly_uniq_array). :- mode array_mui == in(mostly_uniq_array). % An `array__index_out_of_bounds' is the exception thrown % on out-of-bounds array accesses. The string describes % the predicate or function reporting the error. :- type array__index_out_of_bounds ---> array__index_out_of_bounds(string). %-----------------------------------------------------------------------------% % array__make_empty_array(Array) creates an array of size zero % starting at lower bound 0. :- pred array__make_empty_array(array(T)). :- mode array__make_empty_array(array_uo) is det. :- func array__make_empty_array = array(T). :- mode array__make_empty_array = array_uo is det. % array__init(Size, Init, Array) creates an array % with bounds from 0 to Size-1, with each element initialized to Init. :- pred array__init(int, T, array(T)). :- mode array__init(in, in, array_uo) is det. :- func array__init(int, T) = array(T). :- mode array__init(in, in) = array_uo is det. % array/1 is a function that constructs an array from a list. % (It does the same thing as the predicate array__from_list/2.) % The syntax `array([...])' is used to represent arrays % for io__read, io__write, term_to_type, and type_to_term. :- func array(list(T)) = array(T). :- mode array(in) = array_uo is det. %-----------------------------------------------------------------------------% % array__min returns the lower bound of the array. % Note: in this implementation, the lower bound is always zero. :- pred array__min(array(_T), int). :- mode array__min(array_ui, out) is det. :- mode array__min(in, out) is det. :- func array__min(array(_T)) = int. :- mode array__min(array_ui) = out is det. :- mode array__min(in) = out is det. % array__max returns the upper bound of the array. :- pred array__max(array(_T), int). :- mode array__max(array_ui, out) is det. :- mode array__max(in, out) is det. :- func array__max(array(_T)) = int. :- mode array__max(array_ui) = out is det. :- mode array__max(in) = out is det. % array__size returns the length of the array, % i.e. upper bound - lower bound + 1. :- pred array__size(array(_T), int). :- mode array__size(array_ui, out) is det. :- mode array__size(in, out) is det. :- func array__size(array(_T)) = int. :- mode array__size(array_ui) = out is det. :- mode array__size(in) = out is det. % array__bounds returns the upper and lower bounds of an array. % Note: in this implementation, the lower bound is always zero. :- pred array__bounds(array(_T), int, int). :- mode array__bounds(array_ui, out, out) is det. :- mode array__bounds(in, out, out) is det. % array__in_bounds checks whether an index is in the bounds % of an array. :- pred array__in_bounds(array(_T), int). :- mode array__in_bounds(array_ui, in) is semidet. :- mode array__in_bounds(in, in) is semidet. %-----------------------------------------------------------------------------% % array__lookup returns the Nth element of an array. % Throws an exception if the index is out of bounds. :- pred array__lookup(array(T), int, T). :- mode array__lookup(array_ui, in, out) is det. :- mode array__lookup(in, in, out) is det. :- func array__lookup(array(T), int) = T. :- mode array__lookup(array_ui, in) = out is det. :- mode array__lookup(in, in) = out is det. % array__semidet_lookup returns the Nth element of an array. % It fails if the index is out of bounds. :- pred array__semidet_lookup(array(T), int, T). :- mode array__semidet_lookup(array_ui, in, out) is semidet. :- mode array__semidet_lookup(in, in, out) is semidet. % array__set sets the nth element of an array, and returns the % resulting array (good opportunity for destructive update ;-). % Throws an exception if the index is out of bounds. :- pred array__set(array(T), int, T, array(T)). :- mode array__set(array_di, in, in, array_uo) is det. :- func array__set(array(T), int, T) = array(T). :- mode array__set(array_di, in, in) = array_uo is det. % array__semidet_set sets the nth element of an array, % and returns the resulting array. % It fails if the index is out of bounds. :- pred array__semidet_set(array(T), int, T, array(T)). :- mode array__semidet_set(array_di, in, in, array_uo) is semidet. % array__slow_set sets the nth element of an array, % and returns the resulting array. The initial array is not % required to be unique, so the implementation may not be able to use % destructive update. % It is an error if the index is out of bounds. :- pred array__slow_set(array(T), int, T, array(T)). :- mode array__slow_set(array_ui, in, in, array_uo) is det. :- mode array__slow_set(in, in, in, array_uo) is det. :- func array__slow_set(array(T), int, T) = array(T). :- mode array__slow_set(array_ui, in, in) = array_uo is det. :- mode array__slow_set(in, in, in) = array_uo is det. % array__semidet_slow_set sets the nth element of an array, % and returns the resulting array. The initial array is not % required to be unique, so the implementation may not be able to use % destructive update. % It fails if the index is out of bounds. :- pred array__semidet_slow_set(array(T), int, T, array(T)). :- mode array__semidet_slow_set(array_ui, in, in, array_uo) is semidet. :- mode array__semidet_slow_set(in, in, in, array_uo) is semidet. % Field selection for arrays. % Array ^ elem(Index) = array__lookup(Array, Index). :- func array__elem(int, array(T)) = T. :- mode array__elem(in, array_ui) = out is det. :- mode array__elem(in, in) = out is det. % Field update for arrays. % (Array ^ elem(Index) := Value) = array__set(Array, Index, Value). :- func 'array__elem :='(int, array(T), T) = array(T). :- mode 'array__elem :='(in, array_di, in) = array_uo is det. %-----------------------------------------------------------------------------% % array__copy(Array0, Array): % Makes a new unique copy of an array. :- pred array__copy(array(T), array(T)). :- mode array__copy(array_ui, array_uo) is det. :- mode array__copy(in, array_uo) is det. :- func array__copy(array(T)) = array(T). :- mode array__copy(array_ui) = array_uo is det. :- mode array__copy(in) = array_uo is det. % array__resize(Array0, Size, Init, Array): % The array is expanded or shrunk to make it fit % the new size `Size'. Any new entries are filled % with `Init'. :- pred array__resize(array(T), int, T, array(T)). :- mode array__resize(array_di, in, in, array_uo) is det. :- func array__resize(array(T), int, T) = array(T). :- mode array__resize(array_di, in, in) = array_uo is det. % array__shrink(Array0, Size, Array): % The array is shrunk to make it fit the new size `Size'. % Throws an exception if `Size' is larger than the size of `Array0'. :- pred array__shrink(array(T), int, array(T)). :- mode array__shrink(array_di, in, array_uo) is det. :- func array__shrink(array(T), int) = array(T). :- mode array__shrink(array_di, in) = array_uo is det. % array__from_list takes a list, % and returns an array containing those elements in % the same order that they occured in the list. :- pred array__from_list(list(T), array(T)). :- mode array__from_list(in, array_uo) is det. :- func array__from_list(list(T)) = array(T). :- mode array__from_list(in) = array_uo is det. % array__to_list takes an array and returns a list containing % the elements of the array in the same order that they % occurred in the array. :- pred array__to_list(array(T), list(T)). :- mode array__to_list(array_ui, out) is det. :- mode array__to_list(in, out) is det. :- func array__to_list(array(T)) = list(T). :- mode array__to_list(array_ui) = out is det. :- mode array__to_list(in) = out is det. % array__fetch_items takes an array and a lower and upper % index, and places those items in the array between these % indices into a list. It is an error if either index is % out of bounds. :- pred array__fetch_items(array(T), int, int, list(T)). :- mode array__fetch_items(in, in, in, out) is det. :- func array__fetch_items(array(T), int, int) = list(T). :- mode array__fetch_items(array_ui, in, in) = out is det. :- mode array__fetch_items(in, in, in) = out is det. % array__bsearch takes an array, an element to be found % and a comparison predicate and returns the position of % the element in the array. Assumes the array is in sorted % order. Fails if the element is not present. If the % element to be found appears multiple times, the index of % the first occurrence is returned. :- pred array__bsearch(array(T), T, pred(T, T, comparison_result), maybe(int)). :- mode array__bsearch(array_ui, in, pred(in, in, out) is det, out) is det. :- mode array__bsearch(in, in, pred(in, in, out) is det, out) is det. :- func array__bsearch(array(T), T, func(T,T) = comparison_result) = maybe(int). :- mode array__bsearch(array_ui, in, func(in,in) = out is det) = out is det. :- mode array__bsearch(in, in, func(in,in) = out is det) = out is det. % array__map(Closure, OldArray, NewArray) applys `Closure' to % each of the elements of `OldArray' to create `NewArray'. :- pred array__map(pred(T1, T2), array(T1), array(T2)). :- mode array__map(pred(in, out) is det, array_di, array_uo) is det. :- func array__map(func(T1) = T2, array(T1)) = array(T2). :- mode array__map(func(in) = out is det, array_di) = array_uo is det. :- func array_compare(array(T), array(T)) = comparison_result. :- mode array_compare(in, in) = out is det. % array__sort(Array) returns a version of Array sorted % into ascending order. % % This sort is not stable. That is, elements that % compare/3 decides are equal will appear together in % the sorted array, but not necessarily in the same % order in which they occurred in the input array. % This is primarily only an issue with types with % user-defined equivalence for which `equivalent' % objects are otherwise distinguishable. % :- func array__sort(array(T)) = array(T). :- mode array__sort(array_di) = array_uo is det. % array__foldl(Fn, Array, X) is equivalent to % list__foldl(Fn, array__to_list(Array), X) % but more efficient. % :- func array__foldl(func(T1, T2) = T2, array(T1), T2) = T2. :- mode array__foldl(func(in, in) = out is det, array_ui, in) = out is det. :- mode array__foldl(func(in, in) = out is det, in, in) = out is det. :- mode array__foldl(func(in, di) = uo is det, array_ui, di) = uo is det. :- mode array__foldl(func(in, di) = uo is det, in, di) = uo is det. % array__foldr(Fn, Array, X) is equivalent to % list__foldr(Fn, array__to_list(Array), X) % but more efficient. % :- func array__foldr(func(T1, T2) = T2, array(T1), T2) = T2. :- mode array__foldr(func(in, in) = out is det, array_ui, in) = out is det. :- mode array__foldr(func(in, in) = out is det, in, in) = out is det. :- mode array__foldr(func(in, di) = uo is det, array_ui, di) = uo is det. :- mode array__foldr(func(in, di) = uo is det, in, di) = uo is det. % array__random_permutation(A0, A, RS0, RS) permutes the elements in % A0 given random seed RS0 and returns the permuted array in A % and the next random seed in RS. % :- pred array__random_permutation(array(T), array(T), random__supply, random__supply). :- mode array__random_permutation(array_di, array_uo, mdi, muo) is det. %-----------------------------------------------------------------------------% :- implementation. % Everything beyond here is not intended as part of the public interface, % and will not appear in the Mercury Library Reference Manual. %-----------------------------------------------------------------------------% :- interface. % The following predicates have to be declared in the interface, % otherwise dead code elimination will remove them. % But they're an implementation detail; user code should just % use the generic versions. % unify/2 for arrays :- pred array_equal(array(T), array(T)). :- mode array_equal(in, in) is semidet. % compare/3 for arrays :- pred array_compare(comparison_result, array(T), array(T)). :- mode array_compare(out, in, in) is det. %-----------------------------------------------------------------------------% :- implementation. :- import_module exception, int, require, string. /**** lower bounds other than zero are not supported % array__resize takes an array and new lower and upper bounds. % the array is expanded or shrunk at each end to make it fit % the new bounds. :- pred array__resize(array(T), int, int, array(T)). :- mode array__resize(in, in, in, out) is det. ****/ %-----------------------------------------------------------------------------% % Arrays are implemented using the C interface. % The C type which defines the representation of arrays is % MR_ArrayType; it is defined in runtime/mercury_library_types.h. %-----------------------------------------------------------------------------% :- pragma foreign_decl("C", " #ifdef MR_HIGHLEVEL_CODE MR_bool MR_CALL mercury__array__do_unify__array_1_0( MR_Mercury_Type_Info type_info, MR_Box x, MR_Box y); MR_bool MR_CALL mercury__array____Unify____array_1_0( MR_Mercury_Type_Info type_info, MR_Array x, MR_Array y); void MR_CALL mercury__array__do_compare__array_1_0(MR_Mercury_Type_Info type_info, MR_Comparison_Result *result, MR_Box x, MR_Box y); void MR_CALL mercury__array____Compare____array_1_0(MR_Mercury_Type_Info type_info, MR_Comparison_Result *result, MR_Array x, MR_Array y); #endif "). :- pragma foreign_code("C", " #include ""mercury_deep_profiling_hand.h"" #ifdef MR_HIGHLEVEL_CODE MR_define_type_ctor_info(array, array, 1, MR_TYPECTOR_REP_ARRAY); /* forward decl, to suppress gcc -Wmissing-decl warning */ void sys_init_array_module_builtins(void); void sys_init_array_module_builtins_init(void); void sys_init_array_module_builtins_init_type_tables(void); MR_bool MR_CALL mercury__array__do_unify__array_1_0(MR_Mercury_Type_Info type_info, MR_Box x, MR_Box y) { return mercury__array____Unify____array_1_0( type_info, (MR_Array) x, (MR_Array) y); } MR_bool MR_CALL mercury__array____Unify____array_1_0(MR_Mercury_Type_Info type_info, MR_Array x, MR_Array y) { return mercury__array__array_equal_2_p_0(type_info, x, y); } void MR_CALL mercury__array__do_compare__array_1_0( MR_Mercury_Type_Info type_info, MR_Comparison_Result *result, MR_Box x, MR_Box y) { mercury__array____Compare____array_1_0( type_info, result, (MR_Array) x, (MR_Array) y); } void MR_CALL mercury__array____Compare____array_1_0( MR_Mercury_Type_Info type_info, MR_Comparison_Result *result, MR_Array x, MR_Array y) { mercury__array__array_compare_3_p_0(type_info, result, x, y); } #else #ifdef MR_DEEP_PROFILING MR_proc_static_compiler_plain(array, __Unify__, array, 1, 0, array, array_equal, 2, 0, ""array.m"", 99, MR_TRUE); MR_proc_static_compiler_plain(array, __Compare__, array, 1, 0, array, array_compare, 3, 0, ""array.m"", 99, MR_TRUE); #endif MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(array, array, 1, MR_TYPECTOR_REP_ARRAY); MR_declare_entry(mercury__array__array_equal_2_0); MR_declare_entry(mercury__array__array_compare_3_0); MR_BEGIN_MODULE(array_module_builtins) MR_init_entry(mercury____Unify___array__array_1_0); MR_init_entry(mercury____Compare___array__array_1_0); #ifdef MR_DEEP_PROFILING MR_init_label(mercury____Unify___array__array_1_0_i1); MR_init_label(mercury____Unify___array__array_1_0_i2); MR_init_label(mercury____Unify___array__array_1_0_i3); MR_init_label(mercury____Unify___array__array_1_0_i4); MR_init_label(mercury____Unify___array__array_1_0_i5); MR_init_label(mercury____Unify___array__array_1_0_i6); MR_init_label(mercury____Compare___array__array_1_0_i1); MR_init_label(mercury____Compare___array__array_1_0_i2); MR_init_label(mercury____Compare___array__array_1_0_i3); MR_init_label(mercury____Compare___array__array_1_0_i4); #endif MR_BEGIN_CODE /* ** Unification and comparison for arrays are implemented in Mercury, ** not hand-coded low-level C */ #ifdef MR_DEEP_PROFILING #define proc_label mercury____Unify___array__array_1_0 #define proc_static MR_proc_static_compiler_name(array, __Unify__, \ array, 1, 0) #define body_code MR_deep_prepare_normal_call( \ mercury____Unify___array__array_1_0, 3, \ mercury____Unify___array__array_1_0_i5, 0); \ MR_call_localret( \ MR_ENTRY(mercury__array__array_equal_2_0), \ mercury____Unify___array__array_1_0_i6, \ MR_ENTRY(mercury____Unify___array__array_1_0));\ MR_define_label( \ mercury____Unify___array__array_1_0_i6); #include ""mercury_hand_unify_body.h"" #undef body_code #undef proc_static #undef proc_label #define proc_label mercury____Compare___array__array_1_0 #define proc_static MR_proc_static_compiler_name(array, __Compare__,\ array, 1, 0) #define body_code MR_deep_prepare_normal_call( \ mercury____Compare___array__array_1_0, 3, \ mercury____Compare___array__array_1_0_i3, 0); \ MR_call_localret( \ MR_ENTRY(mercury__array__array_compare_3_0), \ mercury____Compare___array__array_1_0_i4, \ MR_ENTRY(mercury____Compare___array__array_1_0));\ MR_define_label( \ mercury____Compare___array__array_1_0_i4); #include ""mercury_hand_compare_body.h"" #undef body_code #undef proc_static #undef proc_label #else MR_define_entry(mercury____Unify___array__array_1_0); MR_tailcall(MR_ENTRY(mercury__array__array_equal_2_0), MR_ENTRY(mercury____Unify___array__array_1_0)); MR_define_entry(mercury____Compare___array__array_1_0); /* this is implemented in Mercury, not hand-coded low-level C */ MR_tailcall(MR_ENTRY(mercury__array__array_compare_3_0), MR_ENTRY(mercury____Compare___array__array_1_0)); #endif MR_END_MODULE /* Ensure that the initialization code for the above module gets run. */ /* INIT sys_init_array_module_builtins */ /* suppress gcc -Wmissing-decl warning */ void sys_init_array_module_builtins_init(void); void sys_init_array_module_builtins_init_type_tables(void); #ifdef MR_DEEP_PROFILING void sys_init_array_module_builtins_write_out_proc_statics(FILE *fp); #endif MR_MODULE_STATIC_OR_EXTERN MR_ModuleFunc array_module_builtins; #endif /* ! MR_HIGHLEVEL_CODE */ void sys_init_array_module_builtins_init(void) { #ifndef MR_HIGHLEVEL_CODE array_module_builtins(); MR_INIT_TYPE_CTOR_INFO( mercury_data_array__type_ctor_info_array_1, array__array_1_0); #endif } void sys_init_array_module_builtins_init_type_tables(void) { #ifndef MR_HIGHLEVEL_CODE MR_register_type_ctor_info( &mercury_data_array__type_ctor_info_array_1); #endif } #ifdef MR_DEEP_PROFILING void sys_init_array_module_builtins_write_out_proc_statics(FILE *fp) { MR_write_out_proc_static(fp, (MR_ProcStatic *) &MR_proc_static_compiler_name(array, __Unify__, array, 1, 0)); MR_write_out_proc_static(fp, (MR_ProcStatic *) &MR_proc_static_compiler_name(array, __Compare__, array, 1, 0)); } #endif "). :- pragma foreign_code("MC++", " MR_DEFINE_BUILTIN_TYPE_CTOR_INFO(array, array, 1, MR_TYPECTOR_REP_ARRAY) static int special___Unify___array_1_0(MR_Word type_info, MR_Array x, MR_Array y) { return mercury::array::mercury_code::ML_array_equal( type_info, x, y); } static void special___Compare___array_1_0( MR_Word type_info, MR_Word_Ref result, MR_Array x, MR_Array y) { mercury::array::mercury_code::ML_array_compare( type_info, result, x, y); } static int do_unify__array_1_0(MR_Word type_info, MR_Box x, MR_Box y) { return mercury::array__cpp_code::mercury_code::special___Unify___array_1_0( type_info, dynamic_cast(x), dynamic_cast(y)); } static void do_compare__array_1_0( MR_Word type_info, MR_Word_Ref result, MR_Box x, MR_Box y) { mercury::array__cpp_code::mercury_code::special___Compare___array_1_0( type_info, result, dynamic_cast(x), dynamic_cast(y)); } "). %-----------------------------------------------------------------------------% :- pragma export(array_equal(in, in), "ML_array_equal"). :- pragma export(array_compare(out, in, in), "ML_array_compare"). % unify/2 for arrays array_equal(Array1, Array2) :- array__size(Array1, Size), array__size(Array2, Size), array__equal_elements(0, Size, Array1, Array2). :- pred array__equal_elements(int, int, array(T), array(T)). :- mode array__equal_elements(in, in, in, in) is semidet. array__equal_elements(N, Size, Array1, Array2) :- ( N = Size -> true ; array__lookup(Array1, N, Elem), array__lookup(Array2, N, Elem), N1 is N + 1, array__equal_elements(N1, Size, Array1, Array2) ). % compare/3 for arrays array_compare(Result, Array1, Array2) :- array__size(Array1, Size1), array__size(Array2, Size2), compare(SizeResult, Size1, Size2), ( SizeResult = (=) -> array__compare_elements(0, Size1, Array1, Array2, Result) ; Result = SizeResult ). :- pred array__compare_elements(int, int, array(T), array(T), comparison_result). :- mode array__compare_elements(in, in, in, in, out) is det. array__compare_elements(N, Size, Array1, Array2, Result) :- ( N = Size -> Result = (=) ; array__lookup(Array1, N, Elem1), array__lookup(Array2, N, Elem2), compare(ElemResult, Elem1, Elem2), ( ElemResult = (=) -> N1 is N + 1, array__compare_elements(N1, Size, Array1, Array2, Result) ; Result = ElemResult ) ). %-----------------------------------------------------------------------------% :- pred bounds_checks is semidet. :- pragma inline(bounds_checks/0). :- pragma foreign_proc("C", bounds_checks, [will_not_call_mercury, promise_pure, thread_safe], " #ifdef ML_OMIT_ARRAY_BOUNDS_CHECKS SUCCESS_INDICATOR = MR_FALSE; #else SUCCESS_INDICATOR = MR_TRUE; #endif "). :- pragma foreign_proc("MC++", bounds_checks, [will_not_call_mercury, promise_pure, thread_safe], " #if ML_OMIT_ARRAY_BOUNDS_CHECKS SUCCESS_INDICATOR = MR_FALSE; #else SUCCESS_INDICATOR = MR_TRUE; #endif "). %-----------------------------------------------------------------------------% :- pragma foreign_decl("C", " #include ""mercury_heap.h"" /* for MR_maybe_record_allocation() */ #include ""mercury_library_types.h"" /* for MR_ArrayType */ "). :- pragma foreign_decl("C", " void ML_init_array(MR_ArrayType *, MR_Integer size, MR_Word item); "). :- pragma foreign_code("C", " /* ** The caller is responsible for allocating the memory for the array. ** This routine does the job of initializing the already-allocated memory. */ void ML_init_array(MR_ArrayType *array, MR_Integer size, MR_Word item) { MR_Integer i; array->size = size; for (i = 0; i < size; i++) { array->elements[i] = item; } } "). array__init(Size, Item, Array) :- ( Size < 0 -> error("array__init: negative size") ; array__init_2(Size, Item, Array) ). :- pred array__init_2(int, T, array(T)). :- mode array__init_2(in, in, array_uo) is det. :- pragma foreign_proc("C", array__init_2(Size::in, Item::in, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " MR_incr_hp_msg(Array, Size + 1, MR_PROC_LABEL, ""array:array/1""); ML_init_array((MR_ArrayType *)Array, Size, Item); "). :- pragma foreign_proc("C", array__make_empty_array(Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " MR_incr_hp_msg(Array, 1, MR_PROC_LABEL, ""array:array/1""); ML_init_array((MR_ArrayType *)Array, 0, 0); "). :- pragma foreign_proc("C#", array__init_2(Size::in, Item::in, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " Array = System.Array.CreateInstance(Item.GetType(), Size); for (int i = 0; i < Size; i++) { Array.SetValue(Item, i); } "). :- pragma foreign_proc("C#", array__make_empty_array(_Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " mercury.runtime.Errors.SORRY(""foreign code for this predicate""); "). %-----------------------------------------------------------------------------% :- pragma foreign_proc("C", array__min(Array::array_ui, Min::out), [will_not_call_mercury, promise_pure, thread_safe], " /* Array not used */ Min = 0; "). :- pragma foreign_proc("C", array__min(Array::in, Min::out), [will_not_call_mercury, promise_pure, thread_safe], " /* Array not used */ Min = 0; "). :- pragma foreign_proc("C#", array__min(Array::array_ui, Min::out), [will_not_call_mercury, promise_pure, thread_safe], " /* Array not used */ Min = 0; "). :- pragma foreign_proc("C#", array__min(Array::in, Min::out), [will_not_call_mercury, promise_pure, thread_safe], " /* Array not used */ Min = 0; "). :- pragma foreign_proc("C", array__max(Array::array_ui, Max::out), [will_not_call_mercury, promise_pure, thread_safe], " Max = ((MR_ArrayType *)Array)->size - 1; "). :- pragma foreign_proc("C", array__max(Array::in, Max::out), [will_not_call_mercury, promise_pure, thread_safe], " Max = ((MR_ArrayType *)Array)->size - 1; "). :- pragma foreign_proc("C#", array__max(Array::array_ui, Max::out), [will_not_call_mercury, promise_pure, thread_safe], " Max = Array.Length - 1; "). :- pragma foreign_proc("C#", array__max(Array::in, Max::out), [will_not_call_mercury, promise_pure, thread_safe], " Max = Array.Length - 1; "). array__bounds(Array, Min, Max) :- array__min(Array, Min), array__max(Array, Max). %-----------------------------------------------------------------------------% :- pragma foreign_proc("C", array__size(Array::array_ui, Max::out), [will_not_call_mercury, promise_pure, thread_safe], " Max = ((MR_ArrayType *)Array)->size; "). :- pragma foreign_proc("C", array__size(Array::in, Max::out), [will_not_call_mercury, promise_pure, thread_safe], " Max = ((MR_ArrayType *)Array)->size; "). :- pragma foreign_proc("C#", array__size(Array::array_ui, Max::out), [will_not_call_mercury, promise_pure, thread_safe], " Max = Array.Length; "). :- pragma foreign_proc("C#", array__size(Array::in, Max::out), [will_not_call_mercury, promise_pure, thread_safe], " Max = Array.Length; "). %-----------------------------------------------------------------------------% array__in_bounds(Array, Index) :- array__bounds(Array, Min, Max), Min =< Index, Index =< Max. array__semidet_lookup(Array, Index, Item) :- array__in_bounds(Array, Index), array__lookup(Array, Index, Item). array__semidet_set(Array0, Index, Item, Array) :- array__in_bounds(Array0, Index), array__set(Array0, Index, Item, Array). array__semidet_slow_set(Array0, Index, Item, Array) :- array__in_bounds(Array0, Index), array__slow_set(Array0, Index, Item, Array). array__slow_set(Array0, Index, Item, Array) :- array__copy(Array0, Array1), array__set(Array1, Index, Item, Array). %-----------------------------------------------------------------------------% array__lookup(Array, Index, Item) :- ( bounds_checks, \+ array__in_bounds(Array, Index) -> out_of_bounds_error(Array, Index, "array__lookup") ; array__unsafe_lookup(Array, Index, Item) ). :- pred array__unsafe_lookup(array(T), int, T). :- mode array__unsafe_lookup(array_ui, in, out) is det. :- mode array__unsafe_lookup(in, in, out) is det. :- pragma foreign_proc("C", array__unsafe_lookup(Array::array_ui, Index::in, Item::out), [will_not_call_mercury, promise_pure, thread_safe], "{ MR_ArrayType *array = (MR_ArrayType *)Array; Item = array->elements[Index]; }"). :- pragma foreign_proc("C", array__unsafe_lookup(Array::in, Index::in, Item::out), [will_not_call_mercury, promise_pure, thread_safe], "{ MR_ArrayType *array = (MR_ArrayType *)Array; Item = array->elements[Index]; }"). :- pragma foreign_proc("C#", array__unsafe_lookup(Array::array_ui, Index::in, Item::out), [will_not_call_mercury, promise_pure, thread_safe], "{ Item = Array.GetValue(Index); }"). :- pragma foreign_proc("C#", array__unsafe_lookup(Array::in, Index::in, Item::out), [will_not_call_mercury, promise_pure, thread_safe], "{ Item = Array.GetValue(Index); }"). %-----------------------------------------------------------------------------% array__set(Array0, Index, Item, Array) :- ( bounds_checks, \+ array__in_bounds(Array0, Index) -> out_of_bounds_error(Array0, Index, "array__set") ; array__unsafe_set(Array0, Index, Item, Array) ). :- pred array__unsafe_set(array(T), int, T, array(T)). :- mode array__unsafe_set(array_di, in, in, array_uo) is det. :- pragma foreign_proc("C", array__unsafe_set(Array0::array_di, Index::in, Item::in, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], "{ MR_ArrayType *array = (MR_ArrayType *)Array0; array->elements[Index] = Item; /* destructive update! */ Array = Array0; }"). :- pragma foreign_proc("C#", array__unsafe_set(Array0::array_di, Index::in, Item::in, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], "{ Array0.SetValue(Item, Index); /* destructive update! */ Array = Array0; }"). %-----------------------------------------------------------------------------% :- pragma foreign_decl("C", " void ML_resize_array(MR_ArrayType *new_array, MR_ArrayType *old_array, MR_Integer array_size, MR_Word item); "). :- pragma foreign_code("C", " /* ** The caller is responsible for allocating the storage for the new array. ** This routine does the job of copying the old array elements to the ** new array, initializing any additional elements in the new array, ** and deallocating the old array. */ void ML_resize_array(MR_ArrayType *array, MR_ArrayType *old_array, MR_Integer array_size, MR_Word item) { MR_Integer i; MR_Integer elements_to_copy; elements_to_copy = old_array->size; if (elements_to_copy > array_size) { elements_to_copy = array_size; } array->size = array_size; for (i = 0; i < elements_to_copy; i++) { array->elements[i] = old_array->elements[i]; } for (; i < array_size; i++) { array->elements[i] = item; } /* ** since the mode on the old array is `array_di', it is safe to ** deallocate the storage for it */ #ifdef MR_CONSERVATIVE_GC GC_free(old_array); #endif } "). :- pragma foreign_proc("C", array__resize(Array0::array_di, Size::in, Item::in, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " if (((MR_ArrayType *)Array0)->size == Size) { Array = Array0; } else { MR_incr_hp_msg(Array, Size + 1, MR_PROC_LABEL, ""array:array/1""); ML_resize_array((MR_ArrayType *) Array, (MR_ArrayType *) Array0, Size, Item); } "). :- pragma foreign_proc("C#", array__resize(Array0::array_di, Size::in, Item::in, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " if (Array0.Length == Size) { Array = Array0; } else if (Array0.Length > Size) { Array = System.Array.CreateInstance(Item.GetType(), Size); System.Array.Copy(Array0, Array, Size); } else { Array = System.Array.CreateInstance(Item.GetType(), Size); System.Array.Copy(Array0, Array, Array0.Length); for (int i = Array0.Length; i < Size; i++) { Array.SetValue(Item, i); } } "). %-----------------------------------------------------------------------------% :- pragma foreign_decl("C", " void ML_shrink_array(MR_ArrayType *array, MR_ArrayType *old_array, MR_Integer array_size); "). :- pragma foreign_code("C", " /* ** The caller is responsible for allocating the storage for the new array. ** This routine does the job of copying the old array elements to the ** new array and deallocating the old array. */ void ML_shrink_array(MR_ArrayType *array, MR_ArrayType *old_array, MR_Integer array_size) { MR_Integer i; array->size = array_size; for (i = 0; i < array_size; i++) { array->elements[i] = old_array->elements[i]; } /* ** since the mode on the old array is `array_di', it is safe to ** deallocate the storage for it */ #ifdef MR_CONSERVATIVE_GC GC_free(old_array); #endif } "). array__shrink(Array0, Size, Array) :- OldSize = array__size(Array0), ( Size > OldSize -> error("array__shrink: can't shrink to a larger size") ; Size = OldSize -> Array = Array0 ; array__shrink_2(Array0, Size, Array) ). :- pred array__shrink_2(array(T), int, array(T)). :- mode array__shrink_2(array_di, in, array_uo) is det. :- pragma foreign_proc("C", array__shrink_2(Array0::array_di, Size::in, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " MR_incr_hp_msg(Array, Size + 1, MR_PROC_LABEL, ""array:array/1""); ML_shrink_array((MR_ArrayType *)Array, (MR_ArrayType *) Array0, Size); "). :- pragma foreign_proc("C#", array__shrink_2(Array0::array_di, Size::in, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " Array = System.Array.CreateInstance( Array0.GetType().GetElementType(), Size); System.Array.Copy(Array0, Array, Size); "). %-----------------------------------------------------------------------------% :- pragma foreign_decl("C", " void ML_copy_array(MR_ArrayType *array, const MR_ArrayType *old_array); "). :- pragma foreign_code("C", " /* ** The caller is responsible for allocating the storage for the new array. ** This routine does the job of copying the array elements. */ void ML_copy_array(MR_ArrayType *array, const MR_ArrayType *old_array) { /* ** Any changes to this function will probably also require ** changes to deepcopy() in runtime/deep_copy.c. */ MR_Integer i; MR_Integer array_size; array_size = old_array->size; array->size = array_size; for (i = 0; i < array_size; i++) { array->elements[i] = old_array->elements[i]; } } "). :- pragma foreign_proc("C", array__copy(Array0::array_ui, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " MR_incr_hp_msg(Array, (((const MR_ArrayType *) Array0)->size) + 1, MR_PROC_LABEL, ""array:array/1""); ML_copy_array((MR_ArrayType *)Array, (const MR_ArrayType *) Array0); "). :- pragma foreign_proc("C", array__copy(Array0::in, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " MR_incr_hp_msg(Array, (((const MR_ArrayType *) Array0)->size) + 1, MR_PROC_LABEL, ""array:array/1""); ML_copy_array((MR_ArrayType *)Array, (const MR_ArrayType *) Array0); "). :- pragma foreign_proc("C#", array__copy(Array0::array_ui, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " // XXX we implement the same as ML_copy_array, which doesn't appear // to deep copy the array elements Array = System.Array.CreateInstance( Array0.GetType().GetElementType(), Array0.Length); System.Array.Copy(Array0, Array, Array0.Length); "). :- pragma foreign_proc("C#", array__copy(Array0::in, Array::array_uo), [will_not_call_mercury, promise_pure, thread_safe], " mercury.runtime.Errors.SORRY(""foreign code for this function""); // XXX need to deep copy it Array = Array0; "). %-----------------------------------------------------------------------------% array(List) = Array :- array__from_list(List, Array). array__from_list([], Array) :- array__make_empty_array(Array). array__from_list(List, Array) :- List = [ Head | Tail ], list__length(List, Len), array__init(Len, Head, Array0), array__insert_items(Tail, 1, Array0, Array). %-----------------------------------------------------------------------------% :- pred array__insert_items(list(T), int, array(T), array(T)). :- mode array__insert_items(in, in, array_di, array_uo) is det. array__insert_items([], _N, Array, Array). array__insert_items([Head|Tail], N, Array0, Array) :- array__set(Array0, N, Head, Array1), N1 is N + 1, array__insert_items(Tail, N1, Array1, Array). %-----------------------------------------------------------------------------% array__to_list(Array, List) :- array__bounds(Array, Low, High), array__fetch_items(Array, Low, High, List). %-----------------------------------------------------------------------------% array__fetch_items(Array, Low, High, List) :- List = foldr_0(func(X, Xs) = [X | Xs], Array, [], Low, High). %-----------------------------------------------------------------------------% array__bsearch(A, El, Compare, Result) :- array__bounds(A, Lo, Hi), array__bsearch_2(A, Lo, Hi, El, Compare, Result). :- pred array__bsearch_2(array(T), int, int, T, pred(T, T, comparison_result), maybe(int)). :- mode array__bsearch_2(in, in, in, in, pred(in, in, out) is det, out) is det. array__bsearch_2(Array, Lo, Hi, El, Compare, Result) :- Width is Hi - Lo, % If Width < 0, there is no range left. ( Width < 0 -> Result = no ; % If Width == 0, we may just have found our element. % Do a Compare to check. ( Width = 0 -> array__lookup(Array, Lo, X), ( call(Compare, El, X, (=)) -> Result = yes(Lo) ; Result = no ) ; % Otherwise find the middle element of the range % and check against that. Mid is (Lo + Hi) >> 1, % `>> 1' is hand-optimized `div 2'. array__lookup(Array, Mid, XMid), call(Compare, XMid, El, Comp), ( Comp = (<), Mid1 is Mid + 1, array__bsearch_2(Array, Mid1, Hi, El, Compare, Result) ; Comp = (=), array__bsearch_2(Array, Lo, Mid, El, Compare, Result) ; Comp = (>), Mid1 is Mid - 1, array__bsearch_2(Array, Lo, Mid1, El, Compare, Result) ) ) ). %-----------------------------------------------------------------------------% array__map(Closure, OldArray, NewArray) :- ( array__semidet_lookup(OldArray, 0, Elem0) -> array__size(OldArray, Size), call(Closure, Elem0, Elem), array__init(Size, Elem, NewArray0), array__map_2(1, Size, Closure, OldArray, NewArray0, NewArray) ; array__make_empty_array(NewArray) ). :- pred array__map_2(int, int, pred(T1, T2), array(T1), array(T2), array(T2)). :- mode array__map_2(in, in, pred(in, out) is det, in, array_di, array_uo) is det. array__map_2(N, Size, Closure, OldArray, NewArray0, NewArray) :- ( N >= Size -> NewArray = NewArray0 ; array__lookup(OldArray, N, OldElem), Closure(OldElem, NewElem), array__set(NewArray0, N, NewElem, NewArray1), array__map_2(N + 1, Size, Closure, OldArray, NewArray1, NewArray) ). %-----------------------------------------------------------------------------% %-----------------------------------------------------------------------------% % Ralph Becket 24/04/99 % Function forms added. array__make_empty_array = A :- array__make_empty_array(A). array__init(N, X) = A :- array__init(N, X, A). array__min(A) = N :- array__min(A, N). array__max(A) = N :- array__max(A, N). array__size(A) = N :- array__size(A, N). array__lookup(A, N) = X :- array__lookup(A, N, X). array__set(A1, N, X) = A2 :- array__set(A1, N, X, A2). array__slow_set(A1, N, X) = A2 :- array__slow_set(A1, N, X, A2). array__copy(A1) = A2 :- array__copy(A1, A2). array__resize(A1, N, X) = A2 :- array__resize(A1, N, X, A2). array__shrink(A1, N) = A2 :- array__shrink(A1, N, A2). array__from_list(Xs) = A :- array__from_list(Xs, A). array__to_list(A) = Xs :- array__to_list(A, Xs). array__fetch_items(A, N1, N2) = Xs :- array__fetch_items(A, N1, N2, Xs). array__bsearch(A, X, F) = MN :- P = ( pred(X1::in, X2::in, C::out) is det :- C = F(X1, X2) ), array__bsearch(A, X, P, MN). array__map(F, A1) = A2 :- P = ( pred(X::in, Y::out) is det :- Y = F(X) ), array__map(P, A1, A2). array_compare(A1, A2) = C :- array_compare(C, A1, A2). array__elem(Index, Array) = array__lookup(Array, Index). 'array__elem :='(Index, Array, Value) = array__set(Array, Index, Value). % ---------------------------------------------------------------------------- % % array__sort/1 has type specialised versions for arrays of % ints and strings on the expectation that these constitute % the common case and are hence worth providing a fast-path. % % Experiments indicate that type specialisation improves % array__sort/1 by a factor of 30-40%. % :- pragma type_spec(array__sort/1, T = int). :- pragma type_spec(array__sort/1, T = string). array__sort(A) = samsort_subarray(A, array__min(A), array__max(A)). %------------------------------------------------------------------------------% array__random_permutation(A0, A, RS0, RS) :- Lo = array__min(A0), Hi = array__max(A0), Sz = array__size(A0), permutation_2(Lo, Lo, Hi, Sz, A0, A, RS0, RS). :- pred permutation_2(int, int, int, int, array(T), array(T), random__supply, random__supply). :- mode permutation_2(in, in, in, in, array_di, array_uo, mdi, muo) is det. permutation_2(I, Lo, Hi, Sz, A0, A, RS0, RS) :- ( if I > Hi then A = A0, RS = RS0 else random__random(R, RS0, RS1), J = Lo + (R `rem` Sz), A1 = swap_elems(A0, I, J), permutation_2(I + 1, Lo, Hi, Sz, A1, A, RS1, RS) ). %------------------------------------------------------------------------------% :- func swap_elems(array(T), int, int) = array(T). :- mode swap_elems(array_di, in, in) = array_uo is det. swap_elems(A0, I, J) = A :- XI = A0 ^ elem(I), XJ = A0 ^ elem(J), A = ((A0 ^ elem(I) := XJ) ^ elem(J) := XI). % ---------------------------------------------------------------------------- % array__foldl(Fn, A, X) = foldl_0(Fn, A, X, array__min(A), array__max(A)). :- func foldl_0(func(T1, T2) = T2, array(T1), T2, int, int) = T2. :- mode foldl_0(func(in, in) = out is det, array_ui, in, in, in) = out is det. :- mode foldl_0(func(in, in) = out is det, in, in, in, in) = out is det. :- mode foldl_0(func(in, di) = uo is det, array_ui, di, in, in) = uo is det. :- mode foldl_0(func(in, di) = uo is det, in, di, in, in) = uo is det. foldl_0(Fn, A, X, I, Max) = ( if Max < I then X else foldl_0(Fn, A, Fn(A ^ elem(I), X), I + 1, Max) ). % ---------------------------------------------------------------------------- % array__foldr(Fn, A, X) = foldr_0(Fn, A, X, array__min(A), array__max(A)). :- func foldr_0(func(T1, T2) = T2, array(T1), T2, int, int) = T2. :- mode foldr_0(func(in, in) = out is det, array_ui, in, in, in) = out is det. :- mode foldr_0(func(in, in) = out is det, in, in, in, in) = out is det. :- mode foldr_0(func(in, di) = uo is det, array_ui, di, in, in) = uo is det. :- mode foldr_0(func(in, di) = uo is det, in, di, in, in) = uo is det. foldr_0(Fn, A, X, Min, I) = ( if I < Min then X else foldr_0(Fn, A, Fn(A ^ elem(I), X), Min, I - 1) ). % ---------------------------------------------------------------------------- % % ---------------------------------------------------------------------------- % % SAMsort (smooth applicative merge) invented by R.A. O'Keefe. % % SAMsort is a mergesort variant that works by identifying contiguous % monotonic sequences and merging them, thereby taking advantage of % any existing order in the input sequence. % :- func samsort_subarray(array(T), int, int) = array(T). :- mode samsort_subarray(array_di, in, in) = array_uo is det. :- pragma type_spec(samsort_subarray/3, T = int). :- pragma type_spec(samsort_subarray/3, T = string). samsort_subarray(A0, Lo, Hi) = A :- samsort_up(0, A0, _, array__copy(A0), A, Lo, Hi, Lo). :- pred samsort_up(int, array(T), array(T), array(T), array(T), int, int, int). :- mode samsort_up(in, array_di, array_uo, array_di, array_uo, in, in, in) is det. :- pragma type_spec(samsort_up/8, T = int). :- pragma type_spec(samsort_up/8, T = string). % Precondition: % We are N levels from the bottom (leaf nodes) of the tree. % A0 is sorted from Lo .. I - 1. % A0 and B0 are identical from I .. Hi. % Postcondition: % B is sorted from Lo .. Hi. % samsort_up(N, A0, A, B0, B, Lo, Hi, I) :- ( if I > Hi then A = A0, B = B0 else if N > 0 then samsort_down(N - 1, B0, B1, A0, A1, I, Hi, J), % A1 is sorted from I .. J - 1. % A1 and B1 are identical from J .. Hi. B2 = merge_subarrays(A1, B1, Lo, I - 1, I, J - 1, Lo), A2 = A1, % B2 is sorted from Lo .. J - 1. samsort_up(N + 1, B2, B, A2, A, Lo, Hi, J) else /* N = 0, I = Lo */ copy_run_ascending(A0, B0, B1, Lo, Hi, J), % B1 is sorted from Lo .. J - 1. samsort_up(N + 1, B1, B, A0, A, Lo, Hi, J) ). :- pred samsort_down(int,array(T),array(T),array(T),array(T),int,int,int). :- mode samsort_down(in, array_di, array_uo, array_di, array_uo, in, in, out) is det. :- pragma type_spec(samsort_down/8, T = int). :- pragma type_spec(samsort_down/8, T = string). % Precondition: % We are N levels from the bottom (leaf nodes) of the tree. % A0 and B0 are identical from Lo .. Hi. % Postcondition: % B is sorted from Lo .. I - 1. % A and B are identical from I .. Hi. % samsort_down(N, A0, A, B0, B, Lo, Hi, I) :- ( if Lo > Hi then A = A0, B = B0, I = Lo else if N > 0 then samsort_down(N - 1, B0, B1, A0, A1, Lo, Hi, J), samsort_down(N - 1, B1, B2, A1, A2, J, Hi, I), % A2 is sorted from Lo .. J - 1. % A2 is sorted from J .. I - 1. A = A2, B = merge_subarrays(A2, B2, Lo, J - 1, J, I - 1, Lo) % B is sorted from Lo .. I - 1. else A = A0, copy_run_ascending(A0, B0, B, Lo, Hi, I) % B is sorted from Lo .. I - 1. ). %------------------------------------------------------------------------------% :- pred copy_run_ascending(array(T), array(T), array(T), int, int, int). :- mode copy_run_ascending(array_ui, array_di, array_uo, in, in, out) is det. :- pragma type_spec(copy_run_ascending/6, T = int). :- pragma type_spec(copy_run_ascending/6, T = string). copy_run_ascending(A, B0, B, Lo, Hi, I) :- ( if Lo < Hi, compare((>), A ^ elem(Lo), A ^ elem(Lo + 1)) then I = search_until((<), A, Lo, Hi), B = copy_subarray_reverse(A, B0, Lo, I - 1, I - 1) else I = search_until((>), A, Lo, Hi), B = copy_subarray(A, B0, Lo, I - 1, Lo) ). %------------------------------------------------------------------------------% :- func search_until(comparison_result, array(T), int, int) = int. :- mode search_until(in, array_ui, in, in) = out is det. :- pragma type_spec(search_until/4, T = int). :- pragma type_spec(search_until/4, T = string). search_until(R, A, Lo, Hi) = ( if Lo < Hi, not compare(R, A ^ elem(Lo), A ^ elem(Lo + 1)) then search_until(R, A, Lo + 1, Hi) else Lo + 1 ). %------------------------------------------------------------------------------% :- func copy_subarray(array(T), array(T), int, int, int) = array(T). :- mode copy_subarray(array_ui, array_di, in, in, in) = array_uo is det. :- pragma type_spec(copy_subarray/5, T = int). :- pragma type_spec(copy_subarray/5, T = string). copy_subarray(A, B, Lo, Hi, I) = ( if Lo =< Hi then copy_subarray(A, B ^ elem(I) := A ^ elem(Lo), Lo + 1, Hi, I + 1) else B ). %------------------------------------------------------------------------------% :- func copy_subarray_reverse(array(T), array(T), int, int, int) = array(T). :- mode copy_subarray_reverse(array_ui, array_di, in, in, in) = array_uo is det. :- pragma type_spec(copy_subarray_reverse/5, T = int). :- pragma type_spec(copy_subarray_reverse/5, T = string). copy_subarray_reverse(A, B, Lo, Hi, I) = ( if Lo =< Hi then copy_subarray_reverse(A, B ^ elem(I) := A ^ elem(Lo), Lo+1, Hi, I-1) else B ). %------------------------------------------------------------------------------% % merges the two sorted consecutive subarrays Lo1 .. Hi1 and % Lo2 .. Hi2 from A into the subarray starting at I in B. % :- func merge_subarrays(array(T), array(T), int, int, int, int, int) = array(T). :- mode merge_subarrays(array_ui, array_di, in, in, in, in, in) = array_uo is det. :- pragma type_spec(merge_subarrays/7, T = int). :- pragma type_spec(merge_subarrays/7, T = string). merge_subarrays(A, B0, Lo1, Hi1, Lo2, Hi2, I) = B :- ( if Lo1 > Hi1 then B = copy_subarray(A, B0, Lo2, Hi2, I) else if Lo2 > Hi2 then B = copy_subarray(A, B0, Lo1, Hi1, I) else X1 = A ^ elem(Lo1), X2 = A ^ elem(Lo2), compare(R, X1, X2), ( R = (<), B = merge_subarrays(A, B0^elem(I) := X1, Lo1+1, Hi1, Lo2, Hi2, I+1) ; R = (=), B = merge_subarrays(A, B0^elem(I) := X1, Lo1+1, Hi1, Lo2, Hi2, I+1) ; R = (>), B = merge_subarrays(A, B0^elem(I) := X2, Lo1, Hi1, Lo2+1, Hi2, I+1) ) ). %------------------------------------------------------------------------------% % throw an exception indicating an array bounds error :- pred out_of_bounds_error(array(T), int, string). :- mode out_of_bounds_error(array_ui, in, in) is erroneous. :- mode out_of_bounds_error(in, in, in) is erroneous. % Note: we deliberately do not include the array element type name % in the error message here, for performance reasons: % using the type name could prevent the compiler from optimizing % away the construction of the type_info in the caller, % because it would prevent unused argument elimination. % Performance is important here, because array__set and array__lookup % are likely to be used in the inner loops of performance-critical % applications. out_of_bounds_error(Array, Index, PredName) :- array__bounds(Array, Min, Max), throw(array__index_out_of_bounds( string__format("%s: index %d not in range [%d, %d]", [s(PredName), i(Index), i(Min), i(Max)]))). %------------------------------------------------------------------------------% %------------------------------------------------------------------------------%