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