math.c

   1 /* -*-comment-start: "//";comment-end:""-*-
   2  * Mes --- Maxwell Equations of Software
   3  * Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
   4  *
   5  * This file is part of Mes.
   6  *
   7  * Mes is free software; you can redistribute it and/or modify it
   8  * under the terms of the GNU General Public License as published by
   9  * the Free Software Foundation; either version 3 of the License, or (at
  10  * your option) any later version.
  11  *
  12  * Mes is distributed in the hope that it will be useful, but
  13  * WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with Mes.  If not, see <http://www.gnu.org/licenses/>.
  19  */
  20
  21 //MINI_MES
  22 // SCM
  23 // greater_p (SCM x) ///((name . ">") (arity . n))
  24 // {
  25 //   int n = INT_MAX;
  26 //   while (x != cell_nil)
  27 //     {
  28 //       assert (TYPE (car (x)) == TNUMBER);
  29 //       if (VALUE (car (x)) >= n) return cell_f;
  30 //       n = VALUE (car (x));
  31 //       x = cdr (x);
  32 //     }
  33 //   return cell_t;
  34 // }
  35
  36 // SCM
  37 // less_p (SCM x) ///((name . "<") (arity . n))
  38 // {
  39 //   int n = INT_MIN;
  40 //   while (x != cell_nil)
  41 //     {
  42 //       assert (TYPE (car (x)) == TNUMBER);
  43 //       if (VALUE (car (x)) <= n) return cell_f;
  44 //       n = VALUE (car (x));
  45 //       x = cdr (x);
  46 //     }
  47 //   return cell_t;
  48 // }
  49
  50 SCM
  51 is_p (SCM x) ///((name . "=") (arity . n))
  52 {
  53   if (x == cell_nil) return cell_t;
  54   assert (TYPE (car (x)) == TNUMBER);
  55   int n = VALUE (car (x));
  56   x = cdr (x);
  57   while (x != cell_nil)
  58     {
  59       if (VALUE (car (x)) != n) return cell_f;
  60       x = cdr (x);
  61     }
  62   return cell_t;
  63 }
  64
  65 SCM
  66 minus (SCM x) ///((name . "-") (arity . n))
  67 {
  68   SCM a = car (x);
  69   assert (TYPE (a) == TNUMBER);
  70   int n = VALUE (a);
  71   x = cdr (x);
  72   if (x == cell_nil)
  73     n = -n;
  74   while (x != cell_nil)
  75     {
  76       assert (TYPE (car (x)) == TNUMBER);
  77       n -= VALUE (car (x));
  78       x = cdr (x);
  79     }
  80   return MAKE_NUMBER (n);
  81 }
  82
  83 SCM
  84 plus (SCM x) ///((name . "+") (arity . n))
  85 {
  86   int n = 0;
  87   while (x != cell_nil)
  88     {
  89       assert (TYPE (car (x)) == TNUMBER);
  90       n += VALUE (car (x));
  91       x = cdr (x);
  92     }
  93   return MAKE_NUMBER (n);
  94 }
  95
  96 SCM
  97 divide (SCM x) ///((name . "/") (arity . n))
  98 {
  99   int n = 1;
 100   if (x != cell_nil) {
 101     assert (TYPE (car (x)) == TNUMBER);
 102     n = VALUE (car (x));
 103     x = cdr (x);
 104   }
 105   while (x != cell_nil)
 106     {
 107       assert (TYPE (car (x)) == TNUMBER);
 108       n /= VALUE (car (x));
 109       x = cdr (x);
 110     }
 111   return MAKE_NUMBER (n);
 112 }
 113
 114 SCM
 115 modulo (SCM a, SCM b)
 116 {
 117   assert (TYPE (a) == TNUMBER);
 118   assert (TYPE (b) == TNUMBER);
 119   int x = VALUE (a);
 120   while (x < 0) x += VALUE (b);
 121   return MAKE_NUMBER (x % VALUE (b));
 122 }
 123
 124 SCM
 125 multiply (SCM x) ///((name . "*") (arity . n))
 126 {
 127   int n = 1;
 128   while (x != cell_nil)
 129     {
 130       assert (TYPE (car (x)) == TNUMBER);
 131       n *= VALUE (car (x));
 132       x = cdr (x);
 133     }
 134   return MAKE_NUMBER (n);
 135 }
 136
 137 SCM
 138 logior (SCM x) ///((arity . n))
 139 {
 140   int n = 0;
 141   while (x != cell_nil)
 142     {
 143       assert (TYPE (car (x)) == TNUMBER);
 144       n |= VALUE (car (x));
 145       x = cdr (x);
 146     }
 147   return MAKE_NUMBER (n);
 148 }
 149
 150 SCM
 151 ash (SCM n, SCM count)
 152 {
 153   assert (TYPE (n) == TNUMBER);
 154   assert (TYPE (count) == TNUMBER);
 155   int cn = VALUE (n);
 156   int ccount = VALUE (count);
 157   return MAKE_NUMBER ((ccount < 0) ? cn >> -ccount : cn << ccount);
 158 }