re-fix my last re-fix of this Array class. I think I have it right this time, or...
[kakapo:kakapo.git] / src / Pmc / Array.nqp
1 # Copyright (C) 2009-2010, Austin Hastings. See accompanying LICENSE file, or
2 # http://www.opensource.org/licenses/artistic-license-2.0.php for license.
3
4 class Array {
5
6 # Special sub called when the Kakapo library is loaded or initialized to
7 # guarantee this module is already initialized during :init and :load
8 # processing.
9 sub _pre_initload() {
10         our %Bsearch_compare_func;
11
12         %Bsearch_compare_func{'<=>'}    := Array::cmp_numeric;
13         %Bsearch_compare_func{'R<=>'}   := Array::cmp_numeric_R;
14         %Bsearch_compare_func{'cmp'}    := Array::cmp_string;
15         %Bsearch_compare_func{'Rcmp'}   := Array::cmp_string_R;
16
17         my @methods := <
18                 bsearch
19                 contains
20                 delete
21                 distinct
22                 elems
23                 grep
24                 is_sorted
25                 keys
26                 kv
27                 join
28                 map
29                 reduce
30                 reverse
31                 slice
32                 splice
33                 unsort
34         >;
35         my %pmcs;
36
37         %pmcs<ResizablePMCArray>        := @methods;
38
39         %pmcs<ResizableStringArray>     := pir::clone__PP(@methods); # No common yet
40         %pmcs<ResizableStringArray>.push( <append> );
41
42         my $from_nsp := pir::get_namespace__P();
43
44         for %pmcs {
45                 my $pmc_name := ~ $_;
46                 my $to_class := Parrot::get_hll_namespace($pmc_name).get_class();
47
48                 for %pmcs{$_} {
49                         my $method := $from_nsp{$_};
50                         if !pir::isnull__IP($method) {
51                             try {
52                                 $to_class.add_method($_, $method);
53                             }
54                         }
55                         else {
56                                 pir::die("Request to export unknown Array method '$_'");
57                         }
58
59                 }
60         }
61
62         # Put some helper functions in the global namespace.
63
64         # These are "list-of-list" subs, and have no corresponding methods.
65         for <cat roundrobin zip> {
66                 Global::inject_root_symbol($from_nsp{$_});
67         }
68
69         # These have corresponding methods.
70         for <grep join map reduce> {
71                 Global::inject_root_symbol(
72                         Parrot::get_hll_global('Array::' ~ $_ ~ '_args'),
73                         :as($_),
74                 );
75         }
76 }
77
78 method append(@other) {
79         for @other {
80                 self.push($_);
81         }
82
83         self;
84 }
85
86 #=begin
87 #
88 #=item bsearch($value, :cmp($)?, :low($)?, :high($)?) returns Integer
89 #
90 #Binary search for C< $value > in the invocant array. The array must be sorted
91 #in the order implied by the comparison function used.
92 #
93 #By default, bsearch uses the "natural" ascending order of the array -- string order
94 #for PMC and String array types, numeric order for numeric arrays. The caller may
95 #specify an alternate comparator using the C< :cmp() > option.
96 #
97 #The string labels C<< '<=>' >> and C<< 'R<=>' >> are defined aliases for the
98 #ascending and descending ('R' for reversed) numeric comparators. Likewise,
99 #the labels C< cmp > and C< Rcmp > are defined aliases for the string comparators.
100 #
101 #A user-provided function may be passed to C< :cmp() > -- just pass the Sub PMC.
102 #As you might expect, the function must accept two parameters and return an
103 #integer value less than zero when the first parameter should appear earlier in
104 #the array than the second parameter.
105 #
106 #The C< :low() > and C< :high() > options may be specified to artificially restrict
107 #the range of the search. By default, C< bsearch > assumes values of C< :low(0) >
108 #and C< :high( self.elems ) >.
109 #
110 #If C< $value > is stored in the array, C< bsearch > returns the index where the
111 #value can be found. If C< $value > is I< not > in the array, the return value is
112 #(-V) - 1, where V is the index where C< $value > would be inserted in order. This
113 #avoids trying to deal with "negative zero" indices for values that would be inserted
114 #at the start of the array. The mapping (-V) - 1 reverses itself.
115 #
116 #=begin code
117 #       my $index := @a.bsearch('needle');
118 #
119 #       if $index < 0 {
120 #               insert_record(@a, -$index - 1);
121 #       }
122 #       else {
123 #               say("Found it at index: $index");
124 #       }
125 #=end code
126 #
127 #=end
128
129 method bsearch($value, *%opts) {
130         our %Bsearch_compare_func;
131
132         my $cmp := %opts<cmp> ?? %opts<cmp> !! '<=>';
133         my $high        := %opts<high> > 0 ?? %opts<high> !! self.elems;
134         my $low := 0 + %opts<low>;
135         my $top := $high;
136
137         my $elts        := self.elems;
138
139         if $high > $elts { $high := $elts; }
140         if $low < 0 { $low := $low + $elts; }
141
142         my &comparator := %Bsearch_compare_func.contains($cmp)
143                 ?? %Bsearch_compare_func{$cmp}
144                 !! $cmp;
145
146         unless &comparator.isa('Sub') || &comparator.isa('MultiSub') {
147                 Opcode::die("Bsearch :cmp function parameter was not a (Multi)Sub");
148         }
149
150         my $mid;
151
152         while $low < $high {
153                 # NQP gets this wrong -- floating point math
154                 #$mid := $low + ($high - $low) / 2;
155                 $mid := Q:PIR {
156                         .local int high, low
157                         $P0 = find_lex '$high'
158                         high = $P0
159                         $P0 = find_lex '$low'
160                         low = $P0
161                         $I0 = high - low
162                         $I0 = $I0 / 2
163                         $I0 = $I0 + low
164                         %r = box $I0
165                 };
166
167                 if &comparator(self[$mid], $value) < 0 {
168                         $low := $mid + 1;
169                 }
170                 else {
171                         $high := $mid;
172                 }
173         }
174
175         my $result := - ($low + 1);
176
177         if $low < $top
178                 && &comparator(self[$low], $value) == 0 {
179                 $result := $low;
180         }
181
182         $result;
183 }
184
185 sub cmp_numeric($a, $b) { return $a - $b; }
186 sub cmp_numeric_R($a, $b) { return $b - $a; }
187 sub cmp_string($a, $b) { if $a lt $b { return -1; } else { return 1; } }
188 sub cmp_string_R($a, $b) { if $b lt $a { return -1; } else { return 1; } }
189
190 # Concatenates a list of zero or more arrays into one long array. Returns the
191 # resulting array. Returns an empty array if no arrays are given, or if the given
192 # arrays have no elements.
193 sub cat(*@sources) {
194         my @cat;
195
196         for @sources {
197                 @cat.append($_);
198         }
199
200         @cat;
201 }
202
203 method contains($item) {
204         for self {
205                 if pir::iseq__IPP($item, $_) {
206                         return 1;
207                 }
208         }
209
210         0;
211 }
212
213 method delete($key) {
214         Opcode::delete(self, $key);     # NB: Needs special key reference
215         self;
216 }
217
218 method distinct(:&cmp = Array::cmp_string) {
219         my $elems := self.elems;
220         my $i := 0;
221         my $j;
222         my $array_i;
223
224         while $i < $elems {
225                 $array_i := self[$i];
226                 $i++;
227
228                 while $i < $elems && &cmp($array_i, self[$i]) == 0 {
229                         self.delete($i);
230                         $elems--;
231                 }
232         }
233
234         self;
235 }
236
237 method elements() {
238         die("No more elements! Use .elems");
239 }
240
241 method elems() {
242         pir::elements__IP(self);
243 }
244
245 sub grep_args(&match, *@values) {
246         @values.grep: &match;
247 }
248
249 method grep(&match) {
250         my @matches;
251
252         for self {
253                 @matches.push($_)
254                         if &match($_);
255         }
256
257         @matches;
258 }
259
260 method is_sorted(:&cmp = Array::cmp_string) {
261         my $index := 0;
262         my $limit := self.elems - 1;
263
264         while $index < $limit {
265                 if &cmp(self[$index], self[$index + 1]) > 0 {
266                         return 0;
267                 }
268
269                 $index++;
270         }
271
272         1;
273 }
274
275 sub join_args( $delim, *@args ) {
276         @args.join($delim);
277 }
278
279 method keys() {
280         my @result;
281
282         my $i := 0;
283         my $limit := self.elems;
284
285         while $i < $limit {
286                 if self.exists($i) {
287                         @result.push($i.clone);
288                 }
289
290                 $i++;
291         }
292
293         @result;
294 }
295
296 method kv() {
297         my @result;
298
299         my $i := 0;
300
301         for self {
302                 @result.push($i.clone);
303                 @result.push($_);
304         }
305
306         @result;
307 }
308
309 method join($delim? = '') {
310         pir::join__SSP($delim, self);
311 }
312
313 sub map_args(&func, *@args) {
314         @args.map: &func;
315 }
316
317 method map(&func) {
318         my @result;
319
320         for self {
321                 @result.push(&func($_));
322         }
323
324         @result;
325 }
326
327 sub new(*@elements) {
328         @elements;
329 }
330
331 sub reduce_args(&expression, *@values) {
332         @values.reduce(&expression);
333 }
334
335 method reduce(&expression) {
336         my $result;
337         my $first := 1;
338
339         if self.elems {
340                 for self {
341                         if $first {
342                                 $first--;
343                                 $result := $_;
344                         }
345                         else {
346                                 $result := &expression($result, $_);
347                         }
348                 }
349         }
350
351         $result;
352 }
353
354 method reverse(:$from = 0, :$to) {
355         $to := self.elems - 1 unless $to.defined;
356         my $temp;
357
358         if $from > $to {
359                 $temp := $from;
360                 $from := $to;
361                 $to := $temp;
362         }
363
364         if $from >= 0 {
365                 while $from < $to {
366                         $temp := self[$from];
367                         self[$from] := self[$to];
368                         self[$to] := $temp;
369                         $from++;
370                         $to--;
371                 }
372         }
373
374         self;
375 }
376
377 sub roundrobin(*@sources) {
378         my @result;
379         my $i := 0;
380         my $done;
381
382         until $done {
383                 $done := 1;
384
385                 for @sources -> @a {
386                         if @a.elems > $i {
387                                 $done := 0;
388                                 @result.push(@a[$i]);
389                         }
390                 }
391         }
392
393         @result;
394 }
395
396 method set_size($size) {
397         pir::assign__vPI(self, $size);
398         self;
399 }
400
401 method slice(:$from = 0, :$to) {
402         my $elems := self.elems;
403         $to := $elems unless $to.defined;
404
405         if $from < 0    { $from := $from + $elems; }
406         if $to < 0      { $to := $to + $elems; }
407
408         if $from >= $elems {
409                 die('$from parameter out of range: ', $from, ' exceeds # elements: ', $elems);
410         }
411
412         if $to > $elems {
413                 die('$to parameter out of range: ', $from, ' exceeds # elements: ', $elems);
414         }
415
416         our @Empty;
417         my @slice := self.clone;
418         @slice.splice(@Empty, :from($to + 1), :replacing($elems - $to));
419         @slice.splice(@Empty, :from(0), :replacing($from));
420         @slice;
421 }
422
423 method splice(@value, :$from = 0, :$replacing = 0) {
424         pir::splice__vPPII(self, @value, $from, $replacing);
425         self;
426 }
427
428 method unsort() {
429         our &Parrot_range_rand;
430
431         if ! pir::defined( &Parrot_range_rand ) {
432                 #$_Math_lib := pir::loadlib__PS('math_ops');
433                 my $lib := pir::loadlib__PS(pir::null__S);
434                 &Parrot_range_rand := pir::dlfunc__PPSS($lib, 'Parrot_range_rand', 'iiii');
435         }
436
437         my $bound := self.elems - 1;
438         my $swap;
439         my $temp;
440
441         while $bound > 0 {
442                 $swap := &Parrot_range_rand(0, $bound + 1, 0);  # +1: see TT#1479
443                 $swap-- if $swap > $bound;      # Rare but possible
444                 $temp := self[$bound];
445                 self[$bound] := self[$swap];
446                 self[$swap] := $temp;
447                 $bound--;
448         }
449
450         self;
451 }
452
453 sub zip(*@sources) {
454         my @result;
455         my $limit := 0;
456
457         if @sources.elems {
458                 $limit := @sources[0].elems;
459         }
460
461         for @sources -> @a {
462                 $limit := @a.elems
463                         if @a.elems < $limit;
464         }
465
466         my $i := 0;
467
468         while $i < $limit {
469                 for @sources -> @a {
470                         @result.push(@a[$i]);
471                 }
472
473                 $i++;
474         }
475
476         @result;
477 }
478 }