modules/ml-math.cc

   1 #include "ml-math.h"
   2 #include "ml.h"
   3 #include "mlenv.h"
   4 #include "motorenv.h"
   5 #include "expr.h"
   6 #include "util_const.h"
   7 #include "util_random.h"
   8 #include <exception>
   9 #include <math.h>
  10
  11 /*DOC:
  12 ==mathematical function==
  13
  14 */
  15
  16 static double  arg1_double (MNode* cell, MlEnv* mlenv) {
  17     MNode*  arg = cell->cdr ();
  18     double  ans;
  19
  20     if (! arg)
  21         throw (uErrorWrongNumber);
  22     ans = eval_double (arg->car (), mlenv);
  23     nextNode (arg);
  24     if (arg)
  25         throw (uErrorWrongNumber);
  26     return ans;
  27 }
  28
  29 /*DOC:
  30 === + ===
  31  (+ NUMBER NUMBER...) -> NUMBER
  32
  33 */
  34 //#AFUNC        +       ml_add
  35 //#WIKIFUNC     +
  36 MNode*  ml_add (MNode* cell, MlEnv* mlenv) {
  37     MNode*  arg = cell->cdr ();
  38     double  a1 = 0.;
  39
  40     while (arg) {
  41         a1 += eval_double (arg->car (), mlenv);
  42         nextNode (arg);
  43     }
  44     return newMNode_num (a1);
  45 }
  46
  47 /*DOC:
  48 === - ===
  49  (- NUMBER) -> NUMBER
  50  (- NUMBER NUMBER) -> NUMBER
  51
  52 */
  53 //#AFUNC        -       ml_sub
  54 //#WIKIFUNC     -
  55 MNode*  ml_sub (MNode* cell, MlEnv* mlenv) {
  56     MNode*  arg = cell->cdr ();
  57     double  a1;
  58     double  a2;
  59
  60     if (arg == NULL)
  61         throw (uErrorWrongNumber);
  62
  63     a1 = eval_double (arg->car (), mlenv);
  64     nextNode (arg);
  65     if (arg) {                  // (- NUM1 NUM2)
  66         a2 = eval_double (arg->car (), mlenv);
  67         nextNode (arg);
  68         if (arg)
  69             throw (uErrorWrongNumber);
  70         return newMNode_num (a1 - a2);
  71     } else {                    // (- NUM1)
  72         return newMNode_num (- a1);
  73     }
  74 }
  75
  76 /*DOC:
  77 === * ===
  78  (* NUMBER NUMBER...) -> NUMBER
  79
  80 */
  81 //#AFUNC        *       ml_mult
  82 //#WIKIFUNC     *
  83 MNode*  ml_mult (MNode* cell, MlEnv* mlenv) {
  84     MNode*  arg = cell->cdr ();
  85     double  a1 = 1.;
  86
  87     if (arg == NULL)
  88         throw (uErrorWrongNumber);
  89
  90     a1 = eval_double (arg->car (), mlenv);
  91     nextNode (arg);
  92     while (arg) {
  93         a1 *= eval_double (arg->car (), mlenv);
  94         nextNode (arg);
  95     }
  96     return newMNode_num (a1);
  97 }
  98
  99 /*DOC:
 100 === / ===
 101  (/ NUMBER NUMBER) -> NUMBER
 102
 103 */
 104 //#AFUNC        /       ml_div
 105 //#WIKIFUNC     /
 106 MNode*  ml_div (MNode* cell, MlEnv* mlenv) {
 107     MNode*  arg = cell->cdr ();
 108     double  a1;
 109     double  a2;
 110
 111     if (arg == NULL)
 112         throw (uErrorWrongNumber);
 113
 114     a1 = eval_double (arg->car (), mlenv);
 115     nextNodeNonNil (arg);
 116     a2 = eval_double (arg->car (), mlenv);
 117     if (a2 == 0.) {
 118         throw (uErrorDiv0);
 119     }
 120
 121     return newMNode_num (a1 / a2);
 122 }
 123
 124 /*DOC:
 125 === % ===
 126  (% NUMBER NUMBER) -> NUMBER
 127
 128 */
 129 //#AFUNC        %       ml_mod
 130 //#WIKIFUNC     %
 131 MNode*  ml_mod (MNode* cell, MlEnv* mlenv) {
 132     MNode*  arg = cell->cdr ();
 133     double  a1;
 134     double  a2;
 135
 136     if (arg == NULL)
 137         throw (uErrorWrongNumber);
 138
 139     a1 = eval_double (arg->car (), mlenv);
 140     nextNodeNonNil (arg);
 141     a2 = eval_double (arg->car (), mlenv);
 142     if (a2 == 0.) {
 143         throw (uErrorDiv0);
 144     }
 145
 146     return newMNode_num (fmod (a1, a2));
 147 }
 148
 149 /*DOC:
 150 ===ceil===
 151  (ceil NUMBER) -> NUMBER
 152
 153 */
 154 //#AFUNC        ceil    ml_ceil
 155 //#WIKIFUNC     ceil
 156 MNode*  ml_ceil (MNode* cell, MlEnv* mlenv) {
 157     double  v = arg1_double (cell, mlenv);
 158     return newMNode_num (ceil (v));
 159 }
 160
 161 /*DOC:
 162 ===floor===
 163  (floor NUMBER) -> NUMBER
 164
 165 */
 166 //#AFUNC        floor   ml_floor
 167 //#WIKIFUNC     floor
 168 MNode*  ml_floor (MNode* cell, MlEnv* mlenv) {
 169     double  v = arg1_double (cell, mlenv);
 170     return newMNode_num (floor (v));
 171 }
 172
 173 /*DOC:
 174 ===fraction===
 175  (fraction NUMBER) -> NUMBER
 176
 177 */
 178 //#AFUNC        fraction        ml_fraction
 179 //#WIKIFUNC     fraction
 180 MNode*  ml_fraction (MNode* cell, MlEnv* mlenv) {
 181     double  v = arg1_double (cell, mlenv);
 182     return newMNode_num (v - floor (v));
 183 }
 184
 185 /*DOC:
 186 ===random===
 187  (random) -> NUMBER
 188
 189 */
 190 //#AFUNC        random  ml_random
 191 //#WIKIFUNC     random
 192 MNode*  ml_random (MNode* cell, MlEnv* mlenv) {
 193     MNode*  arg = cell->cdr ();
 194
 195     if (arg)
 196         throw (uErrorWrongNumber);
 197
 198     return newMNode_num (randDouble ());
 199 }