1/* Various operators as functions. 2 */ 3 4logical_and a b = a && b; 5logical_or a b = a || b; 6bitwise_and a b = a & b; 7bitwise_or a b = a | b; 8eor a b = a ^ b; 9left_shift a b = a << b; 10right_shift a b = a >> b; 11not a = !a; 12 13less a b = a < b; 14more a b = a > b; 15less_equal a b = a <= b; 16more_equal a b = a >= b; 17equal a b = a == b; 18not_equal a b = a != b; 19pointer_equal a b = a === b; 20not_pointer_equal a b = a !== b; 21 22add a b = a + b; 23subtract a b = a - b; 24multiply a b = a * b; 25divide a b = a / b; 26power a b = a ** b; 27square x = x * x; 28remainder a b = a % b; 29 30cons a b = a : b; 31join a b = a ++ b; 32subscript a b = a ? b; 33 34generate s n f = [s, n .. f]; 35comma r i = (r, i); 36 37compose f g = f @ g; 38 39cast_unsigned_char x = (unsigned char) x; 40cast_signed_char x = (signed char) x; 41cast_unsigned_short x = (unsigned short) x; 42cast_signed_short x = (signed short) x; 43cast_unsigned_int x = (unsigned int) x; 44cast_signed_int x = (signed int) x; 45cast_float x = (float) x; 46cast_double x = (double) x; 47cast_complex x = (complex) x; 48cast_double_complex x = (double complex) x; 49 50unary_minus x = -x; 51negate x = !x; 52complement x = ~x; 53unary_plus x = +x; 54 55if_then_else a b c = if a then b else c; 56 57// the vector ops ... im is an image, vec is a real_list 58vec op_name im vec 59 = im_lintra_vec ones im vec, 60 op_name == "add" || op_name == "add'" 61 = im_lintra_vec ones (-1 * im) vec, 62 op_name == "subtract'" 63 = im_lintra_vec ones im inv, 64 op_name == "subtract" 65 = im_lintra_vec vec im zeros, 66 op_name == "multiply" || op_name == "multiply'" 67 = im_lintra_vec vec (1 / im) zeros, 68 op_name == "divide'" 69 = im_lintra_vec recip im zeros, 70 op_name == "divide" 71 = im_expntra_vec im vec, 72 op_name == "power'" 73 = im_powtra_vec im vec, 74 op_name == "power" 75 = im_remainderconst_vec im vec, 76 op_name == "remainder" 77 = im_andimage_vec im vec, 78 op_name == "bitwise_and" || op_name == "bitwise_and'" 79 = im_orimage_vec im vec, 80 op_name == "bitwise_or" || op_name == "bitwise_or'" 81 = im_eorimage_vec im vec, 82 op_name == "eor" || op_name == "eor'" 83 = im_equal_vec im vec, 84 op_name == "equal" || op_name == "equal'" 85 = im_notequal_vec im vec, 86 op_name == "not_equal" || op_name == "not_equal'" 87 = im_less_vec im vec, 88 op_name == "less" 89 = im_moreeq_vec im vec, 90 op_name == "less'" 91 = im_lesseq_vec im vec, 92 op_name == "less_equal" 93 = im_more_vec im vec, 94 op_name == "less_equal'" 95 = error "unimplemented vector operation" 96{ 97 zeros = map (const 0) [1 .. len vec]; 98 ones = map (const 1) [1 .. len vec]; 99 recip = map (divide 1) vec; 100 inv = map (multiply (-1)) vec; 101} 102 103/* Macbeth chart patch names. 104 */ 105_macbeth_names = [ 106 "Dark skin", 107 "Light skin", 108 "Blue sky", 109 "Foliage", 110 "Blue flower", 111 "Bluish green", 112 "Orange", 113 "Purplish blue", 114 "Moderate red", 115 "Purple", 116 "Yellow green", 117 "Orange yellow", 118 "Blue", 119 "Green", 120 "Red", 121 "Yellow", 122 "Magenta", 123 "Cyan", 124 "White (density 0.05)", 125 "Neutral 8 (density 0.23)", 126 "Neutral 6.5 (density 0.44)", 127 "Neutral 5 (density 0.70)", 128 "Neutral 3.5 (density 1.05)", 129 "Black (density 1.50)" 130]; 131 132bandsplit x 133 = oo_unary_function bandsplit_op x, is_class x 134 = map (subscript x) [0 .. bands - 1], is_image x 135 = error (errors.badargs ++ "bandsplit") 136{ 137 bands = im_header_int "Bands" x; 138 bandsplit_op = Operator "bandsplit" (map Image @ bandsplit) 139 Operator_type.COMPOUND false; 140} 141 142bandjoin l 143 = Image (concat (map get_value l)), 144 is_listof (is_instanceof "Image") l 145 = concat l, is_listof is_image l 146 = error (errors.badargs ++ "bandjoin") 147{ 148 get_value x = x.value; 149} 150 151mean x 152 = oo_unary_function mean_op x, is_class x 153 = im_avg x, is_image x 154 = error (errors.badargs ++ "mean") 155{ 156 mean_op = Operator "mean" mean_object Operator_type.COMPOUND false; 157 158 mean_object x 159 = im_avg x, is_image x 160 = mean_list x, is_real_list x || is_matrix x 161 = error (errors.badargs ++ "mean"); 162 163 mean_list l 164 = s / n 165 { 166 totals = sum l; 167 n = totals?0; 168 s = totals?1; 169 } 170 171 // return [n, sum] for a list of numbers, or a list of list of num 172 // etc. 173 sum x 174 = foldr accumulate [0, 0] x 175 { 176 accumulate x sofar 177 = [n + 1, x + s], is_real x 178 = [n + n', s + s'], is_list x 179 = error "mean_list: not real or [real]" 180 { 181 n = sofar?0; 182 s = sofar?1; 183 184 sub_acc = sum x; 185 186 n' = sub_acc?0; 187 s' = sub_acc?1; 188 } 189 } 190} 191 192deviation x 193 = oo_unary_function deviation_op x, is_class x 194 = im_deviate x, is_image x 195 = error (errors.badargs ++ "deviation") 196{ 197 deviation_op = Operator "deviation" 198 deviation_object Operator_type.COMPOUND false; 199 200 deviation_object x 201 = im_deviate x, is_image x 202 = deviation_list x, is_real_list x || is_matrix x 203 = error (errors.badargs ++ "deviation"); 204 205 deviation_list l 206 = (abs (s2 - (s * s / n)) / (n - 1)) ** 0.5 207 { 208 totals = sum_sum2_list l; 209 n = totals?0; 210 s = totals?1; 211 s2 = totals?2; 212 } 213 214 // return n, sum, sum of squares for a list of reals 215 sum_sum2_list x 216 = foldr accumulate [0, 0, 0] x 217 { 218 accumulate x sofar 219 = [n + 1, x + s, x * x + s2], is_real x 220 = [n + n', s + s', s2 + s2'], is_list x 221 = error "sum_sum2_list: not real or [real]" 222 { 223 n = sofar?0; 224 s = sofar?1; 225 s2 = sofar?2; 226 227 sub_acc = sum_sum2_list x; 228 229 n' = sub_acc?0; 230 s' = sub_acc?1; 231 s2' = sub_acc?2; 232 } 233 } 234} 235 236abs x 237 = oo_unary_function abs_op x, is_class x 238 = im_abs x, is_image x 239 = abs_cmplx x, is_complex x 240 = abs_num x, is_real x 241 = error (errors.badargs ++ "abs") 242{ 243 abs_op = Operator "abs" abs_object Operator_type.COMPOUND false; 244 245 abs_object x 246 = im_abs x, is_image x 247 = abs_cmplx x, is_complex x 248 = abs_num x, is_real x 249 = abs_list x, is_real_list x 250 = abs_list (map abs_list x), is_matrix x 251 = error (errors.badargs ++ "abs"); 252 253 abs_list l = (foldr1 add (map square l)) ** 0.5; 254 255 abs_num n 256 = n, n >= 0 257 = -n; 258 259 abs_cmplx c = ((re c)**2 + (im c)**2) ** 0.5; 260} 261 262copy x 263 = oo_unary_function copy_op x, is_class x 264 = im_copy x, is_image x 265 = x 266{ 267 copy_op = Operator "copy" copy Operator_type.COMPOUND_REWRAP false; 268} 269 270// like abs, but treat pixels as vectors ... ie. always get a 1-band image 271// back ... also treat matricies as lists of vectors 272// handy for dE from object difference 273abs_vec x 274 = oo_unary_function abs_vec_op x, is_class x 275 = abs_vec_image x, is_image x 276 = abs_vec_cmplx x, is_complex x 277 = abs_vec_num x, is_real x 278 = error (errors.badargs ++ "abs_vec") 279{ 280 abs_vec_op = Operator "abs_vec" 281 abs_vec_object Operator_type.COMPOUND false; 282 283 abs_vec_object x 284 = abs_vec_image x, is_image x 285 = abs_vec_cmplx x, is_complex x 286 = abs_vec_num x, is_real x 287 = abs_vec_list x, is_real_list x 288 = mean (Vector (map abs_vec_list x)), is_matrix x 289 = error (errors.badargs ++ "abs_vec"); 290 291 abs_vec_list l = (foldr1 add (map square l)) ** 0.5; 292 293 abs_vec_num n 294 = n, n >= 0 295 = -n; 296 297 abs_vec_cmplx c = ((re c)**2 + (im c)**2) ** 0.5; 298 299 abs_vec_image im 300 = (foldr1 add (map square (bandsplit im))) ** 0.5; 301} 302 303transpose x 304 = oo_unary_function transpose_op x, is_class x 305 = transpose_image x, is_image x 306 = transpose_matrix x, is_list x && is_list (hd x) 307 = error (errors.badargs ++ "transpose") 308{ 309 transpose_op = Operator "transpose" 310 transpose_object Operator_type.COMPOUND_REWRAP false; 311 312 transpose_object x 313 = transpose_matrix x, is_matrix x 314 = transpose_image x, is_image x 315 = error (errors.badargs ++ "transpose"); 316 317 transpose_matrix l 318 = [], l' == [] 319 = (map hd l') : (transpose_matrix (map tl l')) 320 { 321 l' = takewhile (not_equal []) l; 322 } 323 324 transpose_image = im_flipver @ im_rot270; 325} 326 327rot45 x 328 = oo_unary_function rot45_op x, is_class x 329 = error "rot45 image: not implemented", is_image x 330 = error (errors.badargs ++ "rot45") 331{ 332 rot45_op = Operator "rot45" 333 rot45_object Operator_type.COMPOUND_REWRAP false; 334 335 rot45_object x 336 = rot45_matrix x, is_odd_square_matrix x 337 = error "rot45 image: not implemented", is_image x 338 = error (errors.badargs ++ "rot45"); 339 340 // slow, but what the heck 341 rot45_matrix l = (im_rotate_dmask45 (Matrix l)).value; 342} 343 344rot90 x 345 = oo_unary_function rot90_op x, is_class x 346 = im_rot90 x, is_image x 347 = error (errors.badargs ++ "rot90") 348{ 349 rot90_op = Operator "rot90" 350 rot90_object Operator_type.COMPOUND_REWRAP false; 351 352 rot90_object x 353 = rot90_matrix x, is_matrix x 354 = im_rot90 x, is_image x 355 = error (errors.badargs ++ "rot90"); 356 357 // slow, but what the heck 358 rot90_matrix l = (im_rotate_dmask90 (Matrix l)).value; 359} 360 361rot180 x 362 = oo_unary_function rot180_op x, is_class x 363 = im_rot180 x, is_image x 364 = error (errors.badargs ++ "rot180") 365{ 366 rot180_op = Operator "rot180" 367 rot180_object Operator_type.COMPOUND_REWRAP false; 368 369 rot180_object x 370 = rot180_matrix x, is_matrix x 371 = im_rot180 x, is_image x 372 = error (errors.badargs ++ "rot180"); 373 374 // slow, but what the heck 375 rot180_matrix l = (im_rotate_dmask90 376 (im_rotate_dmask90 (Matrix l))).value; 377} 378 379rot270 x 380 = oo_unary_function rot270_op x, is_class x 381 = im_rot270 x, is_image x 382 = error (errors.badargs ++ "rot270") 383{ 384 rot270_op = Operator "rot270" 385 rot270_object Operator_type.COMPOUND_REWRAP false; 386 387 rot270_object x 388 = rot270_matrix x, is_matrix x 389 = im_rot270 x, is_image x 390 = error (errors.badargs ++ "rot270"); 391 392 // slow, but what the heck 393 rot270_matrix l = (im_rotate_dmask90 (im_rotate_dmask90 394 (im_rotate_dmask90 (Matrix l)))).value; 395} 396 397rotquad x 398 = oo_unary_function rotquad_op x, is_class x 399 = im_rotquad x, is_image x 400 = error (errors.badargs ++ "rotquad") 401{ 402 rotquad_op = Operator "rotquad" 403 rotquad_object Operator_type.COMPOUND_REWRAP false; 404 405 rotquad_object x 406 = rotquad_matrix x, is_matrix x 407 = im_rotquad x, is_image x 408 = error (errors.badargs ++ "rotquad"); 409 410 rotquad_matrix l = error "rotquad matrix: not implemented"; 411} 412 413flipud x 414 = oo_unary_function flipud_op x, is_class x 415 = im_flipver x, is_image x 416 = error (errors.badargs ++ "flipud") 417{ 418 flipud_op = Operator "flipud" 419 flipud_object Operator_type.COMPOUND_REWRAP false; 420 421 flipud_object x 422 = flipud_matrix x, is_matrix x 423 = im_flipver x, is_image x 424 = error (errors.badargs ++ "flipud"); 425 426 flipud_matrix l = reverse l; 427} 428 429fliplr x 430 = oo_unary_function fliplr_op x, is_class x 431 = im_fliphor x, is_image x 432 = error (errors.badargs ++ "fliplr") 433{ 434 fliplr_op = Operator "fliplr" 435 fliplr_object Operator_type.COMPOUND_REWRAP false; 436 437 fliplr_object x 438 = fliplr_matrix x, is_matrix x 439 = im_fliphor x, is_image x 440 = error (errors.badargs ++ "fliplr"); 441 442 fliplr_matrix l = map reverse l; 443} 444 445max_pair a b 446 = a, a > b 447 = b; 448 449min_pair a b 450 = a, a < b 451 = b; 452 453max x 454 = oo_unary_function max_op x, is_class x 455 = im_max x, is_image x 456 = x, is_number x 457 = error (errors.badargs ++ "max") 458{ 459 max_op = Operator "max" max_list Operator_type.COMPOUND false; 460 461 max_list x 462 = foldr1 max_pair x, is_real_list x 463 = foldr1 max_pair (map max_list x), is_matrix x 464 = max x; 465} 466 467min x 468 = oo_unary_function min_op x, is_class x 469 = im_min x, is_image x 470 = x, is_number x 471 = error (errors.badargs ++ "min") 472{ 473 min_op = Operator "min" min_list Operator_type.COMPOUND false; 474 475 min_list x 476 = foldr1 min_pair x, is_real_list x 477 = foldr1 min_pair (map min_list x), is_matrix x 478 = min x; 479} 480 481maxpos x 482 = oo_unary_function maxpos_op x, is_class x 483 = im_maxpos x, is_image x 484 = error (errors.badargs ++ "maxpos") 485{ 486 maxpos_op = Operator "maxpos" 487 maxpos_object Operator_type.COMPOUND false; 488 489 maxpos_object x 490 = maxpos_matrix x, is_matrix x 491 = im_maxpos x, is_image x 492 = error (errors.badargs ++ "maxpos"); 493 494 maxpos_matrix m 495 = (indexes?row, row) 496 { 497 max_value = max (Matrix m); 498 indexes = map (index (equal max_value)) m; 499 row = index (not_equal (-1)) indexes; 500 } 501} 502 503minpos x 504 = oo_unary_function minpos_op x, is_class x 505 = im_minpos x, is_image x 506 = error (errors.badargs ++ "minpos") 507{ 508 minpos_op = Operator "minpos" 509 minpos_object Operator_type.COMPOUND false; 510 511 minpos_object x 512 = minpos_matrix x, is_matrix x 513 = im_minpos x, is_image x 514 = error (errors.badargs ++ "minpos"); 515 516 minpos_matrix m 517 = (indexes?row, row) 518 { 519 min_value = min (Matrix m); 520 indexes = map (index (equal min_value)) m; 521 row = index (not_equal (-1)) indexes; 522 } 523} 524 525stats x 526 = oo_unary_function stats_op x, is_class x 527 = im_stats x, is_image x 528 = error (errors.badargs ++ "stats") 529{ 530 stats_op = Operator "stats" 531 stats_object Operator_type.COMPOUND false; 532 533 stats_object x 534 = im_stats (to_image x).value, is_matrix x 535 = im_stats x, is_image x 536 = error (errors.badargs ++ "stats"); 537} 538 539e = 2.7182818284590452354; 540 541pi = 3.14159265358979323846; 542 543rad d = 2 * pi * (d / 360); 544 545deg r = 360 * r / (2 * pi); 546 547sign x 548 = oo_unary_function sign_op x, is_class x 549 = im_sign x, is_image x 550 = sign_cmplx x, is_complex x 551 = sign_num x, is_real x 552 = error (errors.badargs ++ "sign") 553{ 554 sign_op = Operator "sign" sign Operator_type.COMPOUND_REWRAP false; 555 556 sign_num n 557 = 0, n == 0 558 = 1, n > 0 559 = -1; 560 561 sign_cmplx c 562 = (0, 0), mod == 0 563 = (re c / mod, im c / mod) 564 { 565 mod = abs c; 566 } 567} 568 569rint x 570 = oo_unary_function rint_op x, is_class x 571 = rint_value x, is_image x || is_number x 572 = error (errors.badargs ++ "rint") 573{ 574 rint_op = Operator "rint" rint_value Operator_type.ARITHMETIC false; 575 576 rint_value x 577 = (int) (x + 0.5), x > 0 578 = (int) (x - 0.5); 579} 580 581scale x 582 = oo_unary_function scale_op x, is_class x 583 = scale_prim x 584{ 585 scale_op = Operator "scale" 586 scale_prim Operator_type.COMPOUND_REWRAP false; 587 588 scale_prim x 589 = (unsigned char) x, is_number x 590 = im_scale x, is_image x 591 = scale_list x, is_real_list x || is_matrix x 592 = error (errors.badargs ++ "scale"); 593 594 scale_list l 595 = apply_scale s o l 596 { 597 mn = find_limit min_pair l; 598 mx = find_limit max_pair l; 599 s = 255.0 / (mx - mn); 600 o = -(mn * s); 601 } 602 603 find_limit fn l 604 = find_limit fn (map (find_limit fn) l), is_listof is_list l 605 = foldr1 fn l; 606 607 apply_scale s o x 608 = x * s + o, is_number x 609 = map (apply_scale s o) x; 610} 611 612scaleps x 613 = oo_unary_function scale_op x, is_class x 614 = im_scaleps x, is_image x 615 = error (errors.badargs ++ "scale") 616{ 617 scale_op = Operator "scaleps" 618 scaleps Operator_type.COMPOUND_REWRAP false; 619} 620 621fwfft x 622 = oo_unary_function fwfft_op x, is_class x 623 = im_fwfft x, is_image x 624 = error (errors.badargs ++ "fwfft") 625{ 626 fwfft_op = Operator "fwfft" 627 fwfft Operator_type.COMPOUND_REWRAP false; 628} 629 630invfft x 631 = oo_unary_function invfft_op x, is_class x 632 = im_invfftr x, is_image x 633 = error (errors.badargs ++ "invfft") 634{ 635 invfft_op = Operator "invfft" 636 invfft Operator_type.COMPOUND_REWRAP false; 637} 638 639falsecolour x 640 = oo_unary_function falsecolour_op x, is_class x 641 = im_falsecolour x, is_image x 642 = error (errors.badargs ++ "falsecolour") 643{ 644 falsecolour_op = Operator "falsecolour" 645 falsecolour Operator_type.COMPOUND_REWRAP false; 646} 647 648polar x 649 = oo_unary_function polar_op x, is_class x 650 = im_c2amph x, is_image x 651 = polar_cmplx x, is_complex x 652 = error (errors.badargs ++ "polar") 653{ 654 polar_op = Operator "polar" polar Operator_type.COMPOUND false; 655 656 polar_cmplx r 657 = (l, a) 658 { 659 a 660 = 270, x == 0 && y < 0 661 = 90, x == 0 && y >= 0 662 = 360 + atan (y / x), x > 0 && y < 0 663 = atan (y / x), x > 0 && y >= 0 664 = 180 + atan (y / x); 665 666 l = (x ** 2 + y ** 2) ** 0.5; 667 668 x = re r; 669 y = im r; 670 } 671} 672 673rectangular x 674 = oo_unary_function rectangular_op x, is_class x 675 = im_c2rect x, is_image x 676 = rectangular_cmplx x, is_complex x 677 = error (errors.badargs ++ "rectangular") 678{ 679 rectangular_op = Operator "rectangular" 680 rectangular Operator_type.COMPOUND false; 681 682 rectangular_cmplx p 683 = (x, y) 684 { 685 l = re p; 686 a = im p; 687 688 x = l * cos a; 689 y = l * sin a; 690 } 691} 692 693recomb matrix image 694 = colour_unary recomb_op image 695{ 696 recomb_op x 697 = im_recomb x matrix, is_image x 698 = error (errors.badargs ++ "recomb"); 699} 700 701extract_area x y w h obj 702 = oo_unary_function extract_area_op obj, is_class obj 703 = extract_area_prim obj 704{ 705 x' = to_real x; 706 y' = to_real y; 707 w' = to_real w; 708 h' = to_real h; 709 710 extract_area_op = Operator "extract_area" 711 extract_area_prim 712 Operator_type.COMPOUND_REWRAP false; 713 714 extract_area_prim obj 715 = im_extract_area obj x' y' w' h', is_image obj 716 = map (extract_range x' w') (extract_range y' h' obj), 717 is_matrix obj 718 = error (errors.badargs ++ "extract_area"); 719 720 extract_range from length list 721 = (take length @ drop from) list; 722} 723 724extract_band b obj = subscript obj b; 725 726extract_row y obj 727 = oo_unary_function extract_row_op obj, is_class obj 728 = extract_row_prim obj 729{ 730 y' = to_real y; 731 732 extract_row_op = Operator "extract_row" 733 extract_row_prim 734 Operator_type.COMPOUND_REWRAP false; 735 736 extract_row_prim obj 737 = im_extract_area obj 0 y' width 1, is_image obj 738 = [obj?y'], is_matrix obj 739 = error (errors.badargs ++ "extract_row") 740 { 741 width = im_header_int "Xsize" obj; 742 } 743} 744 745extract_column x obj 746 = oo_unary_function extract_column_op obj, is_class obj 747 = extract_column_prim obj 748{ 749 x' = to_real x; 750 751 extract_column_op = Operator "extract_column" 752 extract_column_prim 753 Operator_type.COMPOUND_REWRAP false; 754 755 extract_column_prim obj 756 = im_extract_area obj x' 0 1 height, is_image obj 757 = map (converse cons [] @ converse subscript x') obj, 758 is_matrix obj 759 = error (errors.badargs ++ "extract_column") 760 { 761 height = im_header_int "Ysize" obj; 762 } 763} 764 765join_lr a b 766 = oo_binary_function join_lr_op a b, is_class a 767 = oo_binary'_function join_lr_op a b, is_class b 768 = join_lr_prim a b 769{ 770 join_lr_op = Operator "join_lr" 771 join_lr_prim Operator_type.COMPOUND_REWRAP false; 772 773 join_lr_prim a b 774 = im_extract_area (im_insert a b a_width 0) 775 0 0 (a_width + b_width) out_height, 776 is_image a && is_image b 777 = map2 join a b, 778 is_matrix a && is_matrix b 779 = error (errors.badargs ++ "join_lr") 780 { 781 a_height = im_header_int "Ysize" a; 782 b_height = im_header_int "Ysize" b; 783 a_width = im_header_int "Xsize" a; 784 b_width = im_header_int "Xsize" b; 785 out_height = min_pair a_height b_height; 786 } 787} 788 789join_tb a b 790 = oo_binary_function join_tb_op a b, is_class a 791 = oo_binary'_function join_tb_op a b, is_class b 792 = join_tb_prim a b 793{ 794 join_tb_op = Operator "join_tb" 795 join_tb_prim Operator_type.COMPOUND_REWRAP false; 796 797 join_tb_prim a b 798 = im_extract_area (im_insert a b 0 a_height) 799 0 0 out_width (a_height + b_height), 800 is_image a && is_image b 801 = map (take out_matrix_width) a ++ 802 map (take out_matrix_width) b, 803 is_matrix a && is_matrix b 804 = error (errors.badargs ++ "join_tb") 805 { 806 a_height = im_header_int "Ysize" a; 807 b_height = im_header_int "Ysize" b; 808 a_width = im_header_int "Xsize" a; 809 b_width = im_header_int "Xsize" b; 810 out_width = min_pair a_width b_width; 811 812 out_matrix_width 813 = min_pair a_matrix_width b_matrix_width 814 { 815 a_matrix_width = len a?0; 816 b_matrix_width = len b?0; 817 } 818 } 819} 820 821insert x y small big 822 = oo_binary_function insert_op small big, is_class small 823 = oo_binary'_function insert_op small big, is_class big 824 = im_insert big small (to_real x) (to_real y), 825 is_image small && is_image big 826 = error (errors.badargs ++ "insert") 827{ 828 insert_op = Operator "insert" 829 (insert x y) Operator_type.COMPOUND_REWRAP false; 830} 831 832measure x y w h u v image 833 = oo_unary_function measure_op image, is_class image 834 = im_measure image 835 (to_real x) (to_real y) (to_real w) (to_real h) 836 (to_real u) (to_real v), 837 is_image image 838 = error (errors.badargs ++ "measure") 839{ 840 measure_op = Operator "measure" 841 (measure x y w h u v) Operator_type.COMPOUND_REWRAP false; 842} 843 844rotate angle image 845 = oo_binary_function rotate_op angle image, is_class angle 846 = oo_binary'_function rotate_op angle image, is_class image 847 = im_similarity image (cos angle) (sin angle) 0 0, 848 is_real angle && is_image image 849 = error (errors.badargs ++ "rotate") 850{ 851 rotate_op = Operator "rotate" 852 rotate Operator_type.COMPOUND_REWRAP false; 853} 854 855conj x 856 = oo_unary_function conj_op x, is_class x 857 = (re x, -im x), 858 is_complex x || 859 (is_image x && format == Image_format.COMPLEX) || 860 (is_image x && format == Image_format.DPCOMPLEX) 861 // assume it's some sort of real 862 = x 863{ 864 format = im_header_int "BandFmt" x; 865 conj_op = Operator "conj" conj Operator_type.COMPOUND false; 866} 867 868 869clip2fmt format image 870 = oo_unary_function (clip2fmt_op format) image, is_class image 871 = im_clip2fmt image format, is_image image 872 = error (errors.badargs ++ "clip2fmt") 873{ 874 clip2fmt_op format = Operator "clip2fmt" 875 (clip2fmt format) Operator_type.COMPOUND_REWRAP false; 876} 877 878/* Morph a mask with a [[real]] matrix ... turn m2 into an image, morph it 879 * with m1, turn it back to a matrix again. 880 */ 881_morph_2_masks fn m1 m2 882 = m'' 883{ 884 image = (unsigned char) im_mask2vips (Matrix m2); 885 m2_width = im_header_int "Xsize" image; 886 m2_height = im_header_int "Ysize" image; 887 888 // need to embed m2 in an image large enough for us to be able to 889 // position m1 all around the edges, with a 1 pixel overlap 890 image' = im_embed image 0 (m1.width - 1) (m1.height - 1) 891 (m2_width + 2 * (m1.width - 1)) 892 (m2_height + 2 * (m1.height - 1)); 893 894 // morph! 895 image'' = fn m1 image'; 896 897 // back to mask 898 m' = im_vips2mask ((double) image''); 899 900 // Turn 0 in output to 128 (don't care). 901 m'' 902 = map (map fn) m'.value 903 { 904 fn a 905 = 128, a == 0; 906 = a; 907 } 908} 909 910dilate mask image 911 = oo_unary_function dilate_op image, is_class image 912 = im_dilate image mask, is_image image 913 = error (errors.badargs ++ "dilate") 914{ 915 dilate_op = Operator "dilate" 916 dilate_object Operator_type.COMPOUND_REWRAP false; 917 918 dilate_object x 919 = _morph_2_masks dilate mask x, is_matrix x 920 = dilate mask x; 921} 922 923erode mask image 924 = oo_unary_function erode_op image, is_class image 925 = im_erode image mask, is_image image 926 = error (errors.badargs ++ "erode") 927{ 928 erode_op = Operator "erode" 929 erode_object Operator_type.COMPOUND_REWRAP false; 930 931 erode_object x 932 = _morph_2_masks erode mask x, is_matrix x 933 = erode mask x; 934} 935 936conv mask image 937 = oo_unary_function conv_op image, is_class image 938 = im_conv image mask, is_image image 939 = error (errors.badargs ++ "conv") 940{ 941 conv_op = Operator "conv" 942 (conv mask) Operator_type.COMPOUND_REWRAP false; 943} 944 945rank w h n image 946 = oo_unary_function rank_op image, is_class image 947 = im_rank image w h n, is_image image 948 = error (errors.badargs ++ "rank") 949{ 950 rank_op = Operator "rank" 951 (rank w h n) Operator_type.COMPOUND_REWRAP false; 952} 953 954hist_find image 955 = oo_unary_function hist_find_op image, is_class image 956 = im_histgr image (-1), is_image image 957 = error (errors.badargs ++ "hist_find") 958{ 959 hist_find_op = Operator "hist_find" 960 hist_find Operator_type.COMPOUND_REWRAP false; 961} 962 963hist_find_nD bins image 964 = oo_unary_function hist_find_nD_op image, is_class image 965 = im_histnD image bins, is_image image 966 = error (errors.badargs ++ "hist_find_nD") 967{ 968 hist_find_nD_op = Operator "hist_find_nD" 969 hist_find_nD Operator_type.COMPOUND_REWRAP false; 970} 971 972hist_map hist image 973 = oo_binary_function hist_map_op hist image, is_class hist 974 = oo_binary'_function hist_map_op hist image, is_class image 975 = im_maplut image hist, is_image hist && is_image image 976 = error (errors.badargs ++ "hist_map") 977{ 978 hist_map_op = Operator "hist_map" 979 hist_map Operator_type.COMPOUND_REWRAP false; 980} 981 982hist_cum hist 983 = oo_unary_function hist_cum_op hist, is_class hist 984 = im_histcum hist, is_image hist 985 = error (errors.badargs ++ "hist_cum") 986{ 987 hist_cum_op = Operator "hist_cum" 988 hist_cum Operator_type.COMPOUND_REWRAP false; 989} 990 991hist_norm hist 992 = oo_unary_function hist_norm_op hist, is_class hist 993 = im_histnorm hist, is_image hist 994 = error (errors.badargs ++ "hist_norm") 995{ 996 hist_norm_op = Operator "hist_norm" 997 hist_norm Operator_type.COMPOUND_REWRAP false; 998} 999 1000hist_match in ref 1001 = oo_binary_function hist_match_op in ref, is_class in 1002 = oo_binary'_function hist_match_op in ref, is_class ref 1003 = im_histspec in ref, is_image in && is_image ref 1004 = error (errors.badargs ++ "hist_match") 1005{ 1006 hist_match_op = Operator "hist_match" 1007 hist_match Operator_type.COMPOUND_REWRAP false; 1008} 1009 1010hist_equalize x = hist_map ((hist_norm @ hist_cum @ hist_find) x) x; 1011 1012hist_equalize_local w h image 1013 = oo_unary_function hist_equalize_local_op image, is_class image 1014 = im_lhisteq image w h, is_image image 1015 = error (errors.badargs ++ "hist_equalize_local") 1016{ 1017 hist_equalize_local_op = Operator "hist_equalize_local" 1018 (hist_equalize_local w h) Operator_type.COMPOUND_REWRAP false; 1019} 1020 1021resize xfac yfac interp image 1022 = oo_unary_function resize_op image, is_class image 1023 = resize_im image, is_image image 1024 = error (errors.badargs ++ "resize") 1025{ 1026 resize_op = Operator "resize" 1027 resize_im Operator_type.COMPOUND_REWRAP false; 1028 1029 resize_im im 1030 // upscale by integer factor, nearest neighbour 1031 = im_zoom im xfac yfac, 1032 is_int xfac && is_int yfac && xfac >= 1 && yfac >= 1 && 1033 interp == Interpolate.nearest_neighbour 1034 1035 // downscale by integer factor, nearest neighbour 1036 = im_subsample im xfac' yfac', 1037 is_int xfac' && is_int yfac' && 1038 xfac' >= 1 && yfac' >= 1 && 1039 interp == Interpolate.nearest_neighbour 1040 1041 // upscale by any factor, nearest neighbour 1042 // can't really do this right ... upscale by integer part, then 1043 // bilinear to exact size 1044 = scale (break xfac)?1 (break yfac)?1 1045 (im_zoom im (break xfac)?0 (break yfac)?0), 1046 xfac >= 1 && yfac >= 1 && 1047 interp == Interpolate.nearest_neighbour 1048 1049 // downscale by any factor, nearest neighbour 1050 // can't really do this right ... downscale by integer part, 1051 // then bilinear to exact size 1052 = scale (1 / (break xfac')?1) (1 / (break yfac')?1) 1053 (im_subsample im (break xfac')?0 (break yfac')?0), 1054 xfac' >= 1 && yfac' >= 1 && 1055 interp == Interpolate.nearest_neighbour 1056 1057 // upscale by any factor, bilinear 1058 = scale xfac yfac im, 1059 xfac >= 1 && yfac >= 1 && 1060 interp == Interpolate.bilinear 1061 1062 // downscale by any factor, bilinear 1063 // block shrink by integer factor, then bilinear resample to 1064 // exact 1065 = scale (1 / (break xfac')?1) (1 / (break yfac')?1) 1066 (im_shrink im (break xfac')?0 (break yfac')?0), 1067 xfac' >= 1 && yfac' >= 1 && 1068 interp == Interpolate.bilinear 1069 1070 = error ("resize: unimplemented argument combination:\n" ++ 1071 " xfac = " ++ print xfac ++ "\n" ++ 1072 " yfac = " ++ print yfac ++ "\n" ++ 1073 " interp = " ++ print interp ++ " (" ++ 1074 Interpolate.names.lookup 1 0 interp ++ ")") 1075 { 1076 xfac' = 1 / xfac; 1077 yfac' = 1 / yfac; 1078 1079 // convert a float scale to integer plus fraction 1080 // eg. scale by 2.5 becomes [2, 1.25] (x * 2.5 == x * 2 * 1.25) 1081 break f = [floor f, f / floor f]; 1082 1083 // binlinear resize 1084 scale xfac yfac im 1085 = im_affine im 1086 xfac 0 0 yfac 1087 0 0 1088 0 0 (width * xfac) (height * yfac) 1089 { 1090 width = im_header_int "Xsize" im; 1091 height = im_header_int "Ysize" im; 1092 } 1093 } 1094} 1095 1096/* id x: the identity function 1097 * 1098 * id :: * -> * 1099 */ 1100id x = x; 1101 1102/* const x y: junk y, return x 1103 * 1104 * (const 3) is the function that always returns 3. 1105 * const :: * -> ** -> * 1106 */ 1107const x y = x; 1108 1109/* converse fn a b: swap order of args to fn 1110 * 1111 * converse fn a b == fn b a 1112 * converse :: (* -> ** -> ***) -> ** -> * -> *** 1113 */ 1114converse fn a b = fn b a; 1115 1116/* fix fn x: find the fixed point of a function 1117 */ 1118fix fn x = limit (iterate fn x); 1119 1120/* until pred fn n: apply fn to n until pred succeeds; return that value 1121 * 1122 * until (more 1000) (multiply 2) 1 = 1024 1123 * until :: (* -> bool) -> (* -> *) -> * -> * 1124 */ 1125until pred fn n 1126 = n, pred n 1127 = until pred fn (fn n); 1128 1129/* Infinite list of primes. 1130 */ 1131primes 1132 = 1 : (sieve [2..]) 1133{ 1134 sieve l = hd l : sieve (filter (nmultiple (hd l)) (tl l)); 1135 nmultiple n x = x / n != (int) (x / n); 1136} 1137 1138/* Map a 3-ary function over three objects. 1139 */ 1140map_trinary fn a b c 1141 = map3 (map_trinary fn) a b c, is_list a && is_list b && is_list c 1142 1143 = map2 (map_trinary fn a) b c, is_list b && is_list c 1144 = map2 (map_trinary (converse31 fn) b) a c, is_list a && is_list c 1145 = map2 (map_trinary (converse32 fn) c) a b, is_list a && is_list b 1146 1147 = map (map_trinary fn a b) c, is_list c 1148 = map (map_trinary (converse32 fn) a c) b, is_list b 1149 = map (map_trinary (converse34 fn) b c) a, is_list a 1150 1151 = fn a b c 1152{ 1153 converse31 fn a b c = fn b a c; 1154 converse32 fn a b c = fn c a b; 1155 converse33 fn a b c = fn a c b; 1156 converse34 fn a b c = fn b c a; 1157} 1158 1159/* Map a 2-ary function over a pair of objects. 1160 */ 1161map_binary fn a b 1162 = map2 (map_binary fn) a b, is_list a && is_list b 1163 = map (map_binary fn a) b, is_list b 1164 = map (map_binary (converse fn) b) a, is_list a 1165 = fn a b; 1166 1167/* Map a 1-ary function over an object. 1168 */ 1169map_unary fn a 1170 = map (map_unary fn) a, is_list a 1171 = fn a; 1172 1173/* Chop up an image into a list of lists of smaller images. Pad edges with 1174 * black. 1175 */ 1176imagearray_chop block_size overlap i 1177 = map chop' [0, step .. height] 1178{ 1179 width = im_header_int "Xsize" i; 1180 height = im_header_int "Ysize" i; 1181 bands = im_header_int "Bands" i; 1182 format = im_header_int "BandFmt" i; 1183 type = im_header_int "Type" i; 1184 1185 /* Unique pixels per tile. 1186 */ 1187 step = block_size - overlap; 1188 1189 /* Calculate padding ... pad up to block_size pixel boundary. 1190 */ 1191 sx = block_size + (width - width % step); 1192 sy = block_size + (height - height % step); 1193 1194 /* Expand image with black to pad size. 1195 */ 1196 background = image_new sx sy bands format Image_coding.NOCODING type 1197 0 0 0; 1198 pad = im_insert background i 0 0; 1199 1200 /* Chop up a row. 1201 */ 1202 chop' y 1203 = map chop'' [0, step .. width] 1204 { 1205 chop'' x = im_extract_area pad x y block_size block_size; 1206 } 1207} 1208 1209/* Reassemble image. 1210 */ 1211imagearray_assemble hoverlap voverlap il 1212 = vjoin (map hjoin il) 1213{ 1214 /* Join a list of tiles horizontally. 1215 */ 1216 hjoin l 1217 = foldl1 lrj l 1218 { 1219 lrj l r = im_lrmerge l r 1220 (hoverlap - im_header_int "Xsize" l) 0 10; 1221 } 1222 1223 /* Join a list of tiles vertically. 1224 */ 1225 vjoin l 1226 = foldl1 tbj l 1227 { 1228 tbj t b = im_tbmerge t b 1229 0 (voverlap - im_header_int "Ysize" t) 10; 1230 } 1231} 1232 1233/* Generate an nxn identity matrix. 1234 */ 1235identity_matrix n 1236 = error "identity_matrix: n > 0", n < 1 1237 = map line [0 .. n - 1] 1238{ 1239 line p = take p [0, 0 ..] ++ [1] ++ take (n - p - 1) [0, 0 ..]; 1240} 1241