|
996
|
1 package Language::INTERCAL::Arrays;
|
|
|
2
|
|
|
3 # Tails and hybrids; also shark fins
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Arrays.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
19 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
20 use Language::INTERCAL::Numbers '1.-94.-2';
|
|
|
21 use Language::INTERCAL::DataItem '1.-94.-2';
|
|
|
22 use vars qw(@ISA);
|
|
|
23 @ISA = qw(Language::INTERCAL::DataItem);
|
|
|
24
|
|
|
25 sub new {
|
|
|
26 @_ or croak
|
|
|
27 "Usage: new Language::INTERCAL::Arrays [::TYPE | BITS], SUBSCRIPTS";
|
|
|
28 my $class = shift;
|
|
|
29 my $bits;
|
|
|
30 if ($class->isa('Language::INTERCAL::Arrays::Tail')) {
|
|
|
31 @_ == 1 or croak "Usage: new $class SUBSCRIPTS";
|
|
|
32 $bits = 16;
|
|
|
33 } elsif ($class->isa('Language::INTERCAL::Arrays::Hybrid')) {
|
|
|
34 @_ == 1 or croak "Usage: new $class SUBSCRIPTS";
|
|
|
35 $bits = 32;
|
|
|
36 } else {
|
|
|
37 @_ == 2 or croak "Usage: new $class BITS, SUBSCRIPTS";
|
|
|
38 my $bits = shift;
|
|
|
39 $bits > 32 and croak "Invalid number of BITS";
|
|
|
40 $bits = $bits > 16 ? 32 : 16;
|
|
|
41 $class .= $bits > 16 ? '::Hybrid' : '::Tail';
|
|
|
42 }
|
|
|
43 my @subscripts = _make_subscripts(undef, @_);
|
|
|
44 bless {
|
|
|
45 subscripts => \@subscripts,
|
|
|
46 value => {},
|
|
|
47 bits => $bits,
|
|
|
48 overload => undef,
|
|
|
49 }, $class;
|
|
|
50 }
|
|
|
51
|
|
|
52 sub copy {
|
|
|
53 @_ == 1 or croak "Usage: ARRAY->copy";
|
|
|
54 my ($arr) = @_;
|
|
|
55 bless {
|
|
|
56 map {
|
|
|
57 my $v = $arr->{$_};
|
|
|
58 if (ref $v) {
|
|
|
59 $v = [@$v] if ref $v eq 'ARRAY';
|
|
|
60 $v = {%$v} if ref $v eq 'HASH';
|
|
|
61 }
|
|
|
62 ($_, $v);
|
|
|
63 } keys %$arr
|
|
|
64 }, ref $arr;
|
|
|
65 }
|
|
|
66
|
|
|
67 sub _store {
|
|
|
68 @_ == 3 or croak "Usage: ARRAY->store(SUBSCRIPTS, VALUE)";
|
|
|
69 my ($arr, $subscripts, $value) = @_;
|
|
|
70 my @subscripts = _make_subscripts($arr, $subscripts);
|
|
|
71 my $bits = $arr->{bits};
|
|
|
72 if (ref $value) {
|
|
|
73 UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers')
|
|
|
74 or faint(SP_INVARRAY, 'Not a number');
|
|
|
75 $value = $bits > 16 ? $value->twospot : $value->spot;
|
|
|
76 } else {
|
|
|
77 defined $value && $value =~ /^\d+$/
|
|
|
78 or faint(SP_INVARRAY, 'Not a number');
|
|
|
79 $value = new Language::INTERCAL::Numbers $bits, $value;
|
|
|
80 }
|
|
|
81 my $sv = join(' ', @subscripts);
|
|
|
82 if (! exists $arr->{value}{$sv}) {
|
|
|
83 $arr->{value}{$sv} =
|
|
|
84 new Language::INTERCAL::Numbers $arr->{bits}, $value;
|
|
|
85 } else {
|
|
|
86 $arr->{value}{$sv}->assign($value);
|
|
|
87 }
|
|
|
88 $arr;
|
|
|
89 }
|
|
|
90
|
|
|
91 sub _get {
|
|
|
92 @_ == 2 or croak "Usage: ARRAY->get(SUBSCRIPTS)";
|
|
|
93 my ($arr, $subscripts) = @_;
|
|
|
94 my $place = join(' ', _make_subscripts($arr, $subscripts));
|
|
|
95 return $arr->{value}{$place}->value if exists $arr->{value}{$place};
|
|
|
96 new Language::INTERCAL::Numbers $arr->bits, 0;
|
|
|
97 }
|
|
|
98
|
|
|
99 sub elements {
|
|
|
100 @_ == 1 or croak "Usage: ARRAY->elements";
|
|
|
101 my ($arr) = @_;
|
|
|
102 return 0 unless @{$arr->{subscripts}};
|
|
|
103 my $elems = 1;
|
|
|
104 $elems *= $_ for @{$arr->{subscripts}};
|
|
|
105 $elems;
|
|
|
106 }
|
|
|
107
|
|
|
108 sub subscripts {
|
|
|
109 @_ == 1 or croak "Usage: ARRAY->subscripts";
|
|
|
110 my ($arr) = @_;
|
|
|
111 return () unless @{$arr->{subscripts}};
|
|
|
112 @{$arr->{subscripts}};
|
|
|
113 }
|
|
|
114
|
|
|
115 sub range {
|
|
|
116 @_ == 3 or croak "Usage: ARRAY->range(START, LEN)";
|
|
|
117 my ($arr, $start, $len) = @_;
|
|
|
118 my $el = $arr->elements;
|
|
|
119 $start > 0 && $start <= $el
|
|
|
120 or faint(SP_SUBSCRIPT, 'range start outside array');
|
|
|
121 $start--;
|
|
|
122 $len >= 0 && $start + $len <= $el
|
|
|
123 or faint(SP_SUBSCRIPT, 'range length outside array');
|
|
|
124 my @a = _as_list($arr);
|
|
|
125 return (ref $arr)->from_list([splice(@a, $start, $len)]);
|
|
|
126 }
|
|
|
127
|
|
|
128 sub as_string {
|
|
|
129 @_ == 1 or croak "Usage: ARRAY->as_string";
|
|
|
130 my ($arr) = @_;
|
|
|
131 pack('C*', map { $_->number & 0xff } $arr->as_list);
|
|
|
132 }
|
|
|
133
|
|
|
134 sub sparse_list {
|
|
|
135 @_ == 1 or croak "Usage: ARRAY->sparse_list";
|
|
|
136 my ($arr) = @_;
|
|
|
137 return () unless @{$arr->{subscripts}};
|
|
|
138 _sparse_list($arr);
|
|
|
139 }
|
|
|
140
|
|
|
141 sub _sparse_list {
|
|
|
142 my ($arr, @subs) = @_;
|
|
|
143 if (@subs >= @{$arr->{subscripts}}) {
|
|
|
144 my $s = join(' ', @subs);
|
|
|
145 return [$arr->{value}{$s}, @subs] if exists $arr->{value}{$s};
|
|
|
146 return ();
|
|
|
147 }
|
|
|
148 my $max = $arr->{subscripts}[scalar @subs];
|
|
|
149 map { _sparse_list($arr, @subs, $_) } (1..$max);
|
|
|
150 }
|
|
|
151
|
|
|
152 sub as_list {
|
|
|
153 @_ == 1 or croak "Usage: ARRAY->as_list";
|
|
|
154 my ($arr) = @_;
|
|
|
155 return () unless @{$arr->{subscripts}};
|
|
|
156 _as_list($arr);
|
|
|
157 }
|
|
|
158
|
|
|
159 sub _as_list {
|
|
|
160 my ($arr, @subs) = @_;
|
|
|
161 if (@subs >= @{$arr->{subscripts}}) {
|
|
|
162 my $s = join(' ', @subs);
|
|
|
163 return $arr->{value}{$s} if exists $arr->{value}{$s};
|
|
|
164 return new Language::INTERCAL::Numbers $arr->bits, 0;
|
|
|
165 }
|
|
|
166 my $max = $arr->{subscripts}[scalar @subs];
|
|
|
167 map { _as_list($arr, @subs, $_) } (1..$max);
|
|
|
168 }
|
|
|
169
|
|
|
170 sub from_list {
|
|
|
171 @_ or croak "Usage: from_list Language::INTERCAL::Arrays " .
|
|
|
172 "[::TYPE | BITS], VALUES";
|
|
|
173 my $class = shift;
|
|
|
174 if ($class->isa('Language::INTERCAL::Arrays::Tail')) {
|
|
|
175 @_ == 1 or croak "Usage: from_list $class LIST";
|
|
|
176 } elsif ($class->isa('Language::INTERCAL::Arrays::Hybrid')) {
|
|
|
177 @_ == 1 or croak "Usage: from_list $class LIST";
|
|
|
178 } else {
|
|
|
179 @_ == 2 or croak "Usage: from_list $class BITS, LIST";
|
|
|
180 my $bits = shift;
|
|
|
181 $bits > 32 and croak "Invalid number of BITS";
|
|
|
182 $class .= $bits > 16 ? '::Hybrid' : '::Tail';
|
|
|
183 }
|
|
|
184 my ($values) = @_;
|
|
|
185 my $arr = $class->new([@$values ? scalar @$values : ()]);
|
|
|
186 for (my $i = 1; $i <= @$values; $i++) {
|
|
|
187 $arr->store([$i], $values->[$i - 1]);
|
|
|
188 }
|
|
|
189 $arr;
|
|
|
190 }
|
|
|
191
|
|
|
192 sub _assign {
|
|
|
193 @_ == 2 or croak "Usage: ARRAY->assign(VALUE)";
|
|
|
194 my ($arr, $value) = @_;
|
|
|
195 my @subscripts = _make_subscripts(undef, $value);
|
|
|
196 $arr->{subscripts} = \@subscripts;
|
|
|
197 $arr->{value} = {};
|
|
|
198 $arr;
|
|
|
199 }
|
|
|
200
|
|
|
201 sub print {
|
|
|
202 @_ == 1 or croak "Usage: ARRAY->print";
|
|
|
203 my ($arr) = @_;
|
|
|
204 my $s = $arr->{subscripts};
|
|
|
205 return "[]" unless $s && @$s;
|
|
|
206 _print($arr, [], @$s);
|
|
|
207 }
|
|
|
208
|
|
|
209 sub _print {
|
|
|
210 my ($arr, $sp, @s) = @_;
|
|
|
211 if (@s) {
|
|
|
212 my $m = shift @s;
|
|
|
213 my @v = map { _print($arr, [@$sp, $_], @s) } (1..$m);
|
|
|
214 return '[' . join(', ', @v) . ']';
|
|
|
215 } else {
|
|
|
216 my $s = join(' ', @$sp);
|
|
|
217 return $arr->{value}{$s}->print if exists $arr->{value}{$s};
|
|
|
218 return '#0';
|
|
|
219 }
|
|
|
220 }
|
|
|
221
|
|
|
222 sub replace {
|
|
|
223 @_ == 2 or croak "Usage: ARRAY->replace(LIST)";
|
|
|
224 my ($arr, $list) = @_;
|
|
|
225 faint(SP_NODIM) unless @{$arr->{subscripts}};
|
|
|
226 _replace($arr, $list);
|
|
|
227 faint(SP_ARRAY, "Too many elements") if @$list;
|
|
|
228 $arr;
|
|
|
229 }
|
|
|
230
|
|
|
231 sub _replace {
|
|
|
232 my ($arr, $list, @subs) = @_;
|
|
|
233 if (@subs >= @{$arr->{subscripts}}) {
|
|
|
234 my $s = join(' ', @subs);
|
|
|
235 my $num = @$list ? shift @$list : 0;
|
|
|
236 if (exists $arr->{value}{$s}) {
|
|
|
237 $arr->{value}{$s}->assign($num);
|
|
|
238 } else {
|
|
|
239 $arr->{value}{$s} =
|
|
|
240 Language::INTERCAL::Numbers->new($arr->bits, $num);
|
|
|
241 }
|
|
|
242 return;
|
|
|
243 }
|
|
|
244 my $max = $arr->{subscripts}[scalar @subs];
|
|
|
245 for (my $s = 1; $s <= $max; $s++) {
|
|
|
246 _replace($arr, $list, @subs, $s);
|
|
|
247 }
|
|
|
248 }
|
|
|
249
|
|
|
250 # some methods in case arrays are used as numbers or class
|
|
|
251
|
|
|
252 sub digits { faint(SP_ISARRAY); }
|
|
|
253 sub filehandle { faint(SP_NOTCLASS); }
|
|
|
254 sub number { faint(SP_ISARRAY); }
|
|
|
255 sub spot { faint(SP_ISARRAY) }
|
|
|
256 sub twospot { faint(SP_ISARRAY) }
|
|
|
257
|
|
|
258 package Language::INTERCAL::Arrays::Tail;
|
|
|
259
|
|
|
260 use Carp;
|
|
|
261 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
262
|
|
|
263 use vars qw(@ISA);
|
|
|
264 @ISA = qw(Language::INTERCAL::Arrays);
|
|
|
265
|
|
|
266 sub tail {
|
|
|
267 @_ == 1 or croak "Usage: ARRAY->tail";
|
|
|
268 goto &Language::INTERCAL::Arrays::copy;
|
|
|
269 }
|
|
|
270
|
|
|
271 sub hybrid {
|
|
|
272 @_ == 1 or croak "Usage: ARRAY->hybrid";
|
|
|
273 my ($arr) = @_;
|
|
|
274 my $h = new Language::INTERCAL::Arrays::Hybrid $arr->{subscripts};
|
|
|
275 for my $k (keys %{$arr->{value}}) {
|
|
|
276 my $v = $arr->{value}{$k};
|
|
|
277 $h->{value} = $v->twospot;
|
|
|
278 }
|
|
|
279 $h;
|
|
|
280 }
|
|
|
281
|
|
|
282 package Language::INTERCAL::Arrays::Hybrid;
|
|
|
283
|
|
|
284 use Carp;
|
|
|
285 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
286
|
|
|
287 use vars qw(@ISA);
|
|
|
288 @ISA = qw(Language::INTERCAL::Arrays);
|
|
|
289
|
|
|
290 sub tail {
|
|
|
291 @_ == 1 or croak "Usage: ARRAY->tail";
|
|
|
292 my ($arr) = @_;
|
|
|
293 my $t = new Language::INTERCAL::Arrays::Tail $arr->{subscripts};
|
|
|
294 for my $k (keys %{$arr->{value}}) {
|
|
|
295 my $v = $arr->{value}{$k};
|
|
|
296 $t->{value} = $v->spot;
|
|
|
297 }
|
|
|
298 $t;
|
|
|
299 }
|
|
|
300
|
|
|
301 sub hybrid {
|
|
|
302 @_ == 1 or croak "Usage: ARRAY->hybrid";
|
|
|
303 goto &Language::INTERCAL::Arrays::copy;
|
|
|
304 }
|
|
|
305
|
|
|
306 1;
|
