line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package PDLA::Core; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# Core routines for PDLA module |
4
|
|
|
|
|
|
|
|
5
|
77
|
|
|
77
|
|
521
|
use strict; |
|
77
|
|
|
|
|
155
|
|
|
77
|
|
|
|
|
2322
|
|
6
|
77
|
|
|
77
|
|
407
|
use warnings; |
|
77
|
|
|
|
|
164
|
|
|
77
|
|
|
|
|
1949
|
|
7
|
77
|
|
|
77
|
|
30523
|
use PDLA::Exporter; |
|
77
|
|
|
|
|
195
|
|
|
77
|
|
|
|
|
409
|
|
8
|
77
|
|
|
77
|
|
477
|
use DynaLoader; |
|
77
|
|
|
|
|
144
|
|
|
77
|
|
|
|
|
5286
|
|
9
|
|
|
|
|
|
|
our @ISA = qw( PDLA::Exporter DynaLoader ); |
10
|
|
|
|
|
|
|
our $VERSION = "2.019107"; |
11
|
|
|
|
|
|
|
bootstrap PDLA::Core $VERSION; |
12
|
77
|
|
|
77
|
|
34868
|
use PDLA::Types ':All'; |
|
77
|
|
|
|
|
266
|
|
|
77
|
|
|
|
|
22879
|
|
13
|
77
|
|
|
77
|
|
604
|
use Config; |
|
77
|
|
|
|
|
151
|
|
|
77
|
|
|
|
|
34702
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our @EXPORT = qw( piddle pdl null barf ); # Only stuff always exported! |
16
|
|
|
|
|
|
|
my @convertfuncs = map PDLA::Types::typefld($_,'convertfunc'), PDLA::Types::typesrtkeys(); |
17
|
|
|
|
|
|
|
my @exports_internal = qw(howbig threadids topdl); |
18
|
|
|
|
|
|
|
my @exports_normal = (@EXPORT, |
19
|
|
|
|
|
|
|
@convertfuncs, |
20
|
|
|
|
|
|
|
qw(nelem dims shape null |
21
|
|
|
|
|
|
|
convert inplace zeroes zeros ones list listindices unpdl |
22
|
|
|
|
|
|
|
set at flows thread_define over reshape dog cat barf type diagonal |
23
|
|
|
|
|
|
|
dummy mslice approx flat sclr squeeze |
24
|
|
|
|
|
|
|
get_autopthread_targ set_autopthread_targ get_autopthread_actual |
25
|
|
|
|
|
|
|
get_autopthread_size set_autopthread_size) ); |
26
|
|
|
|
|
|
|
our @EXPORT_OK = (@exports_internal, @exports_normal); |
27
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( |
28
|
|
|
|
|
|
|
Func => [@exports_normal], |
29
|
|
|
|
|
|
|
Internal => [@exports_internal] ); |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
our ($level, @dims, $sep, $sep2, $match); |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
# Important variables (place in PDLA namespace) |
34
|
|
|
|
|
|
|
# (twice to eat "used only once" warning) |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
$PDLA::debug = # Debugging info |
37
|
|
|
|
|
|
|
$PDLA::debug = 0; |
38
|
|
|
|
|
|
|
$PDLA::verbose = # Functions provide chatty information |
39
|
|
|
|
|
|
|
$PDLA::verbose = 0; |
40
|
|
|
|
|
|
|
$PDLA::use_commas = 0; # Whether to insert commas when printing arrays |
41
|
|
|
|
|
|
|
$PDLA::floatformat = "%7g"; # Default print format for long numbers |
42
|
|
|
|
|
|
|
$PDLA::doubleformat = "%10.8g"; |
43
|
|
|
|
|
|
|
$PDLA::indxformat = "%12d"; # Default print format for PDLA_Indx values |
44
|
|
|
|
|
|
|
$PDLA::undefval = 0; # Value to use instead of undef when creating PDLAs |
45
|
|
|
|
|
|
|
$PDLA::toolongtoprint = 10000; # maximum pdl size to stringify for printing |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
################ Exportable functions of the Core ###################### |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
# log10() is now defined in ops.pd |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
*howbig = \&PDLA::howbig; *unpdl = \&PDLA::unpdl; |
52
|
|
|
|
|
|
|
*nelem = \&PDLA::nelem; *inplace = \&PDLA::inplace; |
53
|
|
|
|
|
|
|
*dims = \&PDLA::dims; *list = \&PDLA::list; |
54
|
|
|
|
|
|
|
*threadids = \&PDLA::threadids; *listindices = \&PDLA::listindices; |
55
|
|
|
|
|
|
|
*null = \&PDLA::null; *set = \&PDLA::set; |
56
|
|
|
|
|
|
|
*at = \&PDLA::at; *flows = \&PDLA::flows; |
57
|
|
|
|
|
|
|
*sclr = \&PDLA::sclr; *shape = \&PDLA::shape; |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
for (map { |
60
|
|
|
|
|
|
|
[ PDLA::Types::typefld($_,'convertfunc'), PDLA::Types::typefld($_,'numval') ] |
61
|
|
|
|
|
|
|
} PDLA::Types::typesrtkeys()) { |
62
|
|
|
|
|
|
|
my ($conv, $val) = @$_; |
63
|
77
|
|
|
77
|
|
2428
|
no strict 'refs'; |
|
77
|
|
|
|
|
1915
|
|
|
77
|
|
|
|
|
22445
|
|
64
|
|
|
|
|
|
|
*$conv = *{"PDLA::$conv"} = sub { |
65
|
536
|
100
|
|
536
|
|
25144
|
return bless [$val], "PDLA::Type" unless @_; |
66
|
229
|
100
|
|
|
|
1152
|
alltopdl('PDLA', (scalar(@_)>1 ? [@_] : shift), PDLA::Type->new($val)); |
67
|
|
|
|
|
|
|
}; |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
BEGIN { |
71
|
77
|
|
|
77
|
|
518
|
*thread_define = \&PDLA::thread_define; |
72
|
77
|
|
|
|
|
303
|
*convert = \&PDLA::convert; *over = \&PDLA::over; |
|
77
|
|
|
|
|
563
|
|
73
|
77
|
|
|
|
|
263
|
*dog = \&PDLA::dog; *cat = \&PDLA::cat; |
|
77
|
|
|
|
|
220
|
|
74
|
77
|
|
|
|
|
313
|
*type = \&PDLA::type; *approx = \&PDLA::approx; |
|
77
|
|
|
|
|
342
|
|
75
|
77
|
|
|
|
|
334
|
*diagonal = \&PDLA::diagonal; |
76
|
77
|
|
|
|
|
227
|
*dummy = \&PDLA::dummy; |
77
|
77
|
|
|
|
|
317
|
*mslice = \&PDLA::mslice; |
78
|
77
|
|
|
|
|
215
|
*isempty = \&PDLA::isempty; |
79
|
77
|
|
|
|
|
5192
|
*string = \&PDLA::string; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
=head1 NAME |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
PDLA::Core - fundamental PDLA functionality and vectorization/threading |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
=head1 DESCRIPTION |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
Methods and functions for type conversions, PDLA creation, |
89
|
|
|
|
|
|
|
type conversion, threading etc. |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
=head1 SYNOPSIS |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
use PDLA::Core; # Normal routines |
94
|
|
|
|
|
|
|
use PDLA::Core ':Internal'; # Hairy routines |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
=head1 VECTORIZATION/THREADING: METHOD AND NOMENCLATURE |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
PDLA provides vectorized operations via a built-in engine. |
99
|
|
|
|
|
|
|
Vectorization is called "threading" for historical reasons. |
100
|
|
|
|
|
|
|
The threading engine implements simple rules for each operation. |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
Each PDLA object has a "shape" that is a generalized N-dimensional |
103
|
|
|
|
|
|
|
rectangle defined by a "dim list" of sizes in an arbitrary |
104
|
|
|
|
|
|
|
set of dimensions. A PDLA with shape 2x3 has 6 elements and is |
105
|
|
|
|
|
|
|
said to be two-dimensional, or may be referred to as a 2x3-PDLA. |
106
|
|
|
|
|
|
|
The dimensions are indexed numerically starting at 0, so a |
107
|
|
|
|
|
|
|
2x3-PDLA has a dimension 0 (or "dim 0") with size 2 and a 1 dimension |
108
|
|
|
|
|
|
|
(or "dim 1") with size 3. |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
PDLA generalizes *all* mathematical operations with the notion of |
111
|
|
|
|
|
|
|
"active dims": each operator has zero or more active dims that are |
112
|
|
|
|
|
|
|
used in carrying out the operation. Simple scalar operations like |
113
|
|
|
|
|
|
|
scalar multiplication ('*') have 0 active dims. More complicated |
114
|
|
|
|
|
|
|
operators can have more active dims. For example, matrix |
115
|
|
|
|
|
|
|
multiplication ('x') has 2 active dims. Additional dims are |
116
|
|
|
|
|
|
|
automatically vectorized across -- e.g. multiplying a 2x5-PDLA with a |
117
|
|
|
|
|
|
|
2x5-PDLA requires 10 simple multiplication operations, and yields a |
118
|
|
|
|
|
|
|
2x5-PDLA result. |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=head2 Threading rules |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
In any PDLA expression, the active dims appropriate for each operator |
123
|
|
|
|
|
|
|
are used starting at the 0 dim and working forward through the dim |
124
|
|
|
|
|
|
|
list of each object. All additional dims after the active dims are |
125
|
|
|
|
|
|
|
"thread dims". The thread dims do not have to agree exactly: they are |
126
|
|
|
|
|
|
|
coerced to agree according to simple rules: |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
=over 3 |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
=item * Null PDLAs match any dim list (see below). |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
=item * Dims with sizes other than 1 must all agree in size. |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
=item * Dims of size 1 are expanded as necessary. |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
=item * Missing dims are expanded appropriately. |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
=back |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
The "size 1" rule implements "generalized scalar" operation, by |
141
|
|
|
|
|
|
|
analogy to scalar multiplication. The "missing dims" rule |
142
|
|
|
|
|
|
|
acknowledges the ambiguity between a missing dim and a dim of size 1. |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=head2 Null PDLAs |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
PDLAs on the left-hand side of assignment can have the special value |
147
|
|
|
|
|
|
|
"Null". A null PDLA has no dim list and no set size; its shape is |
148
|
|
|
|
|
|
|
determined by the computed shape of the expression being assigned to |
149
|
|
|
|
|
|
|
it. Null PDLAs contain no values and can only be assigned to. When |
150
|
|
|
|
|
|
|
assigned to (e.g. via the C<.=> operator), they cease to be null PDLAs. |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
To create a null PDLA, use Cnull()>. |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
=head2 Empty PDLAs |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
PDLAs can represent the empty set using "structured Empty" variables. |
157
|
|
|
|
|
|
|
An empty PDLA is not a null PDLA. |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
Any dim of a PDLA can be set explicitly to size 0. If so, the PDLA |
160
|
|
|
|
|
|
|
contains zero values (because the total number of values is the |
161
|
|
|
|
|
|
|
product of all the sizes in the PDLA's shape or dimlist). |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
Scalar PDLAs are zero-dimensional and have no entries in the dim list, |
164
|
|
|
|
|
|
|
so they cannot be empty. 1-D and higher PDLAs can be empty. Empty |
165
|
|
|
|
|
|
|
PDLAs are useful for set operations, and are most commonly encountered |
166
|
|
|
|
|
|
|
in the output from selection operators such as L |
167
|
|
|
|
|
|
|
and L. Not all empty PDLAs have the same |
168
|
|
|
|
|
|
|
threading properties -- e.g. a 2x0-PDLA represents a collection of |
169
|
|
|
|
|
|
|
2-vectors that happens to contain no elements, while a simple 0-PDLA |
170
|
|
|
|
|
|
|
represents a collection of scalar values (that also happens to contain |
171
|
|
|
|
|
|
|
no elements). |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
Note that 0 dims are not adjustable via the threading rules -- a dim |
174
|
|
|
|
|
|
|
with size 0 can only match a corresponding dim of size 0 or 1. |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=head2 Thread rules and assignments |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
Versions of PDLA through 2.4.10 have some irregularity with threading and |
179
|
|
|
|
|
|
|
assignments. Currently the threading engine performs a full expansion of |
180
|
|
|
|
|
|
|
both sides of the computed assignment operator C<.=> (which assigns values |
181
|
|
|
|
|
|
|
to a pre-existing PDLA). This leads to counter-intuitive behavior in |
182
|
|
|
|
|
|
|
some cases: |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
=over 3 |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=item * Generalized scalars and computed assignment |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
If the PDLA on the left-hand side of C<.=> has a dim of size 1, it can be |
189
|
|
|
|
|
|
|
treated as a generalized scalar, as in: |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
$x = sequence(2,3); |
192
|
|
|
|
|
|
|
$y = zeroes(1,3); |
193
|
|
|
|
|
|
|
$y .= $x; |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
In this case, C<$y> is automatically treated as a 2x3-PDLA during the |
196
|
|
|
|
|
|
|
threading operation, but half of the values from C<$x> silently disappear. |
197
|
|
|
|
|
|
|
The output is, as Kernighan and Ritchie would say, "undefined". |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
Further, if the value on the right of C<.=> is empty, then C<.=> becomes |
200
|
|
|
|
|
|
|
a silent no-op: |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
$x = zeroes(0); |
203
|
|
|
|
|
|
|
$y = zeroes(1); |
204
|
|
|
|
|
|
|
$y .= $x+1; |
205
|
|
|
|
|
|
|
print $y; |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
will print C<[0]>. In this case, "$x+1" is empty, and "$y" is a generalized |
208
|
|
|
|
|
|
|
scalar that is adjusted to be empty, so the assignment is carried out for |
209
|
|
|
|
|
|
|
zero elements (a no-op). |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
Both of these behaviors are considered harmful and should not be relied upon: |
212
|
|
|
|
|
|
|
they may be patched away in a future version of PDLA. |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
=item * Empty PDLAs and generalized scalars |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
Generalized scalars (PDLAs with a dim of size 1) can match any size in the |
217
|
|
|
|
|
|
|
corresponding dim, including 0. Thus, |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
$x = ones(2,0); |
220
|
|
|
|
|
|
|
$y = sequence(2,1); |
221
|
|
|
|
|
|
|
$c = $x * $y; |
222
|
|
|
|
|
|
|
print $c; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
prints C. |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
This behavior is counterintuitive but desirable, and will be preserved |
227
|
|
|
|
|
|
|
in future versions of PDLA. |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
=back |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=head1 VARIABLES |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
These are important variables of B scope and are placed |
234
|
|
|
|
|
|
|
in the PDLA namespace. |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
=head3 C<$PDLA::debug> |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
=over 4 |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
When true, PDLA debugging information is printed. |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
=back |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
=head3 C<$PDLA::verbose> |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
=over 4 |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
When true, PDLA functions provide chatty information. |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
=back |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
=head3 C<$PDLA::use_commas> |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=over 4 |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
Whether to insert commas when printing pdls |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
=back |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
=head3 C<$PDLA::floatformat>, C<$PDLA::doubleformat>, C<$PDLA::indxformat> |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
=over 4 |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
The default print format for floats, doubles, and indx values, |
265
|
|
|
|
|
|
|
respectively. The default default values are: |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
$PDLA::floatformat = "%7g"; |
268
|
|
|
|
|
|
|
$PDLA::doubleformat = "%10.8g"; |
269
|
|
|
|
|
|
|
$PDLA::indxformat = "%12d"; |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
=back |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
=head3 C<$PDLA::undefval> |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
=over 4 |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
The value to use instead of C when creating pdls. |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
=back |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
=head3 C<$PDLA::toolongtoprint> |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
=over 4 |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
The maximal size pdls to print (defaults to 10000 elements) |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
=back |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
=head1 FUNCTIONS |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
|
292
|
|
|
|
|
|
|
=head2 barf |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
=for ref |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
Standard error reporting routine for PDLA. |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
C is the routine PDLA modules should call to report errors. This |
299
|
|
|
|
|
|
|
is because C will report the error as coming from the correct |
300
|
|
|
|
|
|
|
line in the module user's script rather than in the PDLA module. |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
For now, barf just calls Carp::confess() |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
Remember C is your friend. *Use* it! |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
=for example |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
At the perl level: |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
barf("User has too low an IQ!"); |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
In C or XS code: |
313
|
|
|
|
|
|
|
|
314
|
|
|
|
|
|
|
barf("You have made %d errors", count); |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
Note: this is one of the few functions ALWAYS exported |
317
|
|
|
|
|
|
|
by PDLA::Core |
318
|
|
|
|
|
|
|
|
319
|
|
|
|
|
|
|
=cut |
320
|
|
|
|
|
|
|
|
321
|
77
|
|
|
77
|
|
562
|
use Carp; |
|
77
|
|
|
|
|
168
|
|
|
77
|
|
|
|
|
42420
|
|
322
|
70
|
|
|
70
|
1
|
20287
|
sub barf { goto &Carp::confess } |
323
|
11
|
|
|
11
|
0
|
10250
|
sub cluck { goto &Carp::cluck } |
324
|
|
|
|
|
|
|
*PDLA::barf = \&barf; |
325
|
|
|
|
|
|
|
*PDLA::cluck = \&cluck; |
326
|
|
|
|
|
|
|
|
327
|
|
|
|
|
|
|
########## Set Auto-PThread Based On Environment Vars ############ |
328
|
|
|
|
|
|
|
PDLA::set_autopthread_targ( $ENV{PDLA_AUTOPTHREAD_TARG} ) if( defined ( $ENV{PDLA_AUTOPTHREAD_TARG} ) ); |
329
|
|
|
|
|
|
|
PDLA::set_autopthread_size( $ENV{PDLA_AUTOPTHREAD_SIZE} ) if( defined ( $ENV{PDLA_AUTOPTHREAD_SIZE} ) ); |
330
|
|
|
|
|
|
|
################################################################## |
331
|
|
|
|
|
|
|
|
332
|
|
|
|
|
|
|
=head2 pdl |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
=for ref |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
PDLA constructor - creates new piddle from perl scalars/arrays, piddles, and strings |
337
|
|
|
|
|
|
|
|
338
|
|
|
|
|
|
|
=for usage |
339
|
|
|
|
|
|
|
|
340
|
|
|
|
|
|
|
$double_pdl = pdl(SCALAR|ARRAY REFERENCE|ARRAY|STRING); # default type |
341
|
|
|
|
|
|
|
$type_pdl = pdl(PDLA::Type,SCALAR|ARRAY REFERENCE|ARRAY|STRING); |
342
|
|
|
|
|
|
|
|
343
|
|
|
|
|
|
|
=for example |
344
|
|
|
|
|
|
|
|
345
|
|
|
|
|
|
|
$x = pdl [1..10]; # 1D array |
346
|
|
|
|
|
|
|
$x = pdl ([1..10]); # 1D array |
347
|
|
|
|
|
|
|
$x = pdl (1,2,3,4); # Ditto |
348
|
|
|
|
|
|
|
$y = pdl [[1,2,3],[4,5,6]]; # 2D 3x2 array |
349
|
|
|
|
|
|
|
$y = pdl "[[1,2,3],[4,5,6]]"; # Ditto (slower) |
350
|
|
|
|
|
|
|
$y = pdl "[1 2 3; 4 5 6]"; # Ditto |
351
|
|
|
|
|
|
|
$y = pdl q[1 2 3; 4 5 6]; # Ditto, using the q quote operator |
352
|
|
|
|
|
|
|
$y = pdl "1 2 3; 4 5 6"; # Ditto, less obvious, but still works |
353
|
|
|
|
|
|
|
$y = pdl 42 # 0-dimensional scalar |
354
|
|
|
|
|
|
|
$c = pdl $x; # Make a new copy |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
$u = pdl ushort(), 42 # 0-dimensional ushort scalar |
357
|
|
|
|
|
|
|
$y = pdl(byte(),[[1,2,3],[4,5,6]]); # 2D byte piddle |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
$n = pdl indx(), [1..5]; # 1D array of indx values |
360
|
|
|
|
|
|
|
$n = pdl indx, [1..5]; # ... can leave off parens |
361
|
|
|
|
|
|
|
$n = indx( [1..5] ); # ... still the same! |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
$x = pdl([1,2,3],[4,5,6]); # 2D |
364
|
|
|
|
|
|
|
$x = pdl([1,2,3],[4,5,6]); # 2D |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
Note the last two are equivalent - a list is automatically |
367
|
|
|
|
|
|
|
converted to a list reference for syntactic convenience. i.e. you |
368
|
|
|
|
|
|
|
can omit the outer C<[]> |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
You can mix and match arrays, array refs, and PDLAs in your argument |
371
|
|
|
|
|
|
|
list, and C will sort them out. You get back a PDLA whose last |
372
|
|
|
|
|
|
|
(slowest running) dim runs across the top level of the list you hand |
373
|
|
|
|
|
|
|
in, and whose first (fastest running) dim runs across the deepest |
374
|
|
|
|
|
|
|
level that you supply. |
375
|
|
|
|
|
|
|
|
376
|
|
|
|
|
|
|
At the moment, you cannot mix and match those arguments with string |
377
|
|
|
|
|
|
|
arguments, though we can't imagine a situation in which you would |
378
|
|
|
|
|
|
|
really want to do that. |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
The string version of pdl also allows you to use the strings C, C, |
381
|
|
|
|
|
|
|
and C, and it will insert the values that you mean (and set the bad flag |
382
|
|
|
|
|
|
|
if you use C). You can mix and match case, though you shouldn't. Here are |
383
|
|
|
|
|
|
|
some examples: |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
$bad = pdl q[1 2 3 bad 5 6]; # Set fourth element to the bad value |
386
|
|
|
|
|
|
|
$bad = pdl q[1 2 3 BAD 5 6]; # ditto |
387
|
|
|
|
|
|
|
$bad = pdl q[1 2 inf bad 5]; # now third element is IEEE infinite value |
388
|
|
|
|
|
|
|
$bad = pdl q[nan 2 inf -inf]; # first value is IEEE nan value |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
The default constructor uses IEEE double-precision floating point numbers. You |
391
|
|
|
|
|
|
|
can use other types, but you will get a warning if you try to use C with |
392
|
|
|
|
|
|
|
integer types (it will be replaced with the C value) and you will get a |
393
|
|
|
|
|
|
|
fatal error if you try to use C. |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
Throwing a PDLA into the mix has the same effect as throwing in a list ref: |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
pdl(pdl(1,2),[3,4]) |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
is the same as |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
pdl([1,2],[3,4]). |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
All of the dimensions in the list are "padded-out" with undefval to |
404
|
|
|
|
|
|
|
meet the widest dim in the list, so (e.g.) |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
$x = pdl([[1,2,3],[2]]) |
407
|
|
|
|
|
|
|
|
408
|
|
|
|
|
|
|
gives you the same answer as |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
$x = pdl([[1,2,3],[2,undef,undef]]); |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
If your PDLA module has bad values compiled into it (see L), |
413
|
|
|
|
|
|
|
you can pass BAD values into the constructor within pre-existing PDLAs. |
414
|
|
|
|
|
|
|
The BAD values are automatically kept BAD and propagated correctly. |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
C is a functional synonym for the 'new' constructor, |
417
|
|
|
|
|
|
|
e.g.: |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
$x = new PDLA [1..10]; |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
In order to control how undefs are handled in converting from perl lists to |
422
|
|
|
|
|
|
|
PDLAs, one can set the variable C<$PDLA::undefval>. |
423
|
|
|
|
|
|
|
For example: |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
$foo = [[1,2,undef],[undef,3,4]]; |
426
|
|
|
|
|
|
|
$PDLA::undefval = -999; |
427
|
|
|
|
|
|
|
$f = pdl $foo; |
428
|
|
|
|
|
|
|
print $f |
429
|
|
|
|
|
|
|
[ |
430
|
|
|
|
|
|
|
[ 1 2 -999] |
431
|
|
|
|
|
|
|
[-999 3 4] |
432
|
|
|
|
|
|
|
] |
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
C<$PDLA::undefval> defaults to zero. |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
As a final note, if you include an Empty PDLA in the list of objects to |
437
|
|
|
|
|
|
|
construct into a PDLA, it is kept as a placeholder pane -- so if you feed |
438
|
|
|
|
|
|
|
in (say) 7 objects, you get a size of 7 in the 0th dim of the output PDLA. |
439
|
|
|
|
|
|
|
The placeholder panes are completely padded out. But if you feed in only |
440
|
|
|
|
|
|
|
a single Empty PDLA, you get back the Empty PDLA (no padding). |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
=cut |
443
|
|
|
|
|
|
|
|
444
|
742
|
|
|
742
|
1
|
152927
|
sub pdl {PDLA->pdl(@_)} |
445
|
|
|
|
|
|
|
|
446
|
0
|
|
|
0
|
0
|
0
|
sub piddle {PDLA->pdl(@_)} |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
=head2 null |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
=for ref |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
Returns a 'null' piddle. |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
=for usage |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
$x = null; |
457
|
|
|
|
|
|
|
|
458
|
|
|
|
|
|
|
C has a special meaning to L. It is used to |
459
|
|
|
|
|
|
|
flag a special kind of empty piddle, which can grow to |
460
|
|
|
|
|
|
|
appropriate dimensions to store a result (as opposed to |
461
|
|
|
|
|
|
|
storing a result in an existing piddle). |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
=for example |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
pdla> sumover sequence(10,10), $ans=null;p $ans |
466
|
|
|
|
|
|
|
[45 145 245 345 445 545 645 745 845 945] |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
=cut |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
sub PDLA::null{ |
471
|
1654
|
100
|
|
1654
|
0
|
10159
|
my $class = scalar(@_) ? shift : undef; # if this sub called with no |
472
|
|
|
|
|
|
|
# class ( i.e. like 'null()', instead |
473
|
|
|
|
|
|
|
# of '$obj->null' or 'CLASS->null', setup |
474
|
|
|
|
|
|
|
|
475
|
1654
|
100
|
|
|
|
3287
|
if( defined($class) ){ |
476
|
1552
|
|
66
|
|
|
4873
|
$class = ref($class) || $class; # get the class name |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
else{ |
479
|
102
|
|
|
|
|
156
|
$class = 'PDLA'; # set class to the current package name if null called |
480
|
|
|
|
|
|
|
# with no arguments |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
|
483
|
1654
|
|
|
|
|
1310168
|
return $class->initialize(); |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
=head2 nullcreate |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
=for ref |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
Returns a 'null' piddle. |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
=for usage |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
$x = PDLA->nullcreate($arg) |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
This is an routine used by many of the threading primitives |
497
|
|
|
|
|
|
|
(i.e. L, |
498
|
|
|
|
|
|
|
L, etc.) to generate a null piddle for the |
499
|
|
|
|
|
|
|
function's output that will behave properly for derived (or |
500
|
|
|
|
|
|
|
subclassed) PDLA objects. |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
For the above usage: |
503
|
|
|
|
|
|
|
If C<$arg> is a PDLA, or a derived PDLA, then C<$arg-Enull> is returned. |
504
|
|
|
|
|
|
|
If C<$arg> is a scalar (i.e. a zero-dimensional PDLA) then Cnull> |
505
|
|
|
|
|
|
|
is returned. |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
=for example |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
PDLA::Derived->nullcreate(10) |
510
|
|
|
|
|
|
|
returns PDLA::Derived->null. |
511
|
|
|
|
|
|
|
PDLA->nullcreate($pdlderived) |
512
|
|
|
|
|
|
|
returns $pdlderived->null. |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
=cut |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
sub PDLA::nullcreate{ |
517
|
944
|
|
|
944
|
0
|
2391
|
my ($type,$arg) = @_; |
518
|
944
|
100
|
|
|
|
3141
|
return ref($arg) ? $arg->null : $type->null ; |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
=head2 nelem |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
=for ref |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
Return the number of elements in a piddle |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
=for usage |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
$n = nelem($piddle); $n = $piddle->nelem; |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
=for example |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
$mean = sum($data)/nelem($data); |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
=head2 dims |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
=for ref |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
Return piddle dimensions as a perl list |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
=for usage |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
@dims = $piddle->dims; @dims = dims($piddle); |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
=for example |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
pdla> p @tmp = dims zeroes 10,3,22 |
548
|
|
|
|
|
|
|
10 3 22 |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
See also L which returns a piddle instead. |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
=head2 shape |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
=for ref |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
Return piddle dimensions as a piddle |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
=for usage |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
$shape = $piddle->shape; $shape = shape($piddle); |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
=for example |
563
|
|
|
|
|
|
|
|
564
|
|
|
|
|
|
|
pdla> p $shape = shape zeroes 10,3,22 |
565
|
|
|
|
|
|
|
[10 3 22] |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
See also L which returns a perl list. |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
=head2 ndims |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
=for ref |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
Returns the number of dimensions in a piddle. Alias |
574
|
|
|
|
|
|
|
for L. |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
=head2 getndims |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
=for ref |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
Returns the number of dimensions in a piddle |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
=for usage |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
$ndims = $piddle->getndims; |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
=for example |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
pdla> p zeroes(10,3,22)->getndims |
589
|
|
|
|
|
|
|
3 |
590
|
|
|
|
|
|
|
|
591
|
|
|
|
|
|
|
=head2 dim |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
=for ref |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
Returns the size of the given dimension of a piddle. Alias |
596
|
|
|
|
|
|
|
for L. |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
=head2 getdim |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
=for ref |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
Returns the size of the given dimension. |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
=for usage |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
$dim0 = $piddle->getdim(0); |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
=for example |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
pdla> p zeroes(10,3,22)->getdim(1) |
611
|
|
|
|
|
|
|
3 |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
Negative indices count from the end of the dims array. |
614
|
|
|
|
|
|
|
Indices beyond the end will return a size of 1. This |
615
|
|
|
|
|
|
|
reflects the idea that any pdl is equivalent to an |
616
|
|
|
|
|
|
|
infinitely dimensional array in which only a finite number of |
617
|
|
|
|
|
|
|
dimensions have a size different from one. For example, in that sense a |
618
|
|
|
|
|
|
|
3D piddle of shape [3,5,2] is equivalent to a [3,5,2,1,1,1,1,1,....] |
619
|
|
|
|
|
|
|
piddle. Accordingly, |
620
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
print $x->getdim(10000); |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
will print 1 for most practically encountered piddles. |
624
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
=head2 topdl |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
=for ref |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
alternate piddle constructor - ensures arg is a piddle |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
=for usage |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
$x = topdl(SCALAR|ARRAY REFERENCE|ARRAY); |
634
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
The difference between L and C is that the |
636
|
|
|
|
|
|
|
latter will just 'fall through' if the argument is |
637
|
|
|
|
|
|
|
already a piddle. It will return a reference and I |
638
|
|
|
|
|
|
|
a new copy. |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
This is particularly useful if you are writing a function |
641
|
|
|
|
|
|
|
which is doing some fiddling with internals and assumes |
642
|
|
|
|
|
|
|
a piddle argument (e.g. for method calls). Using C |
643
|
|
|
|
|
|
|
will ensure nothing breaks if passed with '2'. |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
Note that C is not exported by default (see example |
646
|
|
|
|
|
|
|
below for usage). |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
=for example |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
use PDLA::Core ':Internal'; # use the internal routines of |
651
|
|
|
|
|
|
|
# the Core module |
652
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
$x = topdl 43; # $x is piddle with value '43' |
654
|
|
|
|
|
|
|
$y = topdl $piddle; # fall through |
655
|
|
|
|
|
|
|
$x = topdl (1,2,3,4); # Convert 1D array |
656
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
=head2 get_datatype |
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
=for ref |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
Internal: Return the numeric value identifying the piddle datatype |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
=for usage |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
$x = $piddle->get_datatype; |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
Mainly used for internal routines. |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
NOTE: get_datatype returns 'just a number' not any special |
670
|
|
|
|
|
|
|
type object, unlike L. |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
=head2 howbig |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
=for ref |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
Returns the sizeof a piddle datatype in bytes. |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
Note that C is not exported by default (see example |
679
|
|
|
|
|
|
|
below for usage). |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
=for usage |
682
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
use PDLA::Core ':Internal'; # use the internal routines of |
684
|
|
|
|
|
|
|
# the Core module |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
$size = howbig($piddle->get_datatype); |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
Mainly used for internal routines. |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
NOTE: NOT a method! This is because get_datatype returns |
691
|
|
|
|
|
|
|
'just a number' not any special object. |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
=for example |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
pdla> p howbig(ushort([1..10])->get_datatype) |
696
|
|
|
|
|
|
|
2 |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
=head2 get_dataref |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
=for ref |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
Return the internal data for a piddle, as a perl SCALAR ref. |
704
|
|
|
|
|
|
|
|
705
|
|
|
|
|
|
|
Most piddles hold their internal data in a packed perl string, to take |
706
|
|
|
|
|
|
|
advantage of perl's memory management. This gives you direct access |
707
|
|
|
|
|
|
|
to the string, which is handy when you need to manipulate the binary |
708
|
|
|
|
|
|
|
data directly (e.g. for file I/O). If you modify the string, you'll |
709
|
|
|
|
|
|
|
need to call L afterward, to make sure that the |
710
|
|
|
|
|
|
|
piddle points to the new location of the underlying perl variable. |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
Calling C automatically physicalizes your piddle (see |
713
|
|
|
|
|
|
|
L). You definitely |
714
|
|
|
|
|
|
|
don't want to do anything to the SV to truncate or deallocate the |
715
|
|
|
|
|
|
|
string, unless you correspondingly call L to make the |
716
|
|
|
|
|
|
|
PDLA match its new data dimension. |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
You definitely don't want to use get_dataref unless you know what you |
719
|
|
|
|
|
|
|
are doing (or are trying to find out): you can end up scrozzling |
720
|
|
|
|
|
|
|
memory if you shrink or eliminate the string representation of the |
721
|
|
|
|
|
|
|
variable. Here be dragons. |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
=head2 upd_data |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
=for ref |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
Update the data pointer in a piddle to match its perl SV. |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
This is useful if you've been monkeying with the packed string |
730
|
|
|
|
|
|
|
representation of the PDLA, which you probably shouldn't be doing |
731
|
|
|
|
|
|
|
anyway. (see L.) |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
=cut |
734
|
|
|
|
|
|
|
|
735
|
30
|
|
|
30
|
1
|
106
|
sub topdl {PDLA->topdl(@_)} |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
####################### Overloaded operators ####################### |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
# This is to used warn if an operand is non-numeric or non-PDLA. |
740
|
|
|
|
|
|
|
sub warn_non_numeric_op_wrapper { |
741
|
77
|
|
|
77
|
0
|
342
|
my ($cb, $op_name) = @_; |
742
|
|
|
|
|
|
|
return sub { |
743
|
49
|
|
|
49
|
|
11658
|
my ($op1, $op2) = @_; |
744
|
49
|
100
|
66
|
|
|
236
|
unless( Scalar::Util::looks_like_number($op2) |
|
|
|
100
|
|
|
|
|
745
|
|
|
|
|
|
|
|| ( Scalar::Util::blessed($op2) && $op2->isa('PDLA') ) |
746
|
|
|
|
|
|
|
) { |
747
|
6
|
|
|
|
|
82
|
warn "'$op2' is not numeric nor a PDLA in operator $op_name"; |
748
|
|
|
|
|
|
|
}; |
749
|
49
|
|
|
|
|
2623
|
$cb->(@_); |
750
|
|
|
|
|
|
|
} |
751
|
77
|
|
|
|
|
3680
|
} |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
{ package PDLA; |
754
|
|
|
|
|
|
|
# use UNIVERSAL 'isa'; # need that later in info function |
755
|
77
|
|
|
77
|
|
656
|
use Carp; |
|
77
|
|
|
|
|
158
|
|
|
77
|
|
|
|
|
81651
|
|
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
use overload ( |
758
|
|
|
|
|
|
|
"+" => \&PDLA::plus, # in1, in2 |
759
|
|
|
|
|
|
|
"*" => \&PDLA::mult, # in1, in2 |
760
|
|
|
|
|
|
|
"-" => \&PDLA::minus, # in1, in2, swap if true |
761
|
|
|
|
|
|
|
"/" => \&PDLA::divide, # in1, in2, swap if true |
762
|
|
|
|
|
|
|
|
763
|
84
|
|
|
84
|
|
2207738
|
"+=" => sub { PDLA::plus ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
84
|
|
|
|
|
2730
|
|
764
|
38
|
|
|
38
|
|
676
|
"*=" => sub { PDLA::mult ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
38
|
|
|
|
|
316
|
|
765
|
66
|
|
|
66
|
|
1220
|
"-=" => sub { PDLA::minus ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
66
|
|
|
|
|
750
|
|
766
|
51
|
|
|
51
|
|
974
|
"/=" => sub { PDLA::divide ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
51
|
|
|
|
|
527
|
|
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
">" => \&PDLA::gt, # in1, in2, swap if true |
769
|
|
|
|
|
|
|
"<" => \&PDLA::lt, # in1, in2, swap if true |
770
|
|
|
|
|
|
|
"<=" => \&PDLA::le, # in1, in2, swap if true |
771
|
|
|
|
|
|
|
">=" => \&PDLA::ge, # in1, in2, swap if true |
772
|
|
|
|
|
|
|
"==" => \&PDLA::eq, # in1, in2 |
773
|
|
|
|
|
|
|
"eq" => PDLA::Core::warn_non_numeric_op_wrapper(\&PDLA::eq, 'eq'), |
774
|
|
|
|
|
|
|
# in1, in2 |
775
|
|
|
|
|
|
|
"!=" => \&PDLA::ne, # in1, in2 |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
"<<" => \&PDLA::shiftleft, # in1, in2, swap if true |
778
|
|
|
|
|
|
|
">>" => \&PDLA::shiftright, # in1, in2, swap if true |
779
|
|
|
|
|
|
|
"|" => \&PDLA::or2, # in1, in2 |
780
|
|
|
|
|
|
|
"&" => \&PDLA::and2, # in1, in2 |
781
|
|
|
|
|
|
|
"^" => \&PDLA::xor, # in1, in2 |
782
|
|
|
|
|
|
|
|
783
|
0
|
|
|
0
|
|
0
|
"<<=" => sub { PDLA::shiftleft ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
0
|
|
|
|
|
0
|
|
784
|
0
|
|
|
0
|
|
0
|
">>=" => sub { PDLA::shiftright($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
0
|
|
|
|
|
0
|
|
785
|
2
|
|
|
2
|
|
54
|
"|=" => sub { PDLA::or2 ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
2
|
|
|
|
|
20
|
|
786
|
2
|
|
|
2
|
|
104
|
"&=" => sub { PDLA::and2 ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
2
|
|
|
|
|
26
|
|
787
|
0
|
|
|
0
|
|
0
|
"^=" => sub { PDLA::xor ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
0
|
|
|
|
|
0
|
|
788
|
40
|
|
|
40
|
|
2145480
|
"**=" => sub { PDLA::power ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
40
|
|
|
|
|
5164
|
|
789
|
16
|
|
|
16
|
|
417
|
"%=" => sub { PDLA::modulo ($_[0], $_[1], $_[0], 0); $_[0]; }, # in1, in2, out, swap if true |
|
16
|
|
|
|
|
147
|
|
790
|
|
|
|
|
|
|
|
791
|
10
|
|
|
10
|
|
630
|
"sqrt" => sub { PDLA::sqrt ($_[0]); }, |
792
|
305
|
|
|
305
|
|
161113
|
"abs" => sub { PDLA::abs ($_[0]); }, |
793
|
3
|
|
|
3
|
|
419
|
"sin" => sub { PDLA::sin ($_[0]); }, |
794
|
2
|
|
|
2
|
|
69
|
"cos" => sub { PDLA::cos ($_[0]); }, |
795
|
|
|
|
|
|
|
|
796
|
10
|
|
|
10
|
|
1026
|
"!" => sub { PDLA::not ($_[0]); }, |
797
|
2
|
|
|
2
|
|
239
|
"~" => sub { PDLA::bitnot ($_[0]); }, |
798
|
|
|
|
|
|
|
|
799
|
4
|
|
|
4
|
|
440
|
"log" => sub { PDLA::log ($_[0]); }, |
800
|
6
|
|
|
6
|
|
222
|
"exp" => sub { PDLA::exp ($_[0]); }, |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
"**" => \&PDLA::power, # in1, in2, swap if true |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
"atan2" => \&PDLA::atan2, # in1, in2, swap if true |
805
|
|
|
|
|
|
|
"%" => \&PDLA::modulo, # in1, in2, swap if true |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
"<=>" => \&PDLA::spaceship, # in1, in2, swap if true |
808
|
|
|
|
|
|
|
|
809
|
182
|
|
|
182
|
|
1376
|
"=" => sub {$_[0]}, # Don't deep copy, just copy reference |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
".=" => sub { |
812
|
621
|
|
|
621
|
|
1841
|
my @args = reverse &PDLA::Core::rswap; |
813
|
621
|
|
|
|
|
936519
|
PDLA::Ops::assgn(@args); |
814
|
621
|
|
|
|
|
5508
|
return $args[1]; |
815
|
|
|
|
|
|
|
}, |
816
|
|
|
|
|
|
|
|
817
|
17
|
|
|
17
|
|
1362
|
'x' => sub{my $foo = $_[0]->null(); |
818
|
17
|
|
|
|
|
74
|
PDLA::Primitive::matmult(@_[0,1],$foo); $foo;}, |
|
16
|
|
|
|
|
115
|
|
819
|
|
|
|
|
|
|
|
820
|
323
|
50
|
|
323
|
|
19376
|
'bool' => sub { return 0 if $_[0]->isnull; |
821
|
323
|
100
|
|
|
|
1068
|
croak("multielement piddle in conditional expression (see PDLA::FAQ questions 6-10 and 6-11)") |
822
|
|
|
|
|
|
|
unless $_[0]->nelem == 1; |
823
|
322
|
|
|
|
|
791
|
$_[0]->clump(-1)->at(0); }, |
824
|
77
|
|
|
77
|
|
652
|
"\"\"" => \&PDLA::Core::string ); |
|
77
|
|
|
|
|
156
|
|
|
77
|
|
|
|
|
1702
|
|
825
|
|
|
|
|
|
|
} |
826
|
|
|
|
|
|
|
|
827
|
621
|
50
|
|
621
|
0
|
1337
|
sub rswap { if($_[2]) { return @_[1,0]; } else { return @_[0,1]; } } |
|
0
|
|
|
|
|
0
|
|
|
621
|
|
|
|
|
1819
|
|
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
##################### Data type/conversion stuff ######################## |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
# XXX Optimize! |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
sub PDLA::dims { # Return dimensions as @list |
835
|
523
|
|
|
523
|
0
|
6715
|
my $pdl = PDLA->topdl (shift); |
836
|
523
|
|
|
|
|
968
|
my @dims = (); |
837
|
523
|
|
|
|
|
2195
|
for(0..$pdl->getndims()-1) {push @dims,($pdl->getdim($_))} |
|
923
|
|
|
|
|
2474
|
|
838
|
523
|
|
|
|
|
1744
|
return @dims; |
839
|
|
|
|
|
|
|
} |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
sub PDLA::shape { # Return dimensions as a pdl |
842
|
16
|
|
|
16
|
0
|
410
|
my $pdl = PDLA->topdl (shift); |
843
|
16
|
|
|
|
|
38
|
my @dims = (); |
844
|
16
|
|
|
|
|
76
|
for(0..$pdl->getndims()-1) {push @dims,($pdl->getdim($_))} |
|
44
|
|
|
|
|
110
|
|
845
|
16
|
|
|
|
|
45
|
return indx(\@dims); |
846
|
|
|
|
|
|
|
} |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
sub PDLA::howbig { |
849
|
97
|
|
|
97
|
0
|
200
|
my $t = shift; |
850
|
97
|
50
|
|
|
|
221
|
if("PDLA::Type" eq ref $t) {$t = $t->[0]} |
|
0
|
|
|
|
|
0
|
|
851
|
97
|
|
|
|
|
375
|
PDLA::howbig_c($t); |
852
|
|
|
|
|
|
|
} |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
=head2 threadids |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
=for ref |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
Returns the piddle thread IDs as a perl list |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
Note that C is not exported by default (see example |
861
|
|
|
|
|
|
|
below for usage). |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
=for usage |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
use PDLA::Core ':Internal'; # use the internal routines of |
866
|
|
|
|
|
|
|
# the Core module |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
@ids = threadids $piddle; |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
=cut |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
sub PDLA::threadids { # Return dimensions as @list |
873
|
18
|
|
|
18
|
0
|
75
|
my $pdl = PDLA->topdl (shift); |
874
|
18
|
|
|
|
|
44
|
my @dims = (); |
875
|
18
|
|
|
|
|
71
|
for(0..$pdl->getnthreadids()) {push @dims,($pdl->getthreadid($_))} |
|
18
|
|
|
|
|
58
|
|
876
|
18
|
|
|
|
|
49
|
return @dims; |
877
|
|
|
|
|
|
|
} |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
################# Creation/copying functions ####################### |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
|
882
|
759
|
|
|
759
|
0
|
3643
|
sub PDLA::pdl { my $x = shift; return $x->new(@_) } |
|
759
|
|
|
|
|
1958
|
|
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
=head2 doflow |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
=for ref |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
Turn on/off dataflow |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
=for usage |
891
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
$x->doflow; doflow($x); |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
=cut |
895
|
|
|
|
|
|
|
|
896
|
|
|
|
|
|
|
sub PDLA::doflow { |
897
|
3
|
|
|
3
|
0
|
20
|
my $this = shift; |
898
|
3
|
|
|
|
|
18
|
$this->set_dataflow_f(1); |
899
|
3
|
|
|
|
|
13
|
$this->set_dataflow_b(1); |
900
|
|
|
|
|
|
|
} |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
=head2 flows |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
=for ref |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
Whether or not a piddle is indulging in dataflow |
907
|
|
|
|
|
|
|
|
908
|
|
|
|
|
|
|
=for usage |
909
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
something if $x->flows; $hmm = flows($x); |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
=cut |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
sub PDLA::flows { |
915
|
9
|
|
|
9
|
0
|
17
|
my $this = shift; |
916
|
9
|
|
33
|
|
|
70
|
return ($this->fflows || $this->bflows); |
917
|
|
|
|
|
|
|
} |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
=head2 new |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
=for ref |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
new piddle constructor method |
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
=for usage |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
$x = PDLA->new(SCALAR|ARRAY|ARRAY REF|STRING); |
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
=for example |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
$x = PDLA->new(42); # new from a Perl scalar |
932
|
|
|
|
|
|
|
$x = new PDLA 42; # ditto |
933
|
|
|
|
|
|
|
$y = PDLA->new(@list_of_vals); # new from Perl list |
934
|
|
|
|
|
|
|
$y = new PDLA @list_of_vals; # ditto |
935
|
|
|
|
|
|
|
$z = PDLA->new(\@list_of_vals); # new from Perl list reference |
936
|
|
|
|
|
|
|
$w = PDLA->new("[1 2 3]"); # new from Perl string, using |
937
|
|
|
|
|
|
|
# Matlab constructor syntax |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
Constructs piddle from perl numbers and lists |
940
|
|
|
|
|
|
|
and strings with Matlab/Octave style constructor |
941
|
|
|
|
|
|
|
syntax. |
942
|
|
|
|
|
|
|
|
943
|
|
|
|
|
|
|
The string input is fairly versatile though not |
944
|
|
|
|
|
|
|
performance optimized. The goal is to make it |
945
|
|
|
|
|
|
|
easy to copy and paste code from PDLA output and |
946
|
|
|
|
|
|
|
to offer a familiar Matlab syntax for piddle |
947
|
|
|
|
|
|
|
construction. As of May, 2010, it is a new |
948
|
|
|
|
|
|
|
feature, so feel free to report bugs or suggest |
949
|
|
|
|
|
|
|
new features. See documentation for L for |
950
|
|
|
|
|
|
|
more examples of usage. |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
|
953
|
|
|
|
|
|
|
=cut |
954
|
|
|
|
|
|
|
|
955
|
77
|
|
|
77
|
|
72579
|
use Scalar::Util; # for looks_like_number test |
|
77
|
|
|
|
|
166
|
|
|
77
|
|
|
|
|
4147
|
|
956
|
77
|
|
|
77
|
|
483
|
use Carp 'carp'; # for carping (warnings in caller's context) |
|
77
|
|
|
|
|
143
|
|
|
77
|
|
|
|
|
13379
|
|
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
# This is the code that handles string arguments. It has now gotten quite large, |
959
|
|
|
|
|
|
|
# so here's the basic explanation. I want to allow expressions like 2, 1e3, +4, |
960
|
|
|
|
|
|
|
# bad, nan, inf, and more. Checking this can get tricky. This croaks when it |
961
|
|
|
|
|
|
|
# finds: |
962
|
|
|
|
|
|
|
# 1) strings of e or E that are longer than 1 character long (like eeee) |
963
|
|
|
|
|
|
|
# 2) non-supported characters or strings |
964
|
|
|
|
|
|
|
# 3) expressions that are syntactically erroneous, like '1 2 3 ]', which has an |
965
|
|
|
|
|
|
|
# extra bracket |
966
|
|
|
|
|
|
|
# 4) use of inf when the data type does not support inf (i.e. the integers) |
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
sub PDLA::Core::new_pdl_from_string { |
969
|
95
|
|
|
95
|
0
|
242
|
my ($new, $original_value, $this, $type) = @_; |
970
|
95
|
|
|
|
|
166
|
my $value = $original_value; |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
# Check for input that would generate empty piddles as output: |
973
|
95
|
|
|
|
|
260
|
my @types = PDLA::Types::types; |
974
|
95
|
100
|
100
|
|
|
569
|
return zeroes($types[$type], 1)->where(zeroes(1) < 0) |
975
|
|
|
|
|
|
|
if ($value eq '' or $value eq '[]'); |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
# I check for invalid characters later, but arbitrary strings of e will |
978
|
|
|
|
|
|
|
# pass that check, so I'll check for that here, first. |
979
|
|
|
|
|
|
|
# croak("PDLA::Core::new_pdl_from_string: I found consecutive copies of e but\n" |
980
|
|
|
|
|
|
|
# . " I'm not sure what you mean. You gave me $original_value") |
981
|
|
|
|
|
|
|
# if ($value =~ /ee/i); |
982
|
93
|
100
|
100
|
|
|
1760
|
croak("PDLA::Core::new_pdl_from_string: found 'e' as part of a larger word in $original_value") |
983
|
77
|
|
|
77
|
|
47410
|
if $value =~ /e\p{IsAlpha}/ or $value =~ /\p{IsAlpha}e/; |
|
77
|
|
|
|
|
1155
|
|
|
77
|
|
|
|
|
1383
|
|
984
|
|
|
|
|
|
|
|
985
|
|
|
|
|
|
|
# Only a few characters are allowed in the expression, but we want to allow |
986
|
|
|
|
|
|
|
# expressions like 'inf' and 'bad'. As such, convert those values to internal |
987
|
|
|
|
|
|
|
# representations that will pass the invalid-character check. We'll replace |
988
|
|
|
|
|
|
|
# them with Perl-evalute-able strings in a little bit. Here, I represent |
989
|
|
|
|
|
|
|
# bad => EE |
990
|
|
|
|
|
|
|
# nan => ee |
991
|
|
|
|
|
|
|
# inf => Ee |
992
|
|
|
|
|
|
|
# pi => eE |
993
|
|
|
|
|
|
|
# --( Bad )-- |
994
|
83
|
100
|
100
|
|
|
878
|
croak("PDLA::Core::new_pdl_from_string: found 'bad' as part of a larger word in $original_value") |
995
|
|
|
|
|
|
|
if $value =~ /bad\B/ or $value =~ /\Bbad/; |
996
|
79
|
|
|
|
|
337
|
my ($has_bad) = ($value =~ s/\bbad\b/EE/gi); |
997
|
|
|
|
|
|
|
# --( nan )-- |
998
|
79
|
|
|
|
|
147
|
my ($has_nan) = 0; |
999
|
79
|
50
|
33
|
|
|
333
|
croak("PDLA::Core::new_pdl_from_string: found 'nan' as part of a larger word in $original_value") |
1000
|
|
|
|
|
|
|
if $value =~ /\Bnan/ or $value =~ /nan\B/; |
1001
|
79
|
100
|
|
|
|
261
|
$has_nan++ if ($value =~ s/\bnan\b/ee/gi); |
1002
|
|
|
|
|
|
|
# Strawberry Perl compatibility: |
1003
|
79
|
50
|
|
|
|
187
|
croak("PDLA::Core::new_pdl_from_string: found '1.#IND' as part of a larger word in $original_value") |
1004
|
|
|
|
|
|
|
if $value =~ /IND\B/i; |
1005
|
79
|
50
|
|
|
|
176
|
$has_nan++ if ($value =~ s/1\.\#IND/ee/gi); |
1006
|
|
|
|
|
|
|
# --( inf )-- |
1007
|
79
|
|
|
|
|
125
|
my ($has_inf) = 0; |
1008
|
|
|
|
|
|
|
# Strawberry Perl compatibility: |
1009
|
79
|
100
|
|
|
|
487
|
croak("PDLA::Core::new_pdl_from_string: found '1.#INF' as part of a larger word in $original_value") |
1010
|
|
|
|
|
|
|
if $value =~ /INF\B/i; |
1011
|
77
|
100
|
|
|
|
183
|
$has_inf++ if ($value =~ s/1\.\#INF/Ee/gi); |
1012
|
|
|
|
|
|
|
# Other platforms: |
1013
|
77
|
100
|
66
|
|
|
630
|
croak("PDLA::Core::new_pdl_from_string: found 'inf' as part of a larger word in $original_value") |
1014
|
|
|
|
|
|
|
if $value =~ /inf\B/ or $value =~ /\Binf/; |
1015
|
75
|
100
|
|
|
|
243
|
$has_inf++ if ($value =~ s/\binf\b/Ee/gi); |
1016
|
|
|
|
|
|
|
# --( pi )-- |
1017
|
75
|
100
|
100
|
|
|
864
|
croak("PDLA::Core::new_pdl_from_string: found 'pi' as part of a larger word in $original_value") |
1018
|
|
|
|
|
|
|
if $value =~ /pi\B/ or $value =~ /\Bpi/; |
1019
|
71
|
|
|
|
|
192
|
$value =~ s/\bpi\b/eE/gi; |
1020
|
|
|
|
|
|
|
|
1021
|
|
|
|
|
|
|
# Some data types do not support nan and inf, so check for and warn or croak, |
1022
|
|
|
|
|
|
|
# as appropriate: |
1023
|
71
|
50
|
66
|
|
|
200
|
if ($has_nan and not $types[$type]->usenan) { |
1024
|
0
|
|
|
|
|
0
|
carp("PDLA::Core::new_pdl_from_string: no nan for type $types[$type]; converting to bad value"); |
1025
|
0
|
|
|
|
|
0
|
$value =~ s/ee/EE/g; |
1026
|
0
|
|
|
|
|
0
|
$has_bad += $has_nan; |
1027
|
0
|
|
|
|
|
0
|
$has_nan = 0; |
1028
|
|
|
|
|
|
|
} |
1029
|
71
|
50
|
66
|
|
|
175
|
croak("PDLA::Core::new_pdl_from_string: type $types[$type] does not support inf") |
1030
|
|
|
|
|
|
|
if ($has_inf and not $types[$type]->usenan); |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
# Make the white-space uniform and see if any not-allowed characters are |
1033
|
|
|
|
|
|
|
# present: |
1034
|
71
|
|
|
|
|
340
|
$value =~ s/\s+/ /g; |
1035
|
71
|
100
|
|
|
|
251
|
if (my ($disallowed) = ($value =~ /([^\[\]\+\-0-9;,.eE ]+)/)) { |
1036
|
4
|
|
|
|
|
637
|
croak("PDLA::Core::new_pdl_from_string: found disallowed character(s) '$disallowed' in $original_value"); |
1037
|
|
|
|
|
|
|
} |
1038
|
|
|
|
|
|
|
|
1039
|
|
|
|
|
|
|
# Wrap the string in brackets [], so that the following works: |
1040
|
|
|
|
|
|
|
# $x = new PDLA q[1 2 3]; |
1041
|
|
|
|
|
|
|
# We'll have to check for dimensions of size one after we've parsed |
1042
|
|
|
|
|
|
|
# the string and built a PDLA from the resulting array. |
1043
|
67
|
|
|
|
|
157
|
$value = '[' . $value . ']'; |
1044
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
# Make sure that each closing bracket followed by an opening bracket |
1046
|
|
|
|
|
|
|
# has a comma in between them: |
1047
|
67
|
|
|
|
|
153
|
$value =~ s/\]\s*\[/],[/g; |
1048
|
|
|
|
|
|
|
|
1049
|
|
|
|
|
|
|
# Semicolons indicate 'start a new row' and require special handling: |
1050
|
67
|
100
|
|
|
|
161
|
if ($value =~ /;/) { |
1051
|
6
|
|
|
|
|
59
|
$value =~ s/(\[[^\]]+;[^\]]+\])/[$1]/g; |
1052
|
6
|
|
|
|
|
27
|
$value =~ s/;/],[/g; |
1053
|
|
|
|
|
|
|
} |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
# Remove ending decimal points and insert zeroes in front of starting |
1056
|
|
|
|
|
|
|
# decimal points. This makes the white-space-to-comma replacement |
1057
|
|
|
|
|
|
|
# in the next few lines much simpler. |
1058
|
67
|
|
|
|
|
124
|
$value =~ s/(\d\.)(z|[^\d])/${1}0$2/g; |
1059
|
67
|
|
|
|
|
140
|
$value =~ s/(\A|[^\d])\./${1}0./g; |
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
# Remove whitspace between signs and the numbers that follow them: |
1062
|
67
|
|
|
|
|
155
|
$value =~ s/([+\-])\s+/$1/g; |
1063
|
|
|
|
|
|
|
|
1064
|
|
|
|
|
|
|
# # make unambiguous addition/subtraction (white-space on both sides |
1065
|
|
|
|
|
|
|
# # of operator) by removing white-space from both sides |
1066
|
|
|
|
|
|
|
# $value =~ s/([\dEe])\s+([+\-])\s+(?=[Ee\d])/$1$2/g; |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
# Replace white-space separators with commas: |
1069
|
67
|
|
|
|
|
517
|
$value =~ s/([.\deE])\s+(?=[+\-eE\d])/$1,/g; |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
# Remove all other white space: |
1072
|
67
|
|
|
|
|
195
|
$value =~ s/\s+//g; |
1073
|
|
|
|
|
|
|
|
1074
|
|
|
|
|
|
|
# Croak on operations with bad values. It might be nice to simply replace |
1075
|
|
|
|
|
|
|
# these with bad values, but that is more difficult that I like, so I'm just |
1076
|
|
|
|
|
|
|
# going to disallow that here: |
1077
|
67
|
50
|
33
|
|
|
355
|
croak("PDLA::Core::new_pdl_from_string: Operations with bad values are not supported") |
1078
|
|
|
|
|
|
|
if($value =~ /EE[+\-]/ or $value =~ /[+\-]EE/); |
1079
|
|
|
|
|
|
|
|
1080
|
|
|
|
|
|
|
# Check for things that will evaluate as functions and croak if found |
1081
|
67
|
100
|
|
|
|
496
|
if (my ($disallowed) = ($value =~ /((\D+|\A)[eE]\d+)/)) { |
1082
|
2
|
|
|
|
|
270
|
croak("PDLA::Core::new_pdl_from_string: syntax error, looks like an improper exponentiation: $disallowed\n" |
1083
|
|
|
|
|
|
|
. "You originally gave me $original_value\n"); |
1084
|
|
|
|
|
|
|
} |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
# Replace the place-holder strings with strings that will evaluate to their |
1087
|
|
|
|
|
|
|
# correct numerical values when we run the eval: |
1088
|
65
|
|
|
|
|
158
|
$value =~ s/\bEE\b/bad/g; |
1089
|
65
|
|
|
|
|
236
|
my $bad = $types[$type]->badvalue; |
1090
|
65
|
|
|
|
|
191
|
$value =~ s/\bee\b/nan/g; |
1091
|
65
|
|
|
|
|
167
|
my $inf = -pdl(0)->log; |
1092
|
65
|
|
|
|
|
666
|
$value =~ s/\bEe\b/inf/g; |
1093
|
65
|
|
|
|
|
1221
|
my $nnan = $inf - $inf; |
1094
|
65
|
|
|
|
|
304
|
my $nan= $this->initialize(); |
1095
|
65
|
|
|
|
|
315
|
$nan->set_datatype($nnan->get_datatype); |
1096
|
65
|
|
|
|
|
278
|
$nan->setdims([]); |
1097
|
|
|
|
|
|
|
|
1098
|
|
|
|
|
|
|
# pack("d*", "nan") will work here only on perls that numify the string "nan" to a NaN. |
1099
|
|
|
|
|
|
|
# pack( "d*", (-1.0) ** 0.5 ) will hopefully work in more places, though it seems both |
1100
|
|
|
|
|
|
|
# pack("d*", "nan") and pack( "d*", (-1.0) ** 0.5 ) fail on *old* MS Compilers (MSVC++ 6.0 and earlier). |
1101
|
|
|
|
|
|
|
# sisyphus 4 Jan 2013. |
1102
|
65
|
|
|
|
|
140
|
${$nan->get_dataref} = pack( "d*", (-1.0) ** 0.5 ); |
|
65
|
|
|
|
|
186
|
|
1103
|
|
|
|
|
|
|
|
1104
|
65
|
|
|
|
|
213
|
$nan->upd_data(); |
1105
|
65
|
|
|
|
|
138
|
$value =~ s/\beE\b/pi/g; |
1106
|
|
|
|
|
|
|
|
1107
|
65
|
|
|
|
|
100
|
my $val = eval { |
1108
|
|
|
|
|
|
|
# Install the warnings handler: |
1109
|
65
|
|
|
|
|
146
|
my $old_warn_handler = $SIG{__WARN__}; |
1110
|
|
|
|
|
|
|
local $SIG{__WARN__} = sub { |
1111
|
4
|
50
|
|
4
|
|
28
|
if ($_[0] =~ /(Argument ".*" isn't numeric)/) { |
|
|
0
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
# Send the error through die. This is *always* get caught, so keep |
1113
|
|
|
|
|
|
|
# it simple. |
1114
|
4
|
|
|
|
|
64
|
die "Incorrectly formatted input: $1\n"; |
1115
|
|
|
|
|
|
|
} |
1116
|
|
|
|
|
|
|
elsif ($old_warn_handler) { |
1117
|
0
|
|
|
|
|
0
|
$old_warn_handler->(@_); |
1118
|
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
|
else { |
1120
|
0
|
|
|
|
|
0
|
warn @_; |
1121
|
|
|
|
|
|
|
} |
1122
|
65
|
|
|
|
|
534
|
}; |
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
# Let's see if we can parse it as an array-of-arrays: |
1125
|
65
|
|
|
|
|
151
|
local $_ = $value; |
1126
|
65
|
|
|
|
|
214
|
return PDLA::Core::parse_basic_string ($inf, $nan, $nnan, $bad); |
1127
|
|
|
|
|
|
|
}; |
1128
|
|
|
|
|
|
|
|
1129
|
|
|
|
|
|
|
# Respect BADVAL_USENAN |
1130
|
65
|
|
|
|
|
2818
|
require PDLA::Config; |
1131
|
65
|
50
|
|
|
|
207
|
$has_bad += $has_inf + $has_nan if $PDLA::Config{BADVAL_USENAN}; |
1132
|
|
|
|
|
|
|
|
1133
|
65
|
100
|
|
|
|
179
|
if (ref $val eq 'ARRAY') { |
1134
|
59
|
|
|
|
|
572
|
my $to_return = PDLA::Core::pdl_avref($val,$this,$type); |
1135
|
59
|
100
|
|
|
|
297
|
if( $to_return->dim(-1) == 1 ) { |
1136
|
31
|
100
|
|
|
|
80
|
if( $to_return->dims > 1 ) { |
|
|
50
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
# remove potentially spurious last dimension |
1138
|
19
|
|
|
|
|
193
|
$to_return = $to_return->mv(-1,1)->clump(2)->sever; |
1139
|
|
|
|
|
|
|
} elsif( $to_return->dims == 1 ) { |
1140
|
|
|
|
|
|
|
# fix scalar values |
1141
|
12
|
|
|
|
|
56
|
$to_return->setdims([]); |
1142
|
|
|
|
|
|
|
} |
1143
|
|
|
|
|
|
|
} |
1144
|
|
|
|
|
|
|
# Mark bad if appropriate |
1145
|
59
|
|
|
|
|
312
|
$to_return->badflag($has_bad > 0); |
1146
|
59
|
|
|
|
|
995
|
return $to_return; |
1147
|
|
|
|
|
|
|
} |
1148
|
|
|
|
|
|
|
else { |
1149
|
6
|
|
|
|
|
23
|
my @message = ("PDLA::Core::new_pdl_from_string: string input='$original_value', string output='$value'" ); |
1150
|
6
|
50
|
|
|
|
12
|
if ($@) { |
1151
|
6
|
|
|
|
|
14
|
push @message, $@; |
1152
|
|
|
|
|
|
|
} else { |
1153
|
0
|
|
|
|
|
0
|
push @message, "Internal error: unexpected output type ->$val<- is not ARRAY ref"; |
1154
|
|
|
|
|
|
|
} |
1155
|
6
|
|
|
|
|
830
|
croak join("\n ", @message); |
1156
|
|
|
|
|
|
|
} |
1157
|
|
|
|
|
|
|
} |
1158
|
|
|
|
|
|
|
|
1159
|
|
|
|
|
|
|
sub PDLA::Core::parse_basic_string { |
1160
|
|
|
|
|
|
|
# Assumes $_ holds the string of interest, and modifies that value |
1161
|
|
|
|
|
|
|
# in-place. |
1162
|
|
|
|
|
|
|
|
1163
|
77
|
|
|
77
|
|
1757941
|
use warnings; |
|
77
|
|
|
|
|
187
|
|
|
77
|
|
|
|
|
184449
|
|
1164
|
|
|
|
|
|
|
|
1165
|
|
|
|
|
|
|
# Takes a string with proper bracketing, etc, and returns an array-of-arrays |
1166
|
|
|
|
|
|
|
# filled with numbers, suitable for use with pdl_avref. It uses recursive |
1167
|
|
|
|
|
|
|
# descent to handle the nested nature of the data. The string should have |
1168
|
|
|
|
|
|
|
# no whitespace and should be something that would evaluate into a Perl |
1169
|
|
|
|
|
|
|
# array-of-arrays (except that strings like 'inf', etc, are allowed). |
1170
|
|
|
|
|
|
|
|
1171
|
124
|
|
|
124
|
0
|
260
|
my ($inf, $nan, $nnan, $bad) = @_; |
1172
|
|
|
|
|
|
|
|
1173
|
|
|
|
|
|
|
# First character should be a bracket: |
1174
|
124
|
50
|
|
|
|
512
|
die "Internal error: input string -->$_<-- did not start with an opening bracket\n" |
1175
|
|
|
|
|
|
|
unless s/^\[//; |
1176
|
|
|
|
|
|
|
|
1177
|
124
|
|
|
|
|
201
|
my @to_return; |
1178
|
|
|
|
|
|
|
# Loop until we run into our closing bracket: |
1179
|
124
|
|
|
|
|
188
|
my $sign = 1; |
1180
|
124
|
|
|
|
|
171
|
my $expects_number = 0; |
1181
|
124
|
|
|
|
|
264
|
SYMBOL: until (s/^\]//) { |
1182
|
|
|
|
|
|
|
# If we have a bracket, then go recursive: |
1183
|
390
|
100
|
66
|
|
|
2946
|
if (/^\[/) { |
|
|
100
|
66
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1184
|
59
|
50
|
|
|
|
106
|
die "Expected a number but found a bracket at ... ", substr ($_, 0, 10), "...\n" |
1185
|
|
|
|
|
|
|
if $expects_number; |
1186
|
59
|
|
|
|
|
130
|
push @to_return, PDLA::Core::parse_basic_string(@_); |
1187
|
59
|
|
|
|
|
104
|
next SYMBOL; |
1188
|
|
|
|
|
|
|
} |
1189
|
|
|
|
|
|
|
elsif (s/^\+//) { |
1190
|
8
|
100
|
|
|
|
31
|
die "Expected number but found a plus sign at ... ", substr ($_, 0, 10), "...\n" |
1191
|
|
|
|
|
|
|
if $expects_number; |
1192
|
7
|
|
|
|
|
9
|
$expects_number = 1; |
1193
|
7
|
|
|
|
|
13
|
redo SYMBOL; |
1194
|
|
|
|
|
|
|
} |
1195
|
|
|
|
|
|
|
elsif (s/^\-//) { |
1196
|
32
|
100
|
|
|
|
76
|
die "Expected number but found a minus sign at ... ", substr ($_, 0, 10), "...\n" |
1197
|
|
|
|
|
|
|
if $expects_number; |
1198
|
31
|
|
|
|
|
41
|
$sign = -1; |
1199
|
31
|
|
|
|
|
38
|
$expects_number = 1; |
1200
|
31
|
|
|
|
|
57
|
redo SYMBOL; |
1201
|
|
|
|
|
|
|
} |
1202
|
|
|
|
|
|
|
elsif (s/^bad//i) { |
1203
|
16
|
|
|
|
|
43
|
push @to_return, $bad; |
1204
|
|
|
|
|
|
|
} |
1205
|
|
|
|
|
|
|
elsif (s/^inf//i or s/1\.\#INF//i) { |
1206
|
5
|
|
|
|
|
119
|
push @to_return, $sign * $inf; |
1207
|
|
|
|
|
|
|
} |
1208
|
|
|
|
|
|
|
elsif (s/^nan//i or s/^1\.\#IND//i) { |
1209
|
3
|
100
|
|
|
|
7
|
if ($sign == -1) { |
1210
|
1
|
|
|
|
|
2
|
push @to_return, $nnan; |
1211
|
|
|
|
|
|
|
} else { |
1212
|
2
|
|
|
|
|
4
|
push @to_return, $nan; |
1213
|
|
|
|
|
|
|
} |
1214
|
|
|
|
|
|
|
} |
1215
|
|
|
|
|
|
|
elsif (s/^pi//i) { |
1216
|
2
|
|
|
|
|
8
|
push @to_return, $sign * 4 * atan2(1, 1); |
1217
|
|
|
|
|
|
|
} |
1218
|
|
|
|
|
|
|
elsif (s/^e//i) { |
1219
|
11
|
|
|
|
|
31
|
push @to_return, $sign * exp(1); |
1220
|
|
|
|
|
|
|
} |
1221
|
|
|
|
|
|
|
elsif (s/^([\d+\-e.]+)//i) { |
1222
|
|
|
|
|
|
|
# Note that improper numbers are handled by the warning signal |
1223
|
|
|
|
|
|
|
# handler |
1224
|
254
|
|
|
|
|
491
|
my $val = $1; |
1225
|
254
|
|
|
|
|
449
|
my $nval = $val + 0x0; |
1226
|
250
|
100
|
|
|
|
555
|
push @to_return, ($sign>0x0) ? $nval : -$nval; |
1227
|
|
|
|
|
|
|
} |
1228
|
|
|
|
|
|
|
else { |
1229
|
0
|
|
|
|
|
0
|
die "Incorrectly formatted input at:\n ", substr ($_, 0, 10), "...\n"; |
1230
|
|
|
|
|
|
|
} |
1231
|
|
|
|
|
|
|
} |
1232
|
|
|
|
|
|
|
# Strip off any commas |
1233
|
|
|
|
|
|
|
continue { |
1234
|
346
|
|
|
|
|
448
|
$sign = 1; |
1235
|
346
|
|
|
|
|
399
|
$expects_number = 0; |
1236
|
346
|
|
|
|
|
1150
|
s/^,//; |
1237
|
|
|
|
|
|
|
} |
1238
|
|
|
|
|
|
|
|
1239
|
118
|
|
|
|
|
624
|
return \@to_return; |
1240
|
|
|
|
|
|
|
} |
1241
|
|
|
|
|
|
|
|
1242
|
|
|
|
|
|
|
sub PDLA::new { |
1243
|
|
|
|
|
|
|
# print "in PDLA::new\n"; |
1244
|
876
|
|
|
876
|
0
|
2755
|
my $this = shift; |
1245
|
876
|
50
|
|
|
|
2063
|
return $this->copy if ref($this); |
1246
|
876
|
100
|
|
|
|
2401
|
my $type = ref($_[0]) eq 'PDLA::Type' ? ${shift @_}[0] : $PDLA_D; |
|
103
|
|
|
|
|
564
|
|
1247
|
876
|
100
|
|
|
|
2248
|
my $value = (@_ >1 ? [@_] : shift); # ref thyself |
1248
|
|
|
|
|
|
|
|
1249
|
876
|
100
|
|
|
|
2163
|
unless(defined $value) { |
1250
|
19
|
0
|
33
|
|
|
46
|
if($PDLA::debug && $PDLA::undefval) { |
1251
|
0
|
|
|
|
|
0
|
print STDERR "Warning: PDLA::new converted undef to $PDLA::undefval ($PDLA::undefval)\n"; |
1252
|
|
|
|
|
|
|
} |
1253
|
19
|
|
|
|
|
29
|
$value = $PDLA::undefval+0 |
1254
|
|
|
|
|
|
|
} |
1255
|
|
|
|
|
|
|
|
1256
|
876
|
100
|
|
|
|
12623
|
return pdl_avref($value,$this,$type) if ref($value) eq "ARRAY"; |
1257
|
348
|
|
|
|
|
2452
|
my $new = $this->initialize(); |
1258
|
348
|
|
|
|
|
1888
|
$new->set_datatype($type); |
1259
|
|
|
|
|
|
|
|
1260
|
|
|
|
|
|
|
|
1261
|
348
|
100
|
|
|
|
1106
|
if (ref(\$value) eq "SCALAR") { |
|
|
50
|
|
|
|
|
|
1262
|
|
|
|
|
|
|
# The string processing is extremely slow. Benchmarks indicated that it |
1263
|
|
|
|
|
|
|
# takes 10x longer to process a scalar number compared with normal Perl |
1264
|
|
|
|
|
|
|
# conversion of a string to a number. So, only use the string processing |
1265
|
|
|
|
|
|
|
# if the input looks like a real string, i.e. it doesn't look like a plain |
1266
|
|
|
|
|
|
|
# number. Note that for our purposes, looks_like_number incorrectly |
1267
|
|
|
|
|
|
|
# handles the strings 'inf' and 'nan' on Windows machines. We want to send |
1268
|
|
|
|
|
|
|
# those to the string processing, so this checks for them in a way that |
1269
|
|
|
|
|
|
|
# short-circuits the looks_like_number check. |
1270
|
341
|
100
|
100
|
|
|
6759
|
if (PDLA::Core::is_scalar_SvPOK($value) |
|
|
50
|
100
|
|
|
|
|
|
|
|
33
|
|
|
|
|
1271
|
|
|
|
|
|
|
and ($value =~ /inf/i or $value =~ /nan/i |
1272
|
|
|
|
|
|
|
or !Scalar::Util::looks_like_number($value))) { |
1273
|
|
|
|
|
|
|
# new was passed a string argument that doesn't look like a number |
1274
|
|
|
|
|
|
|
# so we can process as a Matlab-style data entry format. |
1275
|
95
|
|
|
|
|
268
|
return PDLA::Core::new_pdl_from_string($new,$value,$this,$type); |
1276
|
|
|
|
|
|
|
} elsif ($Config{ivsize} < 8 && $pack[$new->get_datatype] eq 'q*') { |
1277
|
|
|
|
|
|
|
# special case when running on a perl without 64bit int support |
1278
|
|
|
|
|
|
|
# we have to avoid pack("q", ...) in this case |
1279
|
|
|
|
|
|
|
# because it dies with error: "Invalid type 'q' in pack" |
1280
|
0
|
|
|
|
|
0
|
$new->setdims([]); |
1281
|
0
|
|
|
|
|
0
|
set_c($new, [0], $value); |
1282
|
|
|
|
|
|
|
} else { |
1283
|
246
|
|
|
|
|
1419
|
$new->setdims([]); |
1284
|
246
|
|
|
|
|
1441
|
${$new->get_dataref} = pack( $pack[$new->get_datatype], $value ); |
|
246
|
|
|
|
|
841
|
|
1285
|
246
|
|
|
|
|
756
|
$new->upd_data(); |
1286
|
|
|
|
|
|
|
} |
1287
|
|
|
|
|
|
|
} |
1288
|
|
|
|
|
|
|
elsif (blessed($value)) { # Object |
1289
|
7
|
|
|
|
|
29
|
$new = $value->copy; |
1290
|
|
|
|
|
|
|
} |
1291
|
|
|
|
|
|
|
else { |
1292
|
0
|
|
|
|
|
0
|
barf("Can not interpret argument $value of type ".ref($value) ); |
1293
|
|
|
|
|
|
|
} |
1294
|
253
|
|
|
|
|
4370
|
return $new; |
1295
|
|
|
|
|
|
|
} |
1296
|
|
|
|
|
|
|
|
1297
|
|
|
|
|
|
|
|
1298
|
|
|
|
|
|
|
=head2 copy |
1299
|
|
|
|
|
|
|
|
1300
|
|
|
|
|
|
|
=for ref |
1301
|
|
|
|
|
|
|
|
1302
|
|
|
|
|
|
|
Make a physical copy of a piddle |
1303
|
|
|
|
|
|
|
|
1304
|
|
|
|
|
|
|
=for usage |
1305
|
|
|
|
|
|
|
|
1306
|
|
|
|
|
|
|
$new = $old->copy; |
1307
|
|
|
|
|
|
|
|
1308
|
|
|
|
|
|
|
Since C<$new = $old> just makes a new reference, the |
1309
|
|
|
|
|
|
|
C method is provided to allow real independent |
1310
|
|
|
|
|
|
|
copies to be made. |
1311
|
|
|
|
|
|
|
|
1312
|
|
|
|
|
|
|
=cut |
1313
|
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
|
# Inheritable copy method |
1315
|
|
|
|
|
|
|
# |
1316
|
|
|
|
|
|
|
# XXX Must be fixed |
1317
|
|
|
|
|
|
|
# Inplace is handled by the op currently. |
1318
|
|
|
|
|
|
|
|
1319
|
|
|
|
|
|
|
sub PDLA::copy { |
1320
|
264
|
|
|
264
|
0
|
2446
|
my $value = shift; |
1321
|
264
|
50
|
|
|
|
833
|
barf("Argument is an ".ref($value)." not an object") unless blessed($value); |
1322
|
264
|
|
|
|
|
654
|
my $option = shift; |
1323
|
264
|
50
|
|
|
|
879
|
$option = "" if !defined $option; |
1324
|
264
|
50
|
|
|
|
1112
|
if ($value->is_inplace) { # Copy protection |
1325
|
0
|
|
|
|
|
0
|
$value->set_inplace(0); |
1326
|
0
|
|
|
|
|
0
|
return $value; |
1327
|
|
|
|
|
|
|
} |
1328
|
|
|
|
|
|
|
# threadI(-1,[]) is just an identity vafftrans with threadId copying ;) |
1329
|
264
|
|
|
|
|
44536
|
my $new = $value->threadI(-1,[])->sever; |
1330
|
263
|
|
|
|
|
2714
|
return $new; |
1331
|
|
|
|
|
|
|
} |
1332
|
|
|
|
|
|
|
|
1333
|
|
|
|
|
|
|
=head2 hdr_copy |
1334
|
|
|
|
|
|
|
|
1335
|
|
|
|
|
|
|
=for ref |
1336
|
|
|
|
|
|
|
|
1337
|
|
|
|
|
|
|
Return an explicit copy of the header of a PDLA. |
1338
|
|
|
|
|
|
|
|
1339
|
|
|
|
|
|
|
hdr_copy is just a wrapper for the internal routine _hdr_copy, which |
1340
|
|
|
|
|
|
|
takes the hash ref itself. That is the routine which is used to make |
1341
|
|
|
|
|
|
|
copies of the header during normal operations if the hdrcpy() flag of |
1342
|
|
|
|
|
|
|
a PDLA is set. |
1343
|
|
|
|
|
|
|
|
1344
|
|
|
|
|
|
|
General-purpose deep copies are expensive in perl, so some simple |
1345
|
|
|
|
|
|
|
optimization happens: |
1346
|
|
|
|
|
|
|
|
1347
|
|
|
|
|
|
|
If the header is a tied array or a blessed hash ref with an associated |
1348
|
|
|
|
|
|
|
method called C, then that ->copy method is called. Otherwise, all |
1349
|
|
|
|
|
|
|
elements of the hash are explicitly copied. References are recursively |
1350
|
|
|
|
|
|
|
deep copied. |
1351
|
|
|
|
|
|
|
|
1352
|
|
|
|
|
|
|
This routine seems to leak memory. |
1353
|
|
|
|
|
|
|
|
1354
|
|
|
|
|
|
|
=cut |
1355
|
|
|
|
|
|
|
|
1356
|
|
|
|
|
|
|
sub PDLA::hdr_copy { |
1357
|
0
|
|
|
0
|
0
|
0
|
my $pdl = shift; |
1358
|
0
|
|
|
|
|
0
|
my $hdr = $pdl->gethdr; |
1359
|
0
|
|
|
|
|
0
|
return PDLA::_hdr_copy($hdr); |
1360
|
|
|
|
|
|
|
} |
1361
|
|
|
|
|
|
|
|
1362
|
|
|
|
|
|
|
# Same as hdr_copy but takes a hash ref instead of a PDLA. |
1363
|
|
|
|
|
|
|
sub PDLA::_hdr_copy { |
1364
|
8
|
|
|
8
|
|
1555
|
my $hdr = shift; |
1365
|
8
|
|
|
|
|
13
|
my $tobj; |
1366
|
|
|
|
|
|
|
|
1367
|
8
|
50
|
|
|
|
22
|
print "called _hdr_copy\n" if($PDLA::debug); |
1368
|
|
|
|
|
|
|
|
1369
|
8
|
50
|
|
|
|
40
|
unless( (ref $hdr)=~m/HASH/ ) { |
1370
|
0
|
0
|
|
|
|
0
|
print"returning undef\n" if($PDLA::debug); |
1371
|
0
|
|
|
|
|
0
|
return undef ; |
1372
|
|
|
|
|
|
|
} |
1373
|
|
|
|
|
|
|
|
1374
|
8
|
50
|
|
|
|
38
|
if($tobj = tied %$hdr) { # |
|
|
50
|
|
|
|
|
|
1375
|
0
|
0
|
|
|
|
0
|
print "tied..."if($PDLA::debug); |
1376
|
0
|
0
|
|
|
|
0
|
if(UNIVERSAL::can($tobj,"copy")) { |
1377
|
0
|
|
|
|
|
0
|
my %rhdr; |
1378
|
0
|
|
|
|
|
0
|
tie(%rhdr, ref $tobj, $tobj->copy); |
1379
|
0
|
0
|
|
|
|
0
|
print "returning\n" if($PDLA::debug); |
1380
|
0
|
|
|
|
|
0
|
return \%rhdr; |
1381
|
|
|
|
|
|
|
} |
1382
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
# Astro::FITS::Header is special for now -- no copy method yet |
1384
|
|
|
|
|
|
|
# but it is recognized. Once it gets a copy method this will become |
1385
|
|
|
|
|
|
|
# vestigial: |
1386
|
|
|
|
|
|
|
|
1387
|
0
|
0
|
|
|
|
0
|
if(UNIVERSAL::isa($tobj,"Astro::FITS::Header")) { |
1388
|
0
|
0
|
|
|
|
0
|
print "Astro::FITS::Header..." if($PDLA::debug); |
1389
|
0
|
|
|
|
|
0
|
my @cards = $tobj->cards; |
1390
|
0
|
|
|
|
|
0
|
my %rhdr; |
1391
|
0
|
|
|
|
|
0
|
tie(%rhdr,"Astro::FITS::Header", new Astro::FITS::Header(Cards=>\@cards)); |
1392
|
0
|
0
|
|
|
|
0
|
print "returning\n" if($PDLA::debug); |
1393
|
0
|
|
|
|
|
0
|
return \%rhdr; |
1394
|
|
|
|
|
|
|
} |
1395
|
|
|
|
|
|
|
} |
1396
|
|
|
|
|
|
|
elsif(UNIVERSAL::can($hdr,"copy")) { |
1397
|
0
|
0
|
|
|
|
0
|
print "found a copy method\n" if($PDLA::debug); |
1398
|
0
|
|
|
|
|
0
|
return $hdr->copy; |
1399
|
|
|
|
|
|
|
} |
1400
|
|
|
|
|
|
|
|
1401
|
|
|
|
|
|
|
# We got here if it's an unrecognized tie or if it's a vanilla hash. |
1402
|
8
|
50
|
|
|
|
19
|
print "Making a hash copy..." if($PDLA::debug); |
1403
|
|
|
|
|
|
|
|
1404
|
8
|
|
|
|
|
18
|
return PDLA::_deep_hdr_copy($hdr); |
1405
|
|
|
|
|
|
|
|
1406
|
|
|
|
|
|
|
} |
1407
|
|
|
|
|
|
|
|
1408
|
|
|
|
|
|
|
# |
1409
|
|
|
|
|
|
|
# Sleazy deep-copier that gets most cases |
1410
|
|
|
|
|
|
|
# --CED 14-April-2003 |
1411
|
|
|
|
|
|
|
# |
1412
|
|
|
|
|
|
|
|
1413
|
|
|
|
|
|
|
sub PDLA::_deep_hdr_copy { |
1414
|
8
|
|
|
8
|
|
15
|
my $val = shift; |
1415
|
|
|
|
|
|
|
|
1416
|
8
|
50
|
|
|
|
30
|
if(ref $val eq 'HASH') { |
1417
|
8
|
|
|
|
|
16
|
my (%a,$key); |
1418
|
8
|
|
|
|
|
26
|
for $key(keys %$val) { |
1419
|
20
|
|
|
|
|
36
|
my $value = $val->{$key}; |
1420
|
20
|
50
|
|
|
|
82
|
$a{$key} = (ref $value) ? PDLA::_deep_hdr_copy($value) : $value; |
1421
|
|
|
|
|
|
|
} |
1422
|
8
|
|
|
|
|
100
|
return \%a; |
1423
|
|
|
|
|
|
|
} |
1424
|
|
|
|
|
|
|
|
1425
|
0
|
0
|
|
|
|
0
|
if(ref $val eq 'ARRAY') { |
1426
|
0
|
|
|
|
|
0
|
my (@a,$z); |
1427
|
0
|
|
|
|
|
0
|
for $z(@$val) { |
1428
|
0
|
0
|
|
|
|
0
|
push(@a,(ref $z) ? PDLA::_deep_hdr_copy($z) : $z); |
1429
|
|
|
|
|
|
|
} |
1430
|
0
|
|
|
|
|
0
|
return \@a; |
1431
|
|
|
|
|
|
|
} |
1432
|
|
|
|
|
|
|
|
1433
|
0
|
0
|
|
|
|
0
|
if(ref $val eq 'SCALAR') { |
1434
|
0
|
|
|
|
|
0
|
my $x = $$val; |
1435
|
0
|
|
|
|
|
0
|
return \$x; |
1436
|
|
|
|
|
|
|
} |
1437
|
|
|
|
|
|
|
|
1438
|
0
|
0
|
|
|
|
0
|
if(ref $val eq 'REF') { |
1439
|
0
|
|
|
|
|
0
|
my $x = PDLA::_deep_hdr_copy($$val); |
1440
|
0
|
|
|
|
|
0
|
return \$x; |
1441
|
|
|
|
|
|
|
} |
1442
|
|
|
|
|
|
|
|
1443
|
|
|
|
|
|
|
# Special case for PDLAs avoids potential nasty header recursion... |
1444
|
0
|
0
|
|
|
|
0
|
if(UNIVERSAL::isa($val,'PDLA')) { |
1445
|
0
|
|
|
|
|
0
|
my $h; |
1446
|
0
|
0
|
|
|
|
0
|
$val->hdrcpy(0) if($h = $val->hdrcpy); # assignment |
1447
|
0
|
|
|
|
|
0
|
my $out = $val->copy; |
1448
|
0
|
0
|
|
|
|
0
|
$val->hdrcpy($h) if($h); |
1449
|
0
|
|
|
|
|
0
|
return $out; |
1450
|
|
|
|
|
|
|
} |
1451
|
|
|
|
|
|
|
|
1452
|
0
|
0
|
|
|
|
0
|
if(UNIVERSAL::can($val,'copy')) { |
1453
|
0
|
|
|
|
|
0
|
return $val->copy; |
1454
|
|
|
|
|
|
|
} |
1455
|
|
|
|
|
|
|
|
1456
|
0
|
|
|
|
|
0
|
$val; |
1457
|
|
|
|
|
|
|
} |
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
|
1460
|
|
|
|
|
|
|
=head2 unwind |
1461
|
|
|
|
|
|
|
|
1462
|
|
|
|
|
|
|
=for ref |
1463
|
|
|
|
|
|
|
|
1464
|
|
|
|
|
|
|
Return a piddle which is the same as the argument except |
1465
|
|
|
|
|
|
|
that all threadids have been removed. |
1466
|
|
|
|
|
|
|
|
1467
|
|
|
|
|
|
|
=for usage |
1468
|
|
|
|
|
|
|
|
1469
|
|
|
|
|
|
|
$y = $x->unwind; |
1470
|
|
|
|
|
|
|
|
1471
|
|
|
|
|
|
|
=head2 make_physical |
1472
|
|
|
|
|
|
|
|
1473
|
|
|
|
|
|
|
=for ref |
1474
|
|
|
|
|
|
|
|
1475
|
|
|
|
|
|
|
Make sure the data portion of a piddle can be accessed from XS code. |
1476
|
|
|
|
|
|
|
|
1477
|
|
|
|
|
|
|
=for example |
1478
|
|
|
|
|
|
|
|
1479
|
|
|
|
|
|
|
$x->make_physical; |
1480
|
|
|
|
|
|
|
$x->call_my_xs_method; |
1481
|
|
|
|
|
|
|
|
1482
|
|
|
|
|
|
|
Ensures that a piddle gets its own allocated copy of data. This obviously |
1483
|
|
|
|
|
|
|
implies that there are certain piddles which do not have their own data. |
1484
|
|
|
|
|
|
|
These are so called I piddles that make use of the I |
1485
|
|
|
|
|
|
|
optimisation (see L). |
1486
|
|
|
|
|
|
|
They do not have their own copy of |
1487
|
|
|
|
|
|
|
data but instead store only access information to some (or all) of another |
1488
|
|
|
|
|
|
|
piddle's data. |
1489
|
|
|
|
|
|
|
|
1490
|
|
|
|
|
|
|
Note: this function should not be used unless absolutely necessary |
1491
|
|
|
|
|
|
|
since otherwise memory requirements might be severely increased. Instead |
1492
|
|
|
|
|
|
|
of writing your own XS code with the need to call C you |
1493
|
|
|
|
|
|
|
might want to consider using the PDLA preprocessor |
1494
|
|
|
|
|
|
|
(see L) |
1495
|
|
|
|
|
|
|
which can be used to transparently access virtual piddles without the |
1496
|
|
|
|
|
|
|
need to physicalise them (though there are exceptions). |
1497
|
|
|
|
|
|
|
|
1498
|
|
|
|
|
|
|
=cut |
1499
|
|
|
|
|
|
|
|
1500
|
|
|
|
|
|
|
sub PDLA::unwind { |
1501
|
0
|
|
|
0
|
0
|
0
|
my $value = shift; |
1502
|
0
|
|
|
|
|
0
|
my $foo = $value->null(); |
1503
|
0
|
|
|
|
|
0
|
$foo .= $value->unthread(); |
1504
|
0
|
|
|
|
|
0
|
return $foo; |
1505
|
|
|
|
|
|
|
} |
1506
|
|
|
|
|
|
|
|
1507
|
|
|
|
|
|
|
=head2 dummy |
1508
|
|
|
|
|
|
|
|
1509
|
|
|
|
|
|
|
=for ref |
1510
|
|
|
|
|
|
|
|
1511
|
|
|
|
|
|
|
Insert a 'dummy dimension' of given length (defaults to 1) |
1512
|
|
|
|
|
|
|
|
1513
|
|
|
|
|
|
|
No relation to the 'Dungeon Dimensions' in Discworld! |
1514
|
|
|
|
|
|
|
|
1515
|
|
|
|
|
|
|
Negative positions specify relative to last dimension, |
1516
|
|
|
|
|
|
|
i.e. C appends one dimension at end, |
1517
|
|
|
|
|
|
|
C inserts a dummy dimension in front of the |
1518
|
|
|
|
|
|
|
last dim, etc. |
1519
|
|
|
|
|
|
|
|
1520
|
|
|
|
|
|
|
If you specify a dimension position larger than the existing |
1521
|
|
|
|
|
|
|
dimension list of your PDLA, the PDLA gets automagically padded with extra |
1522
|
|
|
|
|
|
|
dummy dimensions so that you get the dim you asked for, in the slot you |
1523
|
|
|
|
|
|
|
asked for. This could cause you trouble if, for example, |
1524
|
|
|
|
|
|
|
you ask for $x->dummy(5000,1) because $x will get 5,000 dimensions, |
1525
|
|
|
|
|
|
|
each of rank 1. |
1526
|
|
|
|
|
|
|
|
1527
|
|
|
|
|
|
|
Because padding at the beginning of the dimension list moves existing |
1528
|
|
|
|
|
|
|
dimensions from slot to slot, it's considered unsafe, so automagic |
1529
|
|
|
|
|
|
|
padding doesn't work for large negative indices -- only for large |
1530
|
|
|
|
|
|
|
positive indices. |
1531
|
|
|
|
|
|
|
|
1532
|
|
|
|
|
|
|
=for usage |
1533
|
|
|
|
|
|
|
|
1534
|
|
|
|
|
|
|
$y = $x->dummy($position[,$dimsize]); |
1535
|
|
|
|
|
|
|
|
1536
|
|
|
|
|
|
|
=for example |
1537
|
|
|
|
|
|
|
|
1538
|
|
|
|
|
|
|
pdla> p sequence(3)->dummy(0,3) |
1539
|
|
|
|
|
|
|
[ |
1540
|
|
|
|
|
|
|
[0 0 0] |
1541
|
|
|
|
|
|
|
[1 1 1] |
1542
|
|
|
|
|
|
|
[2 2 2] |
1543
|
|
|
|
|
|
|
] |
1544
|
|
|
|
|
|
|
|
1545
|
|
|
|
|
|
|
pdla> p sequence(3)->dummy(3,2) |
1546
|
|
|
|
|
|
|
[ |
1547
|
|
|
|
|
|
|
[ |
1548
|
|
|
|
|
|
|
[0 1 2] |
1549
|
|
|
|
|
|
|
] |
1550
|
|
|
|
|
|
|
[ |
1551
|
|
|
|
|
|
|
[0 1 2] |
1552
|
|
|
|
|
|
|
] |
1553
|
|
|
|
|
|
|
] |
1554
|
|
|
|
|
|
|
|
1555
|
|
|
|
|
|
|
pdla> p sequence(3)->dummy(-3,2) |
1556
|
|
|
|
|
|
|
Runtime error: PDLA: For safety, < -(dims+1) forbidden in dummy. min=-2, pos=-3 |
1557
|
|
|
|
|
|
|
|
1558
|
|
|
|
|
|
|
=cut |
1559
|
|
|
|
|
|
|
|
1560
|
|
|
|
|
|
|
sub PDLA::dummy($$;$) { |
1561
|
47
|
|
|
47
|
0
|
215
|
my ($pdl,$dim,$size) = @_; |
1562
|
47
|
50
|
|
|
|
140
|
barf("Missing position argument to dummy()") unless defined $dim; # required argument |
1563
|
47
|
100
|
|
|
|
137
|
$dim = $pdl->getndims+1+$dim if $dim < 0; |
1564
|
47
|
100
|
|
|
|
139
|
$size = defined($size) ? (1 * $size) : 1; # make $size a number (sf feature # 3479009) |
1565
|
|
|
|
|
|
|
|
1566
|
47
|
50
|
|
|
|
106
|
barf("For safety, < -(dims+1) forbidden in dummy. min=" |
1567
|
|
|
|
|
|
|
. -($pdl->getndims+1).", pos=". ($dim-1-$pdl->getndims) ) if($dim<0); |
1568
|
|
|
|
|
|
|
|
1569
|
|
|
|
|
|
|
# Avoid negative repeat count warning that came with 5.21 and later. |
1570
|
47
|
|
|
|
|
180
|
my $dim_diff = $dim - $pdl->getndims; |
1571
|
47
|
100
|
|
|
|
172
|
my($s) = ',' x ( $dim_diff > 0 ? $pdl->getndims : $dim ); |
1572
|
47
|
100
|
|
|
|
154
|
$s .= '*1,' x ( $dim_diff > 0 ? $dim_diff : 0 ); |
1573
|
47
|
|
|
|
|
116
|
$s .= "*$size"; |
1574
|
|
|
|
|
|
|
|
1575
|
47
|
|
|
|
|
172
|
$pdl->slice($s); |
1576
|
|
|
|
|
|
|
} |
1577
|
|
|
|
|
|
|
|
1578
|
|
|
|
|
|
|
|
1579
|
|
|
|
|
|
|
## Cheesy, slow way |
1580
|
|
|
|
|
|
|
# while ($dim>$pdl->getndims){ |
1581
|
|
|
|
|
|
|
# print STDERR "."; flush STDERR; |
1582
|
|
|
|
|
|
|
# $pdl = $pdl->dummy($pdl->getndims,1); |
1583
|
|
|
|
|
|
|
# } |
1584
|
|
|
|
|
|
|
# |
1585
|
|
|
|
|
|
|
# barf ("too high/low dimension in call to dummy, allowed min/max=0/" |
1586
|
|
|
|
|
|
|
# . $_[0]->getndims) |
1587
|
|
|
|
|
|
|
# if $dim>$pdl->getndims || $dim < 0; |
1588
|
|
|
|
|
|
|
# |
1589
|
|
|
|
|
|
|
# $_[2] = 1 if ($#_ < 2); |
1590
|
|
|
|
|
|
|
# $pdl->slice((','x$dim)."*$_[2]"); |
1591
|
|
|
|
|
|
|
|
1592
|
|
|
|
|
|
|
=head2 clump |
1593
|
|
|
|
|
|
|
|
1594
|
|
|
|
|
|
|
=for ref |
1595
|
|
|
|
|
|
|
|
1596
|
|
|
|
|
|
|
"clumps" several dimensions into one large dimension |
1597
|
|
|
|
|
|
|
|
1598
|
|
|
|
|
|
|
If called with one argument C<$n> clumps the first C<$n> |
1599
|
|
|
|
|
|
|
dimensions into one. For example, if C<$x> has dimensions |
1600
|
|
|
|
|
|
|
C<(5,3,4)> then after |
1601
|
|
|
|
|
|
|
|
1602
|
|
|
|
|
|
|
=for example |
1603
|
|
|
|
|
|
|
|
1604
|
|
|
|
|
|
|
$y = $x->clump(2); # Clump 2 first dimensions |
1605
|
|
|
|
|
|
|
|
1606
|
|
|
|
|
|
|
the variable C<$y> will have dimensions C<(15,4)> |
1607
|
|
|
|
|
|
|
and the element C<$y-Eat(7,3)> refers to the element |
1608
|
|
|
|
|
|
|
C<$x-Eat(1,2,3)>. |
1609
|
|
|
|
|
|
|
|
1610
|
|
|
|
|
|
|
Use C to flatten a piddle. The method L |
1611
|
|
|
|
|
|
|
is provided as a convenient alias. |
1612
|
|
|
|
|
|
|
|
1613
|
|
|
|
|
|
|
Clumping with a negative dimension in general leaves that many |
1614
|
|
|
|
|
|
|
dimensions behind -- e.g. clump(-2) clumps all of the first few |
1615
|
|
|
|
|
|
|
dimensions into a single one, leaving a 2-D piddle. |
1616
|
|
|
|
|
|
|
|
1617
|
|
|
|
|
|
|
If C is called with an index list with more than one element |
1618
|
|
|
|
|
|
|
it is treated as a list of dimensions that should be clumped together |
1619
|
|
|
|
|
|
|
into one. The resulting |
1620
|
|
|
|
|
|
|
clumped dim is placed at the position of the lowest index in the list. |
1621
|
|
|
|
|
|
|
This convention ensures that C does the expected thing in |
1622
|
|
|
|
|
|
|
the usual cases. The following example demonstrates typical usage: |
1623
|
|
|
|
|
|
|
|
1624
|
|
|
|
|
|
|
$x = sequence 2,3,3,3,5; # 5D piddle |
1625
|
|
|
|
|
|
|
$c = $x->clump(1..3); # clump all the dims 1 to 3 into one |
1626
|
|
|
|
|
|
|
print $c->info; # resulting 3D piddle has clumped dim at pos 1 |
1627
|
|
|
|
|
|
|
PDLA: Double D [2,27,5] |
1628
|
|
|
|
|
|
|
|
1629
|
|
|
|
|
|
|
=cut |
1630
|
|
|
|
|
|
|
|
1631
|
|
|
|
|
|
|
sub PDLA::clump { |
1632
|
1327
|
|
|
1327
|
0
|
5027
|
my $ndims = $_[0]->getndims; |
1633
|
1327
|
100
|
|
|
|
3608
|
if ($#_ < 2) { |
1634
|
1326
|
|
|
|
|
13141
|
return &PDLA::_clump_int(@_); |
1635
|
|
|
|
|
|
|
} else { |
1636
|
1
|
|
|
|
|
3
|
my ($this,@dims) = @_; |
1637
|
1
|
|
|
|
|
3
|
my $targd = $ndims-1; |
1638
|
1
|
|
|
|
|
4
|
my @dimmark = (0..$ndims-1); |
1639
|
1
|
50
|
|
|
|
4
|
barf "too many dimensions" if @dims > $ndims; |
1640
|
1
|
|
|
|
|
3
|
for my $dim (@dims) { |
1641
|
2
|
50
|
|
|
|
6
|
barf "dimension index $dim larger than greatest dimension" |
1642
|
|
|
|
|
|
|
if $dim > $ndims-1 ; |
1643
|
2
|
100
|
|
|
|
5
|
$targd = $dim if $targd > $dim; |
1644
|
2
|
50
|
|
|
|
6
|
barf "duplicate dimension $dim" if $dimmark[$dim]++ > $dim; |
1645
|
|
|
|
|
|
|
} |
1646
|
1
|
|
|
|
|
5
|
my $clumped = $this->thread(@dims)->unthread(0)->clump(scalar @dims); |
1647
|
1
|
50
|
|
|
|
8
|
$clumped = $clumped->mv(0,$targd) if $targd > 0; |
1648
|
1
|
|
|
|
|
6
|
return $clumped; |
1649
|
|
|
|
|
|
|
} |
1650
|
|
|
|
|
|
|
} |
1651
|
|
|
|
|
|
|
|
1652
|
|
|
|
|
|
|
=head2 thread_define |
1653
|
|
|
|
|
|
|
|
1654
|
|
|
|
|
|
|
=for ref |
1655
|
|
|
|
|
|
|
|
1656
|
|
|
|
|
|
|
define functions that support threading at the perl level |
1657
|
|
|
|
|
|
|
|
1658
|
|
|
|
|
|
|
=for example |
1659
|
|
|
|
|
|
|
|
1660
|
|
|
|
|
|
|
thread_define 'tline(a(n);b(n))', over { |
1661
|
|
|
|
|
|
|
line $_[0], $_[1]; # make line compliant with threading |
1662
|
|
|
|
|
|
|
}; |
1663
|
|
|
|
|
|
|
|
1664
|
|
|
|
|
|
|
|
1665
|
|
|
|
|
|
|
C provides some support for threading (see |
1666
|
|
|
|
|
|
|
L) at the perl level. It allows you to do things for |
1667
|
|
|
|
|
|
|
which you normally would have resorted to PDLA::PP (see L); |
1668
|
|
|
|
|
|
|
however, it is most useful to wrap existing perl functions so that the |
1669
|
|
|
|
|
|
|
new routine supports PDLA threading. |
1670
|
|
|
|
|
|
|
|
1671
|
|
|
|
|
|
|
C is used to define new I |
1672
|
|
|
|
|
|
|
functions. Its first argument is a symbolic repesentation of the new |
1673
|
|
|
|
|
|
|
function to be defined. The string is composed of the name of the new |
1674
|
|
|
|
|
|
|
function followed by its signature (see L and L) |
1675
|
|
|
|
|
|
|
in parentheses. The second argument is a subroutine that will be |
1676
|
|
|
|
|
|
|
called with the slices of the actual runtime arguments as specified by |
1677
|
|
|
|
|
|
|
its signature. Correct dimension sizes and minimal number of |
1678
|
|
|
|
|
|
|
dimensions for all arguments will be checked (assuming the rules of |
1679
|
|
|
|
|
|
|
PDLA threading, see L). |
1680
|
|
|
|
|
|
|
|
1681
|
|
|
|
|
|
|
The actual work is done by the C class which parses the signature |
1682
|
|
|
|
|
|
|
string, does runtime dimension checks and the routine C that |
1683
|
|
|
|
|
|
|
generates the loop over all appropriate slices of pdl arguments and creates |
1684
|
|
|
|
|
|
|
pdls as needed. |
1685
|
|
|
|
|
|
|
|
1686
|
|
|
|
|
|
|
Similar to C and its C option it is possible to |
1687
|
|
|
|
|
|
|
define the new function so that it accepts normal perl args as well as |
1688
|
|
|
|
|
|
|
piddles. You do this by using the C parameter in the |
1689
|
|
|
|
|
|
|
signature. The number of C specified will be passed |
1690
|
|
|
|
|
|
|
unaltered into the subroutine given as the second argument of |
1691
|
|
|
|
|
|
|
C. Let's illustrate this with an example: |
1692
|
|
|
|
|
|
|
|
1693
|
|
|
|
|
|
|
PDLA::thread_define 'triangles(inda();indb();indc()), NOtherPars => 2', |
1694
|
|
|
|
|
|
|
PDLA::over { |
1695
|
|
|
|
|
|
|
${$_[3]} .= $_[4].join(',',map {$_->at} @_[0..2]).",-1,\n"; |
1696
|
|
|
|
|
|
|
}; |
1697
|
|
|
|
|
|
|
|
1698
|
|
|
|
|
|
|
This defines a function C that takes 3 piddles as input |
1699
|
|
|
|
|
|
|
plus 2 arguments which are passed into the routine unaltered. This routine |
1700
|
|
|
|
|
|
|
is used to collect lists of indices into a perl scalar that is passed by |
1701
|
|
|
|
|
|
|
reference. Each line is preceded by a prefix passed as C<$_[4]>. Here is |
1702
|
|
|
|
|
|
|
typical usage: |
1703
|
|
|
|
|
|
|
|
1704
|
|
|
|
|
|
|
$txt = ''; |
1705
|
|
|
|
|
|
|
triangles(pdl(1,2,3),pdl(1),pdl(0),\$txt," "x10); |
1706
|
|
|
|
|
|
|
print $txt; |
1707
|
|
|
|
|
|
|
|
1708
|
|
|
|
|
|
|
resulting in the following output |
1709
|
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
|
1,1,0,-1, |
1711
|
|
|
|
|
|
|
2,1,0,-1, |
1712
|
|
|
|
|
|
|
3,1,0,-1, |
1713
|
|
|
|
|
|
|
|
1714
|
|
|
|
|
|
|
which is used in |
1715
|
|
|
|
|
|
|
L |
1716
|
|
|
|
|
|
|
to generate VRML output. |
1717
|
|
|
|
|
|
|
|
1718
|
|
|
|
|
|
|
Currently, this is probably not much more than a POP (proof of principle) |
1719
|
|
|
|
|
|
|
but is hoped to be useful enough for some real life work. |
1720
|
|
|
|
|
|
|
|
1721
|
|
|
|
|
|
|
Check L for the format of the signature. Currently, the |
1722
|
|
|
|
|
|
|
C<[t]> qualifier and all type qualifiers are ignored. |
1723
|
|
|
|
|
|
|
|
1724
|
|
|
|
|
|
|
=cut |
1725
|
|
|
|
|
|
|
|
1726
|
4
|
|
|
4
|
0
|
25
|
sub PDLA::over (&) { $_[0] } |
1727
|
|
|
|
|
|
|
sub PDLA::thread_define ($$) { |
1728
|
4
|
|
|
4
|
0
|
483
|
require PDLA::PP::Signature; |
1729
|
4
|
|
|
|
|
15
|
my ($str,$sub) = @_; |
1730
|
4
|
|
|
|
|
6
|
my $others = 0; |
1731
|
4
|
100
|
|
|
|
29
|
if ($str =~ s/[,]*\s*NOtherPars\s*=>\s*([0-9]+)\s*[,]*//) {$others = $1} |
|
2
|
|
|
|
|
6
|
|
1732
|
4
|
50
|
|
|
|
26
|
barf "invalid string $str" unless $str =~ /\s*([^(]+)\((.+)\)\s*$/x; |
1733
|
4
|
|
|
|
|
15
|
my ($name,$sigstr) = ($1,$2); |
1734
|
4
|
50
|
|
|
|
96
|
print "defining '$name' with signature '$sigstr' and $others extra args\n" |
1735
|
|
|
|
|
|
|
if $PDLA::debug; |
1736
|
4
|
|
|
|
|
29
|
my $sig = new PDLA::PP::Signature($sigstr); |
1737
|
4
|
|
|
|
|
7
|
my $args = @{$sig->names}; # number of piddle arguments |
|
4
|
|
|
|
|
28
|
|
1738
|
4
|
50
|
|
|
|
281
|
barf "no piddle args" if $args == 0; |
1739
|
4
|
|
|
|
|
8
|
$args--; |
1740
|
|
|
|
|
|
|
# TODO: $sig->dimcheck(@_) + proper creating generation |
1741
|
4
|
|
|
|
|
14
|
my $def = "\@_[0..$args] = map {PDLA::Core::topdl(\$_)} \@_[0..$args];\n". |
1742
|
|
|
|
|
|
|
'$sig->checkdims(@_); |
1743
|
|
|
|
|
|
|
PDLA::threadover($others,@_,$sig->realdims,$sig->creating,$sub)'; |
1744
|
4
|
|
|
|
|
10
|
my $package = caller; |
1745
|
4
|
|
|
|
|
18
|
local $^W = 0; # supress the 'not shared' warnings |
1746
|
4
|
50
|
|
|
|
151
|
print "defining...\nsub $name { $def }\n" if $PDLA::debug; |
1747
|
4
|
|
|
1
|
|
649
|
eval ("package $package; sub $name { $def }"); |
|
1
|
|
|
2
|
|
5
|
|
|
2
|
|
|
1
|
|
5
|
|
|
1
|
|
|
1
|
|
5
|
|
|
1
|
|
|
|
|
29
|
|
|
2
|
|
|
|
|
126
|
|
|
4
|
|
|
|
|
13
|
|
|
2
|
|
|
|
|
15
|
|
|
1
|
|
|
|
|
36
|
|
|
1
|
|
|
|
|
35
|
|
|
2
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
32
|
|
|
1
|
|
|
|
|
89
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
6
|
|
|
0
|
|
|
|
|
|
|
1748
|
4
|
50
|
|
|
|
35
|
barf "error defining $name: $@\n" if $@; |
1749
|
|
|
|
|
|
|
} |
1750
|
|
|
|
|
|
|
|
1751
|
|
|
|
|
|
|
=head2 thread |
1752
|
|
|
|
|
|
|
|
1753
|
|
|
|
|
|
|
=for ref |
1754
|
|
|
|
|
|
|
|
1755
|
|
|
|
|
|
|
Use explicit threading over specified dimensions (see also L) |
1756
|
|
|
|
|
|
|
|
1757
|
|
|
|
|
|
|
=for usage |
1758
|
|
|
|
|
|
|
|
1759
|
|
|
|
|
|
|
$y = $x->thread($dim,[$dim1,...]) |
1760
|
|
|
|
|
|
|
|
1761
|
|
|
|
|
|
|
=for example |
1762
|
|
|
|
|
|
|
|
1763
|
|
|
|
|
|
|
$x = zeroes 3,4,5; |
1764
|
|
|
|
|
|
|
$y = $x->thread(2,0); |
1765
|
|
|
|
|
|
|
|
1766
|
|
|
|
|
|
|
Same as L, i.e. uses thread id 1. |
1767
|
|
|
|
|
|
|
|
1768
|
|
|
|
|
|
|
=cut |
1769
|
|
|
|
|
|
|
|
1770
|
|
|
|
|
|
|
sub PDLA::thread { |
1771
|
10
|
|
|
10
|
0
|
72
|
my $var = shift; |
1772
|
10
|
|
|
|
|
400
|
$var->threadI(1,\@_); |
1773
|
|
|
|
|
|
|
} |
1774
|
|
|
|
|
|
|
|
1775
|
|
|
|
|
|
|
=head2 diagonal |
1776
|
|
|
|
|
|
|
|
1777
|
|
|
|
|
|
|
=for ref |
1778
|
|
|
|
|
|
|
|
1779
|
|
|
|
|
|
|
Returns the multidimensional diagonal over the specified dimensions. |
1780
|
|
|
|
|
|
|
|
1781
|
|
|
|
|
|
|
=for usage |
1782
|
|
|
|
|
|
|
|
1783
|
|
|
|
|
|
|
$d = $x->diagonal(dim1, dim2,...) |
1784
|
|
|
|
|
|
|
|
1785
|
|
|
|
|
|
|
=for example |
1786
|
|
|
|
|
|
|
|
1787
|
|
|
|
|
|
|
pdla> $x = zeroes(3,3,3); |
1788
|
|
|
|
|
|
|
pdla> ($y = $x->diagonal(0,1))++; |
1789
|
|
|
|
|
|
|
pdla> p $x |
1790
|
|
|
|
|
|
|
[ |
1791
|
|
|
|
|
|
|
[ |
1792
|
|
|
|
|
|
|
[1 0 0] |
1793
|
|
|
|
|
|
|
[0 1 0] |
1794
|
|
|
|
|
|
|
[0 0 1] |
1795
|
|
|
|
|
|
|
] |
1796
|
|
|
|
|
|
|
[ |
1797
|
|
|
|
|
|
|
[1 0 0] |
1798
|
|
|
|
|
|
|
[0 1 0] |
1799
|
|
|
|
|
|
|
[0 0 1] |
1800
|
|
|
|
|
|
|
] |
1801
|
|
|
|
|
|
|
[ |
1802
|
|
|
|
|
|
|
[1 0 0] |
1803
|
|
|
|
|
|
|
[0 1 0] |
1804
|
|
|
|
|
|
|
[0 0 1] |
1805
|
|
|
|
|
|
|
] |
1806
|
|
|
|
|
|
|
] |
1807
|
|
|
|
|
|
|
|
1808
|
|
|
|
|
|
|
=cut |
1809
|
|
|
|
|
|
|
|
1810
|
|
|
|
|
|
|
sub PDLA::diagonal { |
1811
|
30
|
|
|
30
|
0
|
92
|
my $var = shift; |
1812
|
30
|
|
|
|
|
691
|
$var->diagonalI(\@_); |
1813
|
|
|
|
|
|
|
} |
1814
|
|
|
|
|
|
|
|
1815
|
|
|
|
|
|
|
=head2 thread1 |
1816
|
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
|
=for ref |
1818
|
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
|
Explicit threading over specified dims using thread id 1. |
1820
|
|
|
|
|
|
|
|
1821
|
|
|
|
|
|
|
=for usage |
1822
|
|
|
|
|
|
|
|
1823
|
|
|
|
|
|
|
$xx = $x->thread1(3,1) |
1824
|
|
|
|
|
|
|
|
1825
|
|
|
|
|
|
|
=for example |
1826
|
|
|
|
|
|
|
|
1827
|
|
|
|
|
|
|
Wibble |
1828
|
|
|
|
|
|
|
|
1829
|
|
|
|
|
|
|
Convenience function interfacing to |
1830
|
|
|
|
|
|
|
L. |
1831
|
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
|
=cut |
1833
|
|
|
|
|
|
|
|
1834
|
|
|
|
|
|
|
sub PDLA::thread1 { |
1835
|
0
|
|
|
0
|
0
|
0
|
my $var = shift; |
1836
|
0
|
|
|
|
|
0
|
$var->threadI(1,\@_); |
1837
|
|
|
|
|
|
|
} |
1838
|
|
|
|
|
|
|
|
1839
|
|
|
|
|
|
|
=head2 thread2 |
1840
|
|
|
|
|
|
|
|
1841
|
|
|
|
|
|
|
=for ref |
1842
|
|
|
|
|
|
|
|
1843
|
|
|
|
|
|
|
Explicit threading over specified dims using thread id 2. |
1844
|
|
|
|
|
|
|
|
1845
|
|
|
|
|
|
|
=for usage |
1846
|
|
|
|
|
|
|
|
1847
|
|
|
|
|
|
|
$xx = $x->thread2(3,1) |
1848
|
|
|
|
|
|
|
|
1849
|
|
|
|
|
|
|
=for example |
1850
|
|
|
|
|
|
|
|
1851
|
|
|
|
|
|
|
Wibble |
1852
|
|
|
|
|
|
|
|
1853
|
|
|
|
|
|
|
Convenience function interfacing to |
1854
|
|
|
|
|
|
|
L. |
1855
|
|
|
|
|
|
|
|
1856
|
|
|
|
|
|
|
=cut |
1857
|
|
|
|
|
|
|
|
1858
|
|
|
|
|
|
|
sub PDLA::thread2 { |
1859
|
0
|
|
|
0
|
0
|
0
|
my $var = shift; |
1860
|
0
|
|
|
|
|
0
|
$var->threadI(2,\@_); |
1861
|
|
|
|
|
|
|
} |
1862
|
|
|
|
|
|
|
|
1863
|
|
|
|
|
|
|
=head2 thread3 |
1864
|
|
|
|
|
|
|
|
1865
|
|
|
|
|
|
|
=for ref |
1866
|
|
|
|
|
|
|
|
1867
|
|
|
|
|
|
|
Explicit threading over specified dims using thread id 3. |
1868
|
|
|
|
|
|
|
|
1869
|
|
|
|
|
|
|
=for usage |
1870
|
|
|
|
|
|
|
|
1871
|
|
|
|
|
|
|
$xx = $x->thread3(3,1) |
1872
|
|
|
|
|
|
|
|
1873
|
|
|
|
|
|
|
=for example |
1874
|
|
|
|
|
|
|
|
1875
|
|
|
|
|
|
|
Wibble |
1876
|
|
|
|
|
|
|
|
1877
|
|
|
|
|
|
|
Convenience function interfacing to |
1878
|
|
|
|
|
|
|
L. |
1879
|
|
|
|
|
|
|
|
1880
|
|
|
|
|
|
|
=cut |
1881
|
|
|
|
|
|
|
|
1882
|
|
|
|
|
|
|
sub PDLA::thread3 { |
1883
|
0
|
|
|
0
|
0
|
0
|
my $var = shift; |
1884
|
0
|
|
|
|
|
0
|
$var->threadI(3,\@_); |
1885
|
|
|
|
|
|
|
} |
1886
|
|
|
|
|
|
|
|
1887
|
|
|
|
|
|
|
my %info = ( |
1888
|
|
|
|
|
|
|
D => { |
1889
|
|
|
|
|
|
|
Name => 'Dimension', |
1890
|
|
|
|
|
|
|
Sub => \&PDLA::Core::dimstr, |
1891
|
|
|
|
|
|
|
}, |
1892
|
|
|
|
|
|
|
T => { |
1893
|
|
|
|
|
|
|
Name => 'Type', |
1894
|
|
|
|
|
|
|
Sub => sub { return $_[0]->type->shortctype; }, |
1895
|
|
|
|
|
|
|
}, |
1896
|
|
|
|
|
|
|
S => { |
1897
|
|
|
|
|
|
|
Name => 'State', |
1898
|
|
|
|
|
|
|
Sub => sub { my $state = ''; |
1899
|
|
|
|
|
|
|
$state .= 'P' if $_[0]->allocated; |
1900
|
|
|
|
|
|
|
$state .= 'V' if $_[0]->vaffine && |
1901
|
|
|
|
|
|
|
!$_[0]->allocated; # apparently can be both? |
1902
|
|
|
|
|
|
|
$state .= '-' if $state eq ''; # lazy eval |
1903
|
|
|
|
|
|
|
$state .= 'C' if $_[0]->anychgd; |
1904
|
|
|
|
|
|
|
$state .= 'B' if $_[0]->badflag; |
1905
|
|
|
|
|
|
|
$state; |
1906
|
|
|
|
|
|
|
}, |
1907
|
|
|
|
|
|
|
}, |
1908
|
|
|
|
|
|
|
F => { |
1909
|
|
|
|
|
|
|
Name => 'Flow', |
1910
|
|
|
|
|
|
|
Sub => sub { my $flows = ''; |
1911
|
|
|
|
|
|
|
$flows = ($_[0]->bflows ? 'b':'') . |
1912
|
|
|
|
|
|
|
'~' . ($_[0]->fflows ? 'f':'') |
1913
|
|
|
|
|
|
|
if ($_[0]->flows); |
1914
|
|
|
|
|
|
|
$flows; |
1915
|
|
|
|
|
|
|
}, |
1916
|
|
|
|
|
|
|
}, |
1917
|
|
|
|
|
|
|
M => { |
1918
|
|
|
|
|
|
|
Name => 'Mem', |
1919
|
|
|
|
|
|
|
Sub => sub { my ($size,$unit) = ($_[0]->allocated ? |
1920
|
|
|
|
|
|
|
$_[0]->nelem* |
1921
|
|
|
|
|
|
|
PDLA::howbig($_[0]->get_datatype)/1024 : 0, 'KB'); |
1922
|
|
|
|
|
|
|
if ($size > 0.01*1024) { $size /= 1024; |
1923
|
|
|
|
|
|
|
$unit = 'MB' }; |
1924
|
|
|
|
|
|
|
return sprintf "%6.2f%s",$size,$unit; |
1925
|
|
|
|
|
|
|
}, |
1926
|
|
|
|
|
|
|
}, |
1927
|
|
|
|
|
|
|
C => { |
1928
|
|
|
|
|
|
|
Name => 'Class', |
1929
|
|
|
|
|
|
|
Sub => sub { ref $_[0] } |
1930
|
|
|
|
|
|
|
}, |
1931
|
|
|
|
|
|
|
A => { |
1932
|
|
|
|
|
|
|
Name => 'Address', |
1933
|
77
|
|
|
77
|
|
711
|
Sub => sub { use Config; |
|
77
|
|
|
|
|
165
|
|
|
77
|
|
|
|
|
205351
|
|
1934
|
|
|
|
|
|
|
my $ivdformat = $Config{ivdformat}; |
1935
|
|
|
|
|
|
|
$ivdformat =~ s/"//g; |
1936
|
|
|
|
|
|
|
sprintf "%$ivdformat", $_[0]->address } |
1937
|
|
|
|
|
|
|
}, |
1938
|
|
|
|
|
|
|
); |
1939
|
|
|
|
|
|
|
|
1940
|
|
|
|
|
|
|
my $allowed = join '',keys %info; |
1941
|
|
|
|
|
|
|
|
1942
|
|
|
|
|
|
|
# print the dimension information about a pdl in some appropriate form |
1943
|
|
|
|
|
|
|
sub dimstr { |
1944
|
10
|
|
|
10
|
0
|
20
|
my $this = shift; |
1945
|
|
|
|
|
|
|
|
1946
|
10
|
|
|
|
|
26
|
my @dims = $this->dims; |
1947
|
10
|
|
|
|
|
29
|
my @ids = $this->threadids; |
1948
|
10
|
|
|
|
|
25
|
my ($nids,$i) = ($#ids - 1,0); |
1949
|
10
|
|
|
|
|
50
|
my $dstr = 'D ['. join(',',@dims[0..($ids[0]-1)]) .']'; |
1950
|
10
|
50
|
|
|
|
31
|
if ($nids > 0) { |
1951
|
0
|
|
|
|
|
0
|
for $i (1..$nids) { |
1952
|
0
|
|
|
|
|
0
|
$dstr .= " T$i [". join(',',@dims[$ids[$i]..$ids[$i+1]-1]) .']'; |
1953
|
|
|
|
|
|
|
} |
1954
|
|
|
|
|
|
|
} |
1955
|
10
|
|
|
|
|
29
|
return $dstr; |
1956
|
|
|
|
|
|
|
} |
1957
|
|
|
|
|
|
|
|
1958
|
|
|
|
|
|
|
=head2 sever |
1959
|
|
|
|
|
|
|
|
1960
|
|
|
|
|
|
|
=for ref |
1961
|
|
|
|
|
|
|
|
1962
|
|
|
|
|
|
|
sever any links of this piddle to parent piddles |
1963
|
|
|
|
|
|
|
|
1964
|
|
|
|
|
|
|
In PDLA it is possible for a piddle to be just another |
1965
|
|
|
|
|
|
|
view into another piddle's data. In that case we call |
1966
|
|
|
|
|
|
|
this piddle a I and the original piddle owning |
1967
|
|
|
|
|
|
|
the data its parent. In other languages these alternate views |
1968
|
|
|
|
|
|
|
sometimes run by names such as I or I. |
1969
|
|
|
|
|
|
|
|
1970
|
|
|
|
|
|
|
Typical functions that return such piddles are C, C, |
1971
|
|
|
|
|
|
|
C, etc. Sometimes, however, you would like to separate the |
1972
|
|
|
|
|
|
|
I from its parent's data and just give it a life of |
1973
|
|
|
|
|
|
|
its own (so that manipulation of its data doesn't change the parent). |
1974
|
|
|
|
|
|
|
This is simply achieved by using C. For example, |
1975
|
|
|
|
|
|
|
|
1976
|
|
|
|
|
|
|
=for example |
1977
|
|
|
|
|
|
|
|
1978
|
|
|
|
|
|
|
$x = $pdl->index(pdl(0,3,7))->sever; |
1979
|
|
|
|
|
|
|
$x++; # important: $pdl is not modified! |
1980
|
|
|
|
|
|
|
|
1981
|
|
|
|
|
|
|
In many (but not all) circumstances it acts therefore similar to |
1982
|
|
|
|
|
|
|
L. |
1983
|
|
|
|
|
|
|
However, in general performance is better with C and secondly, |
1984
|
|
|
|
|
|
|
C doesn't lead to futile copying when used on piddles that |
1985
|
|
|
|
|
|
|
already have their own data. On the other hand, if you really want to make |
1986
|
|
|
|
|
|
|
sure to work on a copy of a piddle use L. |
1987
|
|
|
|
|
|
|
|
1988
|
|
|
|
|
|
|
$x = zeroes(20); |
1989
|
|
|
|
|
|
|
$x->sever; # NOOP since $x is already its own boss! |
1990
|
|
|
|
|
|
|
|
1991
|
|
|
|
|
|
|
Again note: C I the same as L! |
1992
|
|
|
|
|
|
|
For example, |
1993
|
|
|
|
|
|
|
|
1994
|
|
|
|
|
|
|
$x = zeroes(1); # $x does not have a parent, i.e. it is not a slice etc |
1995
|
|
|
|
|
|
|
$y = $x->sever; # $y is now pointing to the same piddle as $x |
1996
|
|
|
|
|
|
|
$y++; |
1997
|
|
|
|
|
|
|
print $x; |
1998
|
|
|
|
|
|
|
[1] |
1999
|
|
|
|
|
|
|
|
2000
|
|
|
|
|
|
|
but |
2001
|
|
|
|
|
|
|
|
2002
|
|
|
|
|
|
|
$x = zeroes(1); |
2003
|
|
|
|
|
|
|
$y = $x->copy; # $y is now pointing to a new piddle |
2004
|
|
|
|
|
|
|
$y++; |
2005
|
|
|
|
|
|
|
print $x; |
2006
|
|
|
|
|
|
|
[0] |
2007
|
|
|
|
|
|
|
|
2008
|
|
|
|
|
|
|
|
2009
|
|
|
|
|
|
|
=head2 info |
2010
|
|
|
|
|
|
|
|
2011
|
|
|
|
|
|
|
=for ref |
2012
|
|
|
|
|
|
|
|
2013
|
|
|
|
|
|
|
Return formatted information about a piddle. |
2014
|
|
|
|
|
|
|
|
2015
|
|
|
|
|
|
|
=for usage |
2016
|
|
|
|
|
|
|
|
2017
|
|
|
|
|
|
|
$x->info($format_string); |
2018
|
|
|
|
|
|
|
|
2019
|
|
|
|
|
|
|
=for example |
2020
|
|
|
|
|
|
|
|
2021
|
|
|
|
|
|
|
print $x->info("Type: %T Dim: %-15D State: %S"); |
2022
|
|
|
|
|
|
|
|
2023
|
|
|
|
|
|
|
Returns a string with info about a piddle. Takes an optional |
2024
|
|
|
|
|
|
|
argument to specify the format of information a la sprintf. |
2025
|
|
|
|
|
|
|
Format specifiers are in the form C<%EwidthEEletterE> |
2026
|
|
|
|
|
|
|
where the width is optional and the letter is one of |
2027
|
|
|
|
|
|
|
|
2028
|
|
|
|
|
|
|
=over 7 |
2029
|
|
|
|
|
|
|
|
2030
|
|
|
|
|
|
|
=item T |
2031
|
|
|
|
|
|
|
|
2032
|
|
|
|
|
|
|
Type |
2033
|
|
|
|
|
|
|
|
2034
|
|
|
|
|
|
|
=item D |
2035
|
|
|
|
|
|
|
|
2036
|
|
|
|
|
|
|
Formatted Dimensions |
2037
|
|
|
|
|
|
|
|
2038
|
|
|
|
|
|
|
=item F |
2039
|
|
|
|
|
|
|
|
2040
|
|
|
|
|
|
|
Dataflow status |
2041
|
|
|
|
|
|
|
|
2042
|
|
|
|
|
|
|
=item S |
2043
|
|
|
|
|
|
|
|
2044
|
|
|
|
|
|
|
Some internal flags (P=physical,V=Vaffine,C=changed,B=may contain bad data) |
2045
|
|
|
|
|
|
|
|
2046
|
|
|
|
|
|
|
=item C |
2047
|
|
|
|
|
|
|
|
2048
|
|
|
|
|
|
|
Class of this piddle, i.e. C[ ] |
2049
|
|
|
|
|
|
|
|
2050
|
|
|
|
|
|
|
=item A |
2051
|
|
|
|
|
|
|
|
2052
|
|
|
|
|
|
|
Address of the piddle struct as a unique identifier |
2053
|
|
|
|
|
|
|
|
2054
|
|
|
|
|
|
|
=item M |
2055
|
|
|
|
|
|
|
|
2056
|
|
|
|
|
|
|
Calculated memory consumption of this piddle's data area |
2057
|
|
|
|
|
|
|
|
2058
|
|
|
|
|
|
|
=back |
2059
|
|
|
|
|
|
|
|
2060
|
|
|
|
|
|
|
=cut |
2061
|
|
|
|
|
|
|
|
2062
|
|
|
|
|
|
|
sub PDLA::info { |
2063
|
11
|
|
|
11
|
0
|
749
|
my ($this,$str) = @_; |
2064
|
11
|
100
|
|
|
|
32
|
$str = "%C: %T %D" unless defined $str; |
2065
|
11
|
100
|
|
|
|
72
|
return ref($this)."->null" if $this->isnull; |
2066
|
10
|
|
|
|
|
103
|
my @hash = split /(%[-,0-9]*[.]?[0-9]*\w)/, $str; |
2067
|
10
|
|
|
|
|
26
|
my @args = (); |
2068
|
10
|
|
|
|
|
23
|
my $nstr = ''; |
2069
|
10
|
|
|
|
|
20
|
for my $form (@hash) { |
2070
|
90
|
100
|
|
|
|
361
|
if ($form =~ s/^%([-,0-9]*[.]?[0-9]*)(\w)$/%$1s/) { |
2071
|
45
|
50
|
|
|
|
129
|
barf "unknown format specifier $2" unless defined $info{$2}; |
2072
|
45
|
|
|
|
|
69
|
push @args, &{$info{$2}->{Sub}}($this); |
|
45
|
|
|
|
|
120
|
|
2073
|
|
|
|
|
|
|
} |
2074
|
90
|
|
|
|
|
168
|
$nstr .= $form; |
2075
|
|
|
|
|
|
|
} |
2076
|
10
|
|
|
|
|
468
|
return sprintf $nstr, @args; |
2077
|
|
|
|
|
|
|
} |
2078
|
|
|
|
|
|
|
|
2079
|
|
|
|
|
|
|
=head2 approx |
2080
|
|
|
|
|
|
|
|
2081
|
|
|
|
|
|
|
=for ref |
2082
|
|
|
|
|
|
|
|
2083
|
|
|
|
|
|
|
test for approximately equal values (relaxed C<==>) |
2084
|
|
|
|
|
|
|
|
2085
|
|
|
|
|
|
|
=for example |
2086
|
|
|
|
|
|
|
|
2087
|
|
|
|
|
|
|
# ok if all corresponding values in |
2088
|
|
|
|
|
|
|
# piddles are within 1e-8 of each other |
2089
|
|
|
|
|
|
|
print "ok\n" if all approx $x, $y, 1e-8; |
2090
|
|
|
|
|
|
|
|
2091
|
|
|
|
|
|
|
C is a relaxed form of the C<==> operator and |
2092
|
|
|
|
|
|
|
often more appropriate for floating point types (C |
2093
|
|
|
|
|
|
|
and C). |
2094
|
|
|
|
|
|
|
|
2095
|
|
|
|
|
|
|
Usage: |
2096
|
|
|
|
|
|
|
|
2097
|
|
|
|
|
|
|
=for usage |
2098
|
|
|
|
|
|
|
|
2099
|
|
|
|
|
|
|
$res = approx $x, $y [, $eps] |
2100
|
|
|
|
|
|
|
|
2101
|
|
|
|
|
|
|
The optional parameter C<$eps> is remembered across invocations |
2102
|
|
|
|
|
|
|
and initially set to 1e-6, e.g. |
2103
|
|
|
|
|
|
|
|
2104
|
|
|
|
|
|
|
approx $x, $y; # last $eps used (1e-6 initially) |
2105
|
|
|
|
|
|
|
approx $x, $y, 1e-10; # 1e-10 |
2106
|
|
|
|
|
|
|
approx $x, $y; # also 1e-10 |
2107
|
|
|
|
|
|
|
|
2108
|
|
|
|
|
|
|
=cut |
2109
|
|
|
|
|
|
|
|
2110
|
|
|
|
|
|
|
my $approx = 1e-6; # a reasonable init value |
2111
|
|
|
|
|
|
|
sub PDLA::approx { |
2112
|
151
|
|
|
151
|
0
|
7138
|
my ($x,$y,$eps) = @_; |
2113
|
151
|
100
|
|
|
|
451
|
$eps = $approx unless defined $eps; # the default eps |
2114
|
151
|
|
|
|
|
265
|
$approx = $eps; # remember last eps |
2115
|
|
|
|
|
|
|
# NOTE: ($x-$y)->abs breaks for non-piddle inputs |
2116
|
151
|
|
|
|
|
65899
|
return abs($x-$y) < $eps; |
2117
|
|
|
|
|
|
|
} |
2118
|
|
|
|
|
|
|
|
2119
|
|
|
|
|
|
|
=head2 mslice |
2120
|
|
|
|
|
|
|
|
2121
|
|
|
|
|
|
|
=for ref |
2122
|
|
|
|
|
|
|
|
2123
|
|
|
|
|
|
|
Convenience interface to L, |
2124
|
|
|
|
|
|
|
allowing easier inclusion of dimensions in perl code. |
2125
|
|
|
|
|
|
|
|
2126
|
|
|
|
|
|
|
=for usage |
2127
|
|
|
|
|
|
|
|
2128
|
|
|
|
|
|
|
$w = $x->mslice(...); |
2129
|
|
|
|
|
|
|
|
2130
|
|
|
|
|
|
|
=for example |
2131
|
|
|
|
|
|
|
|
2132
|
|
|
|
|
|
|
# below is the same as $x->slice("5:7,:,3:4:2") |
2133
|
|
|
|
|
|
|
$w = $x->mslice([5,7],X,[3,4,2]); |
2134
|
|
|
|
|
|
|
|
2135
|
|
|
|
|
|
|
=cut |
2136
|
|
|
|
|
|
|
|
2137
|
|
|
|
|
|
|
# called for colon-less args |
2138
|
|
|
|
|
|
|
# preserves parens if present |
2139
|
1
|
50
|
|
1
|
0
|
11
|
sub intpars { $_[0] =~ /\(.*\)/ ? '('.int($_[0]).')' : int $_[0] } |
2140
|
|
|
|
|
|
|
|
2141
|
|
|
|
|
|
|
sub PDLA::mslice { |
2142
|
14
|
|
|
14
|
0
|
753
|
my($pdl) = shift; |
2143
|
|
|
|
|
|
|
return $pdl->slice(join ',',(map { |
2144
|
14
|
|
|
|
|
31
|
!ref $_ && $_ eq "X" ? ":" : |
2145
|
|
|
|
|
|
|
ref $_ eq "ARRAY" ? $#$_ > 1 && @$_[2] == 0 ? |
2146
|
15
|
50
|
100
|
|
|
109
|
"(".int(@$_[0]).")" : join ':', map {int $_} @$_ : |
|
26
|
50
|
33
|
|
|
99
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
2147
|
|
|
|
|
|
|
!ref $_ ? intpars $_ : |
2148
|
|
|
|
|
|
|
die "INVALID SLICE DEF $_" |
2149
|
|
|
|
|
|
|
} @_)); |
2150
|
|
|
|
|
|
|
} |
2151
|
|
|
|
|
|
|
|
2152
|
|
|
|
|
|
|
=head2 nslice_if_pdl |
2153
|
|
|
|
|
|
|
|
2154
|
|
|
|
|
|
|
=for ref |
2155
|
|
|
|
|
|
|
|
2156
|
|
|
|
|
|
|
If C<$self> is a PDLA, then calls C with all but the last |
2157
|
|
|
|
|
|
|
argument, otherwise $self->($_[-1]) is called where $_[-1} is the |
2158
|
|
|
|
|
|
|
original argument string found during PDLA::NiceSlice filtering. |
2159
|
|
|
|
|
|
|
|
2160
|
|
|
|
|
|
|
DEVELOPER'S NOTE: this routine is found in Core.pm.PL but would be |
2161
|
|
|
|
|
|
|
better placed in Slices/slices.pd. It is likely to be moved there |
2162
|
|
|
|
|
|
|
and/or changed to "slice_if_pdl" for PDLA 3.0. |
2163
|
|
|
|
|
|
|
|
2164
|
|
|
|
|
|
|
=for usage |
2165
|
|
|
|
|
|
|
|
2166
|
|
|
|
|
|
|
$w = $x->nslice_if_pdl(...,'(args)'); |
2167
|
|
|
|
|
|
|
|
2168
|
|
|
|
|
|
|
=cut |
2169
|
|
|
|
|
|
|
|
2170
|
|
|
|
|
|
|
sub PDLA::nslice_if_pdl { |
2171
|
0
|
|
|
0
|
0
|
0
|
my ($pdl) = shift; |
2172
|
0
|
|
|
|
|
0
|
my ($orig_args) = pop; |
2173
|
|
|
|
|
|
|
|
2174
|
|
|
|
|
|
|
# warn "PDLA::nslice_if_pdl called with (@_) args, originally ($orig_args)\n"; |
2175
|
|
|
|
|
|
|
|
2176
|
0
|
0
|
|
|
|
0
|
if (ref($pdl) eq 'CODE') { |
2177
|
|
|
|
|
|
|
# barf('PDLA::nslice_if_pdl tried to process a sub ref, please use &$subref() syntax') |
2178
|
0
|
|
|
|
|
0
|
@_ = eval $orig_args; |
2179
|
0
|
|
|
|
|
0
|
goto &$pdl; |
2180
|
|
|
|
|
|
|
} |
2181
|
|
|
|
|
|
|
|
2182
|
0
|
|
|
|
|
0
|
unshift @_, $pdl; |
2183
|
0
|
|
|
|
|
0
|
goto &PDLA::slice; |
2184
|
|
|
|
|
|
|
} |
2185
|
|
|
|
|
|
|
|
2186
|
|
|
|
|
|
|
=head2 nslice |
2187
|
|
|
|
|
|
|
|
2188
|
|
|
|
|
|
|
=for ref |
2189
|
|
|
|
|
|
|
|
2190
|
|
|
|
|
|
|
C was an internally used interface for L, |
2191
|
|
|
|
|
|
|
but is now merely a springboard to L. It is deprecated |
2192
|
|
|
|
|
|
|
and likely to disappear in PDLA 3.0. |
2193
|
|
|
|
|
|
|
|
2194
|
|
|
|
|
|
|
=cut |
2195
|
|
|
|
|
|
|
sub PDLA::nslice { |
2196
|
0
|
0
|
|
0
|
0
|
0
|
unless($PDLA::nslice_warning_issued) { |
2197
|
0
|
|
|
|
|
0
|
$PDLA::nslice_warning_issued = 1; |
2198
|
0
|
|
|
|
|
0
|
warn "WARNING: deprecated call to PDLA::nslice detected. Use PDLA::slice instead.\n (Warning will be issued only once per session)\n"; |
2199
|
|
|
|
|
|
|
} |
2200
|
0
|
|
|
|
|
0
|
goto &PDLA::slice; |
2201
|
|
|
|
|
|
|
} |
2202
|
|
|
|
|
|
|
|
2203
|
|
|
|
|
|
|
sub blessed { |
2204
|
1292
|
|
|
1292
|
0
|
2531
|
my $ref = ref(shift); |
2205
|
1292
|
100
|
|
|
|
7110
|
return $ref =~ /^(REF|SCALAR|ARRAY|HASH|CODE|GLOB||)$/ ? 0 : 1; |
2206
|
|
|
|
|
|
|
} |
2207
|
|
|
|
|
|
|
|
2208
|
|
|
|
|
|
|
# Convert numbers to PDLA if not already |
2209
|
|
|
|
|
|
|
|
2210
|
|
|
|
|
|
|
sub PDLA::topdl { |
2211
|
794
|
100
|
|
794
|
0
|
2538
|
return $_[0]->new(@_[1..$#_]) if($#_ > 1); # PDLAify an ARRAY |
2212
|
792
|
100
|
|
|
|
1968
|
return $_[1] if blessed($_[1]); # Fall through |
2213
|
2
|
50
|
66
|
|
|
22
|
return $_[0]->new($_[1]) if ref(\$_[1]) eq 'SCALAR' or |
2214
|
|
|
|
|
|
|
ref($_[1]) eq 'ARRAY'; |
2215
|
0
|
|
|
|
|
0
|
barf("Can not convert a ".ref($_[1])." to a ".$_[0]); |
2216
|
0
|
|
|
|
|
0
|
0;} |
2217
|
|
|
|
|
|
|
|
2218
|
|
|
|
|
|
|
# Convert everything to PDLA if not blessed |
2219
|
|
|
|
|
|
|
|
2220
|
|
|
|
|
|
|
sub alltopdl { |
2221
|
229
|
50
|
|
229
|
0
|
721
|
if (ref $_[2] eq 'PDLA::Type') { |
2222
|
229
|
100
|
|
|
|
585
|
return convert($_[1], $_[2]) if blessed($_[1]); |
2223
|
92
|
50
|
|
|
|
440
|
return $_[0]->new($_[2], $_[1]) if $_[0] eq 'PDLA'; |
2224
|
|
|
|
|
|
|
} |
2225
|
0
|
0
|
|
|
|
0
|
return $_[1] if blessed($_[1]); # Fall through |
2226
|
0
|
|
|
|
|
0
|
return $_[0]->new($_[1]); |
2227
|
0
|
|
|
|
|
0
|
0;} |
2228
|
|
|
|
|
|
|
|
2229
|
|
|
|
|
|
|
|
2230
|
|
|
|
|
|
|
=head2 inplace |
2231
|
|
|
|
|
|
|
|
2232
|
|
|
|
|
|
|
=for ref |
2233
|
|
|
|
|
|
|
|
2234
|
|
|
|
|
|
|
Flag a piddle so that the next operation is done 'in place' |
2235
|
|
|
|
|
|
|
|
2236
|
|
|
|
|
|
|
=for usage |
2237
|
|
|
|
|
|
|
|
2238
|
|
|
|
|
|
|
somefunc($x->inplace); somefunc(inplace $x); |
2239
|
|
|
|
|
|
|
|
2240
|
|
|
|
|
|
|
In most cases one likes to use the syntax C<$y = f($x)>, however |
2241
|
|
|
|
|
|
|
in many case the operation C can be done correctly |
2242
|
|
|
|
|
|
|
'in place', i.e. without making a new copy of the data for |
2243
|
|
|
|
|
|
|
output. To make it easy to use this, we write C in such |
2244
|
|
|
|
|
|
|
a way that it operates in-place, and use C to hint |
2245
|
|
|
|
|
|
|
that a new copy should be disabled. This also makes for |
2246
|
|
|
|
|
|
|
clear syntax. |
2247
|
|
|
|
|
|
|
|
2248
|
|
|
|
|
|
|
Obviously this will not work for all functions, and if in |
2249
|
|
|
|
|
|
|
doubt see the function's documentation. However one |
2250
|
|
|
|
|
|
|
can assume this is |
2251
|
|
|
|
|
|
|
true for all elemental functions (i.e. those which just |
2252
|
|
|
|
|
|
|
operate array element by array element like C). |
2253
|
|
|
|
|
|
|
|
2254
|
|
|
|
|
|
|
=for example |
2255
|
|
|
|
|
|
|
|
2256
|
|
|
|
|
|
|
pdla> $x = xvals zeroes 10; |
2257
|
|
|
|
|
|
|
pdla> log10(inplace $x) |
2258
|
|
|
|
|
|
|
pdla> p $x |
2259
|
|
|
|
|
|
|
[-inf 0 0.30103 0.47712125 0.60205999 0.69897 0.77815125 0.84509804 0.90308999 0.95424251] |
2260
|
|
|
|
|
|
|
|
2261
|
|
|
|
|
|
|
=cut |
2262
|
|
|
|
|
|
|
|
2263
|
|
|
|
|
|
|
# Flag pdl for in-place operations |
2264
|
|
|
|
|
|
|
|
2265
|
|
|
|
|
|
|
sub PDLA::inplace { |
2266
|
165
|
|
|
165
|
0
|
1356
|
my $pdl = PDLA->topdl(shift); $pdl->set_inplace(1); return $pdl; |
|
165
|
|
|
|
|
730
|
|
|
165
|
|
|
|
|
1492
|
|
2267
|
|
|
|
|
|
|
} |
2268
|
|
|
|
|
|
|
|
2269
|
|
|
|
|
|
|
# Copy if not inplace |
2270
|
|
|
|
|
|
|
|
2271
|
|
|
|
|
|
|
|
2272
|
|
|
|
|
|
|
=head2 is_inplace |
2273
|
|
|
|
|
|
|
|
2274
|
|
|
|
|
|
|
=for ref |
2275
|
|
|
|
|
|
|
|
2276
|
|
|
|
|
|
|
Test the in-place flag on a piddle |
2277
|
|
|
|
|
|
|
|
2278
|
|
|
|
|
|
|
=for usage |
2279
|
|
|
|
|
|
|
|
2280
|
|
|
|
|
|
|
$out = ($in->is_inplace) ? $in : zeroes($in); |
2281
|
|
|
|
|
|
|
$in->set_inplace(0) |
2282
|
|
|
|
|
|
|
|
2283
|
|
|
|
|
|
|
Provides access to the L hint flag, within the perl millieu. |
2284
|
|
|
|
|
|
|
That way functions you write can be inplace aware... If given an |
2285
|
|
|
|
|
|
|
argument the inplace flag will be set or unset depending on the value |
2286
|
|
|
|
|
|
|
at the same time. Can be used for shortcut tests that delete the |
2287
|
|
|
|
|
|
|
inplace flag while testing: |
2288
|
|
|
|
|
|
|
|
2289
|
|
|
|
|
|
|
$out = ($in->is_inplace(0)) ? $in : zeroes($in); # test & unset! |
2290
|
|
|
|
|
|
|
|
2291
|
|
|
|
|
|
|
=head2 set_inplace |
2292
|
|
|
|
|
|
|
|
2293
|
|
|
|
|
|
|
=for ref |
2294
|
|
|
|
|
|
|
|
2295
|
|
|
|
|
|
|
Set the in-place flag on a piddle |
2296
|
|
|
|
|
|
|
|
2297
|
|
|
|
|
|
|
=for usage |
2298
|
|
|
|
|
|
|
|
2299
|
|
|
|
|
|
|
$out = ($in->is_inplace) ? $in : zeroes($in); |
2300
|
|
|
|
|
|
|
$in->set_inplace(0); |
2301
|
|
|
|
|
|
|
|
2302
|
|
|
|
|
|
|
Provides access to the L hint flag, within the perl millieu. |
2303
|
|
|
|
|
|
|
Useful mainly for turning it OFF, as L turns it ON more |
2304
|
|
|
|
|
|
|
conveniently. |
2305
|
|
|
|
|
|
|
|
2306
|
|
|
|
|
|
|
=head2 new_or_inplace |
2307
|
|
|
|
|
|
|
|
2308
|
|
|
|
|
|
|
=for usage |
2309
|
|
|
|
|
|
|
|
2310
|
|
|
|
|
|
|
$w = new_or_inplace(shift()); |
2311
|
|
|
|
|
|
|
$w = new_or_inplace(shift(),$preferred_type); |
2312
|
|
|
|
|
|
|
|
2313
|
|
|
|
|
|
|
=for ref |
2314
|
|
|
|
|
|
|
|
2315
|
|
|
|
|
|
|
Return back either the argument pdl or a copy of it depending on whether |
2316
|
|
|
|
|
|
|
it be flagged in-place or no. Handy for building inplace-aware functions. |
2317
|
|
|
|
|
|
|
|
2318
|
|
|
|
|
|
|
If you specify a preferred type (must be one of the usual PDLA type strings, |
2319
|
|
|
|
|
|
|
a list ref containing several of them, or a string containing several of them), |
2320
|
|
|
|
|
|
|
then the copy is coerced into the first preferred type listed if it is not |
2321
|
|
|
|
|
|
|
already one of the preferred types. |
2322
|
|
|
|
|
|
|
|
2323
|
|
|
|
|
|
|
Note that if the inplace flag is set, no coersion happens even if you specify |
2324
|
|
|
|
|
|
|
a preferred type. |
2325
|
|
|
|
|
|
|
|
2326
|
|
|
|
|
|
|
=cut |
2327
|
|
|
|
|
|
|
|
2328
|
|
|
|
|
|
|
sub new_or_inplace { |
2329
|
225
|
|
|
225
|
1
|
496
|
my $pdl = shift; |
2330
|
225
|
|
|
|
|
363
|
my $preferred = shift; |
2331
|
225
|
|
|
|
|
348
|
my $force = shift; |
2332
|
225
|
100
|
|
|
|
773
|
if($pdl->is_inplace) { |
2333
|
116
|
|
|
|
|
381
|
$pdl->set_inplace(0); |
2334
|
116
|
|
|
|
|
270
|
return $pdl; |
2335
|
|
|
|
|
|
|
} else { |
2336
|
109
|
100
|
|
|
|
248
|
unless(defined($preferred)) { |
2337
|
108
|
|
|
|
|
284
|
return $pdl->copy; |
2338
|
|
|
|
|
|
|
} else { |
2339
|
1
|
50
|
|
|
|
5
|
$preferred = join(",",@$preferred) if(ref($preferred) eq 'ARRAY'); |
2340
|
1
|
|
|
|
|
4
|
my $s = "".$pdl->type; |
2341
|
1
|
50
|
|
|
|
40
|
if($preferred =~ m/(^|\,)$s(\,|$)/i) { |
2342
|
|
|
|
|
|
|
# Got a match - the PDLA is one of the preferred types. |
2343
|
0
|
|
|
|
|
0
|
return $pdl->copy(); |
2344
|
|
|
|
|
|
|
} else { |
2345
|
|
|
|
|
|
|
# No match - promote it to the first in the list. |
2346
|
1
|
|
|
|
|
7
|
$preferred =~ s/\,.*//; |
2347
|
1
|
|
|
|
|
5
|
my $out = PDLA::new_from_specification('PDLA',new PDLA::Type($preferred),$pdl->dims); |
2348
|
1
|
|
|
|
|
4
|
$out .= $pdl; |
2349
|
1
|
|
|
|
|
7
|
return $out; |
2350
|
|
|
|
|
|
|
} |
2351
|
|
|
|
|
|
|
} |
2352
|
|
|
|
|
|
|
} |
2353
|
0
|
|
|
|
|
0
|
barf "PDLA::Core::new_or_inplace - This can never happen!"; |
2354
|
|
|
|
|
|
|
} |
2355
|
|
|
|
|
|
|
*PDLA::new_or_inplace = \&new_or_inplace; |
2356
|
|
|
|
|
|
|
|
2357
|
|
|
|
|
|
|
# Allow specifications like zeroes(10,10) or zeroes($x) |
2358
|
|
|
|
|
|
|
# or zeroes(inplace $x) or zeroes(float,4,3) |
2359
|
|
|
|
|
|
|
|
2360
|
|
|
|
|
|
|
=head2 new_from_specification |
2361
|
|
|
|
|
|
|
|
2362
|
|
|
|
|
|
|
=for ref |
2363
|
|
|
|
|
|
|
|
2364
|
|
|
|
|
|
|
Internal method: create piddle by specification |
2365
|
|
|
|
|
|
|
|
2366
|
|
|
|
|
|
|
This is the argument processing method called by L |
2367
|
|
|
|
|
|
|
and some other functions |
2368
|
|
|
|
|
|
|
which constructs piddles from argument lists of the form: |
2369
|
|
|
|
|
|
|
|
2370
|
|
|
|
|
|
|
[type], $nx, $ny, $nz,... |
2371
|
|
|
|
|
|
|
|
2372
|
|
|
|
|
|
|
For C<$nx>, C<$ny>, etc. 0 and 1D piddles are allowed. |
2373
|
|
|
|
|
|
|
Giving those has the same effect as if saying C<$arg-Elist>, |
2374
|
|
|
|
|
|
|
e.g. |
2375
|
|
|
|
|
|
|
|
2376
|
|
|
|
|
|
|
1, pdl(5,2), 4 |
2377
|
|
|
|
|
|
|
|
2378
|
|
|
|
|
|
|
is equivalent to |
2379
|
|
|
|
|
|
|
|
2380
|
|
|
|
|
|
|
1, 5, 2, 4 |
2381
|
|
|
|
|
|
|
|
2382
|
|
|
|
|
|
|
Note, however, that in all functions using C |
2383
|
|
|
|
|
|
|
calling C will probably not do what you want. So to play safe |
2384
|
|
|
|
|
|
|
use (e.g. with zeroes) |
2385
|
|
|
|
|
|
|
|
2386
|
|
|
|
|
|
|
$pdl = zeroes $dimpdl->list; |
2387
|
|
|
|
|
|
|
|
2388
|
|
|
|
|
|
|
Calling |
2389
|
|
|
|
|
|
|
|
2390
|
|
|
|
|
|
|
$pdl = zeroes $dimpdl; |
2391
|
|
|
|
|
|
|
|
2392
|
|
|
|
|
|
|
will rather be equivalent to |
2393
|
|
|
|
|
|
|
|
2394
|
|
|
|
|
|
|
$pdl = zeroes $dimpdl->dims; |
2395
|
|
|
|
|
|
|
|
2396
|
|
|
|
|
|
|
However, |
2397
|
|
|
|
|
|
|
|
2398
|
|
|
|
|
|
|
$pdl = zeroes ushort, $dimpdl; |
2399
|
|
|
|
|
|
|
|
2400
|
|
|
|
|
|
|
will again do what you intended since it is interpreted |
2401
|
|
|
|
|
|
|
as if you had said |
2402
|
|
|
|
|
|
|
|
2403
|
|
|
|
|
|
|
$pdl = zeroes ushort, $dimpdl->list; |
2404
|
|
|
|
|
|
|
|
2405
|
|
|
|
|
|
|
This is unfortunate and confusing but no good solution seems |
2406
|
|
|
|
|
|
|
obvious that would not break existing scripts. |
2407
|
|
|
|
|
|
|
|
2408
|
|
|
|
|
|
|
=cut |
2409
|
|
|
|
|
|
|
|
2410
|
|
|
|
|
|
|
sub PDLA::new_from_specification{ |
2411
|
417
|
|
|
417
|
0
|
988
|
my $class = shift; |
2412
|
417
|
100
|
|
|
|
1600
|
my $type = ref($_[0]) eq 'PDLA::Type' ? ${shift @_}[0] : $PDLA_D; |
|
92
|
|
|
|
|
376
|
|
2413
|
417
|
|
|
|
|
710
|
my $nelems = 1; my @dims; |
|
417
|
|
|
|
|
747
|
|
2414
|
417
|
|
|
|
|
954
|
for (@_) { |
2415
|
752
|
50
|
|
|
|
1362
|
if (ref $_) { |
2416
|
0
|
0
|
|
|
|
0
|
barf "Trying to use non-piddle as dimensions?" unless $_->isa('PDLA'); |
2417
|
0
|
0
|
|
|
|
0
|
barf "Trying to use multi-dim piddle as dimensions?" |
2418
|
|
|
|
|
|
|
if $_->getndims > 1; |
2419
|
0
|
0
|
|
|
|
0
|
warn "creating > 10 dim piddle (piddle arg)!" |
2420
|
|
|
|
|
|
|
if $_->nelem > 10; |
2421
|
0
|
|
|
|
|
0
|
for my $dim ($_->list) {$nelems *= $dim; push @dims, $dim} |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
2422
|
|
|
|
|
|
|
} else { |
2423
|
752
|
100
|
|
|
|
1311
|
if ($_) { # quiet warnings when $_ is the empty string |
2424
|
738
|
50
|
|
|
|
1676
|
barf "Dimensions must be non-negative" if $_<0; |
2425
|
738
|
|
|
|
|
1117
|
$nelems *= $_; push @dims, $_ |
|
738
|
|
|
|
|
1387
|
|
2426
|
|
|
|
|
|
|
} else { |
2427
|
14
|
|
|
|
|
25
|
$nelems *= 0; push @dims, 0; |
|
14
|
|
|
|
|
40
|
|
2428
|
|
|
|
|
|
|
} |
2429
|
|
|
|
|
|
|
} |
2430
|
|
|
|
|
|
|
} |
2431
|
417
|
|
|
|
|
4702
|
my $pdl = $class->initialize(); |
2432
|
417
|
|
|
|
|
2774
|
$pdl->set_datatype($type); |
2433
|
417
|
|
|
|
|
2511
|
$pdl->setdims([@dims]); |
2434
|
417
|
100
|
|
|
|
1792
|
print "Dims: ",(join ',',@dims)," DLen: ",(length $ {$pdl->get_dataref}),"\n" if $PDLA::debug; |
|
10
|
|
|
|
|
642
|
|
2435
|
417
|
|
|
|
|
1156
|
return $pdl; |
2436
|
|
|
|
|
|
|
} |
2437
|
|
|
|
|
|
|
|
2438
|
|
|
|
|
|
|
=head2 isnull |
2439
|
|
|
|
|
|
|
|
2440
|
|
|
|
|
|
|
=for ref |
2441
|
|
|
|
|
|
|
|
2442
|
|
|
|
|
|
|
Test whether a piddle is null |
2443
|
|
|
|
|
|
|
|
2444
|
|
|
|
|
|
|
=for usage |
2445
|
|
|
|
|
|
|
|
2446
|
|
|
|
|
|
|
croak("Input piddle mustn't be null!") |
2447
|
|
|
|
|
|
|
if $input_piddle->isnull; |
2448
|
|
|
|
|
|
|
|
2449
|
|
|
|
|
|
|
This function returns 1 if the piddle is null, zero if it is not. The purpose |
2450
|
|
|
|
|
|
|
of null piddles is to "tell" any PDLA::PP methods to allocate new memory for |
2451
|
|
|
|
|
|
|
an output piddle, but only when that PDLA::PP method is called in full-arg |
2452
|
|
|
|
|
|
|
form. Of course, there's no reason you couldn't commandeer the special value |
2453
|
|
|
|
|
|
|
for your own purposes, for which this test function would prove most helpful. |
2454
|
|
|
|
|
|
|
But in general, you shouldn't need to test for a piddle's nullness. |
2455
|
|
|
|
|
|
|
|
2456
|
|
|
|
|
|
|
See L for more information. |
2457
|
|
|
|
|
|
|
|
2458
|
|
|
|
|
|
|
=head2 isempty |
2459
|
|
|
|
|
|
|
|
2460
|
|
|
|
|
|
|
=for ref |
2461
|
|
|
|
|
|
|
|
2462
|
|
|
|
|
|
|
Test whether a piddle is empty |
2463
|
|
|
|
|
|
|
|
2464
|
|
|
|
|
|
|
=for usage |
2465
|
|
|
|
|
|
|
|
2466
|
|
|
|
|
|
|
print "The piddle has zero dimension\n" if $pdl->isempty; |
2467
|
|
|
|
|
|
|
|
2468
|
|
|
|
|
|
|
This function returns 1 if the piddle has zero elements. This is |
2469
|
|
|
|
|
|
|
useful in particular when using the indexing function which. In the |
2470
|
|
|
|
|
|
|
case of no match to a specified criterion, the returned piddle has |
2471
|
|
|
|
|
|
|
zero dimension. |
2472
|
|
|
|
|
|
|
|
2473
|
|
|
|
|
|
|
pdla> $w=sequence(10) |
2474
|
|
|
|
|
|
|
pdla> $i=which($w < -1) |
2475
|
|
|
|
|
|
|
pdla> print "I found no matches!\n" if ($i->isempty); |
2476
|
|
|
|
|
|
|
I found no matches! |
2477
|
|
|
|
|
|
|
|
2478
|
|
|
|
|
|
|
Note that having zero elements is rather different from the concept |
2479
|
|
|
|
|
|
|
of being a null piddle, see the L and |
2480
|
|
|
|
|
|
|
L |
2481
|
|
|
|
|
|
|
manpages for discussions of this. |
2482
|
|
|
|
|
|
|
|
2483
|
|
|
|
|
|
|
=cut |
2484
|
|
|
|
|
|
|
|
2485
|
|
|
|
|
|
|
sub PDLA::isempty { |
2486
|
182
|
|
|
182
|
0
|
326
|
my $pdl=shift; |
2487
|
182
|
|
|
|
|
921
|
return ($pdl->nelem == 0); |
2488
|
|
|
|
|
|
|
} |
2489
|
|
|
|
|
|
|
|
2490
|
|
|
|
|
|
|
=head2 zeroes |
2491
|
|
|
|
|
|
|
|
2492
|
|
|
|
|
|
|
=for ref |
2493
|
|
|
|
|
|
|
|
2494
|
|
|
|
|
|
|
construct a zero filled piddle from dimension list or template piddle. |
2495
|
|
|
|
|
|
|
|
2496
|
|
|
|
|
|
|
Various forms of usage, |
2497
|
|
|
|
|
|
|
|
2498
|
|
|
|
|
|
|
(i) by specification or (ii) by template piddle: |
2499
|
|
|
|
|
|
|
|
2500
|
|
|
|
|
|
|
=for usage |
2501
|
|
|
|
|
|
|
|
2502
|
|
|
|
|
|
|
# usage type (i): |
2503
|
|
|
|
|
|
|
$w = zeroes([type], $nx, $ny, $nz,...); |
2504
|
|
|
|
|
|
|
$w = PDLA->zeroes([type], $nx, $ny, $nz,...); |
2505
|
|
|
|
|
|
|
$w = $pdl->zeroes([type], $nx, $ny, $nz,...); |
2506
|
|
|
|
|
|
|
# usage type (ii): |
2507
|
|
|
|
|
|
|
$w = zeroes $y; |
2508
|
|
|
|
|
|
|
$w = $y->zeroes |
2509
|
|
|
|
|
|
|
zeroes inplace $w; # Equivalent to $w .= 0; |
2510
|
|
|
|
|
|
|
$w->inplace->zeroes; # "" |
2511
|
|
|
|
|
|
|
|
2512
|
|
|
|
|
|
|
=for example |
2513
|
|
|
|
|
|
|
|
2514
|
|
|
|
|
|
|
pdla> $z = zeroes 4,3 |
2515
|
|
|
|
|
|
|
pdla> p $z |
2516
|
|
|
|
|
|
|
[ |
2517
|
|
|
|
|
|
|
[0 0 0 0] |
2518
|
|
|
|
|
|
|
[0 0 0 0] |
2519
|
|
|
|
|
|
|
[0 0 0 0] |
2520
|
|
|
|
|
|
|
] |
2521
|
|
|
|
|
|
|
pdla> $z = zeroes ushort, 3,2 # Create ushort array |
2522
|
|
|
|
|
|
|
[ushort() etc. with no arg returns a PDLA::Types token] |
2523
|
|
|
|
|
|
|
|
2524
|
|
|
|
|
|
|
See also L |
2525
|
|
|
|
|
|
|
for details on using piddles in the dimensions list. |
2526
|
|
|
|
|
|
|
|
2527
|
|
|
|
|
|
|
=cut |
2528
|
|
|
|
|
|
|
|
2529
|
153
|
100
|
100
|
153
|
1
|
48735
|
sub zeroes { ref($_[0]) && ref($_[0]) ne 'PDLA::Type' ? PDLA::zeroes($_[0]) : PDLA->zeroes(@_) } |
2530
|
|
|
|
|
|
|
sub PDLA::zeroes { |
2531
|
213
|
|
|
213
|
0
|
514
|
my $class = shift; |
2532
|
213
|
100
|
|
|
|
868
|
my $pdl = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; |
2533
|
213
|
|
|
|
|
1588
|
$pdl.=0; |
2534
|
213
|
|
|
|
|
8536
|
return $pdl; |
2535
|
|
|
|
|
|
|
} |
2536
|
|
|
|
|
|
|
|
2537
|
|
|
|
|
|
|
# Create convenience aliases for zeroes |
2538
|
|
|
|
|
|
|
|
2539
|
|
|
|
|
|
|
=head2 zeros |
2540
|
|
|
|
|
|
|
|
2541
|
|
|
|
|
|
|
=for ref |
2542
|
|
|
|
|
|
|
|
2543
|
|
|
|
|
|
|
construct a zero filled piddle (see zeroes for usage) |
2544
|
|
|
|
|
|
|
|
2545
|
|
|
|
|
|
|
=cut |
2546
|
|
|
|
|
|
|
|
2547
|
|
|
|
|
|
|
*zeros = \&zeroes; |
2548
|
|
|
|
|
|
|
*PDLA::zeros = \&PDLA::zeroes; |
2549
|
|
|
|
|
|
|
|
2550
|
|
|
|
|
|
|
=head2 ones |
2551
|
|
|
|
|
|
|
|
2552
|
|
|
|
|
|
|
=for ref |
2553
|
|
|
|
|
|
|
|
2554
|
|
|
|
|
|
|
construct a one filled piddle |
2555
|
|
|
|
|
|
|
|
2556
|
|
|
|
|
|
|
=for usage |
2557
|
|
|
|
|
|
|
|
2558
|
|
|
|
|
|
|
$w = ones([type], $nx, $ny, $nz,...); |
2559
|
|
|
|
|
|
|
etc. (see 'zeroes') |
2560
|
|
|
|
|
|
|
|
2561
|
|
|
|
|
|
|
=for example |
2562
|
|
|
|
|
|
|
|
2563
|
|
|
|
|
|
|
see zeroes() and add one |
2564
|
|
|
|
|
|
|
|
2565
|
|
|
|
|
|
|
See also L |
2566
|
|
|
|
|
|
|
for details on using piddles in the dimensions list. |
2567
|
|
|
|
|
|
|
|
2568
|
|
|
|
|
|
|
=cut |
2569
|
|
|
|
|
|
|
|
2570
|
49
|
100
|
100
|
49
|
1
|
9981
|
sub ones { ref($_[0]) && ref($_[0]) ne 'PDLA::Type' ? PDLA::ones($_[0]) : PDLA->ones(@_) } |
2571
|
|
|
|
|
|
|
sub PDLA::ones { |
2572
|
78
|
|
|
78
|
0
|
194
|
my $class = shift; |
2573
|
78
|
100
|
|
|
|
337
|
my $pdl = scalar(@_)? $class->new_from_specification(@_) : $class->new_or_inplace; |
2574
|
78
|
|
|
|
|
706
|
$pdl.=1; |
2575
|
78
|
|
|
|
|
2579
|
return $pdl; |
2576
|
|
|
|
|
|
|
} |
2577
|
|
|
|
|
|
|
|
2578
|
|
|
|
|
|
|
=head2 reshape |
2579
|
|
|
|
|
|
|
|
2580
|
|
|
|
|
|
|
=for ref |
2581
|
|
|
|
|
|
|
|
2582
|
|
|
|
|
|
|
Change the shape (i.e. dimensions) of a piddle, preserving contents. |
2583
|
|
|
|
|
|
|
|
2584
|
|
|
|
|
|
|
=for usage |
2585
|
|
|
|
|
|
|
|
2586
|
|
|
|
|
|
|
$x->reshape(NEWDIMS); reshape($x, NEWDIMS); |
2587
|
|
|
|
|
|
|
|
2588
|
|
|
|
|
|
|
The data elements are preserved, obviously they will wrap |
2589
|
|
|
|
|
|
|
differently and get truncated if the new array is shorter. |
2590
|
|
|
|
|
|
|
If the new array is longer it will be zero-padded. |
2591
|
|
|
|
|
|
|
|
2592
|
|
|
|
|
|
|
***Potential incompatibility with earlier versions of PDLA**** |
2593
|
|
|
|
|
|
|
If the list of C is empty C will just drop |
2594
|
|
|
|
|
|
|
all dimensions of size 1 (preserving the number of elements): |
2595
|
|
|
|
|
|
|
|
2596
|
|
|
|
|
|
|
$w = sequence(3,4,5); |
2597
|
|
|
|
|
|
|
$y = $w(1,3); |
2598
|
|
|
|
|
|
|
$y->reshape(); |
2599
|
|
|
|
|
|
|
print $y->info; |
2600
|
|
|
|
|
|
|
PDLA: Double D [5] |
2601
|
|
|
|
|
|
|
|
2602
|
|
|
|
|
|
|
Dimensions of size 1 will also be dropped if C is |
2603
|
|
|
|
|
|
|
invoked with the argument -1: |
2604
|
|
|
|
|
|
|
|
2605
|
|
|
|
|
|
|
$y = $w->reshape(-1); |
2606
|
|
|
|
|
|
|
|
2607
|
|
|
|
|
|
|
As opposed to C without arguments, C |
2608
|
|
|
|
|
|
|
preserves dataflow: |
2609
|
|
|
|
|
|
|
|
2610
|
|
|
|
|
|
|
$w = ones(2,1,2); |
2611
|
|
|
|
|
|
|
$y = $w(0)->reshape(-1); |
2612
|
|
|
|
|
|
|
$y++; |
2613
|
|
|
|
|
|
|
print $w; |
2614
|
|
|
|
|
|
|
[ |
2615
|
|
|
|
|
|
|
[ |
2616
|
|
|
|
|
|
|
[2 1] |
2617
|
|
|
|
|
|
|
] |
2618
|
|
|
|
|
|
|
[ |
2619
|
|
|
|
|
|
|
[2 1] |
2620
|
|
|
|
|
|
|
] |
2621
|
|
|
|
|
|
|
] |
2622
|
|
|
|
|
|
|
|
2623
|
|
|
|
|
|
|
Important: Piddles are changed inplace! |
2624
|
|
|
|
|
|
|
|
2625
|
|
|
|
|
|
|
Note: If C<$x> is connected to any other PDLA (e.g. if it is a slice) |
2626
|
|
|
|
|
|
|
then the connection is first severed. |
2627
|
|
|
|
|
|
|
|
2628
|
|
|
|
|
|
|
=for example |
2629
|
|
|
|
|
|
|
|
2630
|
|
|
|
|
|
|
pdla> $x = sequence(10) |
2631
|
|
|
|
|
|
|
pdla> reshape $x,3,4; p $x |
2632
|
|
|
|
|
|
|
[ |
2633
|
|
|
|
|
|
|
[0 1 2] |
2634
|
|
|
|
|
|
|
[3 4 5] |
2635
|
|
|
|
|
|
|
[6 7 8] |
2636
|
|
|
|
|
|
|
[9 0 0] |
2637
|
|
|
|
|
|
|
] |
2638
|
|
|
|
|
|
|
pdla> reshape $x,5; p $x |
2639
|
|
|
|
|
|
|
[0 1 2 3 4] |
2640
|
|
|
|
|
|
|
|
2641
|
|
|
|
|
|
|
=cut |
2642
|
|
|
|
|
|
|
|
2643
|
|
|
|
|
|
|
*reshape = \&PDLA::reshape; |
2644
|
|
|
|
|
|
|
sub PDLA::reshape{ |
2645
|
27
|
100
|
100
|
27
|
0
|
2192
|
if (@_ == 2 && $_[1] == -1) { # a slicing reshape that drops 1-dims |
2646
|
6
|
100
|
|
|
|
25
|
return $_[0]->slice( map { $_==1 ? [0,0,0] : [] } $_[0]->dims); |
|
11
|
|
|
|
|
43
|
|
2647
|
|
|
|
|
|
|
} |
2648
|
21
|
|
|
|
|
70
|
my $pdl = topdl($_[0]); |
2649
|
21
|
|
|
|
|
113
|
$pdl->sever; |
2650
|
21
|
|
|
|
|
61
|
my $nelem = $pdl->nelem; |
2651
|
21
|
|
|
|
|
108
|
my @dims = grep defined, @_[1..$#_]; |
2652
|
21
|
100
|
|
|
|
53
|
for my $dim(@dims) { barf "reshape: invalid dim size '$dim'" if $dim < 0 } |
|
30
|
|
|
|
|
82
|
|
2653
|
19
|
100
|
|
|
|
57
|
@dims = grep($_ != 1, $pdl->dims) if @dims == 0; # get rid of dims of size 1 |
2654
|
19
|
|
|
|
|
108
|
$pdl->setdims([@dims]); |
2655
|
19
|
|
|
|
|
87
|
$pdl->upd_data; |
2656
|
19
|
50
|
|
|
|
76
|
if ($pdl->nelem > $nelem) { |
2657
|
0
|
|
|
|
|
0
|
my $tmp=$pdl->clump(-1)->slice("$nelem:-1"); |
2658
|
0
|
|
|
|
|
0
|
$tmp .= 0; |
2659
|
|
|
|
|
|
|
} |
2660
|
19
|
|
|
|
|
54
|
$_[0] = $pdl; |
2661
|
19
|
|
|
|
|
67
|
return $pdl; |
2662
|
|
|
|
|
|
|
} |
2663
|
|
|
|
|
|
|
|
2664
|
|
|
|
|
|
|
=head2 squeeze |
2665
|
|
|
|
|
|
|
|
2666
|
|
|
|
|
|
|
=for ref |
2667
|
|
|
|
|
|
|
|
2668
|
|
|
|
|
|
|
eliminate all singleton dimensions (dims of size 1) |
2669
|
|
|
|
|
|
|
|
2670
|
|
|
|
|
|
|
=for example |
2671
|
|
|
|
|
|
|
|
2672
|
|
|
|
|
|
|
$y = $w(0,0)->squeeze; |
2673
|
|
|
|
|
|
|
|
2674
|
|
|
|
|
|
|
Alias for C. Removes all singleton dimensions |
2675
|
|
|
|
|
|
|
and preserves dataflow. A more concise interface is |
2676
|
|
|
|
|
|
|
provided by L via modifiers: |
2677
|
|
|
|
|
|
|
|
2678
|
|
|
|
|
|
|
use PDLA::NiceSlice; |
2679
|
|
|
|
|
|
|
$y = $w(0,0;-); # same as $w(0,0)->squeeze |
2680
|
|
|
|
|
|
|
|
2681
|
|
|
|
|
|
|
=cut |
2682
|
|
|
|
|
|
|
|
2683
|
|
|
|
|
|
|
*squeeze = \&PDLA::squeeze; |
2684
|
1
|
|
|
1
|
0
|
10
|
sub PDLA::squeeze { return $_[0]->reshape(-1) } |
2685
|
|
|
|
|
|
|
|
2686
|
|
|
|
|
|
|
=head2 flat |
2687
|
|
|
|
|
|
|
|
2688
|
|
|
|
|
|
|
=for ref |
2689
|
|
|
|
|
|
|
|
2690
|
|
|
|
|
|
|
flatten a piddle (alias for C<< $pdl->clump(-1) >>) |
2691
|
|
|
|
|
|
|
|
2692
|
|
|
|
|
|
|
=for example |
2693
|
|
|
|
|
|
|
|
2694
|
|
|
|
|
|
|
$srt = $pdl->flat->qsort; |
2695
|
|
|
|
|
|
|
|
2696
|
|
|
|
|
|
|
Useful method to make a 1D piddle from an |
2697
|
|
|
|
|
|
|
arbitrarily sized input piddle. Data flows |
2698
|
|
|
|
|
|
|
back and forth as usual with slicing routines. |
2699
|
|
|
|
|
|
|
Falls through if argument already E= 1D. |
2700
|
|
|
|
|
|
|
|
2701
|
|
|
|
|
|
|
=cut |
2702
|
|
|
|
|
|
|
|
2703
|
|
|
|
|
|
|
*flat = \&PDLA::flat; |
2704
|
|
|
|
|
|
|
sub PDLA::flat { # fall through if < 2D |
2705
|
209
|
100
|
|
209
|
0
|
2191
|
return my $dummy = $_[0]->getndims != 1 ? $_[0]->clump(-1) : $_[0]; |
2706
|
|
|
|
|
|
|
} |
2707
|
|
|
|
|
|
|
|
2708
|
|
|
|
|
|
|
=head2 convert |
2709
|
|
|
|
|
|
|
|
2710
|
|
|
|
|
|
|
=for ref |
2711
|
|
|
|
|
|
|
|
2712
|
|
|
|
|
|
|
Generic datatype conversion function |
2713
|
|
|
|
|
|
|
|
2714
|
|
|
|
|
|
|
=for usage |
2715
|
|
|
|
|
|
|
|
2716
|
|
|
|
|
|
|
$y = convert($x, $newtypenum); |
2717
|
|
|
|
|
|
|
|
2718
|
|
|
|
|
|
|
=for example |
2719
|
|
|
|
|
|
|
|
2720
|
|
|
|
|
|
|
$y = convert $x, long |
2721
|
|
|
|
|
|
|
$y = convert $x, ushort |
2722
|
|
|
|
|
|
|
|
2723
|
|
|
|
|
|
|
C<$newtype> is a type B, for convenience they are |
2724
|
|
|
|
|
|
|
returned by C etc when called without arguments. |
2725
|
|
|
|
|
|
|
|
2726
|
|
|
|
|
|
|
=cut |
2727
|
|
|
|
|
|
|
|
2728
|
|
|
|
|
|
|
# type to type conversion functions (with automatic conversion to pdl vars) |
2729
|
|
|
|
|
|
|
|
2730
|
|
|
|
|
|
|
sub PDLA::convert { |
2731
|
|
|
|
|
|
|
# we don't allow inplace conversion at the moment |
2732
|
|
|
|
|
|
|
# (not sure what needs to be changed) |
2733
|
169
|
50
|
|
169
|
0
|
476
|
barf 'Usage: $y = convert($x, $newtypenum)'."\n" if $#_!=1; |
2734
|
169
|
|
|
|
|
388
|
my ($pdl,$type)= @_; |
2735
|
169
|
50
|
|
|
|
400
|
$pdl = pdl($pdl) unless ref $pdl; # Allow normal numbers |
2736
|
169
|
100
|
|
|
|
592
|
$type = $type->enum if ref($type) eq 'PDLA::Type'; |
2737
|
169
|
50
|
|
|
|
663
|
barf 'Usage: $y = convert($x, $newtypenum)'."\n" unless Scalar::Util::looks_like_number($type); |
2738
|
169
|
100
|
|
|
|
1288
|
return $pdl if $pdl->get_datatype == $type; |
2739
|
|
|
|
|
|
|
# make_physical-call: temporary stopgap to work around core bug |
2740
|
131
|
|
|
|
|
4960
|
my $conv = $pdl->flowconvert($type)->make_physical->sever; |
2741
|
131
|
|
|
|
|
3004
|
return $conv; |
2742
|
|
|
|
|
|
|
} |
2743
|
|
|
|
|
|
|
|
2744
|
|
|
|
|
|
|
=head2 Datatype_conversions |
2745
|
|
|
|
|
|
|
|
2746
|
|
|
|
|
|
|
=for ref |
2747
|
|
|
|
|
|
|
|
2748
|
|
|
|
|
|
|
byte|short|ushort|long|indx|longlong|float|double (shorthands to convert datatypes) |
2749
|
|
|
|
|
|
|
|
2750
|
|
|
|
|
|
|
=for usage |
2751
|
|
|
|
|
|
|
|
2752
|
|
|
|
|
|
|
$y = double $x; $y = ushort [1..10]; |
2753
|
|
|
|
|
|
|
# all of the above listed shorthands behave similarly |
2754
|
|
|
|
|
|
|
|
2755
|
|
|
|
|
|
|
When called with a piddle argument, they convert to the specific |
2756
|
|
|
|
|
|
|
datatype. |
2757
|
|
|
|
|
|
|
|
2758
|
|
|
|
|
|
|
When called with a numeric, list, listref, or string argument they |
2759
|
|
|
|
|
|
|
construct a new piddle. This is a convenience to avoid having to be |
2760
|
|
|
|
|
|
|
long-winded and say C<$x = long(pdl(42))> |
2761
|
|
|
|
|
|
|
|
2762
|
|
|
|
|
|
|
Thus one can say: |
2763
|
|
|
|
|
|
|
|
2764
|
|
|
|
|
|
|
$w = float(1,2,3,4); # 1D |
2765
|
|
|
|
|
|
|
$w = float q[1 2 3; 4 5 6]; # 2D |
2766
|
|
|
|
|
|
|
$w = float([1,2,3],[4,5,6]); # 2D |
2767
|
|
|
|
|
|
|
$w = float([[1,2,3],[4,5,6]]); # 2D |
2768
|
|
|
|
|
|
|
|
2769
|
|
|
|
|
|
|
Note the last three give identical results, and the last two are exactly |
2770
|
|
|
|
|
|
|
equivalent - a list is automatically converted to a list reference for |
2771
|
|
|
|
|
|
|
syntactic convenience. i.e. you can omit the outer C<[]> |
2772
|
|
|
|
|
|
|
|
2773
|
|
|
|
|
|
|
When called with no arguments, these functions return a special type token. |
2774
|
|
|
|
|
|
|
This allows syntactical sugar like: |
2775
|
|
|
|
|
|
|
|
2776
|
|
|
|
|
|
|
$x = ones byte, 1000,1000; |
2777
|
|
|
|
|
|
|
|
2778
|
|
|
|
|
|
|
This example creates a large piddle directly as byte datatype in |
2779
|
|
|
|
|
|
|
order to save memory. |
2780
|
|
|
|
|
|
|
|
2781
|
|
|
|
|
|
|
In order to control how undefs are handled in converting from perl lists to |
2782
|
|
|
|
|
|
|
PDLAs, one can set the variable C<$PDLA::undefval>; |
2783
|
|
|
|
|
|
|
see the function L for more details. |
2784
|
|
|
|
|
|
|
|
2785
|
|
|
|
|
|
|
=for example |
2786
|
|
|
|
|
|
|
|
2787
|
|
|
|
|
|
|
pdla> p $x=sqrt float [1..10] |
2788
|
|
|
|
|
|
|
[1 1.41421 1.73205 2 2.23607 2.44949 2.64575 2.82843 3 3.16228] |
2789
|
|
|
|
|
|
|
pdla> p byte $x |
2790
|
|
|
|
|
|
|
[1 1 1 2 2 2 2 2 3 3] |
2791
|
|
|
|
|
|
|
|
2792
|
|
|
|
|
|
|
=head2 byte |
2793
|
|
|
|
|
|
|
|
2794
|
|
|
|
|
|
|
Convert to byte datatype |
2795
|
|
|
|
|
|
|
|
2796
|
|
|
|
|
|
|
=head2 short |
2797
|
|
|
|
|
|
|
|
2798
|
|
|
|
|
|
|
Convert to short datatype |
2799
|
|
|
|
|
|
|
|
2800
|
|
|
|
|
|
|
=head2 ushort |
2801
|
|
|
|
|
|
|
|
2802
|
|
|
|
|
|
|
Convert to ushort datatype |
2803
|
|
|
|
|
|
|
|
2804
|
|
|
|
|
|
|
=head2 long |
2805
|
|
|
|
|
|
|
|
2806
|
|
|
|
|
|
|
Convert to long datatype |
2807
|
|
|
|
|
|
|
|
2808
|
|
|
|
|
|
|
=head2 indx |
2809
|
|
|
|
|
|
|
|
2810
|
|
|
|
|
|
|
Convert to indx datatype |
2811
|
|
|
|
|
|
|
|
2812
|
|
|
|
|
|
|
=head2 longlong |
2813
|
|
|
|
|
|
|
|
2814
|
|
|
|
|
|
|
Convert to longlong datatype |
2815
|
|
|
|
|
|
|
|
2816
|
|
|
|
|
|
|
=head2 float |
2817
|
|
|
|
|
|
|
|
2818
|
|
|
|
|
|
|
Convert to float datatype |
2819
|
|
|
|
|
|
|
|
2820
|
|
|
|
|
|
|
=head2 double |
2821
|
|
|
|
|
|
|
|
2822
|
|
|
|
|
|
|
Convert to double datatype |
2823
|
|
|
|
|
|
|
|
2824
|
|
|
|
|
|
|
=head2 type |
2825
|
|
|
|
|
|
|
|
2826
|
|
|
|
|
|
|
=for ref |
2827
|
|
|
|
|
|
|
|
2828
|
|
|
|
|
|
|
return the type of a piddle as a blessed type object |
2829
|
|
|
|
|
|
|
|
2830
|
|
|
|
|
|
|
A convenience function for use with the piddle constructors, e.g. |
2831
|
|
|
|
|
|
|
|
2832
|
|
|
|
|
|
|
=for example |
2833
|
|
|
|
|
|
|
|
2834
|
|
|
|
|
|
|
$y = PDLA->zeroes($x->type,$x->dims,3); |
2835
|
|
|
|
|
|
|
die "must be float" unless $x->type == float; |
2836
|
|
|
|
|
|
|
|
2837
|
|
|
|
|
|
|
See also the discussion of the C class in L. |
2838
|
|
|
|
|
|
|
Note that the C objects have overloaded comparison and |
2839
|
|
|
|
|
|
|
stringify operators so that you can compare and print types: |
2840
|
|
|
|
|
|
|
|
2841
|
|
|
|
|
|
|
$x = $x->float if $x->type < float; |
2842
|
|
|
|
|
|
|
$t = $x->type; print "Type is $t\"; |
2843
|
|
|
|
|
|
|
|
2844
|
|
|
|
|
|
|
=cut |
2845
|
|
|
|
|
|
|
|
2846
|
79
|
|
|
79
|
0
|
2719
|
sub PDLA::type { return PDLA::Type->new($_[0]->get_datatype); } |
2847
|
|
|
|
|
|
|
|
2848
|
|
|
|
|
|
|
##################### Printing #################### |
2849
|
|
|
|
|
|
|
|
2850
|
|
|
|
|
|
|
# New string routine |
2851
|
|
|
|
|
|
|
|
2852
|
|
|
|
|
|
|
$PDLA::_STRINGIZING = 0; |
2853
|
|
|
|
|
|
|
|
2854
|
|
|
|
|
|
|
sub PDLA::string { |
2855
|
218
|
|
|
218
|
0
|
24518
|
my($self,$format)=@_; |
2856
|
218
|
|
|
|
|
507
|
my $to_return = eval { |
2857
|
218
|
50
|
|
|
|
595
|
if($PDLA::_STRINGIZING) { |
2858
|
0
|
|
|
|
|
0
|
return "ALREADY_STRINGIZING_NO_LOOPS"; |
2859
|
|
|
|
|
|
|
} |
2860
|
218
|
|
|
|
|
428
|
local $PDLA::_STRINGIZING = 1; |
2861
|
218
|
|
|
|
|
1054
|
my $ndims = $self->getndims; |
2862
|
216
|
50
|
|
|
|
828
|
if($self->nelem > $PDLA::toolongtoprint) { |
2863
|
0
|
|
|
|
|
0
|
return "TOO LONG TO PRINT"; |
2864
|
|
|
|
|
|
|
} |
2865
|
216
|
100
|
|
|
|
496
|
if ($ndims==0) { |
2866
|
65
|
100
|
100
|
|
|
797
|
if ( $self->badflag() and $self->isbad() ) { |
2867
|
6
|
|
|
|
|
58
|
return "BAD"; |
2868
|
|
|
|
|
|
|
} else { |
2869
|
59
|
|
|
|
|
135
|
my @x = $self->at(); |
2870
|
59
|
50
|
|
|
|
548
|
return ($format ? sprintf($format, $x[0]) : "$x[0]"); |
2871
|
|
|
|
|
|
|
} |
2872
|
|
|
|
|
|
|
} |
2873
|
151
|
50
|
|
|
|
484
|
return "Null" if $self->isnull; |
2874
|
151
|
100
|
|
|
|
514
|
return "Empty[".join("x",$self->dims)."]" if $self->isempty; # Empty piddle |
2875
|
145
|
50
|
|
|
|
554
|
local $sep = $PDLA::use_commas ? "," : " "; |
2876
|
145
|
50
|
|
|
|
345
|
local $sep2 = $PDLA::use_commas ? "," : ""; |
2877
|
145
|
100
|
|
|
|
309
|
if ($ndims==1) { |
2878
|
94
|
|
|
|
|
259
|
return str1D($self,$format); |
2879
|
|
|
|
|
|
|
} |
2880
|
|
|
|
|
|
|
else{ |
2881
|
51
|
|
|
|
|
146
|
return strND($self,$format,0); |
2882
|
|
|
|
|
|
|
} |
2883
|
|
|
|
|
|
|
}; |
2884
|
218
|
100
|
|
|
|
673
|
if ($@) { |
2885
|
|
|
|
|
|
|
# Remove reference to this line: |
2886
|
2
|
|
|
|
|
20
|
$@ =~ s/\s*at .* line \d+\s*\.\n*/./; |
2887
|
2
|
|
|
|
|
7
|
PDLA::Core::barf("Stringizing problem: $@"); |
2888
|
|
|
|
|
|
|
} |
2889
|
216
|
|
|
|
|
3530
|
return $to_return; |
2890
|
|
|
|
|
|
|
} |
2891
|
|
|
|
|
|
|
|
2892
|
|
|
|
|
|
|
############## Section/subsection functions ################### |
2893
|
|
|
|
|
|
|
|
2894
|
|
|
|
|
|
|
=head2 list |
2895
|
|
|
|
|
|
|
|
2896
|
|
|
|
|
|
|
=for ref |
2897
|
|
|
|
|
|
|
|
2898
|
|
|
|
|
|
|
Convert piddle to perl list |
2899
|
|
|
|
|
|
|
|
2900
|
|
|
|
|
|
|
=for usage |
2901
|
|
|
|
|
|
|
|
2902
|
|
|
|
|
|
|
@tmp = list $x; |
2903
|
|
|
|
|
|
|
|
2904
|
|
|
|
|
|
|
Obviously this is grossly inefficient for the large datasets PDLA is designed to |
2905
|
|
|
|
|
|
|
handle. This was provided as a get out while PDLA matured. It should now be mostly |
2906
|
|
|
|
|
|
|
superseded by superior constructs, such as PP/threading. However it is still |
2907
|
|
|
|
|
|
|
occasionally useful and is provied for backwards compatibility. |
2908
|
|
|
|
|
|
|
|
2909
|
|
|
|
|
|
|
=for example |
2910
|
|
|
|
|
|
|
|
2911
|
|
|
|
|
|
|
for (list $x) { |
2912
|
|
|
|
|
|
|
# Do something on each value... |
2913
|
|
|
|
|
|
|
} |
2914
|
|
|
|
|
|
|
|
2915
|
|
|
|
|
|
|
If you compile PDLA with bad value support (the default), your machine's |
2916
|
|
|
|
|
|
|
docs will also say this: |
2917
|
|
|
|
|
|
|
|
2918
|
|
|
|
|
|
|
=for bad |
2919
|
|
|
|
|
|
|
|
2920
|
|
|
|
|
|
|
list converts any bad values into the string 'BAD'. |
2921
|
|
|
|
|
|
|
|
2922
|
|
|
|
|
|
|
=cut |
2923
|
|
|
|
|
|
|
|
2924
|
|
|
|
|
|
|
# No threading, just the ordinary dims. |
2925
|
|
|
|
|
|
|
sub PDLA::list{ # pdl -> @list |
2926
|
6
|
50
|
|
6
|
0
|
32
|
barf 'Usage: list($pdl)' if $#_!=0; |
2927
|
6
|
|
|
|
|
21
|
my $pdl = PDLA->topdl(shift); |
2928
|
6
|
50
|
|
|
|
29
|
return () if nelem($pdl)==0; |
2929
|
6
|
|
|
|
|
10
|
@{listref_c($pdl)}; |
|
6
|
|
|
|
|
57
|
|
2930
|
|
|
|
|
|
|
} |
2931
|
|
|
|
|
|
|
|
2932
|
|
|
|
|
|
|
=head2 unpdl |
2933
|
|
|
|
|
|
|
|
2934
|
|
|
|
|
|
|
=for ref |
2935
|
|
|
|
|
|
|
|
2936
|
|
|
|
|
|
|
Convert piddle to nested Perl array references |
2937
|
|
|
|
|
|
|
|
2938
|
|
|
|
|
|
|
=for usage |
2939
|
|
|
|
|
|
|
|
2940
|
|
|
|
|
|
|
$arrayref = unpdl $x; |
2941
|
|
|
|
|
|
|
|
2942
|
|
|
|
|
|
|
This function returns a reference to a Perl list-of-lists structure |
2943
|
|
|
|
|
|
|
equivalent to the input piddle (within the limitation that while values |
2944
|
|
|
|
|
|
|
of elements should be preserved, the detailed datatypes will not as |
2945
|
|
|
|
|
|
|
perl itself basically has "number" data rather than byte, short, int... |
2946
|
|
|
|
|
|
|
E.g., C<< sum($x - pdl( $x->unpdl )) >> should equal 0. |
2947
|
|
|
|
|
|
|
|
2948
|
|
|
|
|
|
|
Obviously this is grossly inefficient in memory and processing for the |
2949
|
|
|
|
|
|
|
large datasets PDLA is designed to handle. Sometimes, however, you really |
2950
|
|
|
|
|
|
|
want to move your data back to Perl, and with proper dimensionality, |
2951
|
|
|
|
|
|
|
unlike C. |
2952
|
|
|
|
|
|
|
|
2953
|
|
|
|
|
|
|
=for example |
2954
|
|
|
|
|
|
|
|
2955
|
|
|
|
|
|
|
use JSON; |
2956
|
|
|
|
|
|
|
my $json = encode_json unpdl $pdl; |
2957
|
|
|
|
|
|
|
|
2958
|
|
|
|
|
|
|
If you compile PDLA with bad value support (the default), your machine's |
2959
|
|
|
|
|
|
|
docs will also say this: |
2960
|
|
|
|
|
|
|
|
2961
|
|
|
|
|
|
|
=cut |
2962
|
|
|
|
|
|
|
|
2963
|
|
|
|
|
|
|
=for bad |
2964
|
|
|
|
|
|
|
|
2965
|
|
|
|
|
|
|
unpdl converts any bad values into the string 'BAD'. |
2966
|
|
|
|
|
|
|
|
2967
|
|
|
|
|
|
|
=cut |
2968
|
|
|
|
|
|
|
|
2969
|
|
|
|
|
|
|
sub PDLA::unpdl { |
2970
|
6
|
50
|
|
6
|
0
|
31
|
barf 'Usage: unpdl($pdl)' if $#_ != 0; |
2971
|
6
|
|
|
|
|
19
|
my $pdl = PDLA->topdl(shift); |
2972
|
6
|
50
|
|
|
|
43
|
return [] if $pdl->nelem == 0; |
2973
|
6
|
|
|
|
|
15
|
return _unpdl_int($pdl); |
2974
|
|
|
|
|
|
|
} |
2975
|
|
|
|
|
|
|
|
2976
|
|
|
|
|
|
|
sub _unpdl_int { |
2977
|
15
|
|
|
15
|
|
26
|
my $pdl = shift; |
2978
|
15
|
100
|
|
|
|
79
|
if ($pdl->ndims > 1) { |
2979
|
4
|
|
|
|
|
11
|
return [ map { _unpdl_int($_) } dog $pdl ]; |
|
9
|
|
|
|
|
23
|
|
2980
|
|
|
|
|
|
|
} else { |
2981
|
11
|
|
|
|
|
158
|
return listref_c($pdl); |
2982
|
|
|
|
|
|
|
} |
2983
|
|
|
|
|
|
|
} |
2984
|
|
|
|
|
|
|
|
2985
|
|
|
|
|
|
|
=head2 listindices |
2986
|
|
|
|
|
|
|
|
2987
|
|
|
|
|
|
|
=for ref |
2988
|
|
|
|
|
|
|
|
2989
|
|
|
|
|
|
|
Convert piddle indices to perl list |
2990
|
|
|
|
|
|
|
|
2991
|
|
|
|
|
|
|
=for usage |
2992
|
|
|
|
|
|
|
|
2993
|
|
|
|
|
|
|
@tmp = listindices $x; |
2994
|
|
|
|
|
|
|
|
2995
|
|
|
|
|
|
|
C<@tmp> now contains the values C<0..nelem($x)>. |
2996
|
|
|
|
|
|
|
|
2997
|
|
|
|
|
|
|
Obviously this is grossly inefficient for the large datasets PDLA is designed to |
2998
|
|
|
|
|
|
|
handle. This was provided as a get out while PDLA matured. It should now be mostly |
2999
|
|
|
|
|
|
|
superseded by superior constructs, such as PP/threading. However it is still |
3000
|
|
|
|
|
|
|
occasionally useful and is provied for backwards compatibility. |
3001
|
|
|
|
|
|
|
|
3002
|
|
|
|
|
|
|
=for example |
3003
|
|
|
|
|
|
|
|
3004
|
|
|
|
|
|
|
for $i (listindices $x) { |
3005
|
|
|
|
|
|
|
# Do something on each value... |
3006
|
|
|
|
|
|
|
} |
3007
|
|
|
|
|
|
|
|
3008
|
|
|
|
|
|
|
=cut |
3009
|
|
|
|
|
|
|
|
3010
|
|
|
|
|
|
|
sub PDLA::listindices{ # Return list of index values for 1D pdl |
3011
|
0
|
0
|
|
0
|
0
|
0
|
barf 'Usage: list($pdl)' if $#_!=0; |
3012
|
0
|
|
|
|
|
0
|
my $pdl = shift; |
3013
|
0
|
0
|
|
|
|
0
|
return () if nelem($pdl)==0; |
3014
|
0
|
0
|
|
|
|
0
|
barf 'Not 1D' if scalar(dims($pdl)) != 1; |
3015
|
0
|
|
|
|
|
0
|
return (0..nelem($pdl)-1); |
3016
|
|
|
|
|
|
|
} |
3017
|
|
|
|
|
|
|
|
3018
|
|
|
|
|
|
|
=head2 set |
3019
|
|
|
|
|
|
|
|
3020
|
|
|
|
|
|
|
=for ref |
3021
|
|
|
|
|
|
|
|
3022
|
|
|
|
|
|
|
Set a single value inside a piddle |
3023
|
|
|
|
|
|
|
|
3024
|
|
|
|
|
|
|
=for usage |
3025
|
|
|
|
|
|
|
|
3026
|
|
|
|
|
|
|
set $piddle, @position, $value |
3027
|
|
|
|
|
|
|
|
3028
|
|
|
|
|
|
|
C<@position> is a coordinate list, of size equal to the |
3029
|
|
|
|
|
|
|
number of dimensions in the piddle. Occasionally useful, |
3030
|
|
|
|
|
|
|
mainly provided for backwards compatibility as superseded |
3031
|
|
|
|
|
|
|
by use of L and assignment operator C<.=>. |
3032
|
|
|
|
|
|
|
|
3033
|
|
|
|
|
|
|
=for example |
3034
|
|
|
|
|
|
|
|
3035
|
|
|
|
|
|
|
pdla> $x = sequence 3,4 |
3036
|
|
|
|
|
|
|
pdla> set $x, 2,1,99 |
3037
|
|
|
|
|
|
|
pdla> p $x |
3038
|
|
|
|
|
|
|
[ |
3039
|
|
|
|
|
|
|
[ 0 1 2] |
3040
|
|
|
|
|
|
|
[ 3 4 99] |
3041
|
|
|
|
|
|
|
[ 6 7 8] |
3042
|
|
|
|
|
|
|
[ 9 10 11] |
3043
|
|
|
|
|
|
|
] |
3044
|
|
|
|
|
|
|
|
3045
|
|
|
|
|
|
|
=cut |
3046
|
|
|
|
|
|
|
|
3047
|
|
|
|
|
|
|
sub PDLA::set{ # Sets a particular single value |
3048
|
21
|
50
|
|
21
|
0
|
106
|
barf 'Usage: set($pdl, $x, $y,.., $value)' if $#_<2; |
3049
|
21
|
|
|
|
|
39
|
my $self = shift; my $value = pop @_; |
|
21
|
|
|
|
|
35
|
|
3050
|
21
|
|
|
|
|
128
|
set_c ($self, [@_], $value); |
3051
|
21
|
|
|
|
|
74
|
return $self; |
3052
|
|
|
|
|
|
|
} |
3053
|
|
|
|
|
|
|
|
3054
|
|
|
|
|
|
|
=head2 at |
3055
|
|
|
|
|
|
|
|
3056
|
|
|
|
|
|
|
=for ref |
3057
|
|
|
|
|
|
|
|
3058
|
|
|
|
|
|
|
Returns a single value inside a piddle as perl scalar. |
3059
|
|
|
|
|
|
|
|
3060
|
|
|
|
|
|
|
=for usage |
3061
|
|
|
|
|
|
|
|
3062
|
|
|
|
|
|
|
$z = at($piddle, @position); $z=$piddle->at(@position); |
3063
|
|
|
|
|
|
|
|
3064
|
|
|
|
|
|
|
C<@position> is a coordinate list, of size equal to the |
3065
|
|
|
|
|
|
|
number of dimensions in the piddle. Occasionally useful |
3066
|
|
|
|
|
|
|
in a general context, quite useful too inside PDLA internals. |
3067
|
|
|
|
|
|
|
|
3068
|
|
|
|
|
|
|
=for example |
3069
|
|
|
|
|
|
|
|
3070
|
|
|
|
|
|
|
pdla> $x = sequence 3,4 |
3071
|
|
|
|
|
|
|
pdla> p $x->at(1,2) |
3072
|
|
|
|
|
|
|
7 |
3073
|
|
|
|
|
|
|
|
3074
|
|
|
|
|
|
|
If you compile PDLA with bad value support (the default), your machine's |
3075
|
|
|
|
|
|
|
docs will also say this: |
3076
|
|
|
|
|
|
|
|
3077
|
|
|
|
|
|
|
=for bad |
3078
|
|
|
|
|
|
|
|
3079
|
|
|
|
|
|
|
at converts any bad values into the string 'BAD'. |
3080
|
|
|
|
|
|
|
|
3081
|
|
|
|
|
|
|
=cut |
3082
|
|
|
|
|
|
|
|
3083
|
|
|
|
|
|
|
sub PDLA::at { # Return value at ($x,$y,$z...) |
3084
|
1453
|
50
|
|
1453
|
0
|
86997
|
barf 'Usage: at($pdl, $x, $y, ...)' if $#_<0; |
3085
|
1453
|
|
|
|
|
2683
|
my $self = shift; |
3086
|
1453
|
|
|
|
|
13130
|
at_bad_c ($self, [@_]); |
3087
|
|
|
|
|
|
|
} |
3088
|
|
|
|
|
|
|
|
3089
|
|
|
|
|
|
|
=head2 sclr |
3090
|
|
|
|
|
|
|
|
3091
|
|
|
|
|
|
|
=for ref |
3092
|
|
|
|
|
|
|
|
3093
|
|
|
|
|
|
|
return a single value from a piddle as a scalar |
3094
|
|
|
|
|
|
|
|
3095
|
|
|
|
|
|
|
=for example |
3096
|
|
|
|
|
|
|
|
3097
|
|
|
|
|
|
|
$val = $x(10)->sclr; |
3098
|
|
|
|
|
|
|
$val = sclr inner($x,$y); |
3099
|
|
|
|
|
|
|
|
3100
|
|
|
|
|
|
|
The C method is useful to turn a piddle into a normal Perl |
3101
|
|
|
|
|
|
|
scalar. Its main advantage over using C for this purpose is the fact |
3102
|
|
|
|
|
|
|
that you do not need to worry if the piddle is 0D, 1D or higher dimensional. |
3103
|
|
|
|
|
|
|
Using C you have to supply the correct number of zeroes, e.g. |
3104
|
|
|
|
|
|
|
|
3105
|
|
|
|
|
|
|
$x = sequence(10); |
3106
|
|
|
|
|
|
|
$y = $x->slice('4'); |
3107
|
|
|
|
|
|
|
print $y->sclr; # no problem |
3108
|
|
|
|
|
|
|
print $y->at(); # error: needs at least one zero |
3109
|
|
|
|
|
|
|
|
3110
|
|
|
|
|
|
|
C is generally used when a Perl scalar is required instead |
3111
|
|
|
|
|
|
|
of a one-element piddle. If the input is a multielement piddle |
3112
|
|
|
|
|
|
|
the first value is returned as a Perl scalar. You can optionally |
3113
|
|
|
|
|
|
|
switch on checks to ensure that the input piddle has only one element: |
3114
|
|
|
|
|
|
|
|
3115
|
|
|
|
|
|
|
PDLA->sclr({Check => 'warn'}); # carp if called with multi-el pdls |
3116
|
|
|
|
|
|
|
PDLA->sclr({Check => 'barf'}); # croak if called with multi-el pdls |
3117
|
|
|
|
|
|
|
|
3118
|
|
|
|
|
|
|
are the commands to switch on warnings or raise an error if |
3119
|
|
|
|
|
|
|
a multielement piddle is passed as input. Note that these options |
3120
|
|
|
|
|
|
|
can only be set when C is called as a class method (see |
3121
|
|
|
|
|
|
|
example above). Use |
3122
|
|
|
|
|
|
|
|
3123
|
|
|
|
|
|
|
PDLA->sclr({Check=>0}); |
3124
|
|
|
|
|
|
|
|
3125
|
|
|
|
|
|
|
to switch these checks off again (default setting); |
3126
|
|
|
|
|
|
|
When called as a class method the resulting check mode is returned |
3127
|
|
|
|
|
|
|
(0: no checking, 1: warn, 2: barf). |
3128
|
|
|
|
|
|
|
|
3129
|
|
|
|
|
|
|
=cut |
3130
|
|
|
|
|
|
|
|
3131
|
|
|
|
|
|
|
my $chkmode = 0; # default mode no checks |
3132
|
77
|
|
|
77
|
|
39031
|
use PDLA::Options; |
|
77
|
|
|
|
|
212
|
|
|
77
|
|
|
|
|
214709
|
|
3133
|
|
|
|
|
|
|
sub PDLA::sclr { |
3134
|
221
|
|
|
221
|
0
|
1964
|
my $this = shift; |
3135
|
221
|
100
|
|
|
|
538
|
if (ref $this) { # instance method |
3136
|
220
|
50
|
33
|
|
|
623
|
carp "multielement piddle in 'sclr' call" |
3137
|
|
|
|
|
|
|
if ($chkmode == 1 && $this->nelem > 1); |
3138
|
220
|
100
|
66
|
|
|
808
|
croak "multielement piddle in 'sclr' call" |
3139
|
|
|
|
|
|
|
if ($chkmode == 2 && $this->nelem > 1); |
3140
|
218
|
|
|
|
|
2350
|
return sclr_c($this); |
3141
|
|
|
|
|
|
|
} else { # class method |
3142
|
1
|
|
|
|
|
9
|
my $check = (iparse({Check=>0},ifhref($_[0])))[1]; |
3143
|
1
|
50
|
|
|
|
8
|
if (lc($check) eq 'warn') {$chkmode = 1} |
|
0
|
50
|
|
|
|
0
|
|
3144
|
1
|
|
|
|
|
2
|
elsif (lc($check) eq 'barf') {$chkmode = 2} |
3145
|
0
|
0
|
|
|
|
0
|
else {$chkmode = $check != 0 ? 1 : 0} |
3146
|
1
|
|
|
|
|
5
|
return $chkmode; |
3147
|
|
|
|
|
|
|
} |
3148
|
|
|
|
|
|
|
} |
3149
|
|
|
|
|
|
|
|
3150
|
|
|
|
|
|
|
=head2 cat |
3151
|
|
|
|
|
|
|
|
3152
|
|
|
|
|
|
|
=for ref |
3153
|
|
|
|
|
|
|
|
3154
|
|
|
|
|
|
|
concatenate piddles to N+1 dimensional piddle |
3155
|
|
|
|
|
|
|
|
3156
|
|
|
|
|
|
|
Takes a list of N piddles of same shape as argument, |
3157
|
|
|
|
|
|
|
returns a single piddle of dimension N+1. |
3158
|
|
|
|
|
|
|
|
3159
|
|
|
|
|
|
|
=for example |
3160
|
|
|
|
|
|
|
|
3161
|
|
|
|
|
|
|
pdla> $x = cat ones(3,3),zeroes(3,3),rvals(3,3); p $x |
3162
|
|
|
|
|
|
|
[ |
3163
|
|
|
|
|
|
|
[ |
3164
|
|
|
|
|
|
|
[1 1 1] |
3165
|
|
|
|
|
|
|
[1 1 1] |
3166
|
|
|
|
|
|
|
[1 1 1] |
3167
|
|
|
|
|
|
|
] |
3168
|
|
|
|
|
|
|
[ |
3169
|
|
|
|
|
|
|
[0 0 0] |
3170
|
|
|
|
|
|
|
[0 0 0] |
3171
|
|
|
|
|
|
|
[0 0 0] |
3172
|
|
|
|
|
|
|
] |
3173
|
|
|
|
|
|
|
[ |
3174
|
|
|
|
|
|
|
[1 1 1] |
3175
|
|
|
|
|
|
|
[1 0 1] |
3176
|
|
|
|
|
|
|
[1 1 1] |
3177
|
|
|
|
|
|
|
] |
3178
|
|
|
|
|
|
|
] |
3179
|
|
|
|
|
|
|
|
3180
|
|
|
|
|
|
|
If you compile PDLA with bad value support (the default), your machine's |
3181
|
|
|
|
|
|
|
docs will also say this: |
3182
|
|
|
|
|
|
|
|
3183
|
|
|
|
|
|
|
=for bad |
3184
|
|
|
|
|
|
|
|
3185
|
|
|
|
|
|
|
The output piddle is set bad if any input piddles have their bad flag set. |
3186
|
|
|
|
|
|
|
|
3187
|
|
|
|
|
|
|
Similar functions include L, which |
3188
|
|
|
|
|
|
|
appends only two piddles along their first dimension, and |
3189
|
|
|
|
|
|
|
L, which can append more than two piddles |
3190
|
|
|
|
|
|
|
along an arbitrary dimension. |
3191
|
|
|
|
|
|
|
|
3192
|
|
|
|
|
|
|
Also consider the generic constructor L, which can handle |
3193
|
|
|
|
|
|
|
piddles of different sizes (with zero-padding), and will return a |
3194
|
|
|
|
|
|
|
piddle of type 'double' by default, but may be considerably faster (up |
3195
|
|
|
|
|
|
|
to 10x) than cat. |
3196
|
|
|
|
|
|
|
|
3197
|
|
|
|
|
|
|
=cut |
3198
|
|
|
|
|
|
|
|
3199
|
|
|
|
|
|
|
sub PDLA::cat { |
3200
|
20
|
|
|
20
|
0
|
446
|
my $res; |
3201
|
20
|
|
|
|
|
53
|
my $old_err = $@; |
3202
|
20
|
|
|
|
|
37
|
$@ = ''; |
3203
|
20
|
|
|
|
|
41
|
eval { |
3204
|
20
|
|
|
|
|
132
|
$res = $_[0]->initialize; |
3205
|
17
|
|
|
|
|
61
|
$res->set_datatype((sort {$b<=>$a} map{$_->get_datatype} @_)[0] ); |
|
35
|
|
|
|
|
143
|
|
|
43
|
|
|
|
|
185
|
|
3206
|
|
|
|
|
|
|
|
3207
|
17
|
|
|
|
|
80
|
my @resdims = $_[0]->dims; |
3208
|
17
|
|
|
|
|
55
|
for my $i(0..$#_){ |
3209
|
41
|
|
|
|
|
95
|
my @d = $_[$i]->dims; |
3210
|
41
|
|
|
|
|
88
|
for my $j(0..$#d) { |
3211
|
54
|
100
|
66
|
|
|
228
|
$resdims[$j] = $d[$j] if( !defined($resdims[$j]) or $resdims[$j]==1 ); |
3212
|
54
|
100
|
66
|
|
|
243
|
die "mismatched dims\n" if($d[$j] != 1 and $resdims[$j] != $d[$j]); |
3213
|
|
|
|
|
|
|
} |
3214
|
|
|
|
|
|
|
} |
3215
|
15
|
|
|
|
|
111
|
$res->setdims( [@resdims,scalar(@_) ]); |
3216
|
15
|
|
|
|
|
161
|
my ($i,$t); my $s = ":,"x@resdims; |
|
15
|
|
|
|
|
129
|
|
3217
|
15
|
|
|
|
|
45
|
for (@_) { $t = $res->slice($s."(".$i++.")"); $t .= $_} |
|
37
|
|
|
|
|
190
|
|
|
37
|
|
|
|
|
148
|
|
3218
|
|
|
|
|
|
|
|
3219
|
|
|
|
|
|
|
# propagate any bad flags |
3220
|
15
|
50
|
|
|
|
54
|
for (@_) { if ( $_->badflag() ) { $res->badflag(1); last; } } |
|
37
|
|
|
|
|
414
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
3221
|
|
|
|
|
|
|
}; |
3222
|
20
|
100
|
|
|
|
81
|
if ($@ eq '') { |
3223
|
|
|
|
|
|
|
# Restore the old error and return |
3224
|
15
|
|
|
|
|
35
|
$@ = $old_err; |
3225
|
15
|
|
|
|
|
67
|
return $res; |
3226
|
|
|
|
|
|
|
} |
3227
|
|
|
|
|
|
|
|
3228
|
|
|
|
|
|
|
# If we've gotten here, then there's been an error, so check things |
3229
|
|
|
|
|
|
|
# and barf out a meaningful message. |
3230
|
|
|
|
|
|
|
|
3231
|
5
|
50
|
66
|
|
|
60
|
if ($@ =~ /PDLA::Ops::assgn|mismatched/ |
|
|
|
66
|
|
|
|
|
3232
|
|
|
|
|
|
|
or $@ =~ /"badflag"/ |
3233
|
|
|
|
|
|
|
or $@ =~ /"initialize"/) { |
3234
|
5
|
|
|
|
|
12
|
my (@mismatched_dims, @not_a_piddle); |
3235
|
5
|
|
|
|
|
8
|
my $i = 0; |
3236
|
|
|
|
|
|
|
|
3237
|
|
|
|
|
|
|
# non-piddles and/or dimension mismatch. The first argument is |
3238
|
|
|
|
|
|
|
# ok unless we have the "initialize" error: |
3239
|
5
|
100
|
|
|
|
14
|
if ($@ =~ /"initialize"/) { |
3240
|
|
|
|
|
|
|
# Handle the special case that there are *no* args passed: |
3241
|
3
|
50
|
|
|
|
7
|
barf("Called PDLA::cat without any arguments") unless @_; |
3242
|
|
|
|
|
|
|
|
3243
|
3
|
|
66
|
|
|
11
|
while ($i < @_ and not eval{ $_[$i]->isa('PDLA')}) { |
|
6
|
|
|
|
|
40
|
|
3244
|
3
|
|
|
|
|
8
|
push (@not_a_piddle, $i); |
3245
|
3
|
|
|
|
|
6
|
$i++; |
3246
|
|
|
|
|
|
|
} |
3247
|
|
|
|
|
|
|
} |
3248
|
|
|
|
|
|
|
|
3249
|
|
|
|
|
|
|
# Get the dimensions of the first actual piddle in the argument |
3250
|
|
|
|
|
|
|
# list: |
3251
|
5
|
|
|
|
|
11
|
my $first_piddle_argument = $i; |
3252
|
5
|
50
|
|
|
|
23
|
my @dims = $_[$i]->dims if ref($_[$i]) =~ /PDLA/; |
3253
|
|
|
|
|
|
|
|
3254
|
|
|
|
|
|
|
# Figure out all the ways that the caller screwed up: |
3255
|
5
|
|
|
|
|
14
|
while ($i < @_) { |
3256
|
16
|
|
|
|
|
34
|
my $arg = $_[$i]; |
3257
|
|
|
|
|
|
|
# Check if not a piddle |
3258
|
16
|
100
|
|
|
|
22
|
if (not eval{$arg->isa('PDLA')}) { |
|
16
|
100
|
|
|
|
78
|
|
3259
|
4
|
|
|
|
|
8
|
push @not_a_piddle, $i; |
3260
|
|
|
|
|
|
|
} |
3261
|
|
|
|
|
|
|
# Check if different number of dimensions |
3262
|
|
|
|
|
|
|
elsif (@dims != $arg->ndims) { |
3263
|
3
|
|
|
|
|
6
|
push @mismatched_dims, $i; |
3264
|
|
|
|
|
|
|
} |
3265
|
|
|
|
|
|
|
# Check if size of dimensions agree |
3266
|
|
|
|
|
|
|
else { |
3267
|
9
|
|
|
|
|
23
|
DIMENSION: for (my $j = 0; $j < @dims; $j++) { |
3268
|
9
|
100
|
|
|
|
30
|
if ($dims[$j] != $arg->dim($j)) { |
3269
|
2
|
|
|
|
|
4
|
push @mismatched_dims, $i; |
3270
|
2
|
|
|
|
|
5
|
last DIMENSION; |
3271
|
|
|
|
|
|
|
} |
3272
|
|
|
|
|
|
|
} |
3273
|
|
|
|
|
|
|
} |
3274
|
16
|
|
|
|
|
37
|
$i++; |
3275
|
|
|
|
|
|
|
} |
3276
|
|
|
|
|
|
|
|
3277
|
|
|
|
|
|
|
# Construct a message detailing the results |
3278
|
5
|
|
|
|
|
9
|
my $message = "bad arguments passed to function PDLA::cat\n"; |
3279
|
5
|
100
|
|
|
|
24
|
if (@mismatched_dims > 1) { |
|
|
100
|
|
|
|
|
|
3280
|
|
|
|
|
|
|
# Many dimension mismatches |
3281
|
2
|
|
|
|
|
17
|
$message .= "The dimensions of arguments " |
3282
|
|
|
|
|
|
|
. join(', ', @mismatched_dims[0 .. $#mismatched_dims-1]) |
3283
|
|
|
|
|
|
|
. " and $mismatched_dims[-1] do not match the\n" |
3284
|
|
|
|
|
|
|
. " dimensions of the first piddle argument (argument $first_piddle_argument).\n"; |
3285
|
|
|
|
|
|
|
} |
3286
|
|
|
|
|
|
|
elsif (@mismatched_dims) { |
3287
|
|
|
|
|
|
|
# One dimension mismatch |
3288
|
1
|
|
|
|
|
6
|
$message .= "The dimensions of argument $mismatched_dims[0] do not match the\n" |
3289
|
|
|
|
|
|
|
. " dimensions of the first piddle argument (argument $first_piddle_argument).\n"; |
3290
|
|
|
|
|
|
|
} |
3291
|
5
|
100
|
|
|
|
16
|
if (@not_a_piddle > 1) { |
|
|
100
|
|
|
|
|
|
3292
|
|
|
|
|
|
|
# many non-piddles |
3293
|
2
|
|
|
|
|
14
|
$message .= "Arguments " . join(', ', @not_a_piddle[0 .. $#not_a_piddle-1]) |
3294
|
|
|
|
|
|
|
. " and $not_a_piddle[-1] are not piddles.\n"; |
3295
|
|
|
|
|
|
|
} |
3296
|
|
|
|
|
|
|
elsif (@not_a_piddle) { |
3297
|
|
|
|
|
|
|
# one non-piddle |
3298
|
1
|
|
|
|
|
4
|
$message .= "Argument $not_a_piddle[0] is not a piddle.\n"; |
3299
|
|
|
|
|
|
|
} |
3300
|
|
|
|
|
|
|
|
3301
|
|
|
|
|
|
|
# Handle the edge case that something else happened: |
3302
|
5
|
50
|
66
|
|
|
19
|
if (@not_a_piddle == 0 and @mismatched_dims == 0) { |
3303
|
0
|
|
|
|
|
0
|
barf("cat: unknown error from the internals:\n$@"); |
3304
|
|
|
|
|
|
|
} |
3305
|
|
|
|
|
|
|
|
3306
|
5
|
|
|
|
|
10
|
$message .= "(Argument counting starts from zero.)"; |
3307
|
5
|
|
|
|
|
600
|
croak($message); |
3308
|
|
|
|
|
|
|
} |
3309
|
|
|
|
|
|
|
else { |
3310
|
0
|
|
|
|
|
0
|
croak("cat: unknown error from the internals:\n$@"); |
3311
|
|
|
|
|
|
|
} |
3312
|
|
|
|
|
|
|
} |
3313
|
|
|
|
|
|
|
|
3314
|
|
|
|
|
|
|
=head2 dog |
3315
|
|
|
|
|
|
|
|
3316
|
|
|
|
|
|
|
=for ref |
3317
|
|
|
|
|
|
|
|
3318
|
|
|
|
|
|
|
Opposite of 'cat' :). Split N dim piddle to list of N-1 dim piddles |
3319
|
|
|
|
|
|
|
|
3320
|
|
|
|
|
|
|
Takes a single N-dimensional piddle and splits it into a list of N-1 dimensional |
3321
|
|
|
|
|
|
|
piddles. The breakup is done along the last dimension. |
3322
|
|
|
|
|
|
|
Note the dataflown connection is still preserved by default, |
3323
|
|
|
|
|
|
|
e.g.: |
3324
|
|
|
|
|
|
|
|
3325
|
|
|
|
|
|
|
=for example |
3326
|
|
|
|
|
|
|
|
3327
|
|
|
|
|
|
|
pdla> $p = ones 3,3,3 |
3328
|
|
|
|
|
|
|
pdla> ($x,$y,$c) = dog $p |
3329
|
|
|
|
|
|
|
pdla> $y++; p $p |
3330
|
|
|
|
|
|
|
[ |
3331
|
|
|
|
|
|
|
[ |
3332
|
|
|
|
|
|
|
[1 1 1] |
3333
|
|
|
|
|
|
|
[1 1 1] |
3334
|
|
|
|
|
|
|
[1 1 1] |
3335
|
|
|
|
|
|
|
] |
3336
|
|
|
|
|
|
|
[ |
3337
|
|
|
|
|
|
|
[2 2 2] |
3338
|
|
|
|
|
|
|
[2 2 2] |
3339
|
|
|
|
|
|
|
[2 2 2] |
3340
|
|
|
|
|
|
|
] |
3341
|
|
|
|
|
|
|
[ |
3342
|
|
|
|
|
|
|
[1 1 1] |
3343
|
|
|
|
|
|
|
[1 1 1] |
3344
|
|
|
|
|
|
|
[1 1 1] |
3345
|
|
|
|
|
|
|
] |
3346
|
|
|
|
|
|
|
] |
3347
|
|
|
|
|
|
|
|
3348
|
|
|
|
|
|
|
=for options |
3349
|
|
|
|
|
|
|
|
3350
|
|
|
|
|
|
|
Break => 1 Break dataflow connection (new copy) |
3351
|
|
|
|
|
|
|
|
3352
|
|
|
|
|
|
|
If you compile PDLA with bad value support (the default), your machine's |
3353
|
|
|
|
|
|
|
docs will also say this: |
3354
|
|
|
|
|
|
|
|
3355
|
|
|
|
|
|
|
=for bad |
3356
|
|
|
|
|
|
|
|
3357
|
|
|
|
|
|
|
The output piddles are set bad if the original piddle has its bad flag set. |
3358
|
|
|
|
|
|
|
|
3359
|
|
|
|
|
|
|
=cut |
3360
|
|
|
|
|
|
|
|
3361
|
|
|
|
|
|
|
sub PDLA::dog { |
3362
|
7
|
50
|
|
7
|
0
|
33
|
my $opt = pop @_ if ref($_[-1]) eq 'HASH'; |
3363
|
7
|
|
|
|
|
15
|
my $p = shift; |
3364
|
7
|
|
|
|
|
14
|
my @res; my $s = ":,"x($p->getndims-1); |
|
7
|
|
|
|
|
41
|
|
3365
|
7
|
|
|
|
|
43
|
for my $i (0..$p->getdim($p->getndims-1)-1) { |
3366
|
21
|
|
|
|
|
105
|
$res[$i] = $p->slice($s."(".$i.")"); |
3367
|
21
|
50
|
|
|
|
67
|
$res[$i] = $res[$i]->copy if $$opt{Break}; |
3368
|
21
|
|
|
|
|
39
|
$i++; |
3369
|
|
|
|
|
|
|
} |
3370
|
7
|
|
|
|
|
26
|
return @res; |
3371
|
|
|
|
|
|
|
} |
3372
|
|
|
|
|
|
|
|
3373
|
|
|
|
|
|
|
###################### Misc internal routines #################### |
3374
|
|
|
|
|
|
|
|
3375
|
|
|
|
|
|
|
# Recursively pack an N-D array ref in format [[1,1,2],[2,2,3],[2,2,2]] etc |
3376
|
|
|
|
|
|
|
# package vars $level and @dims must be initialised first. |
3377
|
|
|
|
|
|
|
|
3378
|
|
|
|
|
|
|
sub rpack { |
3379
|
0
|
|
|
0
|
0
|
0
|
my ($ptype,$x) = @_; my ($ret,$type); |
|
0
|
|
|
|
|
0
|
|
3380
|
|
|
|
|
|
|
|
3381
|
0
|
|
|
|
|
0
|
$ret = ""; |
3382
|
0
|
0
|
|
|
|
0
|
if (ref($x) eq "ARRAY") { |
|
|
0
|
|
|
|
|
|
3383
|
|
|
|
|
|
|
|
3384
|
0
|
0
|
|
|
|
0
|
if (defined($dims[$level])) { |
3385
|
0
|
0
|
|
|
|
0
|
barf 'Array is not rectangular' unless $dims[$level] == scalar(@$x); |
3386
|
|
|
|
|
|
|
}else{ |
3387
|
0
|
|
|
|
|
0
|
$dims[$level] = scalar(@$x); |
3388
|
|
|
|
|
|
|
} |
3389
|
|
|
|
|
|
|
|
3390
|
0
|
|
|
|
|
0
|
$type = ref($$x[0]); |
3391
|
0
|
0
|
|
|
|
0
|
if ($type) { |
3392
|
0
|
|
|
|
|
0
|
$level++; |
3393
|
0
|
|
|
|
|
0
|
for(@$x) { |
3394
|
0
|
0
|
|
|
|
0
|
barf 'Array is not rectangular' unless $type eq ref($_); # Equal types |
3395
|
0
|
|
|
|
|
0
|
$ret .= rpack($ptype,$_); |
3396
|
|
|
|
|
|
|
} |
3397
|
0
|
|
|
|
|
0
|
$level--; |
3398
|
|
|
|
|
|
|
} else { |
3399
|
|
|
|
|
|
|
# These are leaf nodes |
3400
|
0
|
0
|
|
|
|
0
|
$ret = pack $ptype, map {defined($_) ? $_ : $PDLA::undefval} @$x; |
|
0
|
|
|
|
|
0
|
|
3401
|
|
|
|
|
|
|
} |
3402
|
|
|
|
|
|
|
} elsif (ref($x) eq "PDLA") { |
3403
|
0
|
|
|
|
|
0
|
barf 'Cannot make a new piddle from two or more piddles, try "cat"'; |
3404
|
|
|
|
|
|
|
} else { |
3405
|
0
|
|
|
|
|
0
|
barf "Don't know how to make a PDLA object from passed argument"; |
3406
|
|
|
|
|
|
|
} |
3407
|
0
|
|
|
|
|
0
|
return $ret; |
3408
|
|
|
|
|
|
|
} |
3409
|
|
|
|
|
|
|
|
3410
|
|
|
|
|
|
|
sub rcopyitem { # Return a deep copy of an item - recursively |
3411
|
0
|
|
|
0
|
0
|
0
|
my $x = shift; |
3412
|
0
|
|
|
|
|
0
|
my ($y, $key, $value); |
3413
|
0
|
0
|
|
|
|
0
|
if (ref(\$x) eq "SCALAR") { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
3414
|
0
|
|
|
|
|
0
|
return $x; |
3415
|
|
|
|
|
|
|
}elsif (ref($x) eq "SCALAR") { |
3416
|
0
|
|
|
|
|
0
|
$y = $$x; return \$y; |
|
0
|
|
|
|
|
0
|
|
3417
|
|
|
|
|
|
|
}elsif (ref($x) eq "ARRAY") { |
3418
|
0
|
|
|
|
|
0
|
$y = []; |
3419
|
0
|
|
|
|
|
0
|
for (@$x) { |
3420
|
0
|
|
|
|
|
0
|
push @$y, rcopyitem($_); |
3421
|
|
|
|
|
|
|
} |
3422
|
0
|
|
|
|
|
0
|
return $y; |
3423
|
|
|
|
|
|
|
}elsif (ref($x) eq "HASH") { |
3424
|
0
|
|
|
|
|
0
|
$y={}; |
3425
|
0
|
|
|
|
|
0
|
while (($key,$value) = each %$x) { |
3426
|
0
|
|
|
|
|
0
|
$$y{$key} = rcopyitem($value); |
3427
|
|
|
|
|
|
|
} |
3428
|
0
|
|
|
|
|
0
|
return $y; |
3429
|
|
|
|
|
|
|
}elsif (blessed($x)) { |
3430
|
0
|
|
|
|
|
0
|
return $x->copy; |
3431
|
|
|
|
|
|
|
}else{ |
3432
|
0
|
|
|
|
|
0
|
barf ('Deep copy of object failed - unknown component with type '.ref($x)); |
3433
|
|
|
|
|
|
|
} |
3434
|
0
|
|
|
|
|
0
|
0;} |
3435
|
|
|
|
|
|
|
|
3436
|
|
|
|
|
|
|
# N-D array stringifier |
3437
|
|
|
|
|
|
|
|
3438
|
|
|
|
|
|
|
sub strND { |
3439
|
55
|
|
|
55
|
0
|
116
|
my($self,$format,$level)=@_; |
3440
|
|
|
|
|
|
|
# $self->make_physical(); |
3441
|
55
|
|
|
|
|
146
|
my @dims = $self->dims; |
3442
|
|
|
|
|
|
|
# print "STRND, $#dims\n"; |
3443
|
|
|
|
|
|
|
|
3444
|
55
|
100
|
|
|
|
199
|
if ($#dims==1) { # Return 2D string |
3445
|
54
|
|
|
|
|
153
|
return str2D($self,$format,$level); |
3446
|
|
|
|
|
|
|
} |
3447
|
|
|
|
|
|
|
else { # Return list of (N-1)D strings |
3448
|
1
|
|
|
|
|
5
|
my $secbas = join '',map {":,"} @dims[0..$#dims-1]; |
|
2
|
|
|
|
|
7
|
|
3449
|
1
|
|
|
|
|
5
|
my $ret="\n"." "x$level ."["; my $j; |
|
1
|
|
|
|
|
2
|
|
3450
|
1
|
|
|
|
|
6
|
for ($j=0; $j<$dims[$#dims]; $j++) { |
3451
|
4
|
|
|
|
|
10
|
my $sec = $secbas . "($j)"; |
3452
|
|
|
|
|
|
|
# print "SLICE: $sec\n"; |
3453
|
|
|
|
|
|
|
|
3454
|
4
|
|
|
|
|
11
|
$ret .= strND($self->slice($sec),$format, $level+1); |
3455
|
4
|
|
|
|
|
26
|
chop $ret; $ret .= $sep2; |
|
4
|
|
|
|
|
14
|
|
3456
|
|
|
|
|
|
|
} |
3457
|
1
|
50
|
|
|
|
4
|
chop $ret if $PDLA::use_commas; |
3458
|
1
|
|
|
|
|
4
|
$ret .= "\n" ." "x$level ."]\n"; |
3459
|
1
|
|
|
|
|
4
|
return $ret; |
3460
|
|
|
|
|
|
|
} |
3461
|
|
|
|
|
|
|
} |
3462
|
|
|
|
|
|
|
|
3463
|
|
|
|
|
|
|
|
3464
|
|
|
|
|
|
|
# String 1D array in nice format |
3465
|
|
|
|
|
|
|
|
3466
|
|
|
|
|
|
|
sub str1D { |
3467
|
94
|
|
|
94
|
0
|
184
|
my($self,$format)=@_; |
3468
|
94
|
50
|
|
|
|
339
|
barf "Not 1D" if $self->getndims()!=1; |
3469
|
94
|
|
|
|
|
553
|
my $x = listref_c($self); |
3470
|
94
|
|
|
|
|
216
|
my ($ret,$dformat,$t); |
3471
|
94
|
|
|
|
|
163
|
$ret = "["; |
3472
|
94
|
|
|
|
|
256
|
my $dtype = $self->get_datatype(); |
3473
|
94
|
100
|
|
|
|
255
|
$dformat = $PDLA::floatformat if $dtype == $PDLA_F; |
3474
|
94
|
100
|
|
|
|
248
|
$dformat = $PDLA::doubleformat if $dtype == $PDLA_D; |
3475
|
94
|
100
|
|
|
|
200
|
$dformat = $PDLA::indxformat if $dtype == $PDLA_IND; |
3476
|
|
|
|
|
|
|
|
3477
|
94
|
|
|
|
|
433
|
my $badflag = $self->badflag(); |
3478
|
94
|
|
|
|
|
277
|
for $t (@$x) { |
3479
|
485
|
100
|
100
|
|
|
1524
|
if ( $badflag and $t eq "BAD" ) { |
|
|
50
|
|
|
|
|
|
3480
|
|
|
|
|
|
|
# do nothing |
3481
|
|
|
|
|
|
|
} elsif ($format) { |
3482
|
0
|
|
|
|
|
0
|
$t = sprintf $format,$t; |
3483
|
|
|
|
|
|
|
} else{ # Default |
3484
|
412
|
100
|
100
|
|
|
1659
|
if ($dformat && length($t)>7) { # Try smaller |
3485
|
8
|
|
|
|
|
49
|
$t = sprintf $dformat,$t; |
3486
|
|
|
|
|
|
|
} |
3487
|
|
|
|
|
|
|
} |
3488
|
485
|
|
|
|
|
1040
|
$ret .= $t.$sep; |
3489
|
|
|
|
|
|
|
} |
3490
|
|
|
|
|
|
|
|
3491
|
94
|
|
|
|
|
191
|
chop $ret; $ret.="]"; |
|
94
|
|
|
|
|
143
|
|
3492
|
94
|
|
|
|
|
415
|
return $ret; |
3493
|
|
|
|
|
|
|
} |
3494
|
|
|
|
|
|
|
|
3495
|
|
|
|
|
|
|
# String 2D array in nice uniform format |
3496
|
|
|
|
|
|
|
|
3497
|
|
|
|
|
|
|
sub str2D{ |
3498
|
54
|
|
|
54
|
0
|
113
|
my($self,$format,$level)=@_; |
3499
|
|
|
|
|
|
|
# print "STR2D:\n"; $self->printdims(); |
3500
|
54
|
|
|
|
|
133
|
my @dims = $self->dims(); |
3501
|
54
|
50
|
|
|
|
146
|
barf "Not 2D" if scalar(@dims)!=2; |
3502
|
54
|
|
|
|
|
491
|
my $x = listref_c($self); |
3503
|
54
|
|
|
|
|
258
|
my ($i, $f, $t, $len, $ret); |
3504
|
|
|
|
|
|
|
|
3505
|
54
|
|
|
|
|
216
|
my $dtype = $self->get_datatype(); |
3506
|
54
|
|
|
|
|
409
|
my $badflag = $self->badflag(); |
3507
|
|
|
|
|
|
|
|
3508
|
54
|
|
|
|
|
91
|
my $findmax = 1; |
3509
|
54
|
50
|
33
|
|
|
178
|
if (!defined $format || $format eq "") { |
3510
|
|
|
|
|
|
|
# Format not given? - find max length of default |
3511
|
54
|
|
|
|
|
94
|
$len=0; |
3512
|
|
|
|
|
|
|
|
3513
|
54
|
100
|
|
|
|
105
|
if ( $badflag ) { |
3514
|
8
|
|
|
|
|
18
|
for (@$x) { |
3515
|
70
|
100
|
|
|
|
153
|
if ( $_ eq "BAD" ) { $i = 3; } |
|
27
|
|
|
|
|
37
|
|
3516
|
43
|
|
|
|
|
72
|
else { $i = length($_); } |
3517
|
70
|
100
|
|
|
|
121
|
$len = $i>$len ? $i : $len; |
3518
|
|
|
|
|
|
|
} |
3519
|
|
|
|
|
|
|
} else { |
3520
|
46
|
100
|
|
|
|
203
|
for (@$x) {$i = length($_); $len = $i>$len ? $i : $len }; |
|
686
|
|
|
|
|
1414
|
|
|
686
|
|
|
|
|
1114
|
|
3521
|
|
|
|
|
|
|
} |
3522
|
|
|
|
|
|
|
|
3523
|
54
|
|
|
|
|
146
|
$format = "%".$len."s"; |
3524
|
|
|
|
|
|
|
|
3525
|
54
|
50
|
|
|
|
225
|
if ($len>7) { # Too long? - perhaps try smaller format |
3526
|
0
|
0
|
|
|
|
0
|
if ($dtype == $PDLA_F) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
3527
|
0
|
|
|
|
|
0
|
$format = $PDLA::floatformat; |
3528
|
|
|
|
|
|
|
} elsif ($dtype == $PDLA_D) { |
3529
|
0
|
|
|
|
|
0
|
$format = $PDLA::doubleformat; |
3530
|
|
|
|
|
|
|
} elsif ($dtype == $PDLA_IND) { |
3531
|
0
|
|
|
|
|
0
|
$format = $PDLA::indxformat; |
3532
|
|
|
|
|
|
|
} else { |
3533
|
|
|
|
|
|
|
# Stick with default |
3534
|
0
|
|
|
|
|
0
|
$findmax = 0; |
3535
|
|
|
|
|
|
|
} |
3536
|
|
|
|
|
|
|
} |
3537
|
|
|
|
|
|
|
else { |
3538
|
|
|
|
|
|
|
# Default ok |
3539
|
54
|
|
|
|
|
154
|
$findmax = 0; |
3540
|
|
|
|
|
|
|
} |
3541
|
|
|
|
|
|
|
} |
3542
|
|
|
|
|
|
|
|
3543
|
54
|
50
|
|
|
|
118
|
if($findmax) { |
3544
|
|
|
|
|
|
|
# Find max length of strings in final format |
3545
|
0
|
|
|
|
|
0
|
$len=0; |
3546
|
|
|
|
|
|
|
|
3547
|
0
|
0
|
|
|
|
0
|
if ( $badflag ) { |
3548
|
0
|
|
|
|
|
0
|
for (@$x) { |
3549
|
0
|
0
|
|
|
|
0
|
if ( $_ eq "BAD" ) { $i = 3; } |
|
0
|
|
|
|
|
0
|
|
3550
|
0
|
|
|
|
|
0
|
else { $i = length(sprintf $format,$_); } |
3551
|
0
|
0
|
|
|
|
0
|
$len = $i>$len ? $i : $len; |
3552
|
|
|
|
|
|
|
} |
3553
|
|
|
|
|
|
|
} else { |
3554
|
0
|
|
|
|
|
0
|
for (@$x) { |
3555
|
0
|
0
|
|
|
|
0
|
$i = length(sprintf $format,$_); $len = $i>$len ? $i : $len; |
|
0
|
|
|
|
|
0
|
|
3556
|
|
|
|
|
|
|
} |
3557
|
|
|
|
|
|
|
} |
3558
|
|
|
|
|
|
|
} # if: $findmax |
3559
|
|
|
|
|
|
|
|
3560
|
54
|
|
|
|
|
150
|
$ret = "\n" . " "x$level . "[\n"; |
3561
|
|
|
|
|
|
|
{ |
3562
|
54
|
|
|
|
|
75
|
my $level = $level+1; |
|
54
|
|
|
|
|
98
|
|
3563
|
54
|
|
|
|
|
115
|
$ret .= " "x$level ."["; |
3564
|
54
|
|
|
|
|
155
|
for ($i=0; $i<=$#$x; $i++) { |
3565
|
|
|
|
|
|
|
|
3566
|
756
|
100
|
100
|
|
|
1381
|
if ( $badflag and $$x[$i] eq "BAD" ) { |
3567
|
27
|
|
|
|
|
38
|
$f = "BAD"; |
3568
|
|
|
|
|
|
|
} else { |
3569
|
729
|
|
|
|
|
1617
|
$f = sprintf $format,$$x[$i]; |
3570
|
|
|
|
|
|
|
} |
3571
|
|
|
|
|
|
|
|
3572
|
756
|
100
|
|
|
|
945
|
$t = $len-length($f); $f = " "x$t .$f if $t>0; |
|
756
|
|
|
|
|
1175
|
|
3573
|
756
|
|
|
|
|
869
|
$ret .= $f; |
3574
|
756
|
100
|
|
|
|
1156
|
if (($i+1)%$dims[0]) { |
3575
|
574
|
|
|
|
|
1019
|
$ret.=$sep; |
3576
|
|
|
|
|
|
|
} |
3577
|
|
|
|
|
|
|
else{ # End of output line |
3578
|
182
|
|
|
|
|
238
|
$ret.="]"; |
3579
|
182
|
100
|
|
|
|
305
|
if ($i==$#$x) { # very last number |
3580
|
54
|
|
|
|
|
164
|
$ret.="\n"; |
3581
|
|
|
|
|
|
|
} |
3582
|
|
|
|
|
|
|
else{ |
3583
|
128
|
|
|
|
|
333
|
$ret.= $sep2."\n" . " "x$level ."["; |
3584
|
|
|
|
|
|
|
} |
3585
|
|
|
|
|
|
|
} |
3586
|
|
|
|
|
|
|
} |
3587
|
|
|
|
|
|
|
} |
3588
|
54
|
|
|
|
|
140
|
$ret .= " "x$level."]\n"; |
3589
|
54
|
|
|
|
|
279
|
return $ret; |
3590
|
|
|
|
|
|
|
} |
3591
|
|
|
|
|
|
|
|
3592
|
|
|
|
|
|
|
# |
3593
|
|
|
|
|
|
|
# Sleazy hcpy saves me time typing |
3594
|
|
|
|
|
|
|
# |
3595
|
|
|
|
|
|
|
sub PDLA::hcpy { |
3596
|
0
|
|
|
0
|
0
|
0
|
$_[0]->hdrcpy($_[1]); |
3597
|
0
|
|
|
|
|
0
|
$_[0]; |
3598
|
|
|
|
|
|
|
} |
3599
|
|
|
|
|
|
|
|
3600
|
|
|
|
|
|
|
########## Docs for functions in Core.xs ################## |
3601
|
|
|
|
|
|
|
# Pod docs for functions that are imported from Core.xs and are |
3602
|
|
|
|
|
|
|
# not documented elsewhere. Currently this is not a complete |
3603
|
|
|
|
|
|
|
# list. There are others. |
3604
|
|
|
|
|
|
|
|
3605
|
|
|
|
|
|
|
=head2 gethdr |
3606
|
|
|
|
|
|
|
|
3607
|
|
|
|
|
|
|
=for ref |
3608
|
|
|
|
|
|
|
|
3609
|
|
|
|
|
|
|
Retrieve header information from a piddle |
3610
|
|
|
|
|
|
|
|
3611
|
|
|
|
|
|
|
=for example |
3612
|
|
|
|
|
|
|
|
3613
|
|
|
|
|
|
|
$pdl=rfits('file.fits'); |
3614
|
|
|
|
|
|
|
$h=$pdl->gethdr; |
3615
|
|
|
|
|
|
|
print "Number of pixels in the X-direction=$$h{NAXIS1}\n"; |
3616
|
|
|
|
|
|
|
|
3617
|
|
|
|
|
|
|
The C function retrieves whatever header information is contained |
3618
|
|
|
|
|
|
|
within a piddle. The header can be set with L and is always a |
3619
|
|
|
|
|
|
|
hash reference or undef. |
3620
|
|
|
|
|
|
|
|
3621
|
|
|
|
|
|
|
C returns undef if the piddle has not yet had a header |
3622
|
|
|
|
|
|
|
defined; compare with C and C, which are guaranteed to return a |
3623
|
|
|
|
|
|
|
defined value. |
3624
|
|
|
|
|
|
|
|
3625
|
|
|
|
|
|
|
Note that gethdr() works by B: you can modify the header |
3626
|
|
|
|
|
|
|
in-place once it has been retrieved: |
3627
|
|
|
|
|
|
|
|
3628
|
|
|
|
|
|
|
$x = rfits($filename); |
3629
|
|
|
|
|
|
|
$xh = $x->gethdr(); |
3630
|
|
|
|
|
|
|
$xh->{FILENAME} = $filename; |
3631
|
|
|
|
|
|
|
|
3632
|
|
|
|
|
|
|
It is also important to realise that in most cases the header is not |
3633
|
|
|
|
|
|
|
automatically copied when you copy the piddle. See L |
3634
|
|
|
|
|
|
|
to enable automatic header copying. |
3635
|
|
|
|
|
|
|
|
3636
|
|
|
|
|
|
|
Here's another example: a wrapper around rcols that allows your piddle |
3637
|
|
|
|
|
|
|
to remember the file it was read from and the columns could be easily |
3638
|
|
|
|
|
|
|
written (here assuming that no regexp is needed, extensions are left |
3639
|
|
|
|
|
|
|
as an exercise for the reader) |
3640
|
|
|
|
|
|
|
|
3641
|
|
|
|
|
|
|
sub ext_rcols { |
3642
|
|
|
|
|
|
|
my ($file, @columns)=@_; |
3643
|
|
|
|
|
|
|
my $header={}; |
3644
|
|
|
|
|
|
|
$$header{File}=$file; |
3645
|
|
|
|
|
|
|
$$header{Columns}=\@columns; |
3646
|
|
|
|
|
|
|
|
3647
|
|
|
|
|
|
|
@piddles=rcols $file, @columns; |
3648
|
|
|
|
|
|
|
foreach (@piddles) { $_->sethdr($header); } |
3649
|
|
|
|
|
|
|
return @piddles; |
3650
|
|
|
|
|
|
|
} |
3651
|
|
|
|
|
|
|
|
3652
|
|
|
|
|
|
|
=head2 hdr |
3653
|
|
|
|
|
|
|
|
3654
|
|
|
|
|
|
|
=for ref |
3655
|
|
|
|
|
|
|
|
3656
|
|
|
|
|
|
|
Retrieve or set header information from a piddle |
3657
|
|
|
|
|
|
|
|
3658
|
|
|
|
|
|
|
=for example |
3659
|
|
|
|
|
|
|
|
3660
|
|
|
|
|
|
|
$pdl->hdr->{CDELT1} = 1; |
3661
|
|
|
|
|
|
|
|
3662
|
|
|
|
|
|
|
The C function allows convenient access to the header of a |
3663
|
|
|
|
|
|
|
piddle. Unlike C it is guaranteed to return a defined value, |
3664
|
|
|
|
|
|
|
so you can use it in a hash dereference as in the example. If the |
3665
|
|
|
|
|
|
|
header does not yet exist, it gets autogenerated as an empty hash. |
3666
|
|
|
|
|
|
|
|
3667
|
|
|
|
|
|
|
Note that this is usually -- but not always -- What You Want. If you |
3668
|
|
|
|
|
|
|
want to use a tied L hash, |
3669
|
|
|
|
|
|
|
for example, you should either construct it yourself and use C |
3670
|
|
|
|
|
|
|
to put it into the piddle, or use L instead. (Note that |
3671
|
|
|
|
|
|
|
you should be able to write out the FITS file successfully regardless |
3672
|
|
|
|
|
|
|
of whether your PDLA has a tied FITS header object or a vanilla hash). |
3673
|
|
|
|
|
|
|
|
3674
|
|
|
|
|
|
|
=head2 fhdr |
3675
|
|
|
|
|
|
|
|
3676
|
|
|
|
|
|
|
=for ref |
3677
|
|
|
|
|
|
|
|
3678
|
|
|
|
|
|
|
Retrieve or set FITS header information from a piddle |
3679
|
|
|
|
|
|
|
|
3680
|
|
|
|
|
|
|
=for example |
3681
|
|
|
|
|
|
|
|
3682
|
|
|
|
|
|
|
$pdl->fhdr->{CDELT1} = 1; |
3683
|
|
|
|
|
|
|
|
3684
|
|
|
|
|
|
|
The C function allows convenient access to the header of a |
3685
|
|
|
|
|
|
|
piddle. Unlike C it is guaranteed to return a defined value, |
3686
|
|
|
|
|
|
|
so you can use it in a hash dereference as in the example. If the |
3687
|
|
|
|
|
|
|
header does not yet exist, it gets autogenerated as a tied |
3688
|
|
|
|
|
|
|
L hash. |
3689
|
|
|
|
|
|
|
|
3690
|
|
|
|
|
|
|
Astro::FITS::Header tied hashes are better at matching the behavior of |
3691
|
|
|
|
|
|
|
FITS headers than are regular hashes. In particular, the hash keys |
3692
|
|
|
|
|
|
|
are CAsE INsEnSItiVE, unlike normal hash keys. See |
3693
|
|
|
|
|
|
|
L for details. |
3694
|
|
|
|
|
|
|
|
3695
|
|
|
|
|
|
|
If you do not have Astro::FITS::Header installed, you get back a |
3696
|
|
|
|
|
|
|
normal hash instead of a tied object. |
3697
|
|
|
|
|
|
|
|
3698
|
|
|
|
|
|
|
=head2 sethdr |
3699
|
|
|
|
|
|
|
|
3700
|
|
|
|
|
|
|
=for ref |
3701
|
|
|
|
|
|
|
|
3702
|
|
|
|
|
|
|
Set header information of a piddle |
3703
|
|
|
|
|
|
|
|
3704
|
|
|
|
|
|
|
=for example |
3705
|
|
|
|
|
|
|
|
3706
|
|
|
|
|
|
|
$pdl = zeroes(100,100); |
3707
|
|
|
|
|
|
|
$h = {NAXIS=>2, NAXIS1=>100, NAXIS=>100, COMMENT=>"Sample FITS-style header"}; |
3708
|
|
|
|
|
|
|
# add a FILENAME field to the header |
3709
|
|
|
|
|
|
|
$$h{FILENAME} = 'file.fits'; |
3710
|
|
|
|
|
|
|
$pdl->sethdr( $h ); |
3711
|
|
|
|
|
|
|
|
3712
|
|
|
|
|
|
|
The C function sets the header information for a piddle. |
3713
|
|
|
|
|
|
|
You must feed in a hash ref or undef, and the header field of the PDLA is |
3714
|
|
|
|
|
|
|
set to be a new ref to the same hash (or undefined). |
3715
|
|
|
|
|
|
|
|
3716
|
|
|
|
|
|
|
The hash ref requirement is a speed bump put in place since the normal |
3717
|
|
|
|
|
|
|
use of headers is to store fits header information and the like. Of course, |
3718
|
|
|
|
|
|
|
if you want you can hang whatever ugly old data structure you want off |
3719
|
|
|
|
|
|
|
of the header, but that makes life more complex. |
3720
|
|
|
|
|
|
|
|
3721
|
|
|
|
|
|
|
Remember that the hash is not copied -- the header is made into a ref |
3722
|
|
|
|
|
|
|
that points to the same underlying data. To get a real copy without |
3723
|
|
|
|
|
|
|
making any assumptions about the underlying data structure, you |
3724
|
|
|
|
|
|
|
can use one of the following: |
3725
|
|
|
|
|
|
|
|
3726
|
|
|
|
|
|
|
use PDLA::IO::Dumper; |
3727
|
|
|
|
|
|
|
$pdl->sethdr( deep_copy($h) ); |
3728
|
|
|
|
|
|
|
|
3729
|
|
|
|
|
|
|
(which is slow but general), or |
3730
|
|
|
|
|
|
|
|
3731
|
|
|
|
|
|
|
$pdl->sethdr( PDLA::_hdr_copy($h) ) |
3732
|
|
|
|
|
|
|
|
3733
|
|
|
|
|
|
|
(which uses the built-in sleazy deep copier), or (if you know that all |
3734
|
|
|
|
|
|
|
the elements happen to be scalars): |
3735
|
|
|
|
|
|
|
|
3736
|
|
|
|
|
|
|
{ my %a = %$h; |
3737
|
|
|
|
|
|
|
$pdl->sethdr(\%a); |
3738
|
|
|
|
|
|
|
} |
3739
|
|
|
|
|
|
|
|
3740
|
|
|
|
|
|
|
which is considerably faster but just copies the top level. |
3741
|
|
|
|
|
|
|
|
3742
|
|
|
|
|
|
|
The C function must be given a hash reference or undef. For |
3743
|
|
|
|
|
|
|
further information on the header, see L, L, |
3744
|
|
|
|
|
|
|
L and L. |
3745
|
|
|
|
|
|
|
|
3746
|
|
|
|
|
|
|
=head2 hdrcpy |
3747
|
|
|
|
|
|
|
|
3748
|
|
|
|
|
|
|
=for ref |
3749
|
|
|
|
|
|
|
|
3750
|
|
|
|
|
|
|
switch on/off/examine automatic header copying |
3751
|
|
|
|
|
|
|
|
3752
|
|
|
|
|
|
|
=for example |
3753
|
|
|
|
|
|
|
|
3754
|
|
|
|
|
|
|
print "hdrs will be copied" if $x->hdrcpy; |
3755
|
|
|
|
|
|
|
$x->hdrcpy(1); # switch on automatic header copying |
3756
|
|
|
|
|
|
|
$y = $x->sumover; # and $y will inherit $x's hdr |
3757
|
|
|
|
|
|
|
$x->hdrcpy(0); # and now make $x non-infectious again |
3758
|
|
|
|
|
|
|
|
3759
|
|
|
|
|
|
|
C without an argument just returns the current setting of the |
3760
|
|
|
|
|
|
|
flag. See also "hcpy" which returns its PDLA argument (and so is useful |
3761
|
|
|
|
|
|
|
in method-call pipelines). |
3762
|
|
|
|
|
|
|
|
3763
|
|
|
|
|
|
|
Normally, the optional header of a piddle is not copied automatically |
3764
|
|
|
|
|
|
|
in pdl operations. Switching on the hdrcpy flag using the C |
3765
|
|
|
|
|
|
|
method will enable automatic hdr copying. Note that an actual deep |
3766
|
|
|
|
|
|
|
copy gets made, which is rather processor-inefficient -- so avoid |
3767
|
|
|
|
|
|
|
using header copying in tight loops! |
3768
|
|
|
|
|
|
|
|
3769
|
|
|
|
|
|
|
Most PDLAs have the C flag cleared by default; however, some |
3770
|
|
|
|
|
|
|
routines (notably L) set it by default |
3771
|
|
|
|
|
|
|
where that makes more sense. |
3772
|
|
|
|
|
|
|
|
3773
|
|
|
|
|
|
|
The C flag is viral: if you set it for a PDLA, then derived |
3774
|
|
|
|
|
|
|
PDLAs will get copies of the header and will also have their C |
3775
|
|
|
|
|
|
|
flags set. For example: |
3776
|
|
|
|
|
|
|
|
3777
|
|
|
|
|
|
|
$x = xvals(50,50); |
3778
|
|
|
|
|
|
|
$x->hdrcpy(1); |
3779
|
|
|
|
|
|
|
$x->hdr->{FOO} = "bar"; |
3780
|
|
|
|
|
|
|
$y = $x++; |
3781
|
|
|
|
|
|
|
$c = $y++; |
3782
|
|
|
|
|
|
|
print $y->hdr->{FOO}, " - ", $c->hdr->{FOO}, "\n"; |
3783
|
|
|
|
|
|
|
$y->hdr->{FOO} = "baz"; |
3784
|
|
|
|
|
|
|
print $x->hdr->{FOO}, " - ", $y->hdr->{FOO}, " - ", $c->hdr->{FOO}, "\n"; |
3785
|
|
|
|
|
|
|
|
3786
|
|
|
|
|
|
|
will print: |
3787
|
|
|
|
|
|
|
|
3788
|
|
|
|
|
|
|
bar - bar |
3789
|
|
|
|
|
|
|
bar - baz - bar |
3790
|
|
|
|
|
|
|
|
3791
|
|
|
|
|
|
|
Performing an operation in which more than one PDLA has its hdrcpy flag |
3792
|
|
|
|
|
|
|
causes the resulting PDLA to take the header of the first PDLA: |
3793
|
|
|
|
|
|
|
|
3794
|
|
|
|
|
|
|
($x,$y) = sequence(5,2)->dog; |
3795
|
|
|
|
|
|
|
$x->hdrcpy(1); $y->hdrcpy(1); |
3796
|
|
|
|
|
|
|
$x->hdr->{foo} = 'a'; |
3797
|
|
|
|
|
|
|
$y->hdr->{foo} = 'b'; |
3798
|
|
|
|
|
|
|
print (($x+$y)->hdr->{foo} , ($y+$x)->hdr->{foo}); |
3799
|
|
|
|
|
|
|
|
3800
|
|
|
|
|
|
|
will print: |
3801
|
|
|
|
|
|
|
|
3802
|
|
|
|
|
|
|
a b |
3803
|
|
|
|
|
|
|
|
3804
|
|
|
|
|
|
|
=head2 hcpy |
3805
|
|
|
|
|
|
|
|
3806
|
|
|
|
|
|
|
=for ref |
3807
|
|
|
|
|
|
|
|
3808
|
|
|
|
|
|
|
Switch on/off automatic header copying, with PDLA pass-through |
3809
|
|
|
|
|
|
|
|
3810
|
|
|
|
|
|
|
=for example |
3811
|
|
|
|
|
|
|
|
3812
|
|
|
|
|
|
|
$x = rfits('foo.fits')->hcpy(0); |
3813
|
|
|
|
|
|
|
$x = rfits('foo.fits')->hcpy(1); |
3814
|
|
|
|
|
|
|
|
3815
|
|
|
|
|
|
|
C sets or clears the hdrcpy flag of a PDLA, and returns the PDLA |
3816
|
|
|
|
|
|
|
itself. That makes it convenient for inline use in expressions. |
3817
|
|
|
|
|
|
|
|
3818
|
|
|
|
|
|
|
=head2 set_autopthread_targ |
3819
|
|
|
|
|
|
|
|
3820
|
|
|
|
|
|
|
=for ref |
3821
|
|
|
|
|
|
|
|
3822
|
|
|
|
|
|
|
Set the target number of processor threads (pthreads) for multi-threaded processing. |
3823
|
|
|
|
|
|
|
|
3824
|
|
|
|
|
|
|
=for usage |
3825
|
|
|
|
|
|
|
|
3826
|
|
|
|
|
|
|
set_autopthread_targ($num_pthreads); |
3827
|
|
|
|
|
|
|
|
3828
|
|
|
|
|
|
|
C<$num_pthreads> is the target number of pthreads the auto-pthread process will try to achieve. |
3829
|
|
|
|
|
|
|
|
3830
|
|
|
|
|
|
|
See L for an overview of the auto-pthread process. |
3831
|
|
|
|
|
|
|
|
3832
|
|
|
|
|
|
|
=for example |
3833
|
|
|
|
|
|
|
|
3834
|
|
|
|
|
|
|
# Example turning on auto-pthreading for a target of 2 pthreads and for functions involving |
3835
|
|
|
|
|
|
|
# PDLAs with greater than 1M elements |
3836
|
|
|
|
|
|
|
set_autopthread_targ(2); |
3837
|
|
|
|
|
|
|
set_autopthread_size(1); |
3838
|
|
|
|
|
|
|
|
3839
|
|
|
|
|
|
|
# Execute a pdl function, processing will split into two pthreads as long as |
3840
|
|
|
|
|
|
|
# one of the pdl-threaded dimensions is divisible by 2. |
3841
|
|
|
|
|
|
|
$x = minimum($y); |
3842
|
|
|
|
|
|
|
|
3843
|
|
|
|
|
|
|
# Get the actual number of pthreads that were run. |
3844
|
|
|
|
|
|
|
$actual_pthread = get_autopthread_actual(); |
3845
|
|
|
|
|
|
|
|
3846
|
|
|
|
|
|
|
=cut |
3847
|
|
|
|
|
|
|
|
3848
|
|
|
|
|
|
|
*set_autopthread_targ = \&PDLA::set_autopthread_targ; |
3849
|
|
|
|
|
|
|
|
3850
|
|
|
|
|
|
|
=head2 get_autopthread_targ |
3851
|
|
|
|
|
|
|
|
3852
|
|
|
|
|
|
|
=for ref |
3853
|
|
|
|
|
|
|
|
3854
|
|
|
|
|
|
|
Get the current target number of processor threads (pthreads) for multi-threaded processing. |
3855
|
|
|
|
|
|
|
|
3856
|
|
|
|
|
|
|
=for usage |
3857
|
|
|
|
|
|
|
|
3858
|
|
|
|
|
|
|
$num_pthreads = get_autopthread_targ(); |
3859
|
|
|
|
|
|
|
|
3860
|
|
|
|
|
|
|
C<$num_pthreads> is the target number of pthreads the auto-pthread process will try to achieve. |
3861
|
|
|
|
|
|
|
|
3862
|
|
|
|
|
|
|
See L for an overview of the auto-pthread process. |
3863
|
|
|
|
|
|
|
|
3864
|
|
|
|
|
|
|
=cut |
3865
|
|
|
|
|
|
|
|
3866
|
|
|
|
|
|
|
*get_autopthread_targ = \&PDLA::get_autopthread_targ; |
3867
|
|
|
|
|
|
|
|
3868
|
|
|
|
|
|
|
=head2 get_autopthread_actual |
3869
|
|
|
|
|
|
|
|
3870
|
|
|
|
|
|
|
=for ref |
3871
|
|
|
|
|
|
|
|
3872
|
|
|
|
|
|
|
Get the actual number of pthreads executed for the last pdl processing function. |
3873
|
|
|
|
|
|
|
|
3874
|
|
|
|
|
|
|
=for usage |
3875
|
|
|
|
|
|
|
|
3876
|
|
|
|
|
|
|
$autopthread_actual = get_autopthread_actual(); |
3877
|
|
|
|
|
|
|
|
3878
|
|
|
|
|
|
|
C<$autopthread_actual> is the actual number of pthreads executed for the last pdl processing function. |
3879
|
|
|
|
|
|
|
|
3880
|
|
|
|
|
|
|
See L for an overview of the auto-pthread process. |
3881
|
|
|
|
|
|
|
|
3882
|
|
|
|
|
|
|
=cut |
3883
|
|
|
|
|
|
|
|
3884
|
|
|
|
|
|
|
*get_autopthread_actual = \&PDLA::get_autopthread_actual; |
3885
|
|
|
|
|
|
|
|
3886
|
|
|
|
|
|
|
=head2 set_autopthread_size |
3887
|
|
|
|
|
|
|
|
3888
|
|
|
|
|
|
|
=for ref |
3889
|
|
|
|
|
|
|
|
3890
|
|
|
|
|
|
|
Set the minimum size (in M-elements or 2^20 elements) of the largest PDLA involved in a function where auto-pthreading will |
3891
|
|
|
|
|
|
|
be performed. For small PDLAs, it probably isn't worth starting multiple pthreads, so this function |
3892
|
|
|
|
|
|
|
is used to define a minimum threshold where auto-pthreading won't be attempted. |
3893
|
|
|
|
|
|
|
|
3894
|
|
|
|
|
|
|
=for usage |
3895
|
|
|
|
|
|
|
|
3896
|
|
|
|
|
|
|
set_autopthread_size($size); |
3897
|
|
|
|
|
|
|
|
3898
|
|
|
|
|
|
|
C<$size> is the mimumum size, in M-elements or 2^20 elements (approx 1e6 elements) for the largest PDLA involved in a function. |
3899
|
|
|
|
|
|
|
|
3900
|
|
|
|
|
|
|
See L for an overview of the auto-pthread process. |
3901
|
|
|
|
|
|
|
|
3902
|
|
|
|
|
|
|
=for example |
3903
|
|
|
|
|
|
|
|
3904
|
|
|
|
|
|
|
# Example turning on auto-pthreading for a target of 2 pthreads and for functions involving |
3905
|
|
|
|
|
|
|
# PDLAs with greater than 1M elements |
3906
|
|
|
|
|
|
|
set_autopthread_targ(2); |
3907
|
|
|
|
|
|
|
set_autopthread_size(1); |
3908
|
|
|
|
|
|
|
|
3909
|
|
|
|
|
|
|
# Execute a pdl function, processing will split into two pthreads as long as |
3910
|
|
|
|
|
|
|
# one of the pdl-threaded dimensions is divisible by 2. |
3911
|
|
|
|
|
|
|
$x = minimum($y); |
3912
|
|
|
|
|
|
|
|
3913
|
|
|
|
|
|
|
# Get the actual number of pthreads that were run. |
3914
|
|
|
|
|
|
|
$actual_pthread = get_autopthread_actual(); |
3915
|
|
|
|
|
|
|
|
3916
|
|
|
|
|
|
|
=cut |
3917
|
|
|
|
|
|
|
|
3918
|
|
|
|
|
|
|
*set_autopthread_size = \&PDLA::set_autopthread_size; |
3919
|
|
|
|
|
|
|
|
3920
|
|
|
|
|
|
|
=head2 get_autopthread_size |
3921
|
|
|
|
|
|
|
|
3922
|
|
|
|
|
|
|
=for ref |
3923
|
|
|
|
|
|
|
|
3924
|
|
|
|
|
|
|
Get the current autopthread_size setting. |
3925
|
|
|
|
|
|
|
|
3926
|
|
|
|
|
|
|
=for usage |
3927
|
|
|
|
|
|
|
|
3928
|
|
|
|
|
|
|
$autopthread_size = get_autopthread_size(); |
3929
|
|
|
|
|
|
|
|
3930
|
|
|
|
|
|
|
C<$autopthread_size> is the mimumum size limit for auto_pthreading to occur, in M-elements or 2^20 elements (approx 1e6 elements) for the largest PDLA involved in a function |
3931
|
|
|
|
|
|
|
|
3932
|
|
|
|
|
|
|
See L for an overview of the auto-pthread process. |
3933
|
|
|
|
|
|
|
|
3934
|
|
|
|
|
|
|
=cut |
3935
|
|
|
|
|
|
|
|
3936
|
|
|
|
|
|
|
*get_autopthread_size = \&PDLA::get_autopthread_size; |
3937
|
|
|
|
|
|
|
|
3938
|
|
|
|
|
|
|
=head1 AUTHOR |
3939
|
|
|
|
|
|
|
|
3940
|
|
|
|
|
|
|
Copyright (C) Karl Glazebrook (kgb@aaoepp.aao.gov.au), |
3941
|
|
|
|
|
|
|
Tuomas J. Lukka, (lukka@husc.harvard.edu) and Christian |
3942
|
|
|
|
|
|
|
Soeller (c.soeller@auckland.ac.nz) 1997. |
3943
|
|
|
|
|
|
|
Modified, Craig DeForest (deforest@boulder.swri.edu) 2002. |
3944
|
|
|
|
|
|
|
All rights reserved. There is no warranty. You are allowed |
3945
|
|
|
|
|
|
|
to redistribute this software / documentation under certain |
3946
|
|
|
|
|
|
|
conditions. For details, see the file COPYING in the PDLA |
3947
|
|
|
|
|
|
|
distribution. If this file is separated from the PDLA distribution, |
3948
|
|
|
|
|
|
|
the copyright notice should be included in the file. |
3949
|
|
|
|
|
|
|
|
3950
|
|
|
|
|
|
|
=cut |
3951
|
|
|
|
|
|
|
|
3952
|
|
|
|
|
|
|
# |
3953
|
|
|
|
|
|
|
# Easier to implement in perl than in XS... |
3954
|
|
|
|
|
|
|
# -- CED |
3955
|
|
|
|
|
|
|
# |
3956
|
|
|
|
|
|
|
|
3957
|
|
|
|
|
|
|
sub PDLA::fhdr { |
3958
|
0
|
|
|
0
|
0
|
0
|
my $pdl = shift; |
3959
|
|
|
|
|
|
|
|
3960
|
0
|
0
|
0
|
|
|
0
|
return $pdl->hdr |
3961
|
|
|
|
|
|
|
if( (defined $pdl->gethdr) || |
3962
|
|
|
|
|
|
|
!defined $Astro::FITS::Header::VERSION |
3963
|
|
|
|
|
|
|
); |
3964
|
|
|
|
|
|
|
|
3965
|
|
|
|
|
|
|
# Avoid bug in 1.15 and earlier Astro::FITS::Header |
3966
|
0
|
|
|
|
|
0
|
my @hdr = ("SIMPLE = T"); |
3967
|
0
|
|
|
|
|
0
|
my $hdr = new Astro::FITS::Header(Cards=>\@hdr); |
3968
|
0
|
|
|
|
|
0
|
tie my %hdr, "Astro::FITS::Header", $hdr; |
3969
|
0
|
|
|
|
|
0
|
$pdl->sethdr(\%hdr); |
3970
|
0
|
|
|
|
|
0
|
return \%hdr; |
3971
|
|
|
|
|
|
|
} |
3972
|
|
|
|
|
|
|
|
3973
|
77
|
|
|
77
|
|
689
|
use Fcntl; |
|
77
|
|
|
|
|
176
|
|
|
77
|
|
|
|
|
24555
|
|
3974
|
|
|
|
|
|
|
|
3975
|
|
|
|
|
|
|
BEGIN { |
3976
|
77
|
|
|
77
|
|
6613
|
eval 'use File::Map 0.47 qw(:all)'; |
|
77
|
|
|
77
|
|
41283
|
|
|
77
|
|
|
|
|
511844
|
|
|
77
|
|
|
|
|
451
|
|
3977
|
77
|
50
|
|
|
|
47104
|
if ($@) { |
|
0
|
|
|
|
|
0
|
|
3978
|
0
|
0
|
|
|
|
0
|
carp "No File::Map found, using legacy mmap (if available)\n" if $PDLA::verbose; |
3979
|
|
|
|
|
|
|
sub sys_map; |
3980
|
|
|
|
|
|
|
sub PROT_READ(); |
3981
|
|
|
|
|
|
|
sub PROT_WRITE(); |
3982
|
|
|
|
|
|
|
sub MAP_SHARED(); |
3983
|
|
|
|
|
|
|
sub MAP_PRIVATE(); |
3984
|
|
|
|
|
|
|
} |
3985
|
|
|
|
|
|
|
} |
3986
|
|
|
|
|
|
|
|
3987
|
|
|
|
|
|
|
# Implement File::Map::sys_map bug fix. Also, might be possible |
3988
|
|
|
|
|
|
|
# to implement without so many external (non-Core perl) modules. |
3989
|
|
|
|
|
|
|
# |
3990
|
|
|
|
|
|
|
# sub pdl_do_sys_map { |
3991
|
|
|
|
|
|
|
# my (undef, $length, $protection, $flags, $fh, $offset) = @_; |
3992
|
|
|
|
|
|
|
# my $utf8 = File::Map::_check_layers($fh); |
3993
|
|
|
|
|
|
|
# my $fd = ($flags & MAP_ANONYMOUS) ? (-1) : fileno($fh); |
3994
|
|
|
|
|
|
|
# $offset ||= 0; |
3995
|
|
|
|
|
|
|
# File::Map::_mmap_impl($_[0], $length, $protection, $flags, $fd, $offset, $utf8); |
3996
|
|
|
|
|
|
|
# return; |
3997
|
|
|
|
|
|
|
# } |
3998
|
|
|
|
|
|
|
|
3999
|
|
|
|
|
|
|
sub PDLA::set_data_by_file_map { |
4000
|
0
|
|
|
0
|
0
|
0
|
my ($pdl,$name,$len,$shared,$writable,$creat,$mode,$trunc) = @_; |
4001
|
0
|
|
|
|
|
0
|
my $pdl_dataref = $pdl->get_dataref(); |
4002
|
|
|
|
|
|
|
|
4003
|
|
|
|
|
|
|
# Assume we have no data to free for now |
4004
|
|
|
|
|
|
|
# pdl_freedata($pdl); |
4005
|
|
|
|
|
|
|
|
4006
|
0
|
0
|
0
|
|
|
0
|
sysopen(my $fh, $name, ($writable && $shared ? O_RDWR : O_RDONLY) | ($creat ? O_CREAT : 0), $mode) |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
4007
|
|
|
|
|
|
|
or die "Error opening file '$name'\n"; |
4008
|
|
|
|
|
|
|
|
4009
|
0
|
|
|
|
|
0
|
binmode $fh; |
4010
|
|
|
|
|
|
|
|
4011
|
0
|
0
|
|
|
|
0
|
if ($trunc) { |
4012
|
0
|
0
|
|
|
|
0
|
truncate($fh,0) or die "set_data_by_mmap: truncate('$name',0) failed, $!"; |
4013
|
0
|
0
|
|
|
|
0
|
truncate($fh,$len) or die "set_data_by_mmap: truncate('$name',$len) failed, $!"; |
4014
|
|
|
|
|
|
|
} |
4015
|
|
|
|
|
|
|
|
4016
|
0
|
0
|
|
|
|
0
|
if ($len) { |
4017
|
|
|
|
|
|
|
|
4018
|
|
|
|
|
|
|
#eval { |
4019
|
|
|
|
|
|
|
# pdl_do_sys_map( # will croak if the mapping fails |
4020
|
0
|
0
|
|
|
|
0
|
if ($PDLA::debug) { |
4021
|
0
|
0
|
|
|
|
0
|
printf STDERR |
|
|
0
|
|
|
|
|
|
4022
|
|
|
|
|
|
|
"set_data_by_file_map: calling sys_map(%s,%d,%d,%d,%s,%d)\n", |
4023
|
|
|
|
|
|
|
$pdl_dataref, |
4024
|
|
|
|
|
|
|
$len, |
4025
|
|
|
|
|
|
|
PROT_READ | ($writable ? PROT_WRITE : 0), |
4026
|
|
|
|
|
|
|
($shared ? MAP_SHARED : MAP_PRIVATE), |
4027
|
|
|
|
|
|
|
$fh, |
4028
|
|
|
|
|
|
|
0; |
4029
|
|
|
|
|
|
|
} |
4030
|
|
|
|
|
|
|
|
4031
|
|
|
|
|
|
|
sys_map( # will croak if the mapping fails |
4032
|
0
|
0
|
|
|
|
0
|
${$pdl_dataref}, |
|
0
|
0
|
|
|
|
0
|
|
4033
|
|
|
|
|
|
|
$len, |
4034
|
|
|
|
|
|
|
PROT_READ | ($writable ? PROT_WRITE : 0), |
4035
|
|
|
|
|
|
|
($shared ? MAP_SHARED : MAP_PRIVATE), |
4036
|
|
|
|
|
|
|
$fh, |
4037
|
|
|
|
|
|
|
0 |
4038
|
|
|
|
|
|
|
); |
4039
|
|
|
|
|
|
|
#}; |
4040
|
|
|
|
|
|
|
|
4041
|
|
|
|
|
|
|
#if ($@) { |
4042
|
|
|
|
|
|
|
#die("Error mmapping!, '$@'\n"); |
4043
|
|
|
|
|
|
|
#} |
4044
|
|
|
|
|
|
|
|
4045
|
0
|
|
|
|
|
0
|
$pdl->upd_data; |
4046
|
|
|
|
|
|
|
|
4047
|
0
|
0
|
|
|
|
0
|
if ($PDLA::debug) { |
4048
|
0
|
|
|
|
|
0
|
printf STDERR "set_data_by_file_map: length \${\$pdl_dataref} is %d.\n", length ${$pdl_dataref}; |
|
0
|
|
|
|
|
0
|
|
4049
|
|
|
|
|
|
|
} |
4050
|
0
|
|
|
|
|
0
|
$pdl->set_state_and_add_deletedata_magic( length ${$pdl_dataref} ); |
|
0
|
|
|
|
|
0
|
|
4051
|
|
|
|
|
|
|
|
4052
|
|
|
|
|
|
|
} else { |
4053
|
|
|
|
|
|
|
|
4054
|
|
|
|
|
|
|
# Special case: zero-length file |
4055
|
0
|
|
|
|
|
0
|
$_[0] = undef; |
4056
|
|
|
|
|
|
|
} |
4057
|
|
|
|
|
|
|
|
4058
|
|
|
|
|
|
|
# PDLADEBUG_f(printf("PDLA::MMap: mapped to %p\n",$pdl->data)); |
4059
|
0
|
|
|
|
|
0
|
close $fh ; |
4060
|
|
|
|
|
|
|
} |
4061
|
|
|
|
|
|
|
|
4062
|
|
|
|
|
|
|
1; |