home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / lisp / kcl_tar.z / kcl_tar / c / num_comp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  5.9 KB  |  304 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     Comparisons on numbers
  9. */
  10. #include "include.h"
  11. #include "num_include.h"
  12.  
  13. /*
  14.     The value of number_compare(x, y) is
  15.  
  16.         -1    if    x < y
  17.         0    if    x = y
  18.         1    if    x > y.
  19.  
  20.     If x or y is complex, 0 or 1 is returned.
  21. */
  22. int
  23. number_compare(x, y)
  24. object x, y;
  25. {
  26.     int i;
  27.     double dx, dy;
  28.     vs_mark;
  29.  
  30.     switch (type_of(x)) {
  31.  
  32.     case t_fixnum:
  33.         switch (type_of(y)) {
  34.         case t_fixnum:
  35.             if (fix(x) < fix(y))
  36.                 return(-1);
  37.             else if (fix(x) == fix(y))
  38.                 return(0);
  39.             else
  40.                 return(1);
  41.         case t_bignum:
  42.             i = big_sign((struct bignum *)y);
  43.             if (i < 0)
  44.                 return(1);
  45.             else
  46.                 return(-1);
  47.         case t_ratio:
  48.             x = number_times(x, y->rat.rat_den);
  49.             y = y->rat.rat_num;
  50.             vs_push(x);
  51.             i = number_compare(x, y);
  52.             vs_reset;
  53.             return(i);
  54.         case t_shortfloat:
  55.             dx = (double)(fix(x));
  56.             dy = (double)(sf(y));
  57.             goto LONGFLOAT;
  58.         case t_longfloat:
  59.             dx = (double)(fix(x));
  60.             dy = lf(y);
  61.             goto LONGFLOAT;
  62.         case t_complex:
  63.             goto Y_COMPLEX;
  64.         default:
  65.             wrong_type_argument(Snumber, y);
  66.         }
  67.  
  68.     case t_bignum:
  69.         switch (type_of(y)) {
  70.         case t_fixnum:
  71.             i = big_sign((struct bignum *)x);
  72.             if (i < 0)
  73.                 return(-1);
  74.             else
  75.                 return(1);
  76.         case t_bignum:
  77.             return(big_compare((struct bignum *)x,
  78.                        (struct bignum *)y));
  79.         case t_ratio:
  80.             x = number_times(x, y->rat.rat_den);
  81.             y = y->rat.rat_num;
  82.             vs_push(x);
  83.             i = number_compare(x, y);
  84.             vs_reset;
  85.             return(i);
  86.         case t_shortfloat:
  87.             dx = number_to_double(x);
  88.             dy = (double)(sf(y));
  89.             goto LONGFLOAT;
  90.         case t_longfloat:
  91.             dx = number_to_double(x);
  92.             dy = lf(y);
  93.             goto LONGFLOAT;
  94.         case t_complex:
  95.             goto Y_COMPLEX;
  96.         default:
  97.             wrong_type_argument(Snumber, y);
  98.         }
  99.  
  100.     case t_ratio:
  101.         switch (type_of(y)) {
  102.         case t_fixnum:
  103.         case t_bignum:
  104.             y = number_times(y, x->rat.rat_den);
  105.             x = x->rat.rat_num;
  106.             vs_push(y);
  107.             i = number_compare(x, y);
  108.             vs_reset;
  109.             return(i);
  110.         case t_ratio:
  111.             vs_push(number_times(x->rat.rat_num,y->rat.rat_den));
  112.             vs_push(number_times(y->rat.rat_num,x->rat.rat_den));
  113.             i = number_compare(vs_top[-2], vs_top[-1]);
  114.             vs_reset;
  115.             return(i);
  116.         case t_shortfloat:
  117.             dx = number_to_double(x);
  118.             dy = (double)(sf(y));
  119.             goto LONGFLOAT;
  120.         case t_longfloat:
  121.             dx = number_to_double(x);
  122.             dy = lf(y);
  123.             goto LONGFLOAT;
  124.         case t_complex:
  125.             goto Y_COMPLEX;
  126.         default:
  127.             wrong_type_argument(Snumber, y);
  128.         }
  129.  
  130.     case t_shortfloat:
  131.         dx = (double)(sf(x));
  132.         goto LONGFLOAT0;
  133.  
  134.     case t_longfloat:
  135.         dx = lf(x);
  136.     LONGFLOAT0:
  137.         switch (type_of(y)) {
  138.         case t_fixnum:
  139.             dy = (double)(fix(y));
  140.             goto LONGFLOAT;
  141.         case t_bignum:
  142.         case t_ratio:
  143.             dy = number_to_double(y);
  144.             goto LONGFLOAT;
  145.         case t_shortfloat:
  146.             dy = (double)(sf(y));
  147.             goto LONGFLOAT;
  148.         case t_longfloat:
  149.             dy = lf(y);
  150.             goto LONGFLOAT;
  151.         case t_complex:
  152.             goto Y_COMPLEX;
  153.         }
  154.     LONGFLOAT:
  155.         if (dx == dy)
  156.             return(0);
  157.         else if (dx < dy)
  158.             return(-1);
  159.         else
  160.             return(1);
  161.  
  162.     Y_COMPLEX:
  163.         if (number_zerop(y->cmp.cmp_imag))
  164.             if (number_compare(x, y->cmp.cmp_real) == 0)
  165.                 return(0);
  166.             else
  167.                 return(1);
  168.         else
  169.             return(1);
  170.  
  171.     case t_complex:
  172.         if (type_of(y) != t_complex)
  173.             if (number_zerop(x->cmp.cmp_imag))
  174.                 if (number_compare(x->cmp.cmp_real, y) == 0)
  175.                     return(0);
  176.                 else
  177.                     return(1);
  178.             else
  179.                 return(1);
  180.         if (number_compare(x->cmp.cmp_real, y->cmp.cmp_real) == 0 &&
  181.             number_compare(x->cmp.cmp_imag, y->cmp.cmp_imag) == 0 )
  182.             return(0);
  183.         else
  184.             return(1);
  185.  
  186.     default:
  187.         FEwrong_type_argument(Snumber, x);
  188.     }
  189. }
  190.  
  191. Lall_the_same()
  192. {
  193.     int narg, i;
  194.  
  195.     narg = vs_top - vs_base;
  196.     if (narg == 0)
  197.         too_few_arguments();
  198.     for (i = 0; i < narg; i++)
  199.         check_type_number(&vs_base[i]);
  200.     for (i = 1; i < narg; i++)
  201.         if (number_compare(vs_base[i-1], vs_base[i]) != 0) {
  202.             vs_top = vs_base+1;
  203.             vs_base[0] = Cnil;
  204.             return;
  205.         }
  206.     vs_top = vs_base+1;
  207.     vs_base[0] = Ct;
  208. }
  209.  
  210. Lall_different()
  211. {
  212.     int narg, i, j;
  213.  
  214.     narg = vs_top - vs_base;
  215.     if (narg == 0)
  216.         too_few_arguments();
  217.     else if (narg == 1) {
  218.         vs_base[0] = Ct;
  219.         return;
  220.     }
  221.     for (i = 0; i < narg; i++)
  222.         check_type_number(&vs_base[i]);
  223.     for(i = 1; i < narg; i++)
  224.         for(j = 0; j < i; j++)
  225.             if (number_compare(vs_base[j], vs_base[i]) == 0) {
  226.                 vs_top = vs_base+1;
  227.                 vs_base[0] = Cnil;
  228.                 return;
  229.             }
  230.     vs_top = vs_base+1;
  231.     vs_base[0] = Ct;
  232. }
  233.  
  234. Lnumber_compare(s, t)
  235. int s, t;
  236. {
  237.     int narg, i;
  238.  
  239.     narg = vs_top - vs_base;
  240.     if (narg == 0)
  241.         too_few_arguments();
  242.     for (i = 0; i < narg; i++)
  243.         check_type_or_rational_float(&vs_base[i]);
  244.     for (i = 1; i < narg; i++)
  245.         if (s*number_compare(vs_base[i], vs_base[i-1]) < t) {
  246.             vs_top = vs_base+1;
  247.             vs_base[0] = Cnil;
  248.             return;
  249.         }
  250.     vs_top = vs_base+1;
  251.     vs_base[0] = Ct;
  252. }
  253.  
  254. Lmonotonically_increasing()    { Lnumber_compare( 1, 1); }
  255. Lmonotonically_decreasing()    { Lnumber_compare(-1, 1); }
  256. Lmonotonically_nondecreasing() { Lnumber_compare( 1, 0); }
  257. Lmonotonically_nonincreasing() { Lnumber_compare(-1, 0); }
  258.  
  259. Lmax()
  260. {
  261.     object max;
  262.     int narg, i;
  263.     
  264.     narg = vs_top - vs_base;
  265.     if (narg == 0)
  266.         too_few_arguments();
  267.     for (i = 0;  i < narg;  i++)
  268.         check_type_or_rational_float(&vs_base[i]);
  269.     for (i = 1, max = vs_base[0];  i < narg;  i++)
  270.         if (number_compare(max, vs_base[i]) < 0)
  271.             max = vs_base[i];
  272.     vs_top = vs_base+1;
  273.     vs_base[0] = max;
  274. }
  275.  
  276. Lmin()
  277. {
  278.     object min;
  279.     int narg, i;
  280.     
  281.     narg = vs_top - vs_base;
  282.     if (narg == 0)
  283.         too_few_arguments();
  284.     for (i = 0;  i < narg;  i++)
  285.         check_type_or_rational_float(&vs_base[i]);
  286.     for (i = 1, min = vs_base[0];  i < narg;  i++)
  287.         if (number_compare(min, vs_base[i]) > 0)
  288.             min = vs_base[i];
  289.     vs_top = vs_base+1;
  290.     vs_base[0] = min;
  291. }
  292.  
  293. init_num_comp()
  294. {
  295.     make_function("=", Lall_the_same);
  296.     make_function("/=", Lall_different);
  297.     make_function("<", Lmonotonically_increasing);
  298.     make_function(">", Lmonotonically_decreasing);
  299.     make_function("<=", Lmonotonically_nondecreasing);
  300.     make_function(">=", Lmonotonically_nonincreasing);
  301.     make_function("MAX", Lmax);
  302.     make_function("MIN", Lmin);
  303. }
  304.