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