1#!perl
2
3# The purpose of this class is to provide a numerical object that can be used
4# as an element in Math::Matrix.
5#
6# See also Math::Matrix::Real, a subclass of Math::Matrix where each element is
7# a Math::Real.
8#
9# Note that the overloading of "=", i.e., to return the same object, is a
10# deliberate decision. It is done to catch the cases where Math::Matrix should
11# have called clone(), but doesn't.
12
13use strict;
14use warnings;
15
16package Math::Real;
17
18use Carp 'croak';
19use Scalar::Util 'blessed';
20
21use overload
22
23  # with_assign: + - * / % ** << >> x .
24
25  '+' => sub {
26      my ($x, $y, $swap) = @_;
27      my $class = ref $x;
28      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
29      return $class -> new($x->{val} + $y->{val});
30  },
31
32  '-' => sub {
33      my ($x, $y, $swap) = @_;
34      my $class = ref $x;
35      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
36      return $swap ? $class -> new($y->{val} - $x->{val}):
37                     $class -> new($x->{val} - $y->{val});
38  },
39
40  '*' => sub {
41      my ($x, $y, $swap) = @_;
42      my $class = ref $x;
43      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
44      return $class -> new($x->{val} * $y->{val});
45  },
46
47  '/' => sub {
48      my ($x, $y, $swap) = @_;
49      my $class = ref $x;
50      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
51      return $swap ? $class -> new($y->{val} / $x->{val}):
52                     $class -> new($x->{val} / $y->{val});
53  },
54
55  '%' => sub {
56      my ($x, $y, $swap) = @_;
57      my $class = ref $x;
58      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
59      return $swap ? $class -> new($y->{val} % $x->{val}):
60                     $class -> new($x->{val} % $y->{val});
61  },
62
63  '**' => sub {
64      my ($x, $y, $swap) = @_;
65      my $class = ref $x;
66      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
67      return $swap ? $class -> new($y->{val} ** $x->{val}):
68                     $class -> new($x->{val} ** $y->{val});
69  },
70
71  '<<' => sub {
72      my ($x, $y, $swap) = @_;
73      my $class = ref $x;
74      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
75      return $swap ? $class -> new($y->{val} << $x->{val}):
76                     $class -> new($x->{val} << $y->{val});
77  },
78
79  '>>' => sub {
80      my ($x, $y, $swap) = @_;
81      my $class = ref $x;
82      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
83      return $swap ? $class -> new($y->{val} >> $x->{val}):
84                     $class -> new($x->{val} >> $y->{val});
85  },
86
87  # assign: += -= *= /= %= **= <<= >>= x= .=
88
89  '+=' => sub {
90      my ($x, $y, $swap) = @_;
91      my $class = ref $x;
92      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
93      $x->{val} += $y->{val};
94      return $x;
95  },
96
97  '-=' => sub {
98      my ($x, $y, $swap) = @_;
99      my $class = ref $x;
100      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
101      $x->{val} -= $y->{val};
102      return $x;
103  },
104
105  '*=' => sub {
106      my ($x, $y, $swap) = @_;
107      my $class = ref $x;
108      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
109      $x->{val} *= $y->{val};
110      return $x;
111  },
112
113  '/=' => sub {
114      my ($x, $y, $swap) = @_;
115      my $class = ref $x;
116      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
117      $x->{val} /= $y->{val};
118      return $x;
119  },
120
121  '%=' => sub {
122      my ($x, $y, $swap) = @_;
123      my $class = ref $x;
124      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
125      $x->{val} %= $y->{val};
126      return $x;
127  },
128
129  '**=' => sub {
130      my ($x, $y, $swap) = @_;
131      my $class = ref $x;
132      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
133      $x->{val} **= $y->{val};
134      return $x;
135  },
136
137  '<<=' => sub {
138      my ($x, $y, $swap) = @_;
139      my $class = ref $x;
140      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
141      $x->{val} <<= $y->{val};
142      return $x;
143  },
144
145  '>>=' => sub {
146      my ($x, $y, $swap) = @_;
147      my $class = ref $x;
148      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
149      $x->{val} >>= $y->{val};
150      return $x;
151  },
152
153  # num_comparison: < <= > >= == !=
154
155  '<' => sub {
156      my ($x, $y, $swap) = @_;
157      my $class = ref $x;
158      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
159      return $x->{val} < $y->{val};
160  },
161
162  '<=' => sub {
163      my ($x, $y, $swap) = @_;
164      my $class = ref $x;
165      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
166      return $x->{val} <= $y->{val};
167  },
168
169  '>' => sub {
170      my ($x, $y, $swap) = @_;
171      my $class = ref $x;
172      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
173      return $x->{val} > $y->{val};
174  },
175
176  '>=' => sub {
177      my ($x, $y, $swap) = @_;
178      my $class = ref $x;
179      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
180      return $x->{val} >= $y->{val};
181  },
182
183  '==' => sub {
184      my ($x, $y, $swap) = @_;
185      my $class = ref $x;
186      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
187      return $x->{val} == $y->{val};
188  },
189
190  '!=' => sub {
191      my ($x, $y, $swap) = @_;
192      my $class = ref $x;
193      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
194      return $x->{val} != $y->{val};
195  },
196
197  # 3way_comparison: <=> cmp
198
199  '<=>' => sub {
200      my ($x, $y, $swap) = @_;
201      my $class = ref $x;
202      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
203
204      return $swap ? $y->{val} <=> $x->{val}
205                   : $x->{val} <=> $y->{val};
206  },
207
208  'cmp' => sub {
209      my ($x, $y, $swap) = @_;
210      my $class = ref $x;
211      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
212
213      return $swap ? $y->{val} cmp $x->{val}
214                   : $x->{val} cmp $y->{val};
215  },
216
217  # str_comparison: lt le gt ge eq ne
218
219  'lt' => sub {
220      my ($x, $y, $swap) = @_;
221      my $class = ref $x;
222      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
223      return $x->{val} lt $y->{val};
224  },
225
226  'le' => sub {
227      my ($x, $y, $swap) = @_;
228      my $class = ref $x;
229      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
230      return $x->{val} le $y->{val};
231  },
232
233  'gt' => sub {
234      my ($x, $y, $swap) = @_;
235      my $class = ref $x;
236      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
237      return $x->{val} gt $y->{val};
238  },
239
240  'ge' => sub {
241      my ($x, $y, $swap) = @_;
242      my $class = ref $x;
243      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
244      return $x->{val} ge $y->{val};
245  },
246
247  'eq' => sub {
248      my ($x, $y, $swap) = @_;
249      my $class = ref $x;
250      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
251      return $x->{val} eq $y->{val};
252  },
253
254  'ne' => sub {
255      my ($x, $y, $swap) = @_;
256      my $class = ref $x;
257      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
258      return $x->{val} ne $y->{val};
259  },
260
261  # binary: & &= | |= ^ ^= &. &.= |. |.= ^. ^.=
262
263  '&' => sub {
264      my ($x, $y, $swap) = @_;
265      my $class = ref $x;
266      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
267      return $x->{val} & $y->{val};
268  },
269
270  '&=' => sub {
271      my ($x, $y, $swap) = @_;
272      my $class = ref $x;
273      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
274      $x->{val} &= $y->{val};
275      return $x;
276  },
277
278  '|' => sub {
279      my ($x, $y, $swap) = @_;
280      my $class = ref $x;
281      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
282      return $x->{val} | $y->{val};
283  },
284
285  '|=' => sub {
286      my ($x, $y, $swap) = @_;
287      my $class = ref $x;
288      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
289      $x->{val} |= $y->{val};
290      return $x;
291  },
292
293  '^' => sub {
294      my ($x, $y, $swap) = @_;
295      my $class = ref $x;
296      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
297      return $x->{val} ^ $y->{val};
298  },
299
300  '^=' => sub {
301      my ($x, $y, $swap) = @_;
302      my $class = ref $x;
303      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
304      $x->{val} ^= $y->{val};
305      return $x;
306  },
307
308  # The following requires "use feature 'bitwise';":
309  #
310  # '&.' => sub {
311  #     my ($x, $y, $swap) = @_;
312  #     my $class = ref $x;
313  #     $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
314  #     return $x->{val} &. $y->{val};
315  # },
316  #
317  # '&.=' => sub {
318  #     my ($x, $y, $swap) = @_;
319  #     my $class = ref $x;
320  #     $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
321  #     $x->{val} &.= $y->{val};
322  #     return $x;
323  # },
324  #
325  # '|.' => sub {
326  #     my ($x, $y, $swap) = @_;
327  #     my $class = ref $x;
328  #     $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
329  #     return $x->{val} |. $y->{val};
330  # },
331  #
332  # '|.=' => sub {
333  #     my ($x, $y, $swap) = @_;
334  #     my $class = ref $x;
335  #     $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
336  #     $x->{val} |.= $y->{val};
337  #     return $x;
338  # },
339  #
340  # '^.' => sub {
341  #     my ($x, $y, $swap) = @_;
342  #     my $class = ref $x;
343  #     $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
344  #     return $x->{val} ^. $y->{val};
345  # },
346  #
347  # '^.=' => sub {
348  #     my ($x, $y, $swap) = @_;
349  #     my $class = ref $x;
350  #     $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
351  #     $x->{val} ^.= $y->{val};
352  #     return $x;
353  # },
354
355  # unary: neg ! ~ ~.
356
357  'neg' => sub {
358      my ($x, $y, $swap) = @_;
359      my $class = ref $x;
360      return $class -> new(-$x->{val});
361  },
362
363  '!' => sub {
364      my ($x, $y, $swap) = @_;
365      my $class = ref $x;
366      return $class -> new(!$x->{val});
367  },
368
369  # mutators: ++ --
370
371  '++' => sub {
372      my ($x, $y, $swap) = @_;
373      $x->{val}++;
374      return $x;
375  },
376
377  '--' => sub {
378      my ($x, $y, $swap) = @_;
379      $x->{val}--;
380      return $x;
381  },
382
383  # func: atan2 cos sin exp abs log sqrt int
384
385  'atan2' => sub {
386      my ($x, $y, $swap) = @_;
387      my $class = ref $x;
388      $y = $class -> new($y) unless blessed($y) && $y -> isa($class);
389
390      return $swap ? $class -> new(atan2($y->{val}, $x->{val}))
391                   : $class -> new(atan2($x->{val}, $y->{val}));
392  },
393
394  'cos' => sub {
395      my $x = shift;
396      my $class = ref $x;
397      return $class -> new(cos($x->{val}));
398  },
399
400  'sin' => sub {
401      my $x = shift;
402      my $class = ref $x;
403      return $class -> new(sin($x->{val}));
404  },
405
406  'exp' => sub {
407      my $x = shift;
408      my $class = ref $x;
409      return $class -> new(exp($x->{val}));
410  },
411
412  'abs' => sub {
413      my $x = shift;
414      my $class = ref $x;
415      return $class -> new(abs($x->{val}));
416  },
417
418  'log' => sub {
419      my $x = shift;
420      my $class = ref $x;
421      return $class -> new(log($x->{val}));
422  },
423
424  'sqrt' => sub {
425      my $x = shift;
426      my $class = ref $x;
427      return $class -> new(sqrt($x->{val}));
428  },
429
430  'int' => sub {
431      my $x = shift;
432      my $class = ref $x;
433      return $class -> new(int($x->{val}));
434  },
435
436  # conversion: bool "" 0+ qr
437
438  'bool' => sub {
439      my $x = shift;
440      $x->{val};
441  },
442
443  '""' => sub {
444      my $x = shift;
445      "" . $x->{val};
446  },
447
448  '0+' => sub {
449      my $x = shift;
450      0 + $x->{val};
451  },
452
453  # iterators: <>
454
455  # filetest: -X
456
457  # dereferencing: ${} @{} %{} &{} *{}
458
459  # matching: ~~
460
461  # special: nomethod fallback =
462
463  'fallback' => "",     # no autogenerating of methods
464
465  '=' => sub {
466      my ($x, $y, $swap) = @_;
467      return $x -> clone();
468  },
469
470  ;
471
472sub new {
473    croak "Too many arguments for ", (caller(0))[3]   if @_ > 2;
474    croak "Not enough arguments for ", (caller(0))[3] if @_ < 2;
475    my $self    = shift;
476    my $selfref = ref $self;
477    my $class   = $selfref || $self;
478
479    croak +(caller(0))[3], " is a class method, not an instance method"
480      if $selfref;
481
482    my $val = shift;
483    croak "Input must be a defined value in ", (caller(0))[3]
484      unless defined $val;
485
486    my $ref = ref $val;
487    croak "Input must be a scalar, not a $ref in ", (caller(0))[3] if $ref;
488
489    croak "Input argument doesn't look like a number in ", (caller(0))[3]
490      unless $val =~ /^[+-]?(\d+(\.\d*)?|\.\d+)([Ee][+-]?\d+)?\z/;
491
492    return bless { val => $val }, $class;
493}
494
495sub clone {
496    croak "Too many arguments for ", (caller(0))[3]   if @_ > 1;
497    croak "Not enough arguments for ", (caller(0))[3] if @_ < 1;
498    my $self    = shift;
499    my $selfref = ref $self;
500    my $class   = $selfref || $self;
501
502    croak +(caller(0))[3], " is an instance method, not a class method"
503      unless $selfref;
504
505    return bless { val => $self->{val} }, $class;
506}
507
5081;
509