1 /* GENIUS Calculator
2 * Copyright (C) 1997-2018 Jiri (George) Lebl
3 *
4 * Author: Jiri (George) Lebl
5 *
6 * This file is part of Genius.
7 *
8 * Genius is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, either version 3 of the License, or
11 * (at your option) any later version.
12 *
13 * This program is distributed in the hope that it will be useful,
14 * but WITHOUT ANY WARRANTY; without even the implied warranty of
15 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 * GNU General Public License for more details.
17 *
18 * You should have received a copy of the GNU General Public License
19 * along with this program. If not, see <http://www.gnu.org/licenses/>.
20 */
21
22 #include "config.h"
23
24 #include <string.h>
25 #include <unistd.h>
26 #include <sys/time.h>
27 #include <math.h>
28 #include <glib.h>
29 #include "calc.h"
30 #include "mpwrap.h"
31 #include "mpzextra.h"
32 #include "eval.h"
33 #include "dict.h"
34 #include "funclib.h"
35 #include "symbolic.h"
36 #include "matrix.h"
37 #include "matrixw.h"
38 #include "matop.h"
39 #include "geloutput.h"
40
41 #include "binreloc.h"
42
43 /* FIXME:static GelEFunc *_internal_ln_function = NULL; */
44 static GelEFunc *_internal_exp_function = NULL;
45 static GelEFunc *_internal_erf_function = NULL;
46
47 static GelEFunc *conj_function = NULL;
48 static GelEFunc *sin_function = NULL;
49 static GelEFunc *sinc_function = NULL;
50 static GelEFunc *cos_function = NULL;
51 static GelEFunc *sinh_function = NULL;
52 static GelEFunc *cosh_function = NULL;
53 static GelEFunc *tan_function = NULL;
54 static GelEFunc *atan_function = NULL;
55 static GelEFunc *sqrt_function = NULL;
56 static GelEFunc *exp_function = NULL;
57 static GelEFunc *ln_function = NULL;
58 static GelEFunc *log2_function = NULL;
59 static GelEFunc *log10_function = NULL;
60 static GelEFunc *round_function = NULL;
61 static GelEFunc *floor_function = NULL;
62 static GelEFunc *ceil_function = NULL;
63 static GelEFunc *trunc_function = NULL;
64 static GelEFunc *float_function = NULL;
65 static GelEFunc *Numerator_function = NULL;
66 static GelEFunc *Denominator_function = NULL;
67 static GelEFunc *Re_function = NULL;
68 static GelEFunc *Im_function = NULL;
69 static GelEFunc *ErrorFunction_function = NULL;
70 static GelEFunc *RiemannZeta_function = NULL;
71 static GelEFunc *GammaFunction_function = NULL;
72 static GelEFunc *BesselJ0_function = NULL;
73 static GelEFunc *BesselJ1_function = NULL;
74 static GelEFunc *BesselY0_function = NULL;
75 static GelEFunc *BesselY1_function = NULL;
76 /*static GelEFunc *BesselJn_function = NULL;
77 static GelEFunc *BesselYn_function = NULL;*/
78 static GelEFunc *pi_function = NULL;
79 static GelEFunc *e_function = NULL;
80 static GelEFunc *GoldenRatio_function = NULL;
81 static GelEFunc *Gravity_function = NULL;
82 static GelEFunc *EulerConstant_function = NULL;
83
84 /*maximum number of primes to precalculate and store*/
85 #define MAXPRIMES 30000
86 static GArray *primes = NULL;
87 static int numprimes = 0;
88
89 static mpw_t e_cache;
90 static int e_iscached = FALSE;
91 static mpw_t golden_ratio_cache;
92 static int golden_ratio_iscached = FALSE;
93
94 #include "funclibhelper.cP"
95
96 void
gel_break_fp_caches(void)97 gel_break_fp_caches (void)
98 {
99 if (e_iscached) {
100 e_iscached = FALSE;
101 mpw_clear (e_cache);
102 }
103 if (golden_ratio_iscached) {
104 golden_ratio_iscached = FALSE;
105 mpw_clear (golden_ratio_cache);
106 }
107 }
108
109 int
gel_get_nonnegative_integer(mpw_ptr z,const char * funcname)110 gel_get_nonnegative_integer (mpw_ptr z, const char *funcname)
111 {
112 long i;
113 i = mpw_get_long(z);
114 if G_UNLIKELY (gel_error_num != 0) {
115 gel_error_num = 0;
116 return -1;
117 }
118 if G_UNLIKELY (i < 0) {
119 /* This should already have been checked */
120 /*gel_errorout (_("%s: argument can't be negative"), funcname);*/
121 return -1;
122 }
123 if G_UNLIKELY (i > G_MAXINT) {
124 gel_errorout (_("%s: argument too large"), funcname);
125 return -1;
126 }
127 return i;
128 }
129
130 static GelETree *
manual_op(GelCtx * ctx,GelETree ** a,gboolean * exception)131 manual_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
132 {
133 gel_call_help (NULL);
134 gel_error_num = GEL_IGNORE_ERROR;
135 RAISE_EXCEPTION (exception);
136 return NULL;
137 }
138
139 static GelETree *
version_op(GelCtx * ctx,GelETree ** a,gboolean * exception)140 version_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
141 {
142 int v,b,c;
143 GelETree *n;
144 GelMatrix *m;
145
146 if (sscanf (VERSION, "%d.%d.%d", &v, &b, &c) != 3) {
147 if (sscanf (VERSION, "%d.%d", &v, &b) == 2) {
148 c = 0;
149 } else if (sscanf (VERSION, "%d", &v) == 1) {
150 b = 0;
151 c = 0;
152 } else {
153 gel_errorout (_("Cannot parse version string: %s"),
154 VERSION);
155 gel_error_num = GEL_IGNORE_ERROR;
156 RAISE_EXCEPTION (exception);
157 return NULL;
158 }
159 }
160
161 m = gel_matrix_new ();
162 gel_matrix_set_size (m, 3, 1, FALSE /* padding */);
163 gel_matrix_index (m, 0, 0) = gel_makenum_ui (v);
164 gel_matrix_index (m, 1, 0) = gel_makenum_ui (b);
165 gel_matrix_index (m, 2, 0) = gel_makenum_ui (c);
166
167 GEL_GET_NEW_NODE (n);
168 n->type = GEL_MATRIX_NODE;
169 n->mat.matrix = gel_matrixw_new_with_matrix_value_only_integer (m);
170 n->mat.quoted = FALSE;
171
172 return n;
173 }
174
175
176 static GelETree *
warranty_op(GelCtx * ctx,GelETree ** a,gboolean * exception)177 warranty_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
178 {
179 gel_infoout (_("Genius %s\n"
180 "%s\n\n"
181 " This program is free software: you can redistribute it and/or modify\n"
182 " it under the terms of the GNU General Public License as published by\n"
183 " the Free Software Foundation, either version 3 of the License, or\n"
184 " (at your option) any later version.\n"
185 "\n"
186 " This program is distributed in the hope that it will be useful,\n"
187 " but WITHOUT ANY WARRANTY; without even the implied warranty of\n"
188 " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n"
189 " GNU General Public License for more details.\n"
190 "\n"
191 " You should have received a copy of the GNU General Public License\n"
192 " along with this program. If not, see <http://www.gnu.org/licenses/>.\n"),
193 VERSION,
194 _(GENIUS_COPYRIGHT_STRING));
195 gel_error_num = GEL_IGNORE_ERROR;
196 RAISE_EXCEPTION (exception);
197 return NULL;
198 }
199
200 static GelETree *
exit_op(GelCtx * ctx,GelETree ** a,gboolean * exception)201 exit_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
202 {
203 gel_got_eof = TRUE;
204 RAISE_EXCEPTION (exception);
205 return NULL;
206 }
207
208 static GelETree *
ninini_op(GelCtx * ctx,GelETree ** a,gboolean * exception)209 ninini_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
210 {
211 gel_infoout ("We are the Knights Who Say... Ni!");
212 RAISE_EXCEPTION (exception);
213 gel_error_num = GEL_IGNORE_ERROR;
214 return NULL;
215 }
216
217 static GelETree *
shrubbery_op(GelCtx * ctx,GelETree ** a,gboolean * exception)218 shrubbery_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
219 {
220 gel_infoout ("Then, when you have found the shrubbery, you must\n"
221 "cut down the mightiest tree in the forest... with...\n"
222 "A HERRING!");
223 RAISE_EXCEPTION (exception);
224 gel_error_num = GEL_IGNORE_ERROR;
225 return NULL;
226 }
227
228 static GelETree *
IsDefined_op(GelCtx * ctx,GelETree ** a,gboolean * exception)229 IsDefined_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
230 {
231 GelToken *tok;
232
233 if (a[0]->type == GEL_MATRIX_NODE)
234 return gel_apply_func_to_matrix
235 (ctx, a[0], IsDefined_op, "IsDefined",
236 exception);
237
238 if G_UNLIKELY ( ! check_argument_string_or_identifier (a, 0, "IsDefined"))
239 return NULL;
240
241 if (a[0]->type == GEL_IDENTIFIER_NODE) {
242 tok = a[0]->id.id;
243 } else /* GEL_STRING_NODE */ {
244 tok = d_intern (a[0]->str.str);
245 }
246
247 if (d_lookup_global (tok) != NULL)
248 return gel_makenum_bool (1);
249 else
250 return gel_makenum_bool (0);
251 }
252
253 static GelETree *
undefine_op(GelCtx * ctx,GelETree ** a,gboolean * exception)254 undefine_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
255 {
256 GelToken *tok;
257
258 if (a[0]->type == GEL_MATRIX_NODE)
259 return gel_apply_func_to_matrix
260 (ctx, a[0], undefine_op, "undefine",
261 exception);
262
263 if G_UNLIKELY ( ! check_argument_string_or_identifier (a, 0, "undefine"))
264 return NULL;
265
266 if (a[0]->type == GEL_IDENTIFIER_NODE) {
267 tok = a[0]->id.id;
268 } else /* GEL_STRING_NODE */ {
269 tok = d_intern (a[0]->str.str);
270 }
271
272 if G_UNLIKELY (tok->protected_) {
273 gel_errorout (_("%s: trying to undefine a protected id!"),
274 "undefine");
275 return NULL;
276 }
277
278 d_delete (tok);
279
280 return gel_makenum_null ();
281 }
282
283 static GelETree *
UndefineAll_op(GelCtx * ctx,GelETree ** a,gboolean * exception)284 UndefineAll_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
285 {
286 GSList *li;
287 GSList *list;
288
289 list = g_slist_copy (d_getcontext_global ());
290
291 for (li = list;
292 li != NULL;
293 li = li->next) {
294 GelEFunc *f = li->data;
295 GelToken *tok = f->id;
296 if ( ! tok->protected_ &&
297 strcmp (tok->token, "Ans") != 0) {
298 d_delete_global (tok);
299 }
300 }
301
302 return gel_makenum_null ();
303 }
304
305 static GelETree *
ProtectAll_op(GelCtx * ctx,GelETree ** a,gboolean * exception)306 ProtectAll_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
307 {
308 d_protect_all ();
309
310 return gel_makenum_null ();
311 }
312
313 static GelETree *
UserVariables_op(GelCtx * ctx,GelETree ** a,gboolean * exception)314 UserVariables_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
315 {
316 GSList *li;
317 GelMatrix *m;
318 GelETree *n;
319 int len, i;
320
321 len = 0;
322
323 for (li = d_getcontext_global ();
324 li != NULL;
325 li = li->next) {
326 GelEFunc *f = li->data;
327 GelToken *tok = f->id;
328 if ( ! tok->protected_ &&
329 strcmp (tok->token, "Ans") != 0) {
330 len++;
331 }
332 }
333
334 if (len == 0)
335 return gel_makenum_null ();
336
337 m = gel_matrix_new ();
338 gel_matrix_set_size (m, len, 1, FALSE /* padding */);
339
340 i = 0;
341 for (li = d_getcontext_global ();
342 li != NULL;
343 li = li->next) {
344 GelEFunc *f = li->data;
345 GelToken *tok = f->id;
346 if ( ! tok->protected_ &&
347 strcmp (tok->token, "Ans") != 0) {
348 gel_matrix_index (m, i, 0) =
349 gel_makenum_identifier (tok);
350 i++;
351 }
352 }
353
354 GEL_GET_NEW_NODE (n);
355 n->type = GEL_MATRIX_NODE;
356 n->mat.matrix = gel_matrixw_new_with_matrix (m);
357 n->mat.quoted = FALSE;
358
359 return n;
360 }
361
362 static GelETree *
true_op(GelCtx * ctx,GelETree ** a,gboolean * exception)363 true_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
364 {
365 return gel_makenum_bool (1);
366 }
367
368 static GelETree *
false_op(GelCtx * ctx,GelETree ** a,gboolean * exception)369 false_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
370 {
371 return gel_makenum_bool (0);
372 }
373
374 static GelETree *
CurrentTime_op(GelCtx * ctx,GelETree ** a,gboolean * exception)375 CurrentTime_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
376 {
377 mpw_t tm;
378 struct timeval tv;
379
380 mpw_init (tm);
381 gettimeofday (&tv, NULL);
382 mpw_set_ui (tm, tv.tv_usec);
383 mpw_make_float (tm);
384 mpw_div_ui (tm, tm, 1000000);
385 mpw_add_ui (tm, tm, tv.tv_sec);
386 return gel_makenum_use (tm);
387 }
388
389 /*sin function*/
390 static GelETree *
IntegerFromBoolean_op(GelCtx * ctx,GelETree ** a,gboolean * exception)391 IntegerFromBoolean_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
392 {
393 int i;
394 if (a[0]->type == GEL_MATRIX_NODE)
395 return gel_apply_func_to_matrix
396 (ctx, a[0], IntegerFromBoolean_op, "IntegerFromBoolean",
397 exception);
398
399 if G_UNLIKELY ( ! check_argument_bool (a, 0, "IntegerFromBoolean"))
400 return NULL;
401
402 if (a[0]->type == GEL_VALUE_NODE)
403 i = mpw_zero_p (a[0]->val.value) ? 0 : 1;
404 else /* a->type == GEL_BOOL_NODE */
405 i = a[0]->bool_.bool_ ? 1 : 0;
406
407 return gel_makenum_ui (i);
408 }
409
410 /*error printing function*/
411 static GelETree *
error_op(GelCtx * ctx,GelETree ** a,gboolean * exception)412 error_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
413 {
414 if (a[0]->type == GEL_STRING_NODE) {
415 gel_errorout ("%s", a[0]->str.str);
416 } else {
417 GelOutput *gelo = gel_output_new();
418 char *s;
419 gel_output_setup_string (gelo, 0, NULL);
420 gel_pretty_print_etree (gelo, a[0]);
421 s = gel_output_snarf_string (gelo);
422 gel_output_unref (gelo);
423 gel_errorout ("%s", s != NULL ? s : "");
424 g_free (s);
425 }
426 return gel_makenum_null();
427 }
428
429 static GelETree *
wait_op(GelCtx * ctx,GelETree ** a,gboolean * exception)430 wait_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
431 {
432 double dsecs;
433 long msecs;
434 struct timeval tv;
435 struct timeval tv2;
436
437 if G_UNLIKELY ( ! check_argument_nonnegative_number (a, 0, "wait"))
438 return NULL;
439
440 dsecs = mpw_get_double (a[0]->val.value);
441 if G_UNLIKELY (gel_error_num != 0) {
442 gel_error_num = 0;
443 return NULL;
444 }
445
446 msecs = (long)(dsecs * 1000);
447 gettimeofday (&tv, NULL);
448 for (;;) {
449 if (gel_evalnode_hook != NULL)
450 (*gel_evalnode_hook)();
451 if G_UNLIKELY (gel_interrupted) {
452 break;
453 }
454 gettimeofday (&tv2, NULL);
455
456 if ( ((tv2.tv_sec - tv.tv_sec) * 1000
457 - (tv.tv_usec / 1000)
458 + (tv2.tv_usec / 1000))
459 >= msecs)
460 break;
461
462 /* sleep 10ms, this is a HORRIBLE HACK! */
463 /* FIXME: do some mainloop thingie over here */
464 usleep (10000);
465 }
466
467 if G_UNLIKELY (gel_interrupted)
468 return NULL;
469 else
470 return gel_makenum_null ();
471 }
472
473 /*print function*/
474 static GelETree *
print_op(GelCtx * ctx,GelETree ** a,gboolean * exception)475 print_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
476 {
477 gboolean old_limit = gel_main_out->length_limit;
478 gel_output_set_length_limit (gel_main_out, FALSE);
479 if (a[0]->type==GEL_STRING_NODE) {
480 gel_output_printf_full (gel_main_out, FALSE, "%s\n", a[0]->str.str);
481 } else {
482 gel_pretty_print_etree (gel_main_out, a[0]);
483 gel_output_string (gel_main_out,"\n");
484 }
485 gel_output_set_length_limit (gel_main_out, old_limit);
486 gel_output_flush (gel_main_out);
487 return gel_makenum_null();
488 }
489 /*print function*/
490 static GelETree *
chdir_op(GelCtx * ctx,GelETree ** a,gboolean * exception)491 chdir_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
492 {
493 if G_UNLIKELY ( ! check_argument_string (a, 0, "chdir"))
494 return NULL;
495 return gel_makenum_si (chdir (a[0]->str.str));
496 }
497 /*print function*/
498 static GelETree *
printn_op(GelCtx * ctx,GelETree ** a,gboolean * exception)499 printn_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
500 {
501 gboolean old_limit = gel_main_out->length_limit;
502 gel_output_set_length_limit (gel_main_out, FALSE);
503 if(a[0]->type==GEL_STRING_NODE)
504 gel_output_printf (gel_main_out, "%s", a[0]->str.str);
505 else
506 gel_print_etree (gel_main_out, a[0], TRUE);
507 gel_output_set_length_limit (gel_main_out, old_limit);
508 gel_output_flush(gel_main_out);
509 return gel_makenum_null();
510 }
511 /*print function*/
512 static GelETree *
display_op(GelCtx * ctx,GelETree ** a,gboolean * exception)513 display_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
514 {
515 gboolean old_limit = gel_main_out->length_limit;
516 if G_UNLIKELY ( ! check_argument_string (a, 0, "display"))
517 return NULL;
518
519 gel_output_set_length_limit (gel_main_out, FALSE);
520
521 gel_output_printf(gel_main_out, "%s: ", a[0]->str.str);
522 gel_pretty_print_etree (gel_main_out, a[1]);
523 gel_output_string(gel_main_out, "\n");
524
525 gel_output_set_length_limit (gel_main_out, old_limit);
526
527 gel_output_flush(gel_main_out);
528 return gel_makenum_null();
529 }
530
531 /*set function*/
532 static GelETree *
set_op(GelCtx * ctx,GelETree ** a,gboolean * exception)533 set_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
534 {
535 GelToken *id;
536 GelEFunc *func;
537 if G_UNLIKELY ( ! check_argument_string_or_identifier (a, 0, "set"))
538 return NULL;
539 if (a[0]->type == GEL_IDENTIFIER_NODE) {
540 id = a[0]->id.id;
541 } else /* GEL_STRING_NODE */ {
542 id = d_intern (a[0]->str.str);
543 }
544
545 if G_UNLIKELY (id->protected_) {
546 gel_errorout (_("%s: trying to set a protected id!"),
547 "set");
548 return NULL;
549 }
550 if G_UNLIKELY (id->parameter) {
551 /* FIXME: fix this, this should just work too */
552 gel_errorout (_("%s: trying to set a parameter, use the equals sign"),
553 "set");
554 return NULL;
555 }
556
557 func = d_makevfunc (id, gel_copynode (a[1]));
558 /* make function global */
559 func->context = 0;
560 d_addfunc_global (func);
561
562 /*
563 * Evil optimization to avoid copying the node from the argument
564 */
565 return gel_stealnode (a[1]);
566 }
567
568 static GelETree *
SetElement_op(GelCtx * ctx,GelETree ** a,gboolean * exception)569 SetElement_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
570 {
571 GelToken *id;
572 GelEFunc *func;
573 GelMatrixW *mat;
574
575 if G_UNLIKELY ( ! check_argument_string_or_identifier (a, 0, "SetElement"))
576 return NULL;
577 if (a[0]->type == GEL_IDENTIFIER_NODE) {
578 id = a[0]->id.id;
579 } else /* GEL_STRING_NODE */ {
580 id = d_intern (a[0]->str.str);
581 }
582
583 if G_UNLIKELY (id->protected_) {
584 gel_errorout (_("%s: trying to set a protected id!"),
585 "set");
586 return NULL;
587 }
588 if G_UNLIKELY (id->parameter) {
589 /* FIXME: fix this, this should just work too */
590 gel_errorout (_("%s: trying to set a parameter, use the equals sign"),
591 "set");
592 return NULL;
593 }
594
595 func = d_lookup_only_global (id);
596
597 if (func == NULL ||
598 func->type != GEL_VARIABLE_FUNC ||
599 func->data.user->type != GEL_MATRIX_NODE) {
600 GelETree *t;
601
602 GEL_GET_NEW_NODE (t);
603 t->type = GEL_MATRIX_NODE;
604 mat = t->mat.matrix = gel_matrixw_new ();
605 t->mat.quoted = FALSE;
606 gel_matrixw_set_size (mat, 1, 1);
607
608 if G_UNLIKELY ( ! _gel_iter_set_element (mat, a[3], a[1], a[2])) {
609 gel_freetree (t);
610 return NULL;
611 }
612
613 func = d_makevfunc (id, t);
614 /* make function global */
615 func->context = 0;
616 d_addfunc_global (func);
617 } else {
618 mat = func->data.user->mat.matrix;
619 if G_UNLIKELY ( ! _gel_iter_set_element (mat, a[3], a[1], a[2])) {
620 return NULL;
621 }
622 }
623
624 /*
625 * Evil optimization to avoid copying the node from the argument
626 */
627 return gel_stealnode (a[3]);
628 }
629
630 static GelETree *
SetVElement_op(GelCtx * ctx,GelETree ** a,gboolean * exception)631 SetVElement_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
632 {
633 GelToken *id;
634 GelEFunc *func;
635 GelMatrixW *mat;
636
637 if G_UNLIKELY ( ! check_argument_string_or_identifier (a, 0, "SetVElement"))
638 return NULL;
639 if (a[0]->type == GEL_IDENTIFIER_NODE) {
640 id = a[0]->id.id;
641 } else /* GEL_STRING_NODE */ {
642 id = d_intern (a[0]->str.str);
643 }
644
645 if G_UNLIKELY (id->protected_) {
646 gel_errorout (_("%s: trying to set a protected id!"),
647 "set");
648 return NULL;
649 }
650 if G_UNLIKELY (id->parameter) {
651 /* FIXME: fix this, this should just work too */
652 gel_errorout (_("%s: trying to set a parameter, use the equals sign"),
653 "set");
654 return NULL;
655 }
656
657 func = d_lookup_only_global (id);
658
659 if (func == NULL ||
660 func->type != GEL_VARIABLE_FUNC ||
661 func->data.user->type != GEL_MATRIX_NODE) {
662 GelETree *t;
663
664 GEL_GET_NEW_NODE (t);
665 t->type = GEL_MATRIX_NODE;
666 mat = t->mat.matrix = gel_matrixw_new ();
667 t->mat.quoted = FALSE;
668 gel_matrixw_set_size (mat, 1, 1);
669
670 if G_UNLIKELY ( ! _gel_iter_set_velement (mat, a[2], a[1])) {
671 gel_freetree (t);
672 return NULL;
673 }
674
675 func = d_makevfunc (id, t);
676 /* make function global */
677 func->context = 0;
678 d_addfunc_global (func);
679 } else {
680 mat = func->data.user->mat.matrix;
681 if G_UNLIKELY ( ! _gel_iter_set_velement (mat, a[2], a[1])) {
682 return NULL;
683 }
684 }
685
686 /*
687 * Evil optimization to avoid copying the node from the argument
688 */
689 return gel_stealnode (a[2]);
690 }
691
692 static void
display_all_vars(void)693 display_all_vars (void)
694 {
695 GelContextFrame *all_contexts, *lic;
696 GSList *funcs;
697 GSList *li;
698 gboolean printed_local_title = FALSE;
699
700 all_contexts = d_get_all_contexts ();
701 funcs = d_getcontext_global ();
702
703 gel_output_string (gel_main_out,
704 _("Global variables:\n\n"));
705
706 for (li = funcs; li != NULL; li = li->next) {
707 GelEFunc *f = li->data;
708 if (f->type != GEL_VARIABLE_FUNC ||
709 f->id == NULL ||
710 /* only for toplevel */ f->id->parameter ||
711 /* only for toplevel */ f->id->protected_ ||
712 f->id->token == NULL ||
713 f->data.user == NULL ||
714 f->context > 0)
715 continue;
716
717 gel_output_printf (gel_main_out, "%s = ", f->id->token);
718 gel_print_etree (gel_main_out, f->data.user, FALSE /*no toplevel, keep this short*/);
719 gel_output_string (gel_main_out, "\n");
720 }
721
722
723 if (d_curcontext () > 0) {
724 int i = d_curcontext ();
725
726 gel_output_string
727 (gel_main_out, _("\nFunction call stack:\n"));
728 gel_output_string
729 (gel_main_out, _("(depth of context in parentheses)\n\n"));
730
731 /* go over all local contexts (not the last one, that is global) */
732 for (lic = all_contexts; lic != NULL && lic->next != NULL; lic = lic->next) {
733 GelToken *tok = lic->name;
734
735 if (tok == NULL) {
736 gel_output_string (gel_main_out, "??");
737 } else {
738 gel_output_string (gel_main_out, tok->token);
739 }
740
741 gel_output_printf (gel_main_out, " (%d)", i);
742
743 if (i <= 1) {
744 gel_output_string (gel_main_out, "\n");
745 } else {
746 gel_output_string (gel_main_out, ", ");
747 }
748
749 i--;
750 }
751 }
752
753
754 /* go over all local contexts (not the last one, that is global) */
755 for (lic = all_contexts; lic != NULL && lic->next != NULL; lic = lic->next) {
756 for (li = lic->functions; li != NULL; li = li->next) {
757 GelEFunc *f = li->data;
758 if (f->type != GEL_VARIABLE_FUNC ||
759 f->id == NULL ||
760 f->id->token == NULL ||
761 f->data.user == NULL ||
762 f->context <= 0)
763 continue;
764
765 if ( ! printed_local_title) {
766 gel_output_string (gel_main_out,
767 _("\nLocal variables:\n"));
768 gel_output_string (gel_main_out,
769 _("(depth of context in parentheses)\n\n"));
770 printed_local_title = TRUE;
771 }
772
773 gel_output_printf (gel_main_out, "(%d) %s = ", f->context, f->id->token);
774 gel_print_etree (gel_main_out, f->data.user, FALSE /*no toplevel, keep this short*/);
775 gel_output_string (gel_main_out, "\n");
776 }
777 }
778 }
779
780 /*set function*/
781 static GelETree *
DisplayVariables_op(GelCtx * ctx,GelETree ** a,gboolean * exception)782 DisplayVariables_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
783 {
784 int j;
785
786 if (a == NULL)
787 display_all_vars ();
788
789 j = 0;
790 while (a != NULL && a[j] != NULL) {
791 GelToken *id;
792 GelEFunc *f;
793 if (a[j]->type == GEL_IDENTIFIER_NODE) {
794 id = a[j]->id.id;
795 } else if (a[j]->type == GEL_STRING_NODE) {
796 id = d_intern (a[j]->str.str);
797 } else {
798 gel_errorout (_("%s: Argument number %d not a string or identifier"),
799 "DisplayVariables",
800 j+1);
801 return NULL;
802 }
803
804 f = d_lookup_global (id);
805
806 if (f == NULL) {
807 gel_output_printf(gel_main_out, _("%s undefined\n"), id->token);
808 } else {
809 gel_output_printf(gel_main_out, "%s = ", id->token);
810 gel_print_func (gel_main_out, f);
811 gel_output_string(gel_main_out, "\n");
812 }
813 j++;
814 }
815
816 return gel_makenum_null ();
817 }
818
819 /*rand function*/
820 static GelETree *
rand_op(GelCtx * ctx,GelETree ** a,gboolean * exception)821 rand_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
822 {
823 int args;
824
825 args = 0;
826 while (a != NULL && a[args] != NULL)
827 args++;
828
829 if G_UNLIKELY (args > 2) {
830 gel_errorout (_("%s: Too many arguments, should be at most %d"),
831 "rand", 2);
832 return NULL;
833 }
834
835 if (args == 0) {
836 mpw_t fr;
837 mpw_init (fr);
838 mpw_rand (fr);
839
840 return gel_makenum_use (fr);
841 } else if (args == 1) {
842 GelETree *n;
843 GelMatrix *m;
844 int size, i;
845
846 if G_UNLIKELY ( ! check_argument_nonnegative_integer (a, 0, "rand"))
847 return NULL;
848
849 size = gel_get_nonnegative_integer (a[0]->val.value, "rand");
850 if G_UNLIKELY (size < 0)
851 return NULL;
852
853 if (size == 0)
854 return gel_makenum_null ();
855
856 m = gel_matrix_new ();
857 gel_matrix_set_size (m, size, 1, FALSE /* padding */);
858 for (i = 0; i < size; i++) {
859 mpw_t fr;
860 mpw_init (fr);
861 mpw_rand (fr);
862
863 gel_matrix_index (m, i, 0) = gel_makenum_use (fr);
864 }
865
866 GEL_GET_NEW_NODE (n);
867 n->type = GEL_MATRIX_NODE;
868 n->mat.matrix = gel_matrixw_new_with_matrix_value_only_real_nonrational (m);
869 n->mat.quoted = FALSE;
870
871 return n;
872 } else /* args == 2 */ {
873 GelETree *n;
874 GelMatrix *m;
875 int sizex, sizey, i, j;
876
877 if G_UNLIKELY ( ! check_argument_nonnegative_integer (a, 0, "rand") ||
878 ! check_argument_nonnegative_integer (a, 1, "rand"))
879 return NULL;
880
881 sizey = gel_get_nonnegative_integer (a[0]->val.value, "rand");
882 if G_UNLIKELY (sizey < 0)
883 return NULL;
884 sizex = gel_get_nonnegative_integer (a[1]->val.value, "rand");
885 if G_UNLIKELY (sizex < 0)
886 return NULL;
887
888 if (sizex == 0 || sizey == 0)
889 return gel_makenum_null ();
890
891 m = gel_matrix_new ();
892 gel_matrix_set_size (m, sizex, sizey, FALSE /* padding */);
893 for (j = 0; j < sizey; j++) {
894 for (i = 0; i < sizex; i++) {
895 mpw_t fr;
896 mpw_init (fr);
897 mpw_rand (fr);
898
899 gel_matrix_index (m, i, j) = gel_makenum_use (fr);
900 }
901 }
902
903 GEL_GET_NEW_NODE (n);
904 n->type = GEL_MATRIX_NODE;
905 n->mat.matrix = gel_matrixw_new_with_matrix_value_only_real_nonrational (m);
906 n->mat.quoted = FALSE;
907
908 return n;
909 }
910 }
911
912 /*rand function*/
913 static GelETree *
randint_op(GelCtx * ctx,GelETree ** a,gboolean * exception)914 randint_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
915 {
916 int args;
917
918 args = 0;
919 while (a[args] != NULL)
920 args++;
921
922 if G_UNLIKELY (args > 3) {
923 gel_errorout (_("%s: Too many arguments, should be at most %d"),
924 "randint", 3);
925 return NULL;
926 }
927
928 if (args == 1) {
929 mpw_t fr;
930
931 if G_UNLIKELY ( ! check_argument_integer (a, 0, "randint"))
932 return NULL;
933
934 mpw_init (fr);
935 mpw_randint (fr, a[0]->val.value);
936 if G_UNLIKELY (gel_error_num != 0) {
937 mpw_clear (fr);
938 return NULL;
939 }
940
941 return gel_makenum_use (fr);
942 } else if (args == 2) {
943 GelETree *n;
944 GelMatrix *m;
945 int size, i;
946
947 if G_UNLIKELY ( ! check_argument_integer (a, 0, "randint") ||
948 ! check_argument_nonnegative_integer (a, 1, "randint"))
949 return NULL;
950
951 size = gel_get_nonnegative_integer (a[1]->val.value, "randint");
952 if G_UNLIKELY (size < 0)
953 return NULL;
954
955 if (size == 0)
956 return gel_makenum_null ();
957
958 m = gel_matrix_new ();
959 gel_matrix_set_size (m, size, 1, FALSE /* padding */);
960 for (i = 0; i < size; i++) {
961 mpw_t fr;
962 mpw_init (fr);
963 mpw_randint (fr, a[0]->val.value);
964 if G_UNLIKELY (gel_error_num != 0) {
965 mpw_clear (fr);
966 /* This can only happen if a[0]->val.value is
967 * evil, in which case we have not set any
968 * elements yet. So we don't have to free any
969 * elements yet */
970 g_assert (i == 0);
971 gel_matrix_free (m);
972 return NULL;
973 }
974
975 gel_matrix_index (m, i, 0) = gel_makenum_use (fr);
976 }
977
978 GEL_GET_NEW_NODE (n);
979 n->type = GEL_MATRIX_NODE;
980 n->mat.matrix = gel_matrixw_new_with_matrix_value_only_integer (m);
981 n->mat.quoted = FALSE;
982
983 return n;
984 } else /* args == 3 */ {
985 GelETree *n;
986 GelMatrix *m;
987 int sizex, sizey, i, j;
988
989 if G_UNLIKELY ( ! check_argument_integer (a, 0, "randint") ||
990 ! check_argument_nonnegative_integer (a, 1, "randint") ||
991 ! check_argument_nonnegative_integer (a, 2, "randint"))
992 return NULL;
993
994 sizey = gel_get_nonnegative_integer (a[1]->val.value, "randint");
995 if G_UNLIKELY (sizey < 0)
996 return NULL;
997 sizex = gel_get_nonnegative_integer (a[2]->val.value, "randint");
998 if G_UNLIKELY (sizex < 0)
999 return NULL;
1000
1001 if (sizex == 0 || sizey == 0)
1002 return gel_makenum_null ();
1003
1004 m = gel_matrix_new ();
1005 gel_matrix_set_size (m, sizex, sizey, FALSE /* padding */);
1006 for (j = 0; j < sizey; j++) {
1007 for (i = 0; i < sizex; i++) {
1008 mpw_t fr;
1009 mpw_init (fr);
1010 mpw_randint (fr, a[0]->val.value);
1011 if G_UNLIKELY (gel_error_num != 0) {
1012 mpw_clear (fr);
1013 /* This can only happen if a[0]->val.value is
1014 * evil, in which case we have not set any
1015 * elements yet. So we don't have to free any
1016 * elements yet */
1017 g_assert (i == 0 && j == 0);
1018 gel_matrix_free (m);
1019 return NULL;
1020 }
1021
1022 gel_matrix_index (m, i, j) = gel_makenum_use (fr);
1023 }
1024 }
1025
1026 GEL_GET_NEW_NODE (n);
1027 n->type = GEL_MATRIX_NODE;
1028 n->mat.matrix = gel_matrixw_new_with_matrix_value_only_integer (m);
1029 n->mat.quoted = FALSE;
1030
1031 return n;
1032 }
1033 }
1034
1035 GelETree *
gel_apply_func_to_matrixen(GelCtx * ctx,GelETree * mat1,GelETree * mat2,GelBIFunction function,const char * ident,gboolean * exception)1036 gel_apply_func_to_matrixen (GelCtx *ctx,
1037 GelETree *mat1,
1038 GelETree *mat2,
1039 GelBIFunction function,
1040 const char *ident,
1041 gboolean *exception)
1042 {
1043 GelMatrixW *m1 = NULL;
1044 GelMatrixW *m2 = NULL;
1045 GelMatrixW *new;
1046 GelETree *re_node = NULL;
1047 gboolean reverse = FALSE;
1048 GelETree *n;
1049 int i, j, w, h;
1050 int quote = 0;
1051 gboolean internal_exception = FALSE;
1052
1053 if(mat1->type == GEL_MATRIX_NODE &&
1054 mat2->type == GEL_MATRIX_NODE) {
1055 m1 = mat1->mat.matrix;
1056 m2 = mat2->mat.matrix;
1057 quote = mat1->mat.quoted || mat2->mat.quoted;
1058 } else if(mat1->type == GEL_MATRIX_NODE) {
1059 m1 = mat1->mat.matrix;
1060 quote = mat1->mat.quoted;
1061 re_node = mat2;
1062 } else /*if(mat2->type == GEL_MATRIX_NODE)*/ {
1063 m1 = mat2->mat.matrix;
1064 quote = mat2->mat.quoted;
1065 re_node = mat1;
1066 reverse = TRUE;
1067 }
1068
1069 if G_UNLIKELY (m2 && (gel_matrixw_width(m1) != gel_matrixw_width(m2) ||
1070 gel_matrixw_height(m1) != gel_matrixw_height(m2))) {
1071 gel_errorout (_("Cannot apply function to two differently sized matrices"));
1072 return NULL;
1073 }
1074
1075 w = gel_matrixw_width (m1);
1076 h = gel_matrixw_height (m1);
1077
1078 /*make us a new empty node*/
1079 GEL_GET_NEW_NODE(n);
1080 n->type = GEL_MATRIX_NODE;
1081 new = n->mat.matrix = gel_matrixw_new();
1082 n->mat.quoted = quote;
1083 gel_matrixw_set_size (new, w, h);
1084
1085 for (j = 0; j < h; j++) {
1086 for (i = 0; i < w; i++) {
1087 GelETree *t[2];
1088 GelETree *e;
1089 if(!reverse) {
1090 t[0] = gel_matrixw_index(m1,i,j);
1091 t[1] = m2?gel_matrixw_index(m2,i,j):re_node;
1092 } else {
1093 t[0] = m2?gel_matrixw_index(m2,i,j):re_node;
1094 t[1] = gel_matrixw_index(m1,i,j);
1095 }
1096 if G_LIKELY ( ! internal_exception)
1097 e = (*function) (ctx, t, &internal_exception);
1098 else
1099 e = NULL;
1100
1101 if G_UNLIKELY (e == NULL) {
1102 GelETree *nn;
1103 GelETree *ni;
1104 GEL_GET_NEW_NODE(ni);
1105 ni->type = GEL_IDENTIFIER_NODE;
1106 ni->id.id = d_intern(ident);
1107 ni->id.uninitialized = FALSE;
1108
1109 GEL_GET_NEW_NODE(nn);
1110 nn->type = GEL_OPERATOR_NODE;
1111 nn->op.oper = GEL_E_CALL;
1112 nn->op.nargs = 3;
1113 nn->op.args = ni;
1114 nn->op.args->any.next = gel_copynode(t[0]);
1115 nn->op.args->any.next->any.next = gel_copynode(t[1]);
1116 nn->op.args->any.next->any.next->any.next = NULL;
1117
1118 gel_matrixw_set_index(new,i,j) = nn;
1119 } else {
1120 gel_matrixw_set_index(new,i,j) = e;
1121 }
1122 }
1123 }
1124
1125 if G_UNLIKELY (internal_exception) {
1126 RAISE_EXCEPTION (exception);
1127 }
1128
1129 return n;
1130 }
1131
1132 GelETree *
gel_apply_func_to_matrix(GelCtx * ctx,GelETree * mat,GelBIFunction function,const char * ident,gboolean * exception)1133 gel_apply_func_to_matrix (GelCtx *ctx,
1134 GelETree *mat,
1135 GelBIFunction function,
1136 const char *ident,
1137 gboolean *exception)
1138 {
1139 GelMatrixW *m;
1140 GelMatrixW *new;
1141 GelETree *n;
1142 int i, j, w, h;
1143 gboolean internal_exception = FALSE;
1144
1145 m = mat->mat.matrix;
1146
1147 w = gel_matrixw_width(m);
1148 h = gel_matrixw_height(m);
1149
1150 /*make us a new empty node*/
1151 GEL_GET_NEW_NODE(n);
1152 n->type = GEL_MATRIX_NODE;
1153 new = n->mat.matrix = gel_matrixw_new();
1154 n->mat.quoted = mat->mat.quoted;
1155 gel_matrixw_set_size (new, w, h);
1156
1157 for (j = 0; j < h; j++) {
1158 for (i = 0; i < w; i++) {
1159 GelETree *t[1];
1160 GelETree *e;
1161 t[0] = gel_matrixw_index(m,i,j);
1162
1163 if G_LIKELY ( ! internal_exception)
1164 e = (*function) (ctx, t, &internal_exception);
1165 else
1166 e = NULL;
1167 if G_UNLIKELY (e == NULL) {
1168 GelETree *nn;
1169 GelETree *ni;
1170 GEL_GET_NEW_NODE(nn);
1171 nn->type = GEL_OPERATOR_NODE;
1172 nn->op.oper = GEL_E_CALL;
1173 nn->op.args = NULL;
1174 nn->op.nargs = 2;
1175
1176 GEL_GET_NEW_NODE(ni);
1177 ni->type = GEL_IDENTIFIER_NODE;
1178 ni->id.id = d_intern(ident);
1179 ni->id.uninitialized = FALSE;
1180
1181 nn->op.args = ni;
1182 nn->op.args->any.next = gel_copynode(t[0]);
1183 nn->op.args->any.next->any.next = NULL;
1184
1185 gel_matrixw_set_index(new,i,j) = nn;
1186 } else if (e->type == GEL_VALUE_NODE &&
1187 mpw_exact_zero_p (e->val.value)) {
1188 gel_freetree (e);
1189 gel_matrixw_set_index(new,i,j) = NULL;
1190 } else {
1191 gel_matrixw_set_index(new,i,j) = e;
1192 }
1193 }
1194 }
1195
1196 if G_UNLIKELY (internal_exception) {
1197 RAISE_EXCEPTION (exception);
1198 }
1199
1200 return n;
1201 }
1202
1203 /* expand matrix function*/
1204 static GelETree *
ExpandMatrix_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1205 ExpandMatrix_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1206 {
1207 GelETree *n;
1208
1209 if (a[0]->type == GEL_NULL_NODE)
1210 return gel_makenum_null ();
1211
1212 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "ExpandMatrix"))
1213 return NULL;
1214
1215 GEL_GET_NEW_NODE (n);
1216 n->type = GEL_MATRIX_NODE;
1217 n->mat.matrix = gel_matrixw_copy (a[0]->mat.matrix);
1218 gel_expandmatrix (n);
1219 n->mat.quoted = FALSE;
1220 return n;
1221 }
1222
1223 static GelETree *
RowsOf_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1224 RowsOf_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1225 {
1226 GelETree *n;
1227
1228 if (a[0]->type == GEL_NULL_NODE)
1229 return gel_makenum_null ();
1230
1231 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "RowsOf"))
1232 return NULL;
1233
1234 GEL_GET_NEW_NODE (n);
1235 n->type = GEL_MATRIX_NODE;
1236 n->mat.matrix = gel_matrixw_rowsof (a[0]->mat.matrix);
1237 n->mat.quoted = FALSE;
1238 return n;
1239 }
1240
1241 static GelETree *
ColumnsOf_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1242 ColumnsOf_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1243 {
1244 GelETree *n;
1245
1246 if (a[0]->type == GEL_NULL_NODE)
1247 return gel_makenum_null ();
1248
1249 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "ColumnsOf"))
1250 return NULL;
1251
1252 GEL_GET_NEW_NODE (n);
1253 n->type = GEL_MATRIX_NODE;
1254 n->mat.matrix = gel_matrixw_columnsof (a[0]->mat.matrix);
1255 n->mat.quoted = FALSE;
1256 return n;
1257 }
1258
1259 static GelETree *
DiagonalOf_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1260 DiagonalOf_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1261 {
1262 GelETree *n;
1263
1264 if G_UNLIKELY ( ! check_argument_matrix_or_null (a, 0, "DiagonalOf"))
1265 return NULL;
1266
1267 if (a[0]->type == GEL_NULL_NODE)
1268 return gel_makenum_null ();
1269
1270 GEL_GET_NEW_NODE (n);
1271 n->type = GEL_MATRIX_NODE;
1272 n->mat.matrix = gel_matrixw_diagonalof (a[0]->mat.matrix);
1273 n->mat.quoted = FALSE;
1274 return n;
1275 }
1276
1277 static GelETree *
CountZeroColumns_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1278 CountZeroColumns_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1279 {
1280 GelMatrixW *m;
1281 int i, j, w, h;
1282 int cnt;
1283
1284 if G_UNLIKELY ( ! check_argument_matrix_or_null (a, 0, "CountZeroColumns"))
1285 return NULL;
1286
1287 if (a[0]->type == GEL_NULL_NODE)
1288 return gel_makenum_ui (0);
1289
1290 m = a[0]->mat.matrix;
1291 w = gel_matrixw_width (m);
1292 h = gel_matrixw_height (m);
1293 cnt = 0;
1294 /* Must be done in this order and not rowise as is usual for genius! */
1295 for (i = 0; i < w; i++) {
1296 for (j = 0; j < h; j++) {
1297 GelETree *t = gel_matrixw_get_index (m, i, j);
1298 if ( ! ( t == NULL ||
1299 t->type == GEL_NULL_NODE ||
1300 (t->type == GEL_VALUE_NODE &&
1301 mpw_zero_p (t->val.value)))) {
1302 cnt++;
1303 break;
1304 }
1305 }
1306 }
1307
1308 return gel_makenum_ui (w-cnt);
1309 }
1310
1311 static GelETree *
StripZeroColumns_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1312 StripZeroColumns_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1313 {
1314 GelETree *n;
1315 GelMatrixW *m;
1316 GelMatrix *nm;
1317 int i, j, w, h, tj;
1318 int cnt;
1319 GSList *cols, *li;
1320
1321 if G_UNLIKELY ( ! check_argument_matrix_or_null (a, 0, "StripZeroColumns"))
1322 return NULL;
1323
1324 if (a[0]->type == GEL_NULL_NODE)
1325 return gel_makenum_null ();
1326
1327 m = a[0]->mat.matrix;
1328 w = gel_matrixw_width (m);
1329 h = gel_matrixw_height (m);
1330 cnt = 0;
1331 cols = NULL;
1332 /* Must be done in this order and not rowise as is usual for genius! */
1333 for (i = 0; i < w; i++) {
1334 for (j = 0; j < h; j++) {
1335 GelETree *t = gel_matrixw_get_index (m, i, j);
1336 if ( ! ( t == NULL ||
1337 t->type == GEL_NULL_NODE ||
1338 (t->type == GEL_VALUE_NODE &&
1339 mpw_zero_p (t->val.value)))) {
1340 cols = g_slist_prepend (cols,
1341 GINT_TO_POINTER (i));
1342 cnt++;
1343 break;
1344 }
1345 }
1346 }
1347
1348 if (cnt == w) {
1349 g_slist_free (cols);
1350 return gel_copynode (a[0]);
1351 } else if (cnt == 0) {
1352 return gel_makenum_null ();
1353 }
1354
1355 nm = gel_matrix_new ();
1356 gel_matrix_set_size (nm, cnt, h, FALSE /* padding */);
1357
1358 tj = cnt-1;
1359 for (li = cols; li != NULL; li = li->next) {
1360 i = GPOINTER_TO_INT (li->data);
1361 for (j = 0; j < h; j++) {
1362 GelETree *t = gel_matrixw_get_index (m, i, j);
1363 if (t != NULL)
1364 gel_matrix_index (nm, tj, j) =
1365 gel_copynode (t);
1366 }
1367 tj--;
1368 }
1369
1370 g_slist_free (cols);
1371
1372 GEL_GET_NEW_NODE (n);
1373 n->type = GEL_MATRIX_NODE;
1374 n->mat.matrix = gel_matrixw_new_with_matrix (nm);
1375 n->mat.quoted = a[0]->mat.quoted;
1376
1377 return n;
1378 }
1379
1380 /*ComplexConjugate function*/
1381 static GelETree *
ComplexConjugate_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1382 ComplexConjugate_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1383 {
1384 mpw_t fr;
1385
1386 if (a[0]->type == GEL_FUNCTION_NODE ||
1387 a[0]->type == GEL_IDENTIFIER_NODE) {
1388 return gel_function_from_function (conj_function, a[0]);
1389 }
1390
1391 if (a[0]->type == GEL_MATRIX_NODE)
1392 return gel_apply_func_to_matrix (ctx, a[0], ComplexConjugate_op, "ComplexConjugate", exception);
1393
1394 if G_UNLIKELY ( ! check_argument_number (a, 0, "ComplexConjugate"))
1395 return NULL;
1396
1397 mpw_init (fr);
1398
1399 mpw_conj (fr, a[0]->val.value);
1400
1401 return gel_makenum_use (fr);
1402 }
1403
1404 /*sin function*/
1405 static GelETree *
sin_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1406 sin_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
1407 {
1408 mpw_t fr;
1409
1410 if (a[0]->type == GEL_FUNCTION_NODE ||
1411 a[0]->type == GEL_IDENTIFIER_NODE) {
1412 return gel_function_from_function (sin_function, a[0]);
1413 }
1414
1415 if(a[0]->type==GEL_MATRIX_NODE)
1416 return gel_apply_func_to_matrix(ctx,a[0],sin_op,"sin", exception);
1417
1418 if G_UNLIKELY ( ! check_argument_number (a, 0, "sin"))
1419 return NULL;
1420
1421 mpw_init(fr);
1422
1423 mpw_sin(fr,a[0]->val.value);
1424
1425 return gel_makenum_use(fr);
1426 }
1427
1428 /*sinc function*/
1429 static GelETree *
sinc_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1430 sinc_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
1431 {
1432 mpw_t fr;
1433
1434 if (a[0]->type == GEL_FUNCTION_NODE ||
1435 a[0]->type == GEL_IDENTIFIER_NODE) {
1436 return gel_function_from_function (sinc_function, a[0]);
1437 }
1438
1439 if(a[0]->type==GEL_MATRIX_NODE)
1440 return gel_apply_func_to_matrix(ctx,a[0],sinc_op,"sinc", exception);
1441
1442 if G_UNLIKELY ( ! check_argument_number (a, 0, "sinc"))
1443 return NULL;
1444
1445 if (mpw_zero_p (a[0]->val.value))
1446 return gel_makenum_ui(1);
1447
1448 mpw_init(fr);
1449
1450 mpw_sin(fr,a[0]->val.value);
1451 mpw_div(fr,fr,a[0]->val.value);
1452
1453 return gel_makenum_use(fr);
1454 }
1455
1456 /*sinh function*/
1457 static GelETree *
sinh_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1458 sinh_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
1459 {
1460 mpw_t fr;
1461
1462 if (a[0]->type == GEL_FUNCTION_NODE ||
1463 a[0]->type == GEL_IDENTIFIER_NODE) {
1464 return gel_function_from_function (sinh_function, a[0]);
1465 }
1466
1467 if(a[0]->type==GEL_MATRIX_NODE)
1468 return gel_apply_func_to_matrix(ctx,a[0],sinh_op,"sinh", exception);
1469
1470 if G_UNLIKELY ( ! check_argument_number (a, 0, "sinh"))
1471 return NULL;
1472
1473 mpw_init(fr);
1474
1475 mpw_sinh(fr,a[0]->val.value);
1476
1477 return gel_makenum_use(fr);
1478 }
1479
1480 /*cos function*/
1481 static GelETree *
cos_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1482 cos_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
1483 {
1484 mpw_t fr;
1485
1486 if (a[0]->type == GEL_FUNCTION_NODE ||
1487 a[0]->type == GEL_IDENTIFIER_NODE) {
1488 return gel_function_from_function (cos_function, a[0]);
1489 }
1490
1491 if(a[0]->type==GEL_MATRIX_NODE)
1492 return gel_apply_func_to_matrix(ctx,a[0],cos_op,"cos", exception);
1493
1494 if G_UNLIKELY ( ! check_argument_number (a, 0, "cos"))
1495 return NULL;
1496
1497 mpw_init(fr);
1498
1499 mpw_cos(fr,a[0]->val.value);
1500
1501 return gel_makenum_use(fr);
1502 }
1503
1504 /*cosh function*/
1505 static GelETree *
cosh_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1506 cosh_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
1507 {
1508 mpw_t fr;
1509
1510 if (a[0]->type == GEL_FUNCTION_NODE ||
1511 a[0]->type == GEL_IDENTIFIER_NODE) {
1512 return gel_function_from_function (cosh_function, a[0]);
1513 }
1514
1515 if(a[0]->type==GEL_MATRIX_NODE)
1516 return gel_apply_func_to_matrix(ctx,a[0],cosh_op,"cosh", exception);
1517
1518 if G_UNLIKELY ( ! check_argument_number (a, 0, "cosh"))
1519 return NULL;
1520
1521 mpw_init(fr);
1522
1523 mpw_cosh(fr,a[0]->val.value);
1524
1525 return gel_makenum_use(fr);
1526 }
1527
1528 /*tan function*/
1529 static GelETree *
tan_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1530 tan_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
1531 {
1532 mpw_t fr;
1533 mpw_t fr2;
1534
1535 if (a[0]->type == GEL_FUNCTION_NODE ||
1536 a[0]->type == GEL_IDENTIFIER_NODE) {
1537 return gel_function_from_function (tan_function, a[0]);
1538 }
1539
1540 if(a[0]->type==GEL_MATRIX_NODE)
1541 return gel_apply_func_to_matrix(ctx,a[0],tan_op,"tan", exception);
1542
1543 if G_UNLIKELY ( ! check_argument_real_number (a, 0, "tan"))
1544 return NULL;
1545
1546 mpw_init(fr);
1547 mpw_set(fr,a[0]->val.value);
1548
1549 /*is this algorithm always precise??? sin/cos*/
1550 mpw_init(fr2);
1551 mpw_cos(fr2,fr);
1552 mpw_sin(fr,fr);
1553 mpw_div(fr,fr,fr2);
1554 mpw_clear(fr2);
1555
1556 return gel_makenum_use(fr);
1557 }
1558
1559 /*atan (arctan) function*/
1560 static GelETree *
atan_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1561 atan_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
1562 {
1563 mpw_t fr;
1564
1565 if (a[0]->type == GEL_FUNCTION_NODE ||
1566 a[0]->type == GEL_IDENTIFIER_NODE) {
1567 return gel_function_from_function (atan_function, a[0]);
1568 }
1569
1570 if(a[0]->type==GEL_MATRIX_NODE)
1571 return gel_apply_func_to_matrix(ctx,a[0],atan_op,"atan", exception);
1572
1573 if G_UNLIKELY ( ! check_argument_number (a, 0, "atan"))
1574 return NULL;
1575
1576 mpw_init(fr);
1577
1578 mpw_arctan(fr,a[0]->val.value);
1579
1580 return gel_makenum_use(fr);
1581 }
1582
1583 /*atan2 (arctan2) function*/
1584 static GelETree *
atan2_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1585 atan2_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
1586 {
1587 mpw_t fr;
1588
1589 if(a[0]->type==GEL_MATRIX_NODE ||
1590 a[1]->type==GEL_MATRIX_NODE)
1591 return gel_apply_func_to_matrixen(ctx,a[0],a[1],atan2_op,"atan2", exception);
1592
1593 if G_UNLIKELY ( ! check_argument_number (a, 0, "atan2") ||
1594 ! check_argument_number (a, 1, "atan2"))
1595 return NULL;
1596
1597 mpw_init (fr);
1598 mpw_arctan2 (fr,
1599 a[0]->val.value,
1600 a[1]->val.value);
1601 if G_UNLIKELY (gel_error_num) {
1602 gel_error_num = 0;
1603 mpw_clear (fr);
1604 return NULL;
1605 }
1606
1607 return gel_makenum_use (fr);
1608 }
1609
1610 /*e function (or e variable actually)*/
1611 static GelETree *
e_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1612 e_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1613 {
1614 if (e_iscached)
1615 return gel_makenum (e_cache);
1616
1617 mpw_init (e_cache);
1618 mpw_set_ui (e_cache,1);
1619 mpw_exp (e_cache, e_cache);
1620 e_iscached = TRUE;
1621 return gel_makenum (e_cache);
1622 }
1623
1624 /* Free fall acceleration */
1625 static GelETree *
Gravity_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1626 Gravity_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1627 {
1628 mpw_t g;
1629 mpw_init (g);
1630 mpw_set_d (g, 9.80665);
1631 return gel_makenum_use (g);
1632 }
1633
1634 /* EulerConstant */
1635 static GelETree *
EulerConstant_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1636 EulerConstant_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1637 {
1638 mpw_t e;
1639 mpw_init (e);
1640 mpw_euler_constant (e);
1641 return gel_makenum_use (e);
1642 }
1643
1644 /* CatalanConstant */
1645 static GelETree *
CatalanConstant_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1646 CatalanConstant_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1647 {
1648 mpw_t cc;
1649 mpw_init (cc);
1650 mpw_catalan_constant (cc);
1651 return gel_makenum_use (cc);
1652 }
1653
1654 /*pi function (or pi variable or whatever)*/
1655 static GelETree *
pi_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1656 pi_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1657 {
1658 mpw_t fr;
1659 mpw_init (fr);
1660 mpw_pi (fr);
1661
1662 return gel_makenum_use (fr);
1663 }
1664
1665 static GelETree *
GoldenRatio_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1666 GoldenRatio_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1667 {
1668 if G_LIKELY (golden_ratio_iscached)
1669 return gel_makenum (golden_ratio_cache);
1670
1671 mpw_init (golden_ratio_cache);
1672 mpw_set_ui (golden_ratio_cache, 5);
1673 mpw_sqrt (golden_ratio_cache, golden_ratio_cache);
1674 mpw_add_ui (golden_ratio_cache, golden_ratio_cache, 1);
1675 mpw_div_ui (golden_ratio_cache, golden_ratio_cache, 2);
1676 golden_ratio_iscached = TRUE;
1677 return gel_makenum (golden_ratio_cache);
1678 }
1679
1680 static GelETree *
ErrorFunction_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1681 ErrorFunction_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1682 {
1683 mpfr_ptr num;
1684 mpfr_t tmp;
1685 mpfr_t ret;
1686 mpw_t retw;
1687
1688 if (a[0]->type == GEL_FUNCTION_NODE ||
1689 a[0]->type == GEL_IDENTIFIER_NODE) {
1690 return gel_function_from_function (ErrorFunction_function, a[0]);
1691 }
1692
1693 if (a[0]->type == GEL_MATRIX_NODE)
1694 return gel_apply_func_to_matrix (ctx, a[0], ErrorFunction_op, "ErrorFunction", exception);
1695
1696 if G_UNLIKELY ( ! check_argument_number (a, 0, "ErrorFunction"))
1697 return NULL;
1698 if G_UNLIKELY (mpw_is_complex (a[0]->val.value)) {
1699 /* FIXME: this is evil! */
1700 if G_UNLIKELY (_internal_erf_function == NULL) {
1701 _internal_erf_function = d_makeufunc(d_intern("<internal>exp"),
1702 gel_parseexp
1703 ("twosqrtpi = 2/sqrt(pi); "
1704 "a = 1; "
1705 "s = 0; "
1706 "n = 0; "
1707 "f = 1; "
1708 "xx = x; "
1709 "xsq = x^2; "
1710 "do ( "
1711 " t = xx * a * twosqrtpi; "
1712 " s = s + t; "
1713 " increment n; "
1714 " f = f * n; "
1715 " a = ((-1)^n) / (((2*n)+1) * f); "
1716 " xx = xx * xsq "
1717 ") while (|t| > ErrorFunctionTolerance); "
1718 "s ",
1719 NULL, FALSE, FALSE,
1720 NULL, NULL),
1721 g_slist_append(NULL,d_intern("x")),1,
1722 NULL);
1723 }
1724 return gel_funccall(ctx,_internal_erf_function,a,1);
1725
1726 return NULL;
1727 } else {
1728 MPW_MPF_REAL (num, a[0]->val.value, tmp);
1729
1730 mpfr_init (ret);
1731 mpfr_erf (ret, num, GMP_RNDN);
1732
1733 MPW_MPF_KILL (num, tmp);
1734
1735 mpw_init (retw);
1736 mpw_set_mpf_use (retw, ret);
1737
1738 return gel_makenum (retw);
1739 }
1740 }
1741
1742 static GelETree *
RiemannZeta_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1743 RiemannZeta_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1744 {
1745 mpfr_ptr num;
1746 mpfr_t tmp;
1747 mpfr_t ret;
1748 mpw_t retw;
1749
1750 if (a[0]->type == GEL_FUNCTION_NODE ||
1751 a[0]->type == GEL_IDENTIFIER_NODE) {
1752 return gel_function_from_function (RiemannZeta_function, a[0]);
1753 }
1754
1755 if (a[0]->type == GEL_MATRIX_NODE)
1756 return gel_apply_func_to_matrix (ctx, a[0], RiemannZeta_op, "RiemannZeta", exception);
1757
1758 if G_UNLIKELY ( ! check_argument_number (a, 0, "RiemannZeta"))
1759 return NULL;
1760 if G_UNLIKELY (mpw_is_complex (a[0]->val.value)) {
1761 gel_errorout (_("%s: Not implemented (yet) for complex values"),
1762 "RiemannZeta");
1763 return NULL;
1764 }
1765
1766 MPW_MPF_REAL (num, a[0]->val.value, tmp);
1767
1768 mpfr_init (ret);
1769 mpfr_zeta (ret, num, GMP_RNDN);
1770
1771 MPW_MPF_KILL (num, tmp);
1772
1773 mpw_init (retw);
1774 mpw_set_mpf_use (retw, ret);
1775
1776 return gel_makenum (retw);
1777 }
1778
1779 static GelETree *
GammaFunction_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1780 GammaFunction_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1781 {
1782 mpfr_ptr num;
1783 mpfr_t tmp;
1784 mpfr_t ret;
1785 mpw_t retw;
1786
1787 if (a[0]->type == GEL_FUNCTION_NODE ||
1788 a[0]->type == GEL_IDENTIFIER_NODE) {
1789 return gel_function_from_function (GammaFunction_function, a[0]);
1790 }
1791
1792 if (a[0]->type == GEL_MATRIX_NODE)
1793 return gel_apply_func_to_matrix (ctx, a[0], GammaFunction_op, "GammaFunction", exception);
1794
1795 if G_UNLIKELY ( ! check_argument_number (a, 0, "GammaFunction"))
1796 return NULL;
1797 if G_UNLIKELY (mpw_is_complex (a[0]->val.value)) {
1798 gel_errorout (_("%s: Not implemented (yet) for complex values"),
1799 "GammaFunction");
1800 return NULL;
1801 }
1802
1803 MPW_MPF_REAL (num, a[0]->val.value, tmp);
1804
1805 mpfr_init (ret);
1806 mpfr_gamma (ret, num, GMP_RNDN);
1807
1808 MPW_MPF_KILL (num, tmp);
1809
1810 mpw_init (retw);
1811 mpw_set_mpf_use (retw, ret);
1812
1813 return gel_makenum (retw);
1814 }
1815
1816 static GelETree *
BesselJ0_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1817 BesselJ0_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1818 {
1819 mpfr_ptr num;
1820 mpfr_t tmp;
1821 mpfr_t ret;
1822 mpw_t retw;
1823
1824 if (a[0]->type == GEL_FUNCTION_NODE ||
1825 a[0]->type == GEL_IDENTIFIER_NODE) {
1826 return gel_function_from_function (BesselJ0_function, a[0]);
1827 }
1828
1829 if (a[0]->type == GEL_MATRIX_NODE)
1830 return gel_apply_func_to_matrix (ctx, a[0], BesselJ0_op, "BesselJ0", exception);
1831
1832 if G_UNLIKELY ( ! check_argument_number (a, 0, "BesselJ0"))
1833 return NULL;
1834 if G_UNLIKELY (mpw_is_complex (a[0]->val.value)) {
1835 gel_errorout (_("%s: Not implemented (yet) for complex values"),
1836 "BesselJ0");
1837 return NULL;
1838 }
1839
1840 MPW_MPF_REAL (num, a[0]->val.value, tmp);
1841
1842 mpfr_init (ret);
1843 mpfr_j0 (ret, num, GMP_RNDN);
1844
1845 MPW_MPF_KILL (num, tmp);
1846
1847 mpw_init (retw);
1848 mpw_set_mpf_use (retw, ret);
1849
1850 return gel_makenum (retw);
1851 }
1852
1853 static GelETree *
BesselJ1_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1854 BesselJ1_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1855 {
1856 mpfr_ptr num;
1857 mpfr_t tmp;
1858 mpfr_t ret;
1859 mpw_t retw;
1860
1861 if (a[0]->type == GEL_FUNCTION_NODE ||
1862 a[0]->type == GEL_IDENTIFIER_NODE) {
1863 return gel_function_from_function (BesselJ1_function, a[0]);
1864 }
1865
1866 if (a[0]->type == GEL_MATRIX_NODE)
1867 return gel_apply_func_to_matrix (ctx, a[0], BesselJ1_op, "BesselJ1", exception);
1868
1869 if G_UNLIKELY ( ! check_argument_number (a, 0, "BesselJ1"))
1870 return NULL;
1871 if G_UNLIKELY (mpw_is_complex (a[0]->val.value)) {
1872 gel_errorout (_("%s: Not implemented (yet) for complex values"),
1873 "BesselJ1");
1874 return NULL;
1875 }
1876
1877 MPW_MPF_REAL (num, a[0]->val.value, tmp);
1878
1879 mpfr_init (ret);
1880 mpfr_j1 (ret, num, GMP_RNDN);
1881
1882 MPW_MPF_KILL (num, tmp);
1883
1884 mpw_init (retw);
1885 mpw_set_mpf_use (retw, ret);
1886
1887 return gel_makenum (retw);
1888 }
1889
1890 /* FIXME: implement over matrices / functions */
1891 static GelETree *
BesselJn_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1892 BesselJn_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1893 {
1894 mpfr_ptr num;
1895 mpfr_t tmp;
1896 mpfr_t ret;
1897 mpw_t retw;
1898 long n;
1899
1900 if (a[0]->type == GEL_MATRIX_NODE)
1901 return gel_apply_func_to_matrix (ctx, a[0], BesselJn_op, "BesselJn", exception);
1902
1903 if G_UNLIKELY ( ! check_argument_integer (a, 0, "BesselJn"))
1904 return NULL;
1905 n = mpw_get_long(a[0]->val.value);
1906 if G_UNLIKELY (gel_error_num != 0) {
1907 gel_error_num = 0;
1908 return NULL;
1909 }
1910
1911 if G_UNLIKELY ( ! check_argument_number (a, 1, "BesselJn"))
1912 return NULL;
1913 if G_UNLIKELY (mpw_is_complex (a[1]->val.value)) {
1914 gel_errorout (_("%s: Not implemented (yet) for complex values"),
1915 "BesselJn");
1916 return NULL;
1917 }
1918
1919 MPW_MPF_REAL (num, a[1]->val.value, tmp);
1920
1921 mpfr_init (ret);
1922 mpfr_jn (ret, n, num, GMP_RNDN);
1923
1924 MPW_MPF_KILL (num, tmp);
1925
1926 mpw_init (retw);
1927 mpw_set_mpf_use (retw, ret);
1928
1929 return gel_makenum (retw);
1930 }
1931
1932 static GelETree *
BesselY0_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1933 BesselY0_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1934 {
1935 mpfr_ptr num;
1936 mpfr_t tmp;
1937 mpfr_t ret;
1938 mpw_t retw;
1939
1940 if (a[0]->type == GEL_FUNCTION_NODE ||
1941 a[0]->type == GEL_IDENTIFIER_NODE) {
1942 return gel_function_from_function (BesselY0_function, a[0]);
1943 }
1944
1945 if (a[0]->type == GEL_MATRIX_NODE)
1946 return gel_apply_func_to_matrix (ctx, a[0], BesselY0_op, "BesselY0", exception);
1947
1948 if G_UNLIKELY ( ! check_argument_number (a, 0, "BesselY0"))
1949 return NULL;
1950 if G_UNLIKELY (mpw_is_complex (a[0]->val.value)) {
1951 gel_errorout (_("%s: Not implemented (yet) for complex values"),
1952 "BesselY0");
1953 return NULL;
1954 }
1955 if G_UNLIKELY (mpw_sgn (a[0]->val.value) <= 0) {
1956 gel_errorout (_("%s: Bessel functions of second kind not defined for nonpositive real numbers"),
1957 "BesselY0");
1958 return NULL;
1959 }
1960
1961 MPW_MPF_REAL (num, a[0]->val.value, tmp);
1962
1963 mpfr_init (ret);
1964 mpfr_y0 (ret, num, GMP_RNDN);
1965
1966 MPW_MPF_KILL (num, tmp);
1967
1968 mpw_init (retw);
1969 mpw_set_mpf_use (retw, ret);
1970
1971 return gel_makenum (retw);
1972 }
1973
1974 static GelETree *
BesselY1_op(GelCtx * ctx,GelETree ** a,gboolean * exception)1975 BesselY1_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
1976 {
1977 mpfr_ptr num;
1978 mpfr_t tmp;
1979 mpfr_t ret;
1980 mpw_t retw;
1981
1982 if (a[0]->type == GEL_FUNCTION_NODE ||
1983 a[0]->type == GEL_IDENTIFIER_NODE) {
1984 return gel_function_from_function (BesselY1_function, a[0]);
1985 }
1986
1987 if (a[0]->type == GEL_MATRIX_NODE)
1988 return gel_apply_func_to_matrix (ctx, a[0], BesselY1_op, "BesselY1", exception);
1989
1990 if G_UNLIKELY ( ! check_argument_number (a, 0, "BesselY1"))
1991 return NULL;
1992 if G_UNLIKELY (mpw_is_complex (a[0]->val.value)) {
1993 gel_errorout (_("%s: Not implemented (yet) for complex values"),
1994 "BesselY1");
1995 return NULL;
1996 }
1997 if G_UNLIKELY (mpw_sgn (a[0]->val.value) <= 0) {
1998 gel_errorout (_("%s: Bessel functions of second kind not defined for nonpositive real numbers"),
1999 "BesselY1");
2000 return NULL;
2001 }
2002
2003 MPW_MPF_REAL (num, a[0]->val.value, tmp);
2004
2005 mpfr_init (ret);
2006 mpfr_y1 (ret, num, GMP_RNDN);
2007
2008 MPW_MPF_KILL (num, tmp);
2009
2010 mpw_init (retw);
2011 mpw_set_mpf_use (retw, ret);
2012
2013 return gel_makenum (retw);
2014 }
2015
2016 /* FIXME: implement over matrices / functions */
2017 static GelETree *
BesselYn_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2018 BesselYn_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
2019 {
2020 mpfr_ptr num;
2021 mpfr_t tmp;
2022 mpfr_t ret;
2023 mpw_t retw;
2024 long n;
2025
2026 if (a[0]->type == GEL_MATRIX_NODE)
2027 return gel_apply_func_to_matrix (ctx, a[0], BesselYn_op, "BesselYn", exception);
2028
2029 if G_UNLIKELY ( ! check_argument_integer (a, 0, "BesselYn"))
2030 return NULL;
2031 n = mpw_get_long(a[0]->val.value);
2032 if G_UNLIKELY (gel_error_num != 0) {
2033 gel_error_num = 0;
2034 return NULL;
2035 }
2036
2037 if G_UNLIKELY ( ! check_argument_number (a, 1, "BesselYn"))
2038 return NULL;
2039 if G_UNLIKELY (mpw_is_complex (a[1]->val.value)) {
2040 gel_errorout (_("%s: Not implemented (yet) for complex values"),
2041 "BesselYn");
2042 return NULL;
2043 }
2044 if G_UNLIKELY (mpw_sgn (a[1]->val.value) <= 0) {
2045 gel_errorout (_("%s: Bessel functions of second kind not defined for nonpositive real numbers"),
2046 "BesselYn");
2047 return NULL;
2048 }
2049
2050 MPW_MPF_REAL (num, a[1]->val.value, tmp);
2051
2052 mpfr_init (ret);
2053 mpfr_yn (ret, n, num, GMP_RNDN);
2054
2055 MPW_MPF_KILL (num, tmp);
2056
2057 mpw_init (retw);
2058 mpw_set_mpf_use (retw, ret);
2059
2060 return gel_makenum (retw);
2061 }
2062
2063
2064 static GelETree *
IsNull_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2065 IsNull_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2066 {
2067 if(a[0]->type==GEL_NULL_NODE)
2068 return gel_makenum_bool (1);
2069 else
2070 return gel_makenum_bool (0);
2071 }
2072 static GelETree *
IsValue_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2073 IsValue_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2074 {
2075 if(a[0]->type==GEL_VALUE_NODE)
2076 return gel_makenum_bool (1);
2077 else
2078 return gel_makenum_bool (0);
2079 }
2080 static GelETree *
IsBoolean_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2081 IsBoolean_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2082 {
2083 if (a[0]->type == GEL_BOOL_NODE)
2084 return gel_makenum_bool (1);
2085 else
2086 return gel_makenum_bool (0);
2087 }
2088 static GelETree *
IsString_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2089 IsString_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
2090 {
2091 if (a[0]->type == GEL_STRING_NODE)
2092 return gel_makenum_bool (1);
2093 else
2094 return gel_makenum_bool (0);
2095 }
2096 static GelETree *
IsMatrix_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2097 IsMatrix_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2098 {
2099 if (a[0]->type == GEL_MATRIX_NODE)
2100 return gel_makenum_bool (1);
2101 else
2102 return gel_makenum_bool (0);
2103 }
2104 static GelETree *
IsVector_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2105 IsVector_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
2106 {
2107 if (a[0]->type == GEL_MATRIX_NODE &&
2108 (gel_matrixw_width(a[0]->mat.matrix) == 1 ||
2109 gel_matrixw_height(a[0]->mat.matrix) == 1))
2110 return gel_makenum_bool (1);
2111 else
2112 return gel_makenum_bool (0);
2113 }
2114 static GelETree *
IsFunction_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2115 IsFunction_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2116 {
2117 if (a[0]->type == GEL_FUNCTION_NODE)
2118 return gel_makenum_bool (1);
2119 else
2120 return gel_makenum_bool (0);
2121 }
2122 static GelETree *
IsFunctionOrIdentifier_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2123 IsFunctionOrIdentifier_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2124 {
2125 if (a[0]->type == GEL_FUNCTION_NODE || a[0]->type == GEL_IDENTIFIER_NODE)
2126 return gel_makenum_bool (1);
2127 else
2128 return gel_makenum_bool (0);
2129 }
2130 static GelETree *
IsFunctionRef_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2131 IsFunctionRef_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2132 {
2133 if(a[0]->type==GEL_OPERATOR_NODE &&
2134 a[0]->op.oper == GEL_E_REFERENCE) {
2135 GelETree *arg = a[0]->op.args;
2136 g_assert(arg);
2137 if(arg->type==GEL_IDENTIFIER_NODE &&
2138 d_lookup_global(arg->id.id))
2139 return gel_makenum_bool (1);
2140 }
2141 return gel_makenum_bool (0);
2142 }
2143 static GelETree *
IsComplex_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2144 IsComplex_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2145 {
2146 if(a[0]->type!=GEL_VALUE_NODE)
2147 return gel_makenum_bool (0);
2148 else if(mpw_is_complex(a[0]->val.value))
2149 return gel_makenum_bool (1);
2150 else
2151 return gel_makenum_bool (0);
2152 }
2153 static GelETree *
IsReal_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2154 IsReal_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2155 {
2156 if(a[0]->type!=GEL_VALUE_NODE)
2157 return gel_makenum_bool (0);
2158 else if(mpw_is_complex(a[0]->val.value))
2159 return gel_makenum_bool (0);
2160 else
2161 return gel_makenum_bool (1);
2162 }
2163 static GelETree *
IsMatrixReal_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2164 IsMatrixReal_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2165 {
2166 if (a[0]->type == GEL_NULL_NODE)
2167 return gel_makenum_bool (1);
2168
2169 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "IsMatrixReal"))
2170 return NULL;
2171
2172 if (gel_is_matrix_value_only_real (a[0]->mat.matrix))
2173 return gel_makenum_bool (1);
2174 else
2175 return gel_makenum_bool (0);
2176 }
2177 static GelETree *
IsInteger_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2178 IsInteger_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2179 {
2180 if(a[0]->type!=GEL_VALUE_NODE ||
2181 mpw_is_complex(a[0]->val.value))
2182 return gel_makenum_bool (0);
2183 else if(mpw_is_integer(a[0]->val.value))
2184 return gel_makenum_bool (1);
2185 else
2186 return gel_makenum_bool (0);
2187 }
2188 static GelETree *
IsPositiveInteger_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2189 IsPositiveInteger_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2190 {
2191 if(a[0]->type!=GEL_VALUE_NODE ||
2192 mpw_is_complex(a[0]->val.value))
2193 return gel_makenum_bool (0);
2194 else if(mpw_is_integer(a[0]->val.value) &&
2195 mpw_sgn (a[0]->val.value) > 0)
2196 return gel_makenum_bool (1);
2197 else
2198 return gel_makenum_bool (0);
2199 }
2200 static GelETree *
IsNonNegativeInteger_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2201 IsNonNegativeInteger_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2202 {
2203 if(a[0]->type!=GEL_VALUE_NODE ||
2204 mpw_is_complex(a[0]->val.value))
2205 return gel_makenum_bool (0);
2206 else if(mpw_is_integer(a[0]->val.value) &&
2207 mpw_sgn (a[0]->val.value) >= 0)
2208 return gel_makenum_bool (1);
2209 else
2210 return gel_makenum_bool (0);
2211 }
2212 static GelETree *
IsGaussInteger_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2213 IsGaussInteger_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2214 {
2215 if(a[0]->type!=GEL_VALUE_NODE)
2216 return gel_makenum_bool (0);
2217 else if(mpw_is_complex_integer(a[0]->val.value))
2218 return gel_makenum_bool (1);
2219 else
2220 return gel_makenum_bool (0);
2221 }
2222 static GelETree *
IsMatrixInteger_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2223 IsMatrixInteger_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2224 {
2225 if (a[0]->type == GEL_NULL_NODE)
2226 return gel_makenum_bool (1);
2227
2228 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "IsMatrixInteger"))
2229 return NULL;
2230
2231 if (gel_is_matrix_value_only_integer (a[0]->mat.matrix))
2232 return gel_makenum_bool (1);
2233 else
2234 return gel_makenum_bool (0);
2235 }
2236 static GelETree *
IsRational_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2237 IsRational_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2238 {
2239 if(a[0]->type!=GEL_VALUE_NODE ||
2240 mpw_is_complex(a[0]->val.value))
2241 return gel_makenum_bool (0);
2242 else if(mpw_is_rational(a[0]->val.value) ||
2243 mpw_is_integer(a[0]->val.value))
2244 return gel_makenum_bool (1);
2245 else
2246 return gel_makenum_bool (0);
2247 }
2248 static GelETree *
IsComplexRational_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2249 IsComplexRational_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2250 {
2251 if(a[0]->type!=GEL_VALUE_NODE)
2252 return gel_makenum_bool (0);
2253 else if (mpw_is_complex_rational_or_integer (a[0]->val.value))
2254 return gel_makenum_bool (1);
2255 else
2256 return gel_makenum_bool (0);
2257 }
2258 static GelETree *
IsMatrixRational_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2259 IsMatrixRational_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2260 {
2261 if (a[0]->type == GEL_NULL_NODE)
2262 return gel_makenum_bool (1);
2263
2264 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "IsMatrixRational"))
2265 return NULL;
2266
2267 if (gel_is_matrix_value_only_rational (a[0]->mat.matrix))
2268 return gel_makenum_bool (1);
2269 else
2270 return gel_makenum_bool (0);
2271 }
2272 static GelETree *
IsFloat_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2273 IsFloat_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2274 {
2275 if(a[0]->type!=GEL_VALUE_NODE ||
2276 mpw_is_complex(a[0]->val.value))
2277 return gel_makenum_bool (0);
2278 else if(mpw_is_real_part_float(a[0]->val.value))
2279 return gel_makenum_bool (1);
2280 else
2281 return gel_makenum_bool (0);
2282 }
2283
2284 static GelETree *
trunc_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2285 trunc_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2286 {
2287 mpw_t fr;
2288
2289 if (a[0]->type == GEL_FUNCTION_NODE ||
2290 a[0]->type == GEL_IDENTIFIER_NODE) {
2291 return gel_function_from_function (trunc_function, a[0]);
2292 }
2293
2294 if(a[0]->type==GEL_MATRIX_NODE)
2295 return gel_apply_func_to_matrix(ctx,a[0],trunc_op,"trunc", exception);
2296
2297 if G_UNLIKELY ( ! check_argument_number (a, 0, "trunc"))
2298 return NULL;
2299 mpw_init(fr);
2300 mpw_trunc(fr,a[0]->val.value);
2301 return gel_makenum_use(fr);
2302 }
2303 static GelETree *
floor_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2304 floor_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2305 {
2306 mpw_t fr;
2307
2308 if (a[0]->type == GEL_FUNCTION_NODE ||
2309 a[0]->type == GEL_IDENTIFIER_NODE) {
2310 return gel_function_from_function (floor_function, a[0]);
2311 }
2312
2313 if(a[0]->type==GEL_MATRIX_NODE)
2314 return gel_apply_func_to_matrix(ctx,a[0],floor_op,"floor", exception);
2315
2316 if G_UNLIKELY ( ! check_argument_number (a, 0, "floor"))
2317 return NULL;
2318 mpw_init(fr);
2319 mpw_floor(fr,a[0]->val.value);
2320 return gel_makenum_use(fr);
2321 }
2322 static GelETree *
ceil_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2323 ceil_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2324 {
2325 mpw_t fr;
2326
2327 if (a[0]->type == GEL_FUNCTION_NODE ||
2328 a[0]->type == GEL_IDENTIFIER_NODE) {
2329 return gel_function_from_function (ceil_function, a[0]);
2330 }
2331
2332 if(a[0]->type==GEL_MATRIX_NODE)
2333 return gel_apply_func_to_matrix(ctx,a[0],ceil_op,"ceil", exception);
2334
2335 if G_UNLIKELY ( ! check_argument_number (a, 0, "ceil"))
2336 return NULL;
2337 mpw_init(fr);
2338 mpw_ceil(fr,a[0]->val.value);
2339 return gel_makenum_use(fr);
2340 }
2341 static GelETree *
round_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2342 round_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2343 {
2344 mpw_t fr;
2345
2346 if (a[0]->type == GEL_FUNCTION_NODE ||
2347 a[0]->type == GEL_IDENTIFIER_NODE) {
2348 return gel_function_from_function (round_function, a[0]);
2349 }
2350
2351 if(a[0]->type==GEL_MATRIX_NODE)
2352 return gel_apply_func_to_matrix(ctx,a[0],round_op,"round", exception);
2353
2354 if G_UNLIKELY ( ! check_argument_number (a, 0, "round"))
2355 return NULL;
2356 mpw_init(fr);
2357 mpw_round(fr,a[0]->val.value);
2358 return gel_makenum_use(fr);
2359 }
2360 static GelETree *
float_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2361 float_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2362 {
2363 mpw_t fr;
2364
2365 if (a[0]->type == GEL_FUNCTION_NODE ||
2366 a[0]->type == GEL_IDENTIFIER_NODE) {
2367 return gel_function_from_function (float_function, a[0]);
2368 }
2369
2370 if(a[0]->type==GEL_MATRIX_NODE)
2371 return gel_apply_func_to_matrix(ctx,a[0],float_op,"float", exception);
2372
2373 if G_UNLIKELY ( ! check_argument_number (a, 0, "float"))
2374 return NULL;
2375 mpw_init_set(fr,a[0]->val.value);
2376 mpw_make_float(fr);
2377 return gel_makenum_use(fr);
2378 }
2379
2380 static GelETree *
Numerator_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2381 Numerator_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2382 {
2383 mpw_t fr;
2384
2385 if (a[0]->type == GEL_FUNCTION_NODE ||
2386 a[0]->type == GEL_IDENTIFIER_NODE) {
2387 return gel_function_from_function (Numerator_function, a[0]);
2388 }
2389
2390 if(a[0]->type==GEL_MATRIX_NODE)
2391 return gel_apply_func_to_matrix(ctx,a[0],Numerator_op,"Numerator", exception);
2392
2393 if G_UNLIKELY ( ! check_argument_number (a, 0, "Numerator"))
2394 return NULL;
2395 mpw_init(fr);
2396 mpw_numerator(fr,a[0]->val.value);
2397 if G_UNLIKELY (gel_error_num) {
2398 gel_error_num = 0;
2399 mpw_clear(fr);
2400 return NULL;
2401 }
2402 return gel_makenum_use(fr);
2403 }
2404
2405 static GelETree *
Denominator_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2406 Denominator_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2407 {
2408 mpw_t fr;
2409
2410 if (a[0]->type == GEL_FUNCTION_NODE ||
2411 a[0]->type == GEL_IDENTIFIER_NODE) {
2412 return gel_function_from_function (Denominator_function, a[0]);
2413 }
2414
2415 if(a[0]->type==GEL_MATRIX_NODE)
2416 return gel_apply_func_to_matrix(ctx,a[0],Denominator_op,"Denominator", exception);
2417
2418 if G_UNLIKELY ( ! check_argument_number (a, 0, "Denominator"))
2419 return NULL;
2420 mpw_init(fr);
2421 mpw_denominator(fr,a[0]->val.value);
2422 if G_UNLIKELY (gel_error_num) {
2423 gel_error_num = 0;
2424 mpw_clear(fr);
2425 return NULL;
2426 }
2427 return gel_makenum_use(fr);
2428 }
2429
2430 static GelETree *
Re_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2431 Re_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2432 {
2433 mpw_t fr;
2434
2435 if (a[0]->type == GEL_FUNCTION_NODE ||
2436 a[0]->type == GEL_IDENTIFIER_NODE) {
2437 return gel_function_from_function (Re_function, a[0]);
2438 }
2439
2440 if(a[0]->type==GEL_MATRIX_NODE)
2441 return gel_apply_func_to_matrix(ctx,a[0],Re_op,"Re", exception);
2442
2443 if G_UNLIKELY ( ! check_argument_number (a, 0, "Re"))
2444 return NULL;
2445 mpw_init(fr);
2446 mpw_re(fr,a[0]->val.value);
2447 return gel_makenum_use(fr);
2448 }
2449
2450 static GelETree *
Im_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2451 Im_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2452 {
2453 mpw_t fr;
2454
2455 if (a[0]->type == GEL_FUNCTION_NODE ||
2456 a[0]->type == GEL_IDENTIFIER_NODE) {
2457 return gel_function_from_function (Im_function, a[0]);
2458 }
2459
2460 if(a[0]->type==GEL_MATRIX_NODE)
2461 return gel_apply_func_to_matrix(ctx,a[0],Im_op,"Im", exception);
2462
2463 if G_UNLIKELY ( ! check_argument_number (a, 0, "Im"))
2464 return NULL;
2465 mpw_init(fr);
2466 mpw_im(fr,a[0]->val.value);
2467 return gel_makenum_use(fr);
2468 }
2469
2470 static GelETree *
sqrt_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2471 sqrt_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2472 {
2473 if (a[0]->type == GEL_FUNCTION_NODE ||
2474 a[0]->type == GEL_IDENTIFIER_NODE) {
2475 return gel_function_from_function (sqrt_function, a[0]);
2476 }
2477
2478 if(a[0]->type==GEL_MATRIX_NODE)
2479 return gel_apply_func_to_matrix(ctx,a[0],sqrt_op,"sqrt", exception);
2480
2481 if G_UNLIKELY ( ! check_argument_number (a, 0, "sqrt"))
2482 return NULL;
2483 if (ctx->modulo != NULL) {
2484 GelETree *arg[3];
2485 GelETree *ret;
2486 gboolean is_prime;
2487 mpz_ptr num;
2488 GelEFunc *SqrtModPrime;
2489 static GelToken *SqrtModPrime_id = NULL;
2490
2491 if G_UNLIKELY ( ! check_argument_integer (a, 0, "sqrt"))
2492 return NULL;
2493
2494 num = mpw_peek_real_mpz (ctx->modulo);
2495 is_prime = mympz_is_prime (num, -1);
2496
2497 if G_UNLIKELY ( ! is_prime) {
2498 gel_errorout (_("%s: square root for composite moduli "
2499 "is not yet implemented"), "sqrt");
2500 return NULL;
2501 }
2502 if G_UNLIKELY (SqrtModPrime_id == NULL)
2503 SqrtModPrime_id = d_intern ("SqrtModPrime");
2504 SqrtModPrime = d_lookup_only_global (SqrtModPrime_id);
2505 if G_UNLIKELY (SqrtModPrime == NULL) {
2506 gel_errorout (_("%s: Cannot find square root function "
2507 "for prime moduli"), "sqrt");
2508 return NULL;
2509 }
2510 arg[0] = a[0];
2511 arg[1] = gel_makenum (ctx->modulo);
2512 arg[2] = NULL;
2513 ret = gel_funccall (ctx, SqrtModPrime, arg, 2);
2514 gel_freetree (arg[1]);
2515
2516 return ret;
2517 } else {
2518 mpw_t fr;
2519
2520 mpw_init(fr);
2521 mpw_sqrt(fr,a[0]->val.value);
2522 return gel_makenum_use(fr);
2523 }
2524 }
2525
2526 static GelETree *
exp_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2527 exp_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2528 {
2529 mpw_t fr;
2530
2531 if (a[0]->type == GEL_FUNCTION_NODE ||
2532 a[0]->type == GEL_IDENTIFIER_NODE) {
2533 return gel_function_from_function (exp_function, a[0]);
2534 }
2535
2536 if(a[0]->type==GEL_MATRIX_NODE) {
2537 if G_UNLIKELY (gel_matrixw_width(a[0]->mat.matrix) !=
2538 gel_matrixw_height(a[0]->mat.matrix)) {
2539 gel_errorout (_("%s: matrix argument is not square"),
2540 "exp");
2541 return NULL;
2542 }
2543 if G_UNLIKELY (_internal_exp_function == NULL) {
2544 /* FIXME: this really is not good*/
2545 _internal_exp_function = d_makeufunc(d_intern("<internal>exp"),
2546 gel_parseexp
2547 ("s = float(x^0); "
2548 "fact = 1; "
2549 "for i = 1 to 100 do "
2550 "(fact = fact * x / i; "
2551 "s = s + fact) ; s",
2552 NULL, FALSE, FALSE,
2553 NULL, NULL),
2554 g_slist_append(NULL,d_intern("x")),1,
2555 NULL);
2556 }
2557 return gel_funccall(ctx,_internal_exp_function,a,1);
2558 }
2559
2560 if G_UNLIKELY ( ! check_argument_number (a, 0, "exp"))
2561 return NULL;
2562 mpw_init(fr);
2563 mpw_exp(fr,a[0]->val.value);
2564 return gel_makenum_use(fr);
2565 }
2566
2567 static GelETree *
ln_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2568 ln_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2569 {
2570 mpw_t fr;
2571
2572 if (a[0]->type == GEL_FUNCTION_NODE ||
2573 a[0]->type == GEL_IDENTIFIER_NODE) {
2574 return gel_function_from_function (ln_function, a[0]);
2575 }
2576
2577 if(a[0]->type==GEL_MATRIX_NODE)
2578 return gel_apply_func_to_matrix(ctx,a[0],ln_op,"ln", exception);
2579
2580 if G_UNLIKELY ( ! check_argument_number (a, 0, "ln"))
2581 return NULL;
2582 mpw_init(fr);
2583 mpw_ln(fr,a[0]->val.value);
2584 if G_UNLIKELY (gel_error_num) {
2585 gel_error_num = 0;
2586 mpw_clear(fr);
2587 return NULL;
2588 }
2589 return gel_makenum_use(fr);
2590 }
2591
2592 static GelETree *
log2_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2593 log2_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2594 {
2595 mpw_t fr;
2596
2597 if (a[0]->type == GEL_FUNCTION_NODE ||
2598 a[0]->type == GEL_IDENTIFIER_NODE) {
2599 return gel_function_from_function (log2_function, a[0]);
2600 }
2601
2602 if(a[0]->type==GEL_MATRIX_NODE)
2603 return gel_apply_func_to_matrix(ctx,a[0],log2_op,"log2", exception);
2604
2605 if G_UNLIKELY ( ! check_argument_number (a, 0, "log2"))
2606 return NULL;
2607 mpw_init(fr);
2608 mpw_log2(fr,a[0]->val.value);
2609 if G_UNLIKELY (gel_error_num) {
2610 gel_error_num = 0;
2611 mpw_clear(fr);
2612 return NULL;
2613 }
2614 return gel_makenum_use(fr);
2615 }
2616
2617 static GelETree *
log10_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2618 log10_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2619 {
2620 mpw_t fr;
2621
2622 if (a[0]->type == GEL_FUNCTION_NODE ||
2623 a[0]->type == GEL_IDENTIFIER_NODE) {
2624 return gel_function_from_function (log10_function, a[0]);
2625 }
2626
2627 if(a[0]->type==GEL_MATRIX_NODE)
2628 return gel_apply_func_to_matrix(ctx,a[0],log10_op,"log10", exception);
2629
2630 if G_UNLIKELY ( ! check_argument_number (a, 0, "log10"))
2631 return NULL;
2632 mpw_init(fr);
2633 mpw_log10(fr,a[0]->val.value);
2634 if G_UNLIKELY (gel_error_num) {
2635 gel_error_num = 0;
2636 mpw_clear(fr);
2637 return NULL;
2638 }
2639 return gel_makenum_use(fr);
2640 }
2641
2642 /*gcd function*/
2643 static GelETree *
gcd2_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2644 gcd2_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2645 {
2646 mpw_t tmp;
2647
2648 if(a[0]->type==GEL_MATRIX_NODE ||
2649 a[1]->type==GEL_MATRIX_NODE)
2650 return gel_apply_func_to_matrixen(ctx,a[0],a[1],gcd2_op,"gcd", exception);
2651
2652 if G_UNLIKELY ( ! check_argument_integer (a, 0, "gcd") ||
2653 ! check_argument_integer (a, 1, "gcd"))
2654 return NULL;
2655
2656 mpw_init(tmp);
2657 mpw_gcd(tmp,
2658 a[0]->val.value,
2659 a[1]->val.value);
2660 if G_UNLIKELY (gel_error_num) {
2661 gel_error_num = 0;
2662 mpw_clear(tmp);
2663 return NULL;
2664 }
2665
2666 return gel_makenum_use(tmp);
2667 }
2668
2669 /*gcd function*/
2670 static GelETree *
gcd_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2671 gcd_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2672 {
2673 int i;
2674
2675 if (a[1] == NULL) {
2676 if (a[0]->type == GEL_MATRIX_NODE) {
2677 int j, w, h;
2678 mpw_t gcd;
2679 if ( ! gel_is_matrix_value_only_integer (a[0]->mat.matrix)) {
2680 gel_errorout (_("%s: matrix argument must be integer only"),
2681 "gcd");
2682 return NULL;
2683 }
2684 w = gel_matrixw_width (a[0]->mat.matrix);
2685 h = gel_matrixw_height (a[0]->mat.matrix);
2686 mpw_init (gcd);
2687 for (i = 0; i < w; i++) {
2688 for (j = 0; j < h; j++) {
2689 GelETree *n = gel_matrixw_index (a[0]->mat.matrix, i, j);
2690 if (i == 0 && j == 0) {
2691 mpw_abs (gcd, n->val.value);
2692 } else {
2693 mpw_gcd (gcd, gcd, n->val.value);
2694 }
2695 }
2696 }
2697 return gel_makenum_use (gcd);
2698 } else if (a[0]->type == GEL_VALUE_NODE) {
2699 mpw_t tmp;
2700 if (mpw_is_complex (a[0]->val.value) ||
2701 ! mpw_is_integer (a[0]->val.value)) {
2702 gel_errorout (_("%s: argument must be an integer"),
2703 "gcd");
2704 return NULL;
2705 }
2706 mpw_init (tmp);
2707 mpw_abs (tmp, a[0]->val.value);
2708 return gel_makenum_use (tmp);
2709 }
2710 }
2711
2712 /* FIXME: optimize value only case */
2713
2714 {
2715 GelETree *gcd;
2716 /* kind of a quick hack follows */
2717 gcd = a[0];
2718 for (i = 1; a[i] != NULL; i++) {
2719 /* at least ONE iteration will be run */
2720 GelETree *argv[2] = { gcd, a[i] };
2721 GelETree *res;
2722 res = gcd2_op (ctx, argv, exception);
2723 if (res == NULL) {
2724 if (gcd != a[0])
2725 gel_freetree (gcd);
2726 return NULL;
2727 }
2728 if (gcd != a[0])
2729 gel_freetree (gcd);
2730 gcd = res;
2731 }
2732 if (gcd == a[0]) {
2733 mpw_t tmp;
2734 mpw_init (tmp);
2735 mpw_abs (tmp, a[0]->val.value);
2736 return gel_makenum_use (tmp);
2737 } else {
2738 return gcd;
2739 }
2740 }
2741 }
2742
2743 /*lcm function*/
2744 static GelETree *
lcm2_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2745 lcm2_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2746 {
2747 mpw_t tmp;
2748
2749 if(a[0]->type==GEL_MATRIX_NODE ||
2750 a[1]->type==GEL_MATRIX_NODE)
2751 return gel_apply_func_to_matrixen(ctx,a[0],a[1],lcm2_op,"lcm", exception);
2752
2753 if G_UNLIKELY ( ! check_argument_integer (a, 0, "lcm") ||
2754 ! check_argument_integer (a, 1, "lcm"))
2755 return NULL;
2756
2757 mpw_init(tmp);
2758 mpw_lcm(tmp,
2759 a[0]->val.value,
2760 a[1]->val.value);
2761 if G_UNLIKELY (gel_error_num) {
2762 gel_error_num = 0;
2763 mpw_clear(tmp);
2764 return NULL;
2765 }
2766
2767 return gel_makenum_use(tmp);
2768 }
2769
2770 /*lcm function*/
2771 static GelETree *
lcm_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2772 lcm_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2773 {
2774 int i;
2775
2776 if (a[1] == NULL) {
2777 if (a[0]->type == GEL_MATRIX_NODE) {
2778 int j, w, h;
2779 mpw_t lcm;
2780 if ( ! gel_is_matrix_value_only_integer (a[0]->mat.matrix)) {
2781 gel_errorout (_("%s: matrix argument must be integer only"),
2782 "lcm");
2783 return NULL;
2784 }
2785 w = gel_matrixw_width (a[0]->mat.matrix);
2786 h = gel_matrixw_height (a[0]->mat.matrix);
2787 mpw_init (lcm);
2788 for (i = 0; i < w; i++) {
2789 for (j = 0; j < h; j++) {
2790 GelETree *n = gel_matrixw_index (a[0]->mat.matrix, i, j);
2791 if (i == 0 && j == 0) {
2792 mpw_set (lcm, n->val.value);
2793 } else {
2794 mpw_lcm (lcm, lcm, n->val.value);
2795 }
2796 }
2797 }
2798 return gel_makenum_use (lcm);
2799 } else if (a[0]->type == GEL_VALUE_NODE) {
2800 mpw_t tmp;
2801 if (mpw_is_complex (a[0]->val.value) ||
2802 ! mpw_is_integer (a[0]->val.value)) {
2803 gel_errorout (_("%s: argument must be an integer"),
2804 "lcm");
2805 return NULL;
2806 }
2807 mpw_init (tmp);
2808 mpw_abs (tmp, a[0]->val.value);
2809 return gel_makenum_use (tmp);
2810 }
2811 }
2812
2813 /* FIXME: optimize value only case */
2814
2815 {
2816 GelETree *lcm;
2817 /* kind of a quick hack follows */
2818 lcm = a[0];
2819 for (i = 1; a[i] != NULL; i++) {
2820 /* at least ONE iteration will be run */
2821 GelETree *argv[2] = { lcm, a[i] };
2822 GelETree *res;
2823 res = lcm2_op (ctx, argv, exception);
2824 if (res == NULL) {
2825 if (lcm != a[0])
2826 gel_freetree (lcm);
2827 return NULL;
2828 }
2829 if (lcm != a[0])
2830 gel_freetree (lcm);
2831 lcm = res;
2832 }
2833 if (lcm == a[0]) {
2834 mpw_t tmp;
2835 mpw_init (tmp);
2836 mpw_abs (tmp, a[0]->val.value);
2837 return gel_makenum_use (tmp);
2838 } else {
2839 return lcm;
2840 }
2841 }
2842 }
2843
2844 /*jacobi function*/
2845 static GelETree *
Jacobi_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2846 Jacobi_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2847 {
2848 mpw_t tmp;
2849
2850 if(a[0]->type==GEL_MATRIX_NODE ||
2851 a[1]->type==GEL_MATRIX_NODE)
2852 return gel_apply_func_to_matrixen(ctx,a[0],a[1],Jacobi_op,"Jacobi", exception);
2853
2854 if G_UNLIKELY ( ! check_argument_integer (a, 0, "Jacobi") ||
2855 ! check_argument_integer (a, 1, "Jacobi"))
2856 return NULL;
2857
2858 mpw_init(tmp);
2859 mpw_jacobi(tmp,
2860 a[0]->val.value,
2861 a[1]->val.value);
2862 if G_UNLIKELY (gel_error_num) {
2863 gel_error_num = 0;
2864 mpw_clear(tmp);
2865 return NULL;
2866 }
2867
2868 return gel_makenum_use(tmp);
2869 }
2870
2871 static GelETree *
IntegerQuotient_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2872 IntegerQuotient_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2873 {
2874 mpz_ptr num1, num2;
2875 mpz_t quo;
2876 mpw_t numw;
2877
2878 if (a[0]->type == GEL_MATRIX_NODE ||
2879 a[1]->type == GEL_MATRIX_NODE)
2880 return gel_apply_func_to_matrixen (ctx, a[0], a[1], IntegerQuotient_op, "IntegerQuotient", exception);
2881
2882 if G_UNLIKELY ( ! check_argument_integer (a, 0, "IntegerQuotient") ||
2883 ! check_argument_integer (a, 1, "IntegerQuotient"))
2884 return NULL;
2885
2886 num1 = mpw_peek_real_mpz (a[0]->val.value);
2887 num2 = mpw_peek_real_mpz (a[1]->val.value);
2888
2889 if (mpz_sgn (num2) == 0) {
2890 gel_errorout (_("Division by zero!"));
2891
2892 return NULL;
2893 }
2894
2895 mpz_init (quo);
2896 mpz_fdiv_q (quo, num1, num2);
2897 mpw_init (numw);
2898 mpw_set_mpz_use (numw, quo);
2899 return gel_makenum_use (numw);
2900 }
2901
2902 /*kronecker function*/
2903 static GelETree *
JacobiKronecker_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2904 JacobiKronecker_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2905 {
2906 mpw_t tmp;
2907
2908 if(a[0]->type==GEL_MATRIX_NODE ||
2909 a[1]->type==GEL_MATRIX_NODE)
2910 return gel_apply_func_to_matrixen (ctx, a[0], a[1], JacobiKronecker_op, "JacobiKronecker", exception);
2911
2912 if G_UNLIKELY ( ! check_argument_integer (a, 0, "JacobiKronecker") ||
2913 ! check_argument_integer (a, 1, "JacobiKronecker"))
2914 return NULL;
2915
2916 mpw_init(tmp);
2917 mpw_kronecker(tmp,
2918 a[0]->val.value,
2919 a[1]->val.value);
2920 if G_UNLIKELY (gel_error_num) {
2921 gel_error_num = 0;
2922 mpw_clear(tmp);
2923 return NULL;
2924 }
2925
2926 return gel_makenum_use(tmp);
2927 }
2928
2929 /*legendre function*/
2930 static GelETree *
Legendre_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2931 Legendre_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2932 {
2933 mpw_t tmp;
2934
2935 if(a[0]->type==GEL_MATRIX_NODE ||
2936 a[1]->type==GEL_MATRIX_NODE)
2937 return gel_apply_func_to_matrixen(ctx,a[0],a[1],Legendre_op,"Legendre", exception);
2938
2939 if G_UNLIKELY ( ! check_argument_integer (a, 0, "Legendere") ||
2940 ! check_argument_integer (a, 1, "Legendere"))
2941 return NULL;
2942
2943 mpw_init(tmp);
2944 mpw_legendre(tmp,
2945 a[0]->val.value,
2946 a[1]->val.value);
2947 if G_UNLIKELY (gel_error_num) {
2948 gel_error_num = 0;
2949 mpw_clear(tmp);
2950 return NULL;
2951 }
2952
2953 return gel_makenum_use(tmp);
2954 }
2955
2956 /*perfect square testing function*/
2957 static GelETree *
IsPerfectSquare_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2958 IsPerfectSquare_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2959 {
2960 if(a[0]->type==GEL_MATRIX_NODE)
2961 return gel_apply_func_to_matrix(ctx,a[0],IsPerfectSquare_op,"IsPerfectSquare", exception);
2962
2963 if G_UNLIKELY ( ! check_argument_number (a, 0, "IsPerfectSquare"))
2964 return NULL;
2965
2966 if(mpw_perfect_square(a[0]->val.value)) {
2967 return gel_makenum_bool (1);
2968 } else {
2969 if G_UNLIKELY (gel_error_num) {
2970 gel_error_num = 0;
2971 return NULL;
2972 }
2973 return gel_makenum_bool (0);
2974 }
2975 }
2976
2977
2978 /*perfect square testing function*/
2979 static GelETree *
IsPerfectPower_op(GelCtx * ctx,GelETree ** a,gboolean * exception)2980 IsPerfectPower_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
2981 {
2982 if(a[0]->type==GEL_MATRIX_NODE)
2983 return gel_apply_func_to_matrix(ctx,a[0],IsPerfectPower_op,"IsPerfectPower", exception);
2984
2985 if G_UNLIKELY ( ! check_argument_integer (a, 0, "IsPerfectPower"))
2986 return NULL;
2987
2988 if(mpw_perfect_power(a[0]->val.value)) {
2989 return gel_makenum_bool (1);
2990 } else {
2991 if G_UNLIKELY (gel_error_num) {
2992 gel_error_num = 0;
2993 return NULL;
2994 }
2995 return gel_makenum_bool (0);
2996 }
2997 }
2998
2999 static GelETree *
IsEven_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3000 IsEven_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3001 {
3002 if(a[0]->type==GEL_MATRIX_NODE)
3003 return gel_apply_func_to_matrix(ctx,a[0],IsEven_op,"IsEven", exception);
3004
3005 if G_UNLIKELY ( ! check_argument_integer (a, 0, "IsEven"))
3006 return NULL;
3007
3008 if(mpw_even_p(a[0]->val.value)) {
3009 return gel_makenum_bool (1);
3010 } else {
3011 if G_UNLIKELY (gel_error_num) {
3012 gel_error_num = 0;
3013 return NULL;
3014 }
3015 return gel_makenum_bool (0);
3016 }
3017 }
3018
3019 static GelETree *
IsOdd_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3020 IsOdd_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3021 {
3022 if(a[0]->type==GEL_MATRIX_NODE)
3023 return gel_apply_func_to_matrix(ctx,a[0],IsOdd_op,"IsOdd", exception);
3024
3025 if G_UNLIKELY ( ! check_argument_integer (a, 0, "IsOdd"))
3026 return NULL;
3027
3028 if(mpw_odd_p(a[0]->val.value)) {
3029 return gel_makenum_bool (1);
3030 } else {
3031 if G_UNLIKELY (gel_error_num) {
3032 gel_error_num = 0;
3033 return NULL;
3034 }
3035 return gel_makenum_bool (0);
3036 }
3037 }
3038
3039 /*max function for two elements */
3040 static GelETree *
max2_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3041 max2_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3042 {
3043 if(a[0]->type==GEL_MATRIX_NODE ||
3044 a[1]->type==GEL_MATRIX_NODE)
3045 return gel_apply_func_to_matrixen(ctx,a[0],a[1],max2_op,"max", exception);
3046
3047 if G_UNLIKELY ( ! check_argument_number (a, 0, "max") ||
3048 ! check_argument_number (a, 1, "max"))
3049 return NULL;
3050
3051 if(mpw_cmp(a[0]->val.value,a[1]->val.value)<0)
3052 return gel_copynode (a[1]);
3053 else {
3054 if G_UNLIKELY (gel_error_num) {
3055 gel_error_num = 0;
3056 return NULL;
3057 }
3058 return gel_copynode (a[0]);
3059 }
3060 }
3061
3062 /*max function*/
3063 static GelETree *
max_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3064 max_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3065 {
3066 GelETree *max = NULL;
3067 int i;
3068 if (a[1] == NULL) {
3069 if (a[0]->type == GEL_MATRIX_NODE) {
3070 int j, w, h;
3071 if G_UNLIKELY ( ! gel_is_matrix_value_only (a[0]->mat.matrix)) {
3072 gel_errorout (_("%s: matrix argument must be value only"),
3073 "max");
3074 return NULL;
3075 }
3076 w = gel_matrixw_width (a[0]->mat.matrix);
3077 h = gel_matrixw_height (a[0]->mat.matrix);
3078 for (i = 0; i < w; i++) {
3079 for (j = 0; j < h; j++) {
3080 GelETree *n = gel_matrixw_index (a[0]->mat.matrix, i, j);
3081 if (max == NULL) {
3082 max = n;
3083 } else if (max != n) {
3084 if (mpw_cmp (n->val.value, max->val.value) > 0)
3085 max = n;
3086 }
3087 }
3088 }
3089 g_assert (max != NULL);
3090 return gel_copynode (max);
3091 } else if (a[0]->type == GEL_VALUE_NODE) {
3092 if (mpw_is_complex (a[0]->val.value)) {
3093 gel_errorout (_("%s: Cannot compare complex numbers"),
3094 "max");
3095 return NULL;
3096 }
3097
3098 /*
3099 * Evil optimization to avoid copying the node from the argument
3100 */
3101 return gel_stealnode (a[0]);
3102 } else {
3103 gel_errorout (_("%s: Input not a number or a matrix of numbers."),
3104 "max");
3105 return NULL;
3106 }
3107 }
3108
3109 /* FIXME: optimize value only case */
3110
3111 /* kind of a quick hack follows */
3112 max = a[0];
3113 for (i = 1; a[i] != NULL; i++) {
3114 /* at least ONE iteration will be run */
3115 GelETree *argv[2] = { max, a[i] };
3116 GelETree *res;
3117 res = max2_op (ctx, argv, exception);
3118 if (res == NULL) {
3119 if (max != a[0])
3120 gel_freetree (max);
3121 return NULL;
3122 }
3123 if (max != a[0])
3124 gel_freetree (max);
3125 max = res;
3126 }
3127 if (max == a[0])
3128 /*
3129 * Evil optimization to avoid copying the node from the argument
3130 */
3131 return gel_stealnode (a[0]);
3132 else
3133 return max;
3134 }
3135
3136 /*min function*/
3137 static GelETree *
min2_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3138 min2_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3139 {
3140 if(a[0]->type==GEL_MATRIX_NODE ||
3141 a[1]->type==GEL_MATRIX_NODE)
3142 return gel_apply_func_to_matrixen(ctx,a[0],a[1],min2_op,"min", exception);
3143
3144 if G_UNLIKELY ( ! check_argument_number (a, 0, "min") ||
3145 ! check_argument_number (a, 1, "min"))
3146 return NULL;
3147
3148 if(mpw_cmp(a[0]->val.value,a[1]->val.value)>0)
3149 return gel_copynode (a[1]);
3150 else {
3151 if G_UNLIKELY (gel_error_num) {
3152 gel_error_num = 0;
3153 return NULL;
3154 }
3155 return gel_copynode (a[0]);
3156 }
3157 }
3158
3159 /*min function*/
3160 static GelETree *
min_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3161 min_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3162 {
3163 GelETree *min = NULL;
3164 int i;
3165 if (a[1] == NULL) {
3166 if (a[0]->type == GEL_MATRIX_NODE) {
3167 int j, w, h;
3168 if ( ! gel_is_matrix_value_only (a[0]->mat.matrix)) {
3169 gel_errorout (_("%s: matrix argument must be value only"),
3170 "min");
3171 return NULL;
3172 }
3173 w = gel_matrixw_width (a[0]->mat.matrix);
3174 h = gel_matrixw_height (a[0]->mat.matrix);
3175 for (i = 0; i < w; i++) {
3176 for (j = 0; j < h; j++) {
3177 GelETree *n = gel_matrixw_index (a[0]->mat.matrix, i, j);
3178 if (min == NULL) {
3179 min = n;
3180 } else if (min != n) {
3181 if (mpw_cmp (n->val.value, min->val.value) < 0)
3182 min = n;
3183 }
3184 }
3185 }
3186 g_assert (min != NULL);
3187 return gel_copynode (min);
3188 } else if (a[0]->type == GEL_VALUE_NODE) {
3189 if (mpw_is_complex (a[0]->val.value)) {
3190 gel_errorout (_("%s: Cannot compare complex numbers"),
3191 "min");
3192 return NULL;
3193 }
3194 /*
3195 * Evil optimization to avoid copying the node from the argument
3196 */
3197 return gel_stealnode (a[0]);
3198 } else {
3199 gel_errorout (_("%s: Input not a number or a matrix of numbers."),
3200 "min");
3201 return NULL;
3202 }
3203 }
3204
3205 /* FIXME: optimize value only case */
3206
3207 /* kind of a quick hack follows */
3208 min = a[0];
3209 for (i = 1; a[i] != NULL; i++) {
3210 /* at least ONE iteration will be run */
3211 GelETree *argv[2] = { min, a[i] };
3212 GelETree *res;
3213 res = min2_op (ctx, argv, exception);
3214 if (res == NULL) {
3215 if (min != a[0])
3216 gel_freetree (min);
3217 return NULL;
3218 }
3219 if (min != a[0])
3220 gel_freetree (min);
3221 min = res;
3222 }
3223 if (min == a[0])
3224 /*
3225 * Evil optimization to avoid copying the node from the argument
3226 */
3227 return gel_stealnode (a[0]);
3228 else
3229 return min;
3230 }
3231
3232 static GelETree *
IsValueOnly_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3233 IsValueOnly_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3234 {
3235 if (a[0]->type == GEL_NULL_NODE)
3236 return gel_makenum_bool (1);
3237
3238 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "IsValueOnly"))
3239 return NULL;
3240
3241 if(gel_is_matrix_value_only(a[0]->mat.matrix))
3242 return gel_makenum_bool (1);
3243 else
3244 return gel_makenum_bool (0);
3245 }
3246
3247 static GelETree *
IsMatrixPositive_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3248 IsMatrixPositive_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3249 {
3250 GelMatrixW *m;
3251 int i,j,w,h;
3252
3253 if G_UNLIKELY ( ! check_argument_value_only_matrix (a, 0, "IsMatrixPositive"))
3254 return NULL;
3255
3256 m = a[0]->mat.matrix;
3257
3258 w = gel_matrixw_width (m);
3259 h = gel_matrixw_height (m);
3260 for (j = 0; j < h; j++) {
3261 for (i = 0; i < w; i++) {
3262 GelETree *t = gel_matrixw_get_index (m, i, j);
3263 if (t == NULL ||
3264 t->type != GEL_VALUE_NODE ||
3265 mpw_is_complex (t->val.value) ||
3266 mpw_sgn (t->val.value) <= 0)
3267 return gel_makenum_bool (0);
3268 }
3269 }
3270 return gel_makenum_bool (1);
3271 }
3272
3273 static GelETree *
IsMatrixNonnegative_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3274 IsMatrixNonnegative_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3275 {
3276 GelMatrixW *m;
3277 int i,j,w,h;
3278
3279 if G_UNLIKELY ( ! check_argument_value_only_matrix (a, 0, "IsMatrixNonnegative"))
3280 return NULL;
3281
3282 m = a[0]->mat.matrix;
3283 w = gel_matrixw_width (m);
3284 h = gel_matrixw_height (m);
3285
3286 for (j = 0; j < h; j++) {
3287 for (i = 0; i < w; i++) {
3288 GelETree *t = gel_matrixw_get_index (m, i, j);
3289 if (t != NULL) {
3290 if (t->type != GEL_VALUE_NODE ||
3291 mpw_is_complex (t->val.value) ||
3292 mpw_sgn (t->val.value) < 0)
3293 return gel_makenum_bool (0);
3294 }
3295 }
3296 }
3297 return gel_makenum_bool (1);
3298 }
3299
3300 static GelETree *
IsZero_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3301 IsZero_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3302 {
3303 if G_UNLIKELY ( ! check_argument_null_or_number_or_matrix (a, 0, "IsZero"))
3304 return NULL;
3305
3306 if (a[0]->type == GEL_NULL_NODE)
3307 return gel_makenum_bool (1);
3308 else if (a[0]->type == GEL_VALUE_NODE)
3309 return gel_makenum_bool (mpw_zero_p (a[0]->val.value));
3310 else {
3311 GelMatrixW *m = a[0]->mat.matrix;
3312 int i,j,w,h;
3313 w = gel_matrixw_width (m);
3314 h = gel_matrixw_height (m);
3315 for (j = 0; j < h; j++) {
3316 for (i = 0; i < w; i++) {
3317 GelETree *t = gel_matrixw_get_index (m, i, j);
3318 if ( ! ( t == NULL ||
3319 (t->type == GEL_VALUE_NODE &&
3320 mpw_zero_p (t->val.value)))) {
3321 return gel_makenum_bool (0);
3322 }
3323 }
3324 }
3325 return gel_makenum_bool (1);
3326 }
3327 }
3328
3329 static GelETree *
IsIdentity_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3330 IsIdentity_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3331 {
3332 if G_UNLIKELY ( ! check_argument_null_or_number_or_matrix (a, 0, "IsIdentity"))
3333 return NULL;
3334
3335 if (a[0]->type == GEL_NULL_NODE)
3336 return gel_makenum_bool (0);
3337 else if (a[0]->type == GEL_VALUE_NODE)
3338 return gel_makenum_bool (mpw_eql_ui (a[0]->val.value, 1));
3339 else {
3340 GelMatrixW *m = a[0]->mat.matrix;
3341 int i,j,w,h;
3342 w = gel_matrixw_width (m);
3343 h = gel_matrixw_height (m);
3344 if (w != h)
3345 return gel_makenum_bool (0);
3346 for (j = 0; j < h; j++) {
3347 for (i = 0; i < w; i++) {
3348 GelETree *t = gel_matrixw_get_index (m, i, j);
3349 if (i == j) {
3350 if (t == NULL ||
3351 t->type != GEL_VALUE_NODE ||
3352 ! mpw_eql_ui (t->val.value, 1)) {
3353 return gel_makenum_bool (0);
3354 }
3355 } else if ( ! ( t == NULL ||
3356 (t->type == GEL_VALUE_NODE &&
3357 mpw_zero_p (t->val.value)))) {
3358 return gel_makenum_bool (0);
3359 }
3360 }
3361 }
3362 return gel_makenum_bool (1);
3363 }
3364 }
3365
3366 static GelETree *
I_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3367 I_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3368 {
3369 GelETree *n;
3370 long size;
3371 int i;
3372 static int cached_size = -1;
3373 static GelMatrixW *cached_m = NULL;
3374
3375 if G_UNLIKELY ( ! check_argument_nonnegative_integer (a, 0, "I"))
3376 return NULL;
3377
3378 size = gel_get_nonnegative_integer (a[0]->val.value, "I");
3379 if G_UNLIKELY (size < 0)
3380 return NULL;
3381
3382 if (size == 0)
3383 return gel_makenum_null ();
3384
3385 /*make us a new empty node*/
3386 GEL_GET_NEW_NODE(n);
3387 n->type = GEL_MATRIX_NODE;
3388 n->mat.quoted = FALSE;
3389
3390 if (cached_size == size) {
3391 n->mat.matrix = gel_matrixw_copy (cached_m);
3392 } else {
3393 GelMatrixW *m;
3394
3395 if (cached_m != NULL)
3396 gel_matrixw_free (cached_m);
3397 n->mat.matrix = m = gel_matrixw_new();
3398 gel_matrixw_set_size (m, size, size);
3399
3400 for (i = 0; i < size; i++)
3401 gel_matrixw_set_indexii (m, i) =
3402 gel_makenum_ui(1);
3403 /* This is in row reduced form, duh! */
3404 m->rref = 1;
3405
3406 m->cached_value_only = 1;
3407 m->value_only = 1;
3408 m->cached_value_only_real = 1;
3409 m->value_only_real = 1;
3410 m->cached_value_only_rational = 1;
3411 m->value_only_rational = 1;
3412 m->cached_value_only_integer = 1;
3413 m->value_only_integer = 1;
3414 m->cached_value_or_bool_only = 1;
3415 m->value_or_bool_only = 1;
3416
3417 cached_m = gel_matrixw_copy (m);
3418 cached_size = size;
3419 }
3420
3421 return n;
3422 }
3423
3424 static GelETree *
zeros_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3425 zeros_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3426 {
3427 GelETree *n;
3428 GelMatrixW *m;
3429 long rows, cols;
3430
3431 if G_UNLIKELY ( ! check_argument_nonnegative_integer (a, 0, "zeros") ||
3432 (a[1] != NULL &&
3433 ! check_argument_nonnegative_integer (a, 1, "zeros")))
3434 return NULL;
3435
3436 if G_UNLIKELY (a[1] != NULL && a[2] != NULL) {
3437 gel_errorout (_("%s: too many arguments"), "zeros");
3438 return NULL;
3439 }
3440
3441 rows = gel_get_nonnegative_integer (a[0]->val.value, "zeros");
3442 if G_UNLIKELY (rows < 0)
3443 return NULL;
3444 if (a[1] != NULL) {
3445 cols = gel_get_nonnegative_integer (a[1]->val.value, "zeros");
3446 if G_UNLIKELY (cols < 0)
3447 return NULL;
3448 } else {
3449 /* In this case we want a row vector */
3450 cols = rows;
3451 rows = 1;
3452 }
3453
3454 if (cols == 0 || rows == 0)
3455 return gel_makenum_null ();
3456
3457 /*make us a new empty node*/
3458 GEL_GET_NEW_NODE(n);
3459 n->type = GEL_MATRIX_NODE;
3460 n->mat.matrix = m = gel_matrixw_new();
3461 n->mat.quoted = FALSE;
3462 gel_matrixw_set_size (m, cols, rows);
3463
3464 /* trivially rref */
3465 m->rref = 1;
3466
3467 m->cached_value_only = 1;
3468 m->value_only = 1;
3469 m->cached_value_only_real = 1;
3470 m->value_only_real = 1;
3471 m->cached_value_only_rational = 1;
3472 m->value_only_rational = 1;
3473 m->cached_value_only_integer = 1;
3474 m->value_only_integer = 1;
3475 m->cached_value_or_bool_only = 1;
3476 m->value_or_bool_only = 1;
3477
3478 return n;
3479 }
3480
3481 static GelETree *
ones_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3482 ones_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3483 {
3484 GelETree *n;
3485 GelMatrixW *m;
3486 long rows, cols;
3487 int i, j;
3488
3489 if G_UNLIKELY ( ! check_argument_nonnegative_integer (a, 0, "ones") ||
3490 (a[1] != NULL &&
3491 ! check_argument_nonnegative_integer (a, 1, "ones")))
3492 return NULL;
3493
3494 if G_UNLIKELY (a[1] != NULL && a[2] != NULL) {
3495 gel_errorout (_("%s: too many arguments"), "ones");
3496 return NULL;
3497 }
3498
3499 rows = gel_get_nonnegative_integer (a[0]->val.value, "ones");
3500 if (rows < 0)
3501 return NULL;
3502 if (a[1] != NULL) {
3503 cols = gel_get_nonnegative_integer (a[1]->val.value, "ones");
3504 if (cols < 0)
3505 return NULL;
3506 } else {
3507 /* In this case we want a row vector */
3508 cols = rows;
3509 rows = 1;
3510 }
3511
3512 if (cols == 0 || rows == 0)
3513 return gel_makenum_null ();
3514
3515 /*make us a new empty node*/
3516 GEL_GET_NEW_NODE(n);
3517 n->type = GEL_MATRIX_NODE;
3518 n->mat.matrix = m = gel_matrixw_new();
3519 n->mat.quoted = FALSE;
3520 gel_matrixw_set_size (m, cols, rows);
3521
3522 m->cached_value_only = 1;
3523 m->value_only = 1;
3524 m->cached_value_only_real = 1;
3525 m->value_only_real = 1;
3526 m->cached_value_only_rational = 1;
3527 m->value_only_rational = 1;
3528 m->cached_value_only_integer = 1;
3529 m->value_only_integer = 1;
3530 m->cached_value_or_bool_only = 1;
3531 m->value_or_bool_only = 1;
3532
3533 for(j=0;j<rows;j++)
3534 for(i=0;i<cols;i++)
3535 gel_matrixw_set_index (m, i, j) =
3536 gel_makenum_ui (1);
3537
3538 return n;
3539 }
3540
3541 static GelETree *
rows_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3542 rows_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3543 {
3544 if (a[0]->type == GEL_NULL_NODE)
3545 return gel_makenum_ui (0);
3546 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "rows"))
3547 return NULL;
3548 return gel_makenum_ui(gel_matrixw_height(a[0]->mat.matrix));
3549 }
3550 static GelETree *
columns_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3551 columns_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3552 {
3553 if (a[0]->type == GEL_NULL_NODE)
3554 return gel_makenum_ui (0);
3555 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "columns"))
3556 return NULL;
3557 return gel_makenum_ui(gel_matrixw_width(a[0]->mat.matrix));
3558 }
3559 static GelETree *
elements_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3560 elements_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3561 {
3562 if (a[0]->type == GEL_NULL_NODE)
3563 return gel_makenum_ui (0);
3564 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "elements"))
3565 return NULL;
3566 return gel_makenum_ui (gel_matrixw_width (a[0]->mat.matrix) *
3567 gel_matrixw_height (a[0]->mat.matrix));
3568 }
3569 static GelETree *
IsMatrixSquare_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3570 IsMatrixSquare_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3571 {
3572 if (a[0]->type == GEL_NULL_NODE)
3573 return gel_makenum_bool (1);
3574
3575 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "IsMatrixSquare"))
3576 return NULL;
3577 if (gel_matrixw_width (a[0]->mat.matrix) == gel_matrixw_height (a[0]->mat.matrix))
3578 return gel_makenum_bool (1);
3579 else
3580 return gel_makenum_bool (0);
3581 }
3582
3583 static GelETree *
IsLowerTriangular_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3584 IsLowerTriangular_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3585 {
3586 int i,j,w;
3587 GelMatrixW *m;
3588
3589 if G_UNLIKELY ( ! check_argument_square_matrix (a, 0, "IsLowerTriangular"))
3590 return NULL;
3591
3592 m = a[0]->mat.matrix;
3593
3594 w = gel_matrixw_width (m);
3595 for (i = 1; i < w; i++) {
3596 for (j = 0; j < i; j++) {
3597 GelETree *node = gel_matrixw_get_index (m, i, j);
3598 if (node != NULL &&
3599 (node->type != GEL_VALUE_NODE ||
3600 /* FIXME: perhaps use some zero tolerance */
3601 ! mpw_zero_p (node->val.value))) {
3602 return gel_makenum_bool (0);
3603 }
3604 }
3605 }
3606 return gel_makenum_bool (1);
3607 }
3608
3609 static GelETree *
IsUpperTriangular_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3610 IsUpperTriangular_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3611 {
3612 int i,j,w;
3613 GelMatrixW *m;
3614
3615 if G_UNLIKELY ( ! check_argument_square_matrix (a, 0, "IsUpperTriangular"))
3616 return NULL;
3617
3618 m = a[0]->mat.matrix;
3619
3620 w = gel_matrixw_width (m);
3621 for (j = 1; j < w; j++) {
3622 for (i = 0; i < j; i++) {
3623 GelETree *node = gel_matrixw_get_index (m, i, j);
3624 if (node != NULL &&
3625 (node->type != GEL_VALUE_NODE ||
3626 /* FIXME: perhaps use some zero tolerance */
3627 ! mpw_zero_p (node->val.value))) {
3628 return gel_makenum_bool (0);
3629 }
3630 }
3631 }
3632 return gel_makenum_bool (1);
3633 }
3634
3635 static GelETree *
IsDiagonal_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3636 IsDiagonal_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3637 {
3638 int i,j,w;
3639 GelMatrixW *m;
3640
3641 if G_UNLIKELY ( ! check_argument_square_matrix (a, 0, "IsDiagonal"))
3642 return NULL;
3643
3644 m = a[0]->mat.matrix;
3645
3646 w = gel_matrixw_width (m);
3647 for (j = 0; j < w; j++) {
3648 for (i = 0; i < w; i++) {
3649 GelETree *node = gel_matrixw_get_index (m, i, j);
3650 if (i != j &&
3651 node != NULL &&
3652 (node->type != GEL_VALUE_NODE ||
3653 /* FIXME: perhaps use some zero tolerance */
3654 ! mpw_zero_p (node->val.value))) {
3655 return gel_makenum_bool (0);
3656 }
3657 }
3658 }
3659 return gel_makenum_bool (1);
3660 }
3661
3662 static GelETree *
SetMatrixSize_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3663 SetMatrixSize_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3664 {
3665 GelETree *n;
3666 long w,h;
3667
3668 if G_UNLIKELY ( ! check_argument_matrix_or_null (a, 0, "SetMatrixSize"))
3669 return NULL;
3670 if G_UNLIKELY ( ! check_argument_nonnegative_integer (a, 1, "SetMatrixSize"))
3671 return NULL;
3672 if G_UNLIKELY ( ! check_argument_nonnegative_integer (a, 2, "SetMatrixSize"))
3673 return NULL;
3674
3675 w = gel_get_nonnegative_integer (a[1]->val.value, "SetMatrixSize");
3676 if G_UNLIKELY (w < 0)
3677 return NULL;
3678 h = gel_get_nonnegative_integer (a[2]->val.value, "SetMatrixSize");
3679 if G_UNLIKELY (h < 0)
3680 return NULL;
3681
3682 if (w == 0 || h == 0)
3683 return gel_makenum_null ();
3684
3685 n = gel_stealnode (a[0]);
3686 if (n->type == GEL_NULL_NODE) {
3687 GelMatrixW *m;
3688
3689 n->type = GEL_MATRIX_NODE;
3690 n->mat.matrix = m = gel_matrixw_new();
3691 n->mat.quoted = FALSE;
3692 gel_matrixw_set_size (m, h, w);
3693
3694 /* trivially rref */
3695 m->rref = 1;
3696
3697 m->cached_value_only = 1;
3698 m->value_only = 1;
3699 m->cached_value_only_real = 1;
3700 m->value_only_real = 1;
3701 m->cached_value_only_rational = 1;
3702 m->value_only_rational = 1;
3703 m->cached_value_only_integer = 1;
3704 m->value_only_integer = 1;
3705 m->cached_value_or_bool_only = 1;
3706 m->value_or_bool_only = 1;
3707 } else {
3708 gel_matrixw_set_size (n->mat.matrix, h, w);
3709 }
3710 return n;
3711 }
3712
3713 static GelETree *
AppendElement_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3714 AppendElement_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3715 {
3716 GelETree *n;
3717 GelMatrixW *m;
3718 int eltnum;
3719
3720 if G_UNLIKELY ( ! check_argument_vector_or_null (a, 0, "AppendElement"))
3721 return NULL;
3722
3723 /*
3724 * Evil optimization to avoid copying the node from the argument
3725 */
3726 n = gel_stealnode (a[0]);
3727 if (n->type == GEL_NULL_NODE) {
3728 n->type = GEL_MATRIX_NODE;
3729 n->mat.matrix = m = gel_matrixw_new();
3730 n->mat.quoted = FALSE;
3731 gel_matrixw_set_size (m, 1, 1);
3732
3733 eltnum = 0;
3734
3735 /* trivially rref */
3736 m->rref = 1;
3737
3738 m->cached_value_only = 1;
3739 m->value_only = 1;
3740 m->cached_value_only_real = 1;
3741 m->value_only_real = 1;
3742 m->cached_value_only_rational = 1;
3743 m->value_only_rational = 1;
3744 m->cached_value_only_integer = 1;
3745 m->value_only_integer = 1;
3746 m->cached_value_or_bool_only = 1;
3747 m->value_or_bool_only = 1;
3748 } else {
3749 m = n->mat.matrix;
3750 eltnum = gel_matrixw_elements(m);
3751 }
3752
3753 gel_matrixw_set_velement (m,
3754 eltnum,
3755 /*
3756 * Evil optimization to avoid copying the node from the argument
3757 */
3758 gel_stealnode(a[1]));
3759 return n;
3760 }
3761
3762 static GelETree *
IndexComplement_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3763 IndexComplement_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3764 {
3765 GelETree *n;
3766 GelMatrix *nm;
3767 GelMatrixW *m;
3768 int nml;
3769 char *index;
3770 int i, ii, ml;
3771 int len;
3772
3773 if G_UNLIKELY ( ! check_argument_integer_or_matrix (a, 0, "IndexComplement") ||
3774 ! check_argument_nonnegative_integer (a, 1, "IndexComplement"))
3775 return NULL;
3776
3777 len = gel_get_nonnegative_integer (a[1]->val.value, "IndexComplement");
3778 if G_UNLIKELY (len < 0)
3779 return NULL;
3780
3781 if G_UNLIKELY (len == 0)
3782 return gel_makenum_null ();
3783
3784 if (a[0]->type == GEL_MATRIX_NODE) {
3785 index = g_new0 (char, len);
3786
3787 m = a[0]->mat.matrix;
3788 ml = gel_matrixw_elements (m);
3789 nml = len;
3790 for (i = 0; i < ml; i++) {
3791 GelETree *t = gel_matrixw_vindex (m, i);
3792 int elt;
3793 if G_UNLIKELY (t->type != GEL_VALUE_NODE) {
3794 gel_errorout (_("%s: vector argument not value only"), "IndexComplement");
3795 g_free (index);
3796 return NULL;
3797 }
3798 elt = gel_get_nonnegative_integer (t->val.value, "IndexComplement");
3799 if G_UNLIKELY (elt < 0) {
3800 g_free (index);
3801 return NULL;
3802 }
3803
3804 if G_UNLIKELY (elt == 0) {
3805 gel_errorout (_("%s: argument can't be negative or 0"),
3806 "IndexComplement");
3807 g_free (index);
3808 return NULL;
3809 }
3810
3811 elt--;
3812 if G_UNLIKELY (elt >= len) {
3813 gel_errorout (_("%s: vector argument has too large entries"), "IndexComplement");
3814 g_free (index);
3815 return NULL;
3816 }
3817
3818 if (index[elt] == 0) {
3819 nml --;
3820 index[elt] = 1;
3821 }
3822 }
3823
3824 if (nml <= 0) {
3825 g_free (index);
3826 return gel_makenum_null ();
3827 }
3828
3829 nm = gel_matrix_new ();
3830 gel_matrix_set_size (nm, nml, 1, FALSE /* padding */);
3831 ii = 0;
3832 for (i = 0; i < len; i++) {
3833 if (index[i] == 0) {
3834 gel_matrix_index (nm, ii++, 0) = gel_makenum_ui (i+1);
3835 }
3836 }
3837
3838 g_free (index);
3839 } else {
3840 int elt = gel_get_nonnegative_integer (a[0]->val.value, "IndexComplement");
3841 if G_UNLIKELY (elt < 0)
3842 return NULL;
3843 if G_UNLIKELY (elt == 0) {
3844 gel_errorout (_("%s: argument can't be negative or 0"),
3845 "IndexComplement");
3846 return NULL;
3847 }
3848 if G_UNLIKELY (elt > len) {
3849 gel_errorout (_("%s: vector argument has too large entries"), "IndexComplement");
3850 return NULL;
3851 }
3852 if (len == 1 && elt == 1)
3853 return gel_makenum_null ();
3854
3855 nm = gel_matrix_new ();
3856 gel_matrix_set_size (nm, len-1, 1, FALSE /* padding */);
3857 ii = 0;
3858 for (i = 1; i <= len; i++) {
3859 if (i != elt)
3860 gel_matrix_index (nm, ii++, 0) = gel_makenum_ui (i);
3861 }
3862 }
3863
3864 GEL_GET_NEW_NODE (n);
3865 n->type = GEL_MATRIX_NODE;
3866 n->mat.matrix = gel_matrixw_new_with_matrix_value_only_integer (nm);
3867 if (a[0]->type == GEL_MATRIX_NODE)
3868 n->mat.quoted = a[0]->mat.quoted;
3869 else
3870 n->mat.quoted = TRUE;
3871
3872 return n;
3873 }
3874
3875 static GelETree *
HermitianProduct_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3876 HermitianProduct_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
3877 {
3878 GelMatrixW *m1, *m2;
3879 int i, len;
3880 mpw_t res;
3881 mpw_t trm;
3882
3883 if G_UNLIKELY ( ! check_argument_value_only_vector (a, 0, "HermitianProduct") ||
3884 ! check_argument_value_only_vector (a, 1, "HermitianProduct"))
3885 return NULL;
3886
3887 m1 = a[0]->mat.matrix;
3888 m2 = a[1]->mat.matrix;
3889 len = gel_matrixw_elements (m1);
3890 if G_UNLIKELY (gel_matrixw_elements (m2) != len) {
3891 gel_errorout (_("%s: arguments must be vectors of equal size"), "HermitianProduct");
3892 return NULL;
3893 }
3894
3895 mpw_init (res);
3896 mpw_init (trm);
3897 mpw_set_ui (res, 0);
3898 for (i = 0; i < len; i++) {
3899 GelETree *t1 = gel_matrixw_vindex (m1, i);
3900 GelETree *t2 = gel_matrixw_vindex (m2, i);
3901 /* (t1 and t2 must be value only nodes! checked above!) */
3902 mpw_conj (trm, t2->val.value);
3903 mpw_mul (trm, trm, t1->val.value);
3904 mpw_add (res, res, trm);
3905 }
3906
3907 mpw_clear (trm);
3908
3909 return gel_makenum_use (res);
3910 }
3911
3912 static gboolean
symbolic_isinmatrix(GelETree * n,GelMatrixW * m)3913 symbolic_isinmatrix (GelETree *n, GelMatrixW *m)
3914 {
3915 int w, h, i, j;
3916
3917 w = gel_matrixw_width (m);
3918 h = gel_matrixw_height (m);
3919
3920 for (i = 0; i < w; i++) {
3921 for (j = 0; j < h; j++) {
3922 GelETree *t = gel_matrixw_index (m, i, j);
3923 if (gel_is_tree_same (t, n)) {
3924 return TRUE;
3925 }
3926 }
3927 }
3928 /*int elts, i;
3929
3930 elts = gel_matrixw_elements (m);
3931
3932 for (i = 0; i < elts; i++) {
3933 GelETree *t = gel_matrixw_vindex (m, i);
3934 if (gel_is_tree_same (t, n)) {
3935 return TRUE;
3936 }
3937 }*/
3938
3939 return FALSE;
3940 }
3941
3942 static GelETree *
IsIn_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3943 IsIn_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3944 {
3945 if G_UNLIKELY ( ! check_argument_matrix_or_null (a, 1, "IsIn"))
3946 return NULL;
3947
3948 if (a[1]->type == GEL_NULL_NODE)
3949 return gel_makenum_bool (FALSE);
3950
3951 return gel_makenum_bool (symbolic_isinmatrix (a[0], a[1]->mat.matrix));
3952 }
3953
3954 static GelETree *
IsSubset_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3955 IsSubset_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3956 {
3957 GelMatrixW *mX, *mY;
3958 int w, h, i, j;
3959
3960 if G_UNLIKELY ( ! check_argument_matrix_or_null (a, 0, "IsSubset") ||
3961 ! check_argument_matrix_or_null (a, 1, "IsSubset"))
3962 return NULL;
3963
3964 /* emptyset is a subset of everything */
3965 if (a[0]->type == GEL_NULL_NODE)
3966 return gel_makenum_bool (TRUE);
3967
3968 /* now we know that X is not empty so if Y is empty
3969 * then answer is no */
3970 if (a[1]->type == GEL_NULL_NODE)
3971 return gel_makenum_bool (FALSE);
3972
3973 mX = a[0]->mat.matrix;
3974 mY = a[1]->mat.matrix;
3975
3976 w = gel_matrixw_width (mX);
3977 h = gel_matrixw_height (mX);
3978
3979 for (i = 0; i < w; i++) {
3980 for (j = 0; j < h; j++) {
3981 GelETree *t = gel_matrixw_index (mX, i, j);
3982 if ( ! symbolic_isinmatrix (t, mY)) {
3983 return gel_makenum_bool (FALSE);
3984 }
3985 }
3986 }
3987 return gel_makenum_bool (TRUE);
3988
3989 }
3990
3991 static GelETree *
SetMinus_op(GelCtx * ctx,GelETree ** a,gboolean * exception)3992 SetMinus_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
3993 {
3994 GelMatrixW *m1, *m2;
3995 int w, h, i, j;
3996 int len;
3997 GSList *list, *li;
3998 GelETree *n;
3999 GelMatrix *nm;
4000
4001 if G_UNLIKELY ( ! check_argument_matrix_or_null (a, 0, "SetMinus") ||
4002 ! check_argument_matrix_or_null (a, 1, "SetMinus"))
4003 return NULL;
4004
4005 if (a[0]->type == GEL_NULL_NODE) {
4006 return gel_makenum_null ();
4007 } else if (a[1]->type == GEL_NULL_NODE) {
4008 return gel_copynode (a[0]);
4009 }
4010
4011 m1 = a[0]->mat.matrix;
4012 m2 = a[1]->mat.matrix;
4013
4014 list = NULL;
4015 len = 0;
4016
4017 w = gel_matrixw_width (m1);
4018 h = gel_matrixw_height (m1);
4019
4020 for (i = 0; i < w; i++) {
4021 for (j = 0; j < h; j++) {
4022 GelETree *t = gel_matrixw_index (m1, i, j);
4023 if ( ! symbolic_isinmatrix (t, m2)) {
4024 if (t == the_zero)
4025 list = g_slist_prepend (list, NULL);
4026 else
4027 list = g_slist_prepend (list, gel_copynode (t));
4028 len ++;
4029 }
4030 }
4031 }
4032 if (list == NULL) {
4033 return gel_makenum_null ();
4034 }
4035
4036 nm = gel_matrix_new ();
4037 gel_matrix_set_size (nm, len, 1, FALSE /* padding */);
4038 /* go backwards to "preserver order" */
4039 li = list;
4040 for (i = len-1; i >= 0; i--) {
4041 gel_matrix_index (nm, i, 0) = li->data;
4042 li = li->next;
4043 }
4044 g_slist_free (list);
4045
4046 GEL_GET_NEW_NODE (n);
4047 n->type = GEL_MATRIX_NODE;
4048 n->mat.matrix = gel_matrixw_new_with_matrix (nm);
4049 n->mat.quoted = a[0]->mat.quoted;
4050
4051 return n;
4052 }
4053
4054 static GelETree *
Intersection_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4055 Intersection_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
4056 {
4057 GelMatrixW *m1, *m2;
4058 int w, h, i, j;
4059 int len;
4060 GSList *list, *li;
4061 GelETree *n;
4062 GelMatrix *nm;
4063
4064 if G_UNLIKELY ( ! check_argument_matrix_or_null (a, 0, "Intersection") ||
4065 ! check_argument_matrix_or_null (a, 1, "Intersection"))
4066 return NULL;
4067
4068 if (a[0]->type == GEL_NULL_NODE) {
4069 return gel_makenum_null ();
4070 } else if (a[1]->type == GEL_NULL_NODE) {
4071 return gel_makenum_null ();
4072 }
4073
4074 m1 = a[0]->mat.matrix;
4075 m2 = a[1]->mat.matrix;
4076
4077 list = NULL;
4078 len = 0;
4079
4080 w = gel_matrixw_width (m1);
4081 h = gel_matrixw_height (m1);
4082
4083 for (i = 0; i < w; i++) {
4084 for (j = 0; j < h; j++) {
4085 GelETree *t = gel_matrixw_index (m1, i, j);
4086 if (symbolic_isinmatrix (t, m2)) {
4087 if (t == the_zero)
4088 list = g_slist_prepend (list, NULL);
4089 else
4090 list = g_slist_prepend (list, gel_copynode (t));
4091 len ++;
4092 }
4093 }
4094 }
4095 if (list == NULL) {
4096 return gel_makenum_null ();
4097 }
4098
4099 nm = gel_matrix_new ();
4100 gel_matrix_set_size (nm, len, 1, FALSE /* padding */);
4101 /* go backwards to "preserver order" */
4102 li = list;
4103 for (i = len-1; i >= 0; i--) {
4104 gel_matrix_index (nm, i, 0) = li->data;
4105 li = li->next;
4106 }
4107 g_slist_free (list);
4108
4109 GEL_GET_NEW_NODE (n);
4110 n->type = GEL_MATRIX_NODE;
4111 n->mat.matrix = gel_matrixw_new_with_matrix (nm);
4112 n->mat.quoted = a[0]->mat.quoted;
4113
4114 return n;
4115 }
4116
4117 static GelETree *
det_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4118 det_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4119 {
4120 mpw_t ret;
4121 if G_UNLIKELY ( ! check_argument_value_only_matrix (a, 0, "det"))
4122 return NULL;
4123 mpw_init(ret);
4124 if G_UNLIKELY ( ! gel_value_matrix_det (ctx, ret, a[0]->mat.matrix)) {
4125 mpw_clear(ret);
4126 return NULL;
4127 }
4128 return gel_makenum_use(ret);
4129 }
4130 static GelETree *
ref_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4131 ref_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4132 {
4133 GelETree *n;
4134 if G_UNLIKELY ( ! check_argument_value_only_matrix (a, 0, "ref"))
4135 return NULL;
4136
4137 GEL_GET_NEW_NODE(n);
4138 n->type = GEL_MATRIX_NODE;
4139 n->mat.matrix = gel_matrixw_copy(a[0]->mat.matrix);
4140 gel_value_matrix_gauss (ctx, n->mat.matrix, FALSE, FALSE, FALSE, FALSE, NULL, NULL);
4141 n->mat.quoted = FALSE;
4142 return n;
4143 }
4144 static GelETree *
rref_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4145 rref_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4146 {
4147 GelETree *n;
4148 if G_UNLIKELY ( ! check_argument_value_only_matrix (a, 0, "rref"))
4149 return NULL;
4150
4151 GEL_GET_NEW_NODE(n);
4152 n->type = GEL_MATRIX_NODE;
4153 n->mat.matrix = gel_matrixw_copy(a[0]->mat.matrix);
4154 if ( ! n->mat.matrix->rref) {
4155 gel_value_matrix_gauss (ctx, n->mat.matrix, TRUE, FALSE, FALSE, FALSE, NULL, NULL);
4156 }
4157 n->mat.quoted = FALSE;
4158 return n;
4159 }
4160
4161 /* cols and rows should have enough space (min(cols,rows) of m)
4162 * and m should be in at least ref (if not rref) form) and value only,
4163 * returns the count. The values returned are zero based! */
4164 static int
get_pivot_cols(GelMatrixW * m,int * cols,int * rows)4165 get_pivot_cols (GelMatrixW *m, int *cols, int *rows)
4166 {
4167 int i, j, w, h, mwh;
4168 int cnt = 0;
4169
4170 w = gel_matrixw_width (m);
4171 h = gel_matrixw_height (m);
4172 mwh = MIN (w, h);
4173
4174 for (j = 0; j < mwh; j++) {
4175 for (i = j; i < w; i++) {
4176 GelETree *t = gel_matrixw_get_index (m, i, j);
4177 if (t != NULL &&
4178 ! mpw_zero_p (t->val.value)) {
4179 cols[cnt] = i;
4180 rows[cnt] = j;
4181 cnt++;
4182 break;
4183 }
4184 }
4185 }
4186 return cnt;
4187 }
4188
4189 /* PivotColumns
4190 * Given a matrix in rref form, the columns which have a leading 1
4191 * in some row are the pivot columns.
4192 * (also returns in which row they occur) */
4193 static GelETree *
PivotColumns_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4194 PivotColumns_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4195 {
4196 GelETree *n;
4197 GelMatrixW *m;
4198 GelMatrix *nm;
4199 gboolean copied_m = FALSE;
4200 int *cols, *rows;
4201 int cnt, mwh;
4202 int i;
4203
4204 if G_UNLIKELY (a[0]->type == GEL_NULL_NODE)
4205 return gel_makenum_null ();
4206
4207 if G_UNLIKELY ( ! check_argument_value_only_matrix (a, 0, "PivotColumns"))
4208 return NULL;
4209
4210 m = a[0]->mat.matrix;
4211 if ( ! m->rref) {
4212 m = gel_matrixw_copy (m);
4213 /* only do ref, not rref for speed */
4214 gel_value_matrix_gauss (ctx, m, FALSE, FALSE, FALSE, FALSE, NULL, NULL);
4215 copied_m = TRUE;
4216 }
4217
4218 mwh = MIN (gel_matrixw_width (m), gel_matrixw_height (m));
4219
4220 cols = g_new (int, mwh);
4221 rows = g_new (int, mwh);
4222
4223 cnt = get_pivot_cols (m, cols, rows);
4224
4225 if (copied_m)
4226 gel_matrixw_free (m);
4227
4228 if (cnt == 0) {
4229 g_free (cols);
4230 g_free (rows);
4231 return gel_makenum_null ();
4232 }
4233
4234 nm = gel_matrix_new ();
4235 gel_matrix_set_size (nm, cnt, 2, FALSE /* padding */);
4236 for (i = 0; i < cnt; i++) {
4237 gel_matrix_index (nm, i, 0) = gel_makenum_ui (cols[i]+1);
4238 gel_matrix_index (nm, i, 1) = gel_makenum_ui (rows[i]+1);
4239 }
4240
4241 GEL_GET_NEW_NODE (n);
4242 n->type = GEL_MATRIX_NODE;
4243 n->mat.matrix = gel_matrixw_new_with_matrix_value_only_integer (nm);
4244 n->mat.quoted = FALSE;
4245
4246 g_free (cols);
4247 g_free (rows);
4248
4249 return n;
4250 }
4251
4252 /*
4253 # Null space/kernel of a linear transform
4254 # Okay, here's the idea:
4255 # Row reduce a matrix. Then the non-pivot columns are basically
4256 # the independent variables, and the pivot columns are the dependent ones.
4257 # So if your row reduced matrix looks like this:
4258 # [1 0 0 2 4]
4259 # [0 0 1 -3 5]
4260 # then to find a basis for the kernel, look at your non-pivot columns
4261 # (4, 5)
4262 # and for each non-pivot column, you get one vector.
4263 # So take the fourth column, and start off with the vector [0,0,0,-1,0].'
4264 # (so a -1 in the fourth place)
4265 # Now in each pivot entry, you need to put a value to cancel what this
4266 # -1 gives you -- so the pivot column entries are 2 and -3 (the entries
4267 # of the fourth column that have a pivot to the left of them).
4268 # So the first vector is [2,0,-3,-1,0], and the second is
4269 # [4,0,5,0,-1]
4270 # This is poorly explained (FIXME), but some examples should make it
4271 # clear (find a good reference for this!)
4272 */
4273
4274 static GelETree *
NullSpace_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4275 NullSpace_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4276 {
4277 GelETree *n;
4278 GelMatrixW *m;
4279 GelMatrix *nm;
4280 gboolean copied_m = FALSE;
4281 int *pivot_cols, *pivot_rows;
4282 int dim_image;
4283 int number_of_pivots, mwh;
4284 int i, ii, j, pi;
4285
4286 if G_UNLIKELY (a[0]->type == GEL_NULL_NODE)
4287 return gel_makenum_null ();
4288
4289 if G_UNLIKELY ( ! check_argument_value_only_matrix (a, 0, "NullSpace"))
4290 return NULL;
4291
4292 m = a[0]->mat.matrix;
4293 if ( ! m->rref) {
4294 m = gel_matrixw_copy (m);
4295 if (gel_value_matrix_gauss (ctx, m,
4296 TRUE /* reduce */,
4297 FALSE /* uppertriang */,
4298 FALSE /* stopsing */,
4299 TRUE /* stopnonsing */,
4300 NULL /* detop */,
4301 NULL /* simul */)) {
4302 gel_matrixw_free (m);
4303 return gel_makenum_null ();
4304 }
4305 copied_m = TRUE;
4306 }
4307
4308 dim_image = gel_matrixw_width (m);
4309
4310 mwh = MIN (dim_image, gel_matrixw_height (m));
4311
4312 pivot_cols = g_new (int, mwh);
4313 pivot_rows = g_new (int, mwh);
4314
4315 number_of_pivots = get_pivot_cols (m, pivot_cols, pivot_rows);
4316
4317 if (dim_image == number_of_pivots) {
4318 if (copied_m)
4319 gel_matrixw_free (m);
4320
4321 g_free (pivot_cols);
4322 g_free (pivot_rows);
4323
4324 return gel_makenum_null ();
4325 }
4326
4327 nm = gel_matrix_new ();
4328 gel_matrix_set_size (nm, dim_image - number_of_pivots, dim_image,
4329 FALSE /* padding */);
4330
4331 j = 0;
4332
4333 /* Loop over nonpivots */
4334 ii = 0;
4335 for (i = 0; i < dim_image; i++) {
4336 /* skip pivots */
4337 if (ii < number_of_pivots &&
4338 i == pivot_cols[ii]) {
4339 ii++;
4340 continue;
4341 }
4342
4343 gel_matrix_index (nm, j, i) = gel_makenum_si (-1);
4344
4345 for (pi = 0; pi < number_of_pivots; pi++) {
4346 if (pivot_cols[pi] < i) {
4347 GelETree *t = gel_matrixw_get_index
4348 (m, i, pivot_rows[pi]);
4349 if (t != NULL)
4350 gel_matrix_index (nm, j, pivot_cols[pi])
4351 = gel_copynode (t);
4352 } else {
4353 break;
4354 }
4355 }
4356 j++;
4357 }
4358
4359 if (copied_m)
4360 gel_matrixw_free (m);
4361
4362 g_free (pivot_cols);
4363 g_free (pivot_rows);
4364
4365 GEL_GET_NEW_NODE (n);
4366 n->type = GEL_MATRIX_NODE;
4367 n->mat.matrix = gel_matrixw_new_with_matrix_value_only (nm);
4368 n->mat.quoted = FALSE;
4369
4370 return n;
4371 }
4372
4373
4374 static GelEFunc *
get_reference(GelETree * a,const char * argname,const char * func)4375 get_reference (GelETree *a, const char *argname, const char *func)
4376 {
4377 if G_LIKELY (a->type == GEL_OPERATOR_NODE &&
4378 a->op.oper == GEL_E_REFERENCE) {
4379 GelETree *arg = a->op.args;
4380 g_assert(arg);
4381 if G_UNLIKELY (arg->type != GEL_IDENTIFIER_NODE ||
4382 d_lookup_global (arg->id.id) == NULL) {
4383 gel_errorout (_("%s: %s not a reference"),
4384 func, argname);
4385 return NULL;
4386 }
4387 return d_lookup_global (arg->id.id);
4388 } else {
4389 gel_errorout (_("%s: %s not a reference"),
4390 func, argname);
4391 return NULL;
4392 }
4393 }
4394
4395 static gboolean
is_row_zero(GelMatrixW * m,int r)4396 is_row_zero (GelMatrixW *m, int r)
4397 {
4398 int i;
4399 int w = gel_matrixw_width (m);
4400 for (i = 0; i < w; i++) {
4401 GelETree *node = gel_matrixw_get_index (m, i, r);
4402 if (node != NULL &&
4403 (node->type != GEL_VALUE_NODE ||
4404 /* FIXME: perhaps use some zero tolerance */
4405 ! mpw_zero_p (node->val.value))) {
4406 return FALSE;
4407 }
4408 }
4409 return TRUE;
4410 }
4411
4412 /* FIXME: work in modulo mode */
4413 static GelETree *
SolveLinearSystem_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4414 SolveLinearSystem_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4415 {
4416 GelMatrixW *RM, *RV;
4417 GelETree *n;
4418 GelEFunc *retm = NULL;
4419 GelEFunc *retv = NULL;
4420 gboolean ret;
4421
4422 if G_UNLIKELY ( ! check_argument_value_only_matrix (a, 0, "SolveLinearSystem") ||
4423 ! check_argument_value_only_matrix (a, 1, "SolveLinearSystem"))
4424 return NULL;
4425
4426 if G_UNLIKELY (gel_matrixw_height(a[0]->mat.matrix) !=
4427 gel_matrixw_height(a[1]->mat.matrix)) {
4428 gel_errorout (_("%s: matrices not of the same height"), "SolveLinearSystem");
4429 return NULL;
4430 }
4431
4432 if (a[2] != NULL) {
4433 retm = get_reference (a[2], _("third argument"),
4434 "SolveLinearSystem");
4435 if G_UNLIKELY (retm == NULL)
4436 return NULL;
4437 if (a[3] != NULL) {
4438 retv = get_reference (a[3], _("fourth argument"),
4439 "SolveLinearSystem");
4440 if G_UNLIKELY (retv == NULL)
4441 return NULL;
4442 }
4443 }
4444
4445 RM = gel_matrixw_copy(a[0]->mat.matrix);
4446 RV = gel_matrixw_copy(a[1]->mat.matrix);
4447
4448 ret = gel_value_matrix_gauss (ctx, RM, TRUE, FALSE, FALSE, FALSE, NULL, RV);
4449
4450 if (retm != NULL) {
4451 GEL_GET_NEW_NODE(n);
4452 n->type = GEL_MATRIX_NODE;
4453 n->mat.matrix = RM;
4454 n->mat.quoted = FALSE;
4455 d_set_value (retm, n);
4456 } else {
4457 gel_matrixw_free (RM);
4458 }
4459
4460 if (retv != NULL) {
4461 GEL_GET_NEW_NODE(n);
4462 n->type = GEL_MATRIX_NODE;
4463 n->mat.matrix = gel_matrixw_copy (RV);
4464 n->mat.quoted = FALSE;
4465 d_set_value (retv, n);
4466 }
4467
4468 if (ret) {
4469 int r;
4470 int h = gel_matrixw_height (RV);
4471 r = gel_matrixw_width (a[0]->mat.matrix);
4472 /* here we kill the zero rows such that only the
4473 * solution is returned */
4474 if (r < h) {
4475 GelMatrixW *tmp;
4476 int *regx, *regy, i, w;
4477 for (i = r; i < h; i++) {
4478 if ( ! is_row_zero (RV, i)) {
4479 /* Yaikes, this means there is
4480 * no solution! */
4481 gel_matrixw_free (RV);
4482 return gel_makenum_null ();
4483 }
4484 }
4485 w = gel_matrixw_width (RV);
4486 regx = g_new(int, w);
4487 for (i = 0; i < w; i++)
4488 regx[i] = i;
4489 regy = g_new(int, r);
4490 for (i = 0; i < r; i++)
4491 regy[i] = i;
4492
4493 tmp = gel_matrixw_get_region (RV, regx, regy, w, r);
4494 g_free (regx);
4495 g_free (regy);
4496
4497 gel_matrixw_free (RV);
4498 RV = tmp;
4499 }
4500 GEL_GET_NEW_NODE(n);
4501 n->type = GEL_MATRIX_NODE;
4502 n->mat.matrix = RV;
4503 n->mat.quoted = FALSE;
4504 return n;
4505 } else {
4506 gel_matrixw_free (RV);
4507 return gel_makenum_null ();
4508 }
4509 }
4510
4511 /* this is utterly stupid, but only used for small primes
4512 * where it's all ok */
4513 static gboolean
is_prime_small(unsigned int testnum)4514 is_prime_small (unsigned int testnum)
4515 {
4516 int i;
4517 unsigned int s = (unsigned int)sqrt(testnum);
4518
4519 for(i=0;g_array_index(primes,unsigned int,i)<=s && i<numprimes;i++) {
4520 if((testnum%g_array_index(primes,unsigned int,i))==0) {
4521 return FALSE;
4522 }
4523 }
4524 return TRUE;
4525 }
4526
4527 static GelETree *
Prime_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4528 Prime_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4529 {
4530 long num;
4531 unsigned int i;
4532 unsigned int last_prime;
4533
4534 if(a[0]->type==GEL_MATRIX_NODE)
4535 return gel_apply_func_to_matrix(ctx,a[0],Prime_op,"prime", exception);
4536
4537 if G_UNLIKELY ( ! check_argument_positive_integer (a, 0, "Prime"))
4538 return NULL;
4539
4540 num = gel_get_nonnegative_integer (a[0]->val.value, "Prime");
4541 if G_UNLIKELY (num < 0)
4542 return NULL;
4543
4544 if G_UNLIKELY (primes == NULL) {
4545 unsigned int b;
4546 primes = g_array_new(FALSE,FALSE,sizeof(unsigned int));
4547 b = 2;
4548 primes = g_array_append_val(primes,b);
4549 b = 3;
4550 primes = g_array_append_val(primes,b);
4551 b = 5;
4552 primes = g_array_append_val(primes,b);
4553 b = 7;
4554 primes = g_array_append_val(primes,b);
4555 numprimes = 4;
4556 }
4557
4558 if(num-1 < numprimes)
4559 return gel_makenum_ui(g_array_index(primes,unsigned int,num-1));
4560
4561 last_prime = g_array_index (primes, unsigned int, numprimes-1);
4562 primes = g_array_set_size(primes,num);
4563 for(i=g_array_index(primes,unsigned int,numprimes-1)+2;
4564 numprimes<=num-1 && numprimes <= MAXPRIMES && i<=G_MAXUINT-1;i+=2) {
4565 if (is_prime_small (i)) {
4566 g_array_index(primes,unsigned int,numprimes++) = i;
4567 last_prime = i;
4568 }
4569 }
4570
4571 if (numprimes <= num-1) {
4572 mpw_t prime;
4573 mpw_init (prime);
4574 mpw_set_ui (prime, last_prime);
4575 for (i = numprimes; i <= num-1; i++) {
4576 mpw_nextprime (prime, prime);
4577 }
4578 return gel_makenum_use (prime);
4579 }
4580 return gel_makenum_ui(g_array_index(primes,unsigned int,num-1));
4581 }
4582
4583 static GelETree *
NextPrime_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4584 NextPrime_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4585 {
4586 mpw_t ret;
4587
4588 if(a[0]->type==GEL_MATRIX_NODE)
4589 return gel_apply_func_to_matrix(ctx,a[0],NextPrime_op,"NextPrime", exception);
4590
4591 if G_UNLIKELY ( ! check_argument_integer (a, 0, "NextPrime"))
4592 return NULL;
4593
4594 mpw_init (ret);
4595 mpw_nextprime (ret, a[0]->val.value);
4596 if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
4597 mpw_clear (ret);
4598 /* eek! should not happen */
4599 gel_error_num = GEL_NO_ERROR;
4600 return NULL;
4601 }
4602 return gel_makenum_use (ret);
4603 }
4604
4605 static GelETree *
LucasNumber_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4606 LucasNumber_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4607 {
4608 mpw_t ret;
4609
4610 if(a[0]->type==GEL_MATRIX_NODE)
4611 return gel_apply_func_to_matrix(ctx,a[0],LucasNumber_op,"LucasNumber", exception);
4612
4613 if G_UNLIKELY ( ! check_argument_integer (a, 0, "LucasNumber"))
4614 return NULL;
4615
4616 mpw_init (ret);
4617 mpw_lucnum (ret, a[0]->val.value);
4618 if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
4619 mpw_clear (ret);
4620 gel_error_num = GEL_NO_ERROR;
4621 return NULL;
4622 }
4623 return gel_makenum_use (ret);
4624 }
4625
4626 static GelETree *
IsPrime_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4627 IsPrime_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4628 {
4629 int ret;
4630 mpz_ptr num;
4631
4632 if (a[0]->type == GEL_MATRIX_NODE)
4633 return gel_apply_func_to_matrix (ctx, a[0], IsPrime_op, "IsPrime", exception);
4634
4635 if G_UNLIKELY ( ! check_argument_integer (a, 0, "IsPrime"))
4636 return NULL;
4637
4638 num = mpw_peek_real_mpz (a[0]->val.value);
4639
4640 ret = mympz_is_prime (num, -1);
4641
4642 return gel_makenum_bool (ret);
4643 }
4644
4645 static GelETree *
StrongPseudoprimeTest_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4646 StrongPseudoprimeTest_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4647 {
4648 int ret;
4649 mpz_ptr num;
4650 mpz_ptr b;
4651
4652 if (a[0]->type == GEL_MATRIX_NODE)
4653 return gel_apply_func_to_matrixen (ctx, a[0], a[1],
4654 StrongPseudoprimeTest_op,
4655 "StrongPseudoprimeTest",
4656 exception);
4657
4658 if G_UNLIKELY ( ! check_argument_positive_integer (a, 0, "StrongPseudoprimeTest") ||
4659 ! check_argument_positive_integer (a, 1, "StrongPseudoprimeTest"))
4660 return NULL;
4661
4662 num = mpw_peek_real_mpz (a[0]->val.value);
4663 b = mpw_peek_real_mpz (a[1]->val.value);
4664
4665 ret = mympz_strong_pseudoprime_test (num, b);
4666
4667 return gel_makenum_bool (ret);
4668 }
4669
4670 static GelETree *
MillerRabinTest_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4671 MillerRabinTest_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4672 {
4673 int ret;
4674 int reps;
4675 mpz_ptr num;
4676
4677 if (a[0]->type == GEL_MATRIX_NODE ||
4678 a[1]->type == GEL_MATRIX_NODE)
4679 return gel_apply_func_to_matrixen (ctx, a[0], a[1],
4680 MillerRabinTest_op,
4681 "MillerRabinTest",
4682 exception);
4683
4684 if G_UNLIKELY ( ! check_argument_positive_integer (a, 0, "MillerRabinTest") ||
4685 ! check_argument_positive_integer (a, 1, "MillerRabinTest"))
4686 return NULL;
4687
4688 reps = gel_get_nonnegative_integer (a[1]->val.value, "MillerRabinTest");
4689 if (reps < 0)
4690 return NULL;
4691
4692 num = mpw_peek_real_mpz (a[0]->val.value);
4693
4694 ret = mpz_millerrabin (num, reps);
4695
4696 return gel_makenum_bool (ret);
4697 }
4698
4699 static GelETree *
MillerRabinTestSure_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4700 MillerRabinTestSure_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4701 {
4702 int ret;
4703 mpz_ptr num;
4704
4705 if (a[0]->type == GEL_MATRIX_NODE)
4706 return gel_apply_func_to_matrix (ctx, a[0],
4707 MillerRabinTestSure_op,
4708 "MillerRabinTestSure", exception);
4709
4710 if G_UNLIKELY ( ! check_argument_positive_integer (a, 0, "MillerRabinTestSure"))
4711 return NULL;
4712 if G_UNLIKELY (mpw_cmp_ui (a[0]->val.value, 2) <= 0) {
4713 gel_errorout (_("%s: argument must be greater "
4714 "than 2"), "MillerRabinTestSure");
4715 return NULL;
4716 }
4717
4718 num = mpw_peek_real_mpz (a[0]->val.value);
4719
4720 ret = mympz_miller_rabin_test_sure (num);
4721
4722 return gel_makenum_bool (ret);
4723 }
4724
4725 static GelETree *
Factorize_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4726 Factorize_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4727 {
4728 mpz_ptr numz;
4729 GArray *fact;
4730 GelETree *n;
4731 GelMatrixW *mn;
4732 guint i;
4733
4734 if (a[0]->type == GEL_MATRIX_NODE)
4735 return gel_apply_func_to_matrix (ctx, a[0],
4736 Factorize_op,
4737 "Factorize", exception);
4738
4739 if G_UNLIKELY ( ! check_argument_integer (a, 0, "Factorize"))
4740 return NULL;
4741
4742 numz = mpw_peek_real_mpz (a[0]->val.value);
4743
4744 fact = mympz_pollard_rho_factorize (numz);
4745
4746 /* error or interrupt or whatnot */
4747 if G_UNLIKELY (fact == NULL) {
4748 RAISE_EXCEPTION (exception);
4749 return NULL;
4750 }
4751
4752 GEL_GET_NEW_NODE (n);
4753 n->type = GEL_MATRIX_NODE;
4754 n->mat.matrix = mn = gel_matrixw_new();
4755 n->mat.quoted = FALSE;
4756 gel_matrixw_set_size (mn, fact->len, 2);
4757
4758 for (i = 0; i < fact->len; i++) {
4759 GelFactor f = g_array_index (fact, GelFactor, i);
4760 mpw_t num;
4761 mpw_init (num);
4762 mpw_set_mpz_use (num, f.num);
4763 gel_matrixw_set_index (mn, (int)i, 0) = gel_makenum_use (num);
4764 gel_matrixw_set_index (mn, (int)i, 1) = gel_makenum_ui (f.exp);
4765 }
4766
4767 g_array_free (fact, TRUE /*free segment */);
4768
4769 return n;
4770 }
4771
4772 static GelETree *
ModInvert_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4773 ModInvert_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4774 {
4775 mpw_t ret;
4776
4777 if (a[0]->type == GEL_MATRIX_NODE ||
4778 a[1]->type == GEL_MATRIX_NODE)
4779 return gel_apply_func_to_matrixen (ctx, a[0], a[1],
4780 ModInvert_op,
4781 "ModInvert",
4782 exception);
4783
4784 if G_UNLIKELY ( ! check_argument_integer (a, 0, "ModInvert") ||
4785 ! check_argument_integer (a, 1, "ModInvert"))
4786 return NULL;
4787
4788 mpw_init (ret);
4789 mpw_invert (ret, a[0]->val.value, a[1]->val.value);
4790 if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
4791 mpw_clear (ret);
4792 gel_error_num = GEL_NO_ERROR;
4793 return NULL;
4794 }
4795 return gel_makenum_use (ret);
4796 }
4797
4798 static GelETree *
Divides_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4799 Divides_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
4800 {
4801 int ret;
4802 mpz_ptr numa, numb;
4803
4804 if (a[0]->type == GEL_MATRIX_NODE ||
4805 a[1]->type == GEL_MATRIX_NODE)
4806 return gel_apply_func_to_matrixen (ctx, a[0], a[1], Divides_op, "Divides", exception);
4807
4808 if G_UNLIKELY ( ! check_argument_integer (a, 0, "Divides") ||
4809 ! check_argument_integer (a, 1, "Divides"))
4810 return NULL;
4811
4812 numa = mpw_peek_real_mpz (a[0]->val.value);
4813 numb = mpw_peek_real_mpz (a[1]->val.value);
4814
4815 if (mpz_sgn (numa) == 0) {
4816 gel_errorout (_("Division by zero!"));
4817
4818 return NULL;
4819 }
4820
4821 ret = mpz_divisible_p (numb, numa);
4822
4823 return gel_makenum_bool (ret);
4824 }
4825
4826 static GelETree *
ExactDivision_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4827 ExactDivision_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
4828 {
4829 mpz_ptr numa, numb;
4830 mpz_t ret;
4831 mpw_t retw;
4832
4833 if (a[0]->type == GEL_MATRIX_NODE ||
4834 a[1]->type == GEL_MATRIX_NODE)
4835 return gel_apply_func_to_matrixen (ctx, a[0], a[1], ExactDivision_op, "ExactDivision", exception);
4836
4837 if G_UNLIKELY ( ! check_argument_integer (a, 0, "ExactDivision") ||
4838 ! check_argument_integer (a, 1, "ExactDivision"))
4839 return NULL;
4840
4841 numa = mpw_peek_real_mpz (a[0]->val.value);
4842 numb = mpw_peek_real_mpz (a[1]->val.value);
4843
4844 if (mpz_sgn (numb) == 0) {
4845 gel_errorout (_("Division by zero!"));
4846
4847 return NULL;
4848 }
4849
4850 mpz_init (ret);
4851 mpz_divexact (ret, numa, numb);
4852
4853 mpw_init (retw);
4854 mpw_set_mpz_use (retw, ret);
4855
4856 return gel_makenum (retw);
4857 }
4858
4859 /* this can return 0! unlike what poly_cut_zeros does */
4860 static int
poly_find_cutoff_size(GelMatrixW * m)4861 poly_find_cutoff_size (GelMatrixW *m)
4862 {
4863 int i;
4864 int cutoff;
4865 for(i = gel_matrixw_width(m)-1; i >= 0; i--) {
4866 GelETree *t = gel_matrixw_get_index(m,i,0);
4867 if (t != NULL &&
4868 ! mpw_zero_p (t->val.value))
4869 break;
4870 }
4871 cutoff = i+1;
4872 return cutoff;
4873 }
4874
4875 static void
poly_cut_zeros(GelMatrixW * m)4876 poly_cut_zeros(GelMatrixW *m)
4877 {
4878 int i;
4879 int cutoff;
4880 for(i=gel_matrixw_width(m)-1;i>=1;i--) {
4881 GelETree *t = gel_matrixw_get_index(m,i,0);
4882 if (t != NULL &&
4883 ! mpw_zero_p (t->val.value))
4884 break;
4885 }
4886 cutoff = i+1;
4887 if(cutoff==gel_matrixw_width(m))
4888 return;
4889 gel_matrixw_set_size(m,cutoff,1);
4890 }
4891
4892 static gboolean
check_poly(GelETree ** a,int args,const char * func,gboolean complain)4893 check_poly(GelETree * *a, int args, const char *func, gboolean complain)
4894 {
4895 int i,j;
4896
4897 for (j = 0; j < args; j++) {
4898 if (a[j]->type != GEL_MATRIX_NODE ||
4899 gel_matrixw_height (a[j]->mat.matrix) != 1) {
4900 if G_UNLIKELY (complain)
4901 gel_errorout (_("%s: arguments not horizontal vectors"),
4902 func);
4903 return FALSE;
4904 }
4905
4906 for(i=0;i<gel_matrixw_width(a[j]->mat.matrix);i++) {
4907 GelETree *t = gel_matrixw_index(a[j]->mat.matrix,i,0);
4908 if (t->type != GEL_VALUE_NODE) {
4909 if G_UNLIKELY (complain)
4910 gel_errorout (_("%s: arguments not numeric only vectors"),
4911 func);
4912 return FALSE;
4913 }
4914 }
4915 }
4916 return TRUE;
4917 }
4918
4919 static GelETree *
AddPoly_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4920 AddPoly_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4921 {
4922 GelETree *n;
4923 long size;
4924 int i;
4925 GelMatrixW *m1,*m2,*mn;
4926
4927 if G_UNLIKELY ( ! check_poly(a,2,"AddPoly",TRUE))
4928 return NULL;
4929
4930 m1 = a[0]->mat.matrix;
4931 m2 = a[1]->mat.matrix;
4932
4933 GEL_GET_NEW_NODE(n);
4934 n->type = GEL_MATRIX_NODE;
4935 n->mat.matrix = mn = gel_matrixw_new();
4936 n->mat.quoted = FALSE;
4937 size = MAX(gel_matrixw_width(m1), gel_matrixw_width(m2));
4938 gel_matrixw_set_size(mn,size,1);
4939
4940 for(i=0;i<size;i++) {
4941 if(i<gel_matrixw_width(m1) &&
4942 i<gel_matrixw_width(m2)) {
4943 GelETree *l,*r;
4944 mpw_t t;
4945 mpw_init(t);
4946 l = gel_matrixw_index(m1,i,0);
4947 r = gel_matrixw_index(m2,i,0);
4948 mpw_add(t,l->val.value,r->val.value);
4949 gel_matrixw_set_index(mn,i,0) = gel_makenum_use(t);
4950 } else if(i<gel_matrixw_width(m1)) {
4951 gel_matrixw_set_index(mn,i,0) =
4952 gel_copynode(gel_matrixw_get_index(m1,i,0));
4953 } else /*if(i<gel_matrixw_width(m2)*/ {
4954 gel_matrixw_set_index(mn,i,0) =
4955 gel_copynode(gel_matrixw_set_index(m2,i,0));
4956 }
4957 }
4958
4959 poly_cut_zeros(mn);
4960
4961 return n;
4962 }
4963
4964 static GelETree *
SubtractPoly_op(GelCtx * ctx,GelETree ** a,gboolean * exception)4965 SubtractPoly_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
4966 {
4967 GelETree *n;
4968 long size;
4969 int i;
4970 GelMatrixW *m1,*m2,*mn;
4971
4972 if G_UNLIKELY ( ! check_poly(a,2,"SubtractPoly",TRUE))
4973 return NULL;
4974
4975 m1 = a[0]->mat.matrix;
4976 m2 = a[1]->mat.matrix;
4977
4978 GEL_GET_NEW_NODE(n);
4979 n->type = GEL_MATRIX_NODE;
4980 n->mat.matrix = mn = gel_matrixw_new();
4981 n->mat.quoted = FALSE;
4982 size = MAX(gel_matrixw_width(m1), gel_matrixw_width(m2));
4983 gel_matrixw_set_size(mn,size,1);
4984
4985 for(i=0;i<size;i++) {
4986 if(i<gel_matrixw_width(m1) &&
4987 i<gel_matrixw_width(m2)) {
4988 GelETree *l,*r;
4989 mpw_t t;
4990 mpw_init(t);
4991 l = gel_matrixw_index(m1,i,0);
4992 r = gel_matrixw_index(m2,i,0);
4993 mpw_sub(t,l->val.value,r->val.value);
4994 gel_matrixw_set_index(mn,i,0) = gel_makenum_use(t);
4995 } else if(i<gel_matrixw_width(m1)) {
4996 gel_matrixw_set_index(mn,i,0) =
4997 gel_copynode(gel_matrixw_set_index(m1,i,0));
4998 } else /*if(i<gel_matrixw_width(m2))*/ {
4999 GelETree *nn,*r;
5000 r = gel_matrixw_index(m2,i,0);
5001 nn = gel_makenum_ui(0);
5002 mpw_neg(nn->val.value,r->val.value);
5003 gel_matrixw_set_index(mn,i,0) = nn;
5004 }
5005 }
5006
5007 poly_cut_zeros(mn);
5008
5009 return n;
5010 }
5011
5012 static GelETree *
MultiplyPoly_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5013 MultiplyPoly_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5014 {
5015 GelETree *n;
5016 long size;
5017 int i,j;
5018 mpw_t accu;
5019 GelMatrixW *m1,*m2,*mn;
5020
5021 if G_UNLIKELY ( ! check_poly(a,2,"MultiplyPoly",TRUE))
5022 return NULL;
5023 m1 = a[0]->mat.matrix;
5024 m2 = a[1]->mat.matrix;
5025
5026 GEL_GET_NEW_NODE(n);
5027 n->type = GEL_MATRIX_NODE;
5028 n->mat.matrix = mn = gel_matrixw_new();
5029 n->mat.quoted = FALSE;
5030 size = gel_matrixw_width(m1) + gel_matrixw_width(m2);
5031 gel_matrixw_set_size(mn,size,1);
5032
5033 mpw_init(accu);
5034
5035 for(i=0;i<gel_matrixw_width(m1);i++) {
5036 for(j=0;j<gel_matrixw_width(m2);j++) {
5037 GelETree *l,*r,*nn;
5038 l = gel_matrixw_get_index(m1,i,0);
5039 r = gel_matrixw_get_index(m2,j,0);
5040 if (l == NULL ||
5041 r == NULL ||
5042 mpw_zero_p (l->val.value) ||
5043 mpw_zero_p (r->val.value))
5044 continue;
5045 mpw_mul(accu,l->val.value,r->val.value);
5046 nn = gel_matrixw_get_index(mn,i+j,0);
5047 if(nn)
5048 mpw_add(nn->val.value,nn->val.value,accu);
5049 else
5050 gel_matrixw_set_index(mn,i+j,0) =
5051 gel_makenum(accu);
5052 }
5053 }
5054
5055 mpw_clear(accu);
5056
5057 poly_cut_zeros(mn);
5058
5059 return n;
5060 }
5061
5062 static GelETree *
DividePoly_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5063 DividePoly_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5064 {
5065 GelETree *n, *rn, *ql;
5066 long size, sizeq;
5067 int i, j;
5068 GelMatrixW *pm, *qm, *mn, *rem;
5069 GelEFunc *retrem = NULL;
5070 mpw_t tmp;
5071
5072 if G_UNLIKELY ( ! check_poly (a, 2, "DividePoly", TRUE))
5073 return NULL;
5074 if (a[2] != NULL) {
5075 if (a[2]->type != GEL_NULL_NODE) {
5076 retrem = get_reference (a[2], _("third argument"),
5077 "DividePoly");
5078 if G_UNLIKELY (retrem == NULL)
5079 return NULL;
5080 }
5081 if G_UNLIKELY (a[3] != NULL) {
5082 gel_errorout (_("%s: too many arguments"),
5083 "DividePoly");
5084 return NULL;
5085 }
5086 }
5087
5088 pm = a[0]->mat.matrix;
5089 qm = a[1]->mat.matrix;
5090
5091 size = poly_find_cutoff_size (pm);
5092 sizeq = poly_find_cutoff_size (qm);
5093
5094 if (sizeq <= 0) {
5095 gel_errorout ("%s: %s",
5096 "DividePoly",
5097 _("Division by zero!"));
5098 return NULL;
5099 }
5100
5101 GEL_GET_NEW_NODE (n);
5102 n->type = GEL_MATRIX_NODE;
5103 n->mat.matrix = mn = gel_matrixw_new ();
5104 n->mat.quoted = FALSE;
5105
5106 /* nothing to do */
5107 if (size < sizeq) {
5108 gel_matrixw_set_size (mn, 1, 1);
5109
5110 if (retrem != NULL) {
5111 GEL_GET_NEW_NODE(rn);
5112 rn->type = GEL_MATRIX_NODE;
5113 rn->mat.matrix = gel_matrixw_copy (pm);
5114 poly_cut_zeros (rn->mat.matrix);
5115 rn->mat.quoted = FALSE;
5116 d_set_value (retrem, rn);
5117 }
5118
5119 return n;
5120 }
5121
5122 gel_matrixw_set_size (mn, size, 1);
5123
5124 rem = gel_matrixw_copy (pm);
5125 gel_matrixw_make_private (rem, TRUE /* kill_type_caches */);
5126
5127 /* we know ql can't be zero */
5128 ql = gel_matrixw_index (qm, sizeq-1, 0);
5129
5130 mpw_init (tmp);
5131
5132 for (i = size-sizeq; i >= 0; i--) {
5133 GelETree *pt;
5134 pt = gel_matrixw_get_index (rem, i+sizeq-1, 0);
5135 if (pt == NULL || mpw_zero_p (pt->val.value)) {
5136 /* Leave mn[i,0] at NULL (zero) */
5137 continue;
5138 }
5139 gel_matrixw_set_index (mn, i, 0) = pt;
5140 gel_matrixw_set_index (rem, i+sizeq-1, 0) = NULL;
5141 mpw_div (pt->val.value,
5142 pt->val.value, ql->val.value);
5143
5144 for (j = 0; j < sizeq-1; j++) {
5145 GelETree *rv, *qt;
5146 rv = gel_matrixw_get_index (rem, i+j, 0);
5147 if (rv == NULL)
5148 rv = gel_matrixw_set_index (rem, i+j, 0)
5149 = gel_makenum_ui (0);
5150 qt = gel_matrixw_index (qm, j, 0);
5151 mpw_mul (tmp, pt->val.value, qt->val.value);
5152 mpw_sub (rv->val.value, rv->val.value, tmp);
5153 }
5154 }
5155
5156 mpw_clear (tmp);
5157
5158 poly_cut_zeros (mn);
5159
5160 if (retrem != NULL) {
5161 poly_cut_zeros (rem);
5162
5163 GEL_GET_NEW_NODE (rn);
5164 rn->type = GEL_MATRIX_NODE;
5165 rn->mat.matrix = rem;
5166 rn->mat.quoted = FALSE;
5167 d_set_value (retrem, rn);
5168 } else {
5169 gel_matrixw_free (rem);
5170 }
5171
5172 return n;
5173 }
5174
5175 static GelETree *
PolyDerivative_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5176 PolyDerivative_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5177 {
5178 GelETree *n;
5179 int i;
5180 GelMatrixW *m,*mn;
5181
5182 if G_UNLIKELY ( ! check_poly(a,1,"PolyDerivative",TRUE))
5183 return NULL;
5184
5185 m = a[0]->mat.matrix;
5186
5187 GEL_GET_NEW_NODE(n);
5188 n->type = GEL_MATRIX_NODE;
5189 n->mat.matrix = mn = gel_matrixw_new();
5190 n->mat.quoted = FALSE;
5191 if(gel_matrixw_width(m)==1) {
5192 gel_matrixw_set_size(mn,1,1);
5193 return n;
5194 }
5195 gel_matrixw_set_size(mn,gel_matrixw_width(m)-1,1);
5196
5197 for(i=1;i<gel_matrixw_width(m);i++) {
5198 GelETree *r;
5199 mpw_t t;
5200 mpw_init(t);
5201 r = gel_matrixw_index(m,i,0);
5202 mpw_mul_ui(t,r->val.value,i);
5203 gel_matrixw_set_index(mn,i-1,0) = gel_makenum_use(t);
5204 }
5205
5206 poly_cut_zeros(mn);
5207
5208 return n;
5209 }
5210
5211 static GelETree *
Poly2ndDerivative_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5212 Poly2ndDerivative_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5213 {
5214 GelETree *n;
5215 int i;
5216 GelMatrixW *m,*mn;
5217
5218 if G_UNLIKELY ( ! check_poly(a,1,"Poly2ndDerivative",TRUE))
5219 return NULL;
5220
5221 m = a[0]->mat.matrix;
5222
5223 GEL_GET_NEW_NODE(n);
5224 n->type = GEL_MATRIX_NODE;
5225 n->mat.matrix = mn = gel_matrixw_new();
5226 n->mat.quoted = FALSE;
5227 if(gel_matrixw_width(m)<=2) {
5228 gel_matrixw_set_size(mn,1,1);
5229 return n;
5230 }
5231 gel_matrixw_set_size(mn,gel_matrixw_width(m)-2,1);
5232
5233 for(i=2;i<gel_matrixw_width(m);i++) {
5234 GelETree *r;
5235 mpw_t t;
5236 r = gel_matrixw_index(m,i,0);
5237 mpw_init(t);
5238 mpw_mul_ui(t,r->val.value,i*(i-1));
5239 gel_matrixw_set_index(mn,i-2,0) = gel_makenum_use(t);
5240 }
5241
5242 poly_cut_zeros(mn);
5243
5244 return n;
5245 }
5246
5247 static GelETree *
TrimPoly_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5248 TrimPoly_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5249 {
5250 GelETree *n;
5251
5252 if G_UNLIKELY ( ! check_poly(a,1,"TrimPoly",TRUE))
5253 return NULL;
5254
5255 GEL_GET_NEW_NODE(n);
5256 n->type = GEL_MATRIX_NODE;
5257 n->mat.matrix = gel_matrixw_copy(a[0]->mat.matrix);
5258 n->mat.quoted = FALSE;
5259
5260 poly_cut_zeros(n->mat.matrix);
5261
5262 return n;
5263 }
5264
5265 static GelETree *
IsPoly_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5266 IsPoly_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5267 {
5268 if(check_poly(a,1,"IsPoly",FALSE))
5269 return gel_makenum_bool (1);
5270 else
5271 return gel_makenum_bool (0);
5272 }
5273
5274 static GelETree *
QuadraticFormula_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5275 QuadraticFormula_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5276 {
5277 GelETree *n;
5278 GelMatrixW *m;
5279 GelMatrix *nm;
5280
5281 mpw_ptr aa, bb, cc;
5282 mpw_t r1, r2;
5283
5284 if G_UNLIKELY (a[0]->type == GEL_NULL_NODE)
5285 return gel_makenum_null ();
5286
5287 if G_UNLIKELY ( ! check_poly(a,1,"QuadraticFormula",TRUE))
5288 return NULL;
5289
5290 m = a[0]->mat.matrix;
5291
5292 if G_UNLIKELY (gel_matrixw_elements (m) != 3 ||
5293 mpw_zero_p (gel_matrixw_index(m,2,0)->val.value)) {
5294 gel_errorout (_("%s: argument 1 must be a quadratic polynomial"),
5295 "QuadraticFormula");
5296 return NULL;
5297 }
5298
5299 aa = gel_matrixw_index(m,2,0)->val.value;
5300 bb = gel_matrixw_index(m,1,0)->val.value;
5301 cc = gel_matrixw_index(m,0,0)->val.value;
5302
5303 mpw_init (r1);
5304 mpw_init (r2);
5305
5306 if (mpw_zero_p (cc)) {
5307 mpw_div (r1, bb, aa);
5308 mpw_neg (r1, r1);
5309 mpw_set_ui (r2, 0);
5310 } else if (mpw_zero_p (bb)) {
5311 mpw_mul (r1, aa, cc);
5312 mpw_neg (r1, r1);
5313 mpw_sqrt (r1, r1);
5314 mpw_div (r1, r1, aa);
5315 mpw_neg (r2, r1);
5316 } else {
5317 mpw_mul (r1, bb, bb);
5318 mpw_mul (r2, aa, cc);
5319 mpw_mul_ui (r2, r2, 4);
5320 mpw_sub (r1, r1, r2);
5321 mpw_sqrt (r1, r1);
5322 /* r1 is now the sqrt of the discriminant */
5323
5324 /* try to avoid instability */
5325 if (mpw_re_sgn (r1) != mpw_re_sgn (bb)) {
5326 mpw_neg (r1, r1);
5327 }
5328
5329 mpw_add (r1, r1, bb);
5330 mpw_div_ui (r1, r1, 2);
5331 mpw_neg (r1, r1);
5332
5333 /* r1 = (bb + s * sqrt(bb^2 - 4*aa*cc)) / (-2); */
5334
5335 /* set r2 first */
5336 mpw_div (r2, cc, r1);
5337
5338 mpw_div (r1, r1, aa);
5339 }
5340
5341 nm = gel_matrix_new ();
5342 gel_matrix_set_size (nm, 1, 2, FALSE /* padding */);
5343 gel_matrix_index (nm, 0, 0) = gel_makenum_use (r1);
5344 gel_matrix_index (nm, 0, 1) = gel_makenum_use (r2);
5345
5346 GEL_GET_NEW_NODE (n);
5347 n->type = GEL_MATRIX_NODE;
5348 n->mat.matrix = gel_matrixw_new_with_matrix_value_only (nm);
5349 n->mat.quoted = FALSE;
5350
5351 return n;
5352 }
5353
5354
5355 static GelETree *
PolyToString_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5356 PolyToString_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
5357 {
5358 GelETree *n;
5359 int i;
5360 GString *gs;
5361 gboolean any = FALSE;
5362 GelMatrixW *m;
5363 const char *var;
5364 GelOutput *gelo;
5365 char *r;
5366
5367 if G_UNLIKELY ( ! check_poly(a,1,"PolyToString",TRUE))
5368 return NULL;
5369
5370 if (a[1] == NULL) {
5371 var = "x";
5372 } else if G_UNLIKELY ( ! check_argument_string (a, 1, "PolyToString")) {
5373 return NULL;
5374 } else {
5375 if G_UNLIKELY (a[2] != NULL) {
5376 gel_errorout (_("%s: too many arguments"),
5377 "PolyToString");
5378 return NULL;
5379 }
5380 var = a[1]->str.str;
5381 }
5382
5383 m = a[0]->mat.matrix;
5384
5385 gs = g_string_new("");
5386
5387 gelo = gel_output_new();
5388 gel_output_setup_string(gelo, 0, NULL);
5389 gel_output_set_gstring(gelo, gs);
5390
5391 for(i=gel_matrixw_width(m)-1;i>=0;i--) {
5392 GelETree *t;
5393 t = gel_matrixw_index(m,i,0);
5394 if (mpw_zero_p (t->val.value))
5395 continue;
5396 /*positive (or complex) */
5397 if (mpw_is_complex (t->val.value) ||
5398 mpw_sgn (t->val.value) > 0) {
5399 if(any) g_string_append(gs," + ");
5400 if (MPW_IS_COMPLEX (t->val.value)) {
5401 g_string_append_c (gs, '(');
5402 if (i==0) {
5403 gel_print_etree (gelo, t, FALSE);
5404 g_string_append_c (gs, ')');
5405 } else if ( ! mpw_eql_ui(t->val.value,1)) {
5406 gel_print_etree (gelo, t, FALSE);
5407 g_string_append_c (gs, ')');
5408 g_string_append_c(gs,'*');
5409 }
5410 } else {
5411 if (i == 0) {
5412 gel_print_etree (gelo, t, FALSE);
5413 } else if ( ! mpw_eql_ui (t->val.value, 1)) {
5414 gel_print_etree (gelo, t, FALSE);
5415 g_string_append_c(gs,'*');
5416 }
5417 }
5418 /*negative*/
5419 } else {
5420 if(any) g_string_append(gs," - ");
5421 else g_string_append_c(gs,'-');
5422 mpw_neg(t->val.value,t->val.value);
5423 if (i == 0) {
5424 gel_print_etree (gelo, t, FALSE);
5425 } else if ( ! mpw_eql_ui (t->val.value, 1)) {
5426 gel_print_etree (gelo, t, FALSE);
5427 g_string_append_c(gs,'*');
5428 }
5429 mpw_neg(t->val.value,t->val.value);
5430 }
5431 if(i==1)
5432 g_string_append_printf (gs, "%s", var);
5433 else if(i>1)
5434 g_string_append_printf (gs, "%s^%d", var, i);
5435 any = TRUE;
5436 }
5437 if(!any)
5438 g_string_append(gs,"0");
5439
5440 r = gel_output_snarf_string (gelo);
5441 gel_output_unref (gelo);
5442
5443 GEL_GET_NEW_NODE(n);
5444 n->type = GEL_STRING_NODE;
5445 n->str.str = r;
5446 n->str.constant = FALSE;
5447
5448 return n;
5449 }
5450
5451 static GelETree *
ptf_makenew_power(GelToken * id,int power)5452 ptf_makenew_power(GelToken *id, int power)
5453 {
5454 GelETree *n;
5455 GelETree *tokn;
5456 GEL_GET_NEW_NODE(tokn);
5457 tokn->type = GEL_IDENTIFIER_NODE;
5458 tokn->id.id = id;
5459 tokn->id.uninitialized = FALSE;
5460
5461 if(power == 1)
5462 return tokn;
5463
5464 GEL_GET_NEW_NODE(n);
5465 n->type = GEL_OPERATOR_NODE;
5466 n->op.oper = GEL_E_EXP;
5467 n->op.args = tokn;
5468 n->op.args->any.next = gel_makenum_ui(power);
5469 n->op.args->any.next->any.next = NULL;
5470 n->op.nargs = 2;
5471
5472 return n;
5473 }
5474
5475 static GelETree *
ptf_makenew_term(mpw_t mul,GelToken * id,int power)5476 ptf_makenew_term(mpw_t mul, GelToken *id, int power)
5477 {
5478 GelETree *n;
5479
5480 if (power == 0) {
5481 return gel_makenum (mul);
5482 } else if (mpw_eql_ui (mul, 1)) {
5483 n = ptf_makenew_power(id,power);
5484 } else {
5485 GEL_GET_NEW_NODE(n);
5486 n->type = GEL_OPERATOR_NODE;
5487 n->op.oper = GEL_E_MUL;
5488 n->op.args = gel_makenum (mul);
5489 n->op.args->any.next = ptf_makenew_power(id,power);
5490 n->op.args->any.next->any.next = NULL;
5491 n->op.nargs = 2;
5492 }
5493 return n;
5494 }
5495
5496 static GelETree *
PolyToFunction_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5497 PolyToFunction_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5498 {
5499 GelETree *n;
5500 GelETree *nn = NULL;
5501 int i;
5502 GelMatrixW *m;
5503
5504 static GelToken *var = NULL;
5505
5506 if G_UNLIKELY ( ! check_poly(a,1,"PolyToFunction",TRUE))
5507 return NULL;
5508
5509 if G_UNLIKELY (var == NULL)
5510 var = d_intern("x");
5511
5512 m = a[0]->mat.matrix;
5513
5514 for(i=gel_matrixw_width(m)-1;i>=0;i--) {
5515 GelETree *t;
5516 t = gel_matrixw_index(m,i,0);
5517 if (mpw_zero_p (t->val.value))
5518 continue;
5519
5520 if(!nn)
5521 nn = ptf_makenew_term(t->val.value,var,i);
5522 else {
5523 GelETree *nnn;
5524 GEL_GET_NEW_NODE(nnn);
5525 nnn->type = GEL_OPERATOR_NODE;
5526 nnn->op.oper = GEL_E_PLUS;
5527 nnn->op.args = nn;
5528 nnn->op.args->any.next =
5529 ptf_makenew_term(t->val.value,var,i);
5530 nnn->op.args->any.next->any.next = NULL;
5531 nnn->op.nargs = 2;
5532 nn = nnn;
5533 }
5534 }
5535 if(!nn)
5536 nn = gel_makenum_ui(0);
5537
5538 GEL_GET_NEW_NODE(n);
5539 n->type = GEL_FUNCTION_NODE;
5540 n->func.func = d_makeufunc(NULL,nn,g_slist_append(NULL,var),1, NULL);
5541 n->func.func->context = -1;
5542
5543 return n;
5544 }
5545
5546 static GelETree *
StringToASCII_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5547 StringToASCII_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5548 {
5549 GelETree *n;
5550 const char *s;
5551 int size;
5552 int i;
5553 GelMatrixW *m;
5554
5555 if G_UNLIKELY ( ! check_argument_string (a, 0, "StringToASCII"))
5556 return NULL;
5557
5558 s = a[0]->str.str;
5559 size = strlen(s);
5560 if (size == 0)
5561 return gel_makenum_null ();
5562
5563 GEL_GET_NEW_NODE(n);
5564 n->type = GEL_MATRIX_NODE;
5565 n->mat.matrix = m = gel_matrixw_new();
5566 n->mat.quoted = FALSE;
5567 gel_matrixw_set_size (m, size, 1);
5568
5569 for (i = 0; i < size; i++) {
5570 gel_matrixw_set_index (m, i, 0) = gel_makenum_si (s[i]);
5571 }
5572
5573 return n;
5574 }
5575
5576 static GelETree *
ASCIIToString_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5577 ASCIIToString_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5578 {
5579 char *s;
5580 int size;
5581 int i;
5582 GelMatrixW *m;
5583
5584 if (a[0]->type == GEL_NULL_NODE)
5585 return gel_makenum_string ("");
5586
5587 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "ASCIIToString"))
5588 return NULL;
5589
5590 m = a[0]->mat.matrix;
5591
5592 size = gel_matrixw_elements (m);
5593
5594 s = g_new0 (char, size+1);
5595
5596 for (i = 0; i < size; i++) {
5597 GelETree *t;
5598 t = gel_matrixw_vindex (m, i);
5599 if (t->type != GEL_VALUE_NODE ||
5600 mpw_is_complex (t->val.value) ||
5601 ! mpw_is_integer (t->val.value) ||
5602 mpw_sgn (t->val.value) < 0 ||
5603 mpw_cmp_ui (t->val.value, 256) >= 0) {
5604 g_free (s);
5605 gel_errorout (_("%s: value out of range"),
5606 "ASCIIToString");
5607 return NULL;
5608 }
5609 s[i] = mpw_get_long (t->val.value);
5610 }
5611
5612 return gel_makenum_string_use (s);
5613 }
5614
5615 static int
alphabet_value(char a,const char * alph)5616 alphabet_value (char a, const char *alph)
5617 {
5618 int i;
5619 for (i = 0; alph[i] != '\0'; i++) {
5620 if (alph[i] == a)
5621 return i;
5622 }
5623 return -1;
5624 }
5625
5626 static GelETree *
StringToAlphabet_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5627 StringToAlphabet_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5628 {
5629 GelETree *n;
5630 const char *s;
5631 const char *alph;
5632 int size;
5633 int i;
5634 GelMatrixW *m;
5635
5636 if G_UNLIKELY ( ! check_argument_string (a, 0, "AlphabetToString") ||
5637 ! check_argument_string (a, 1, "AlphabetToString"))
5638 return NULL;
5639
5640 s = a[0]->str.str;
5641 alph = a[1]->str.str;
5642 size = strlen(s);
5643 if (size == 0)
5644 return gel_makenum_null ();
5645
5646 GEL_GET_NEW_NODE(n);
5647 n->type = GEL_MATRIX_NODE;
5648 n->mat.matrix = m = gel_matrixw_new();
5649 n->mat.quoted = FALSE;
5650 gel_matrixw_set_size (m, size, 1);
5651
5652 for (i = 0; i < size; i++) {
5653 int val = alphabet_value (s[i], alph);
5654 gel_matrixw_set_index (m, i, 0) = gel_makenum_si (val);
5655 }
5656
5657 return n;
5658 }
5659
5660 static GelETree *
AlphabetToString_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5661 AlphabetToString_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5662 {
5663 char *s;
5664 const char *alph;
5665 int size;
5666 int alph_size;
5667 int i;
5668 GelMatrixW *m;
5669
5670 if (a[0]->type == GEL_NULL_NODE)
5671 return gel_makenum_string ("");
5672
5673 if G_UNLIKELY ( ! check_argument_matrix (a, 0, "AlphabetToString") ||
5674 ! check_argument_string (a, 1, "AlphabetToString"))
5675 return NULL;
5676
5677 m = a[0]->mat.matrix;
5678 alph = a[1]->str.str;
5679
5680 size = gel_matrixw_elements (m);
5681 alph_size = strlen (alph);
5682
5683 s = g_new0 (char, size+1);
5684
5685 for (i = 0; i < size; i++) {
5686 GelETree *t;
5687 t = gel_matrixw_vindex (m, i);
5688 if G_UNLIKELY (t->type != GEL_VALUE_NODE ||
5689 mpw_is_complex (t->val.value) ||
5690 ! mpw_is_integer (t->val.value) ||
5691 mpw_sgn (t->val.value) < 0 ||
5692 mpw_cmp_ui (t->val.value, alph_size) >= 0) {
5693 g_free (s);
5694 gel_errorout (_("%s: value out of range"),
5695 "AlphabetToString");
5696 return NULL;
5697 }
5698 s[i] = alph[mpw_get_long (t->val.value)];
5699 }
5700
5701 return gel_makenum_string_use (s);
5702 }
5703
5704 static GelETree *
SetHelp_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5705 SetHelp_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5706 {
5707 const char *fname;
5708
5709 if G_UNLIKELY ( ! check_argument_string_or_identifier (a, 0, "SetHelp") ||
5710 ! check_argument_string (a, 1, "SetHelp") ||
5711 ! check_argument_string (a, 2, "SetHelp"))
5712 return NULL;
5713
5714 if (a[0]->type == GEL_IDENTIFIER_NODE) {
5715 fname = a[0]->id.id->token;
5716 } else /* GEL_STRING_NODE */ {
5717 fname = a[0]->str.str;
5718 }
5719
5720 gel_add_category (fname, a[1]->str.str);
5721 gel_add_description (fname, a[2]->str.str);
5722
5723 return gel_makenum_null();
5724 }
5725
5726 static GelETree *
SetHelpAlias_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5727 SetHelpAlias_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
5728 {
5729 const char *fname1;
5730 const char *fname2;
5731
5732 if G_UNLIKELY ( ! check_argument_string_or_identifier (a, 0, "SetHelpAlias") ||
5733 ! check_argument_string_or_identifier (a, 1, "SetHelpAlias"))
5734 return NULL;
5735
5736 if (a[0]->type == GEL_IDENTIFIER_NODE) {
5737 fname1 = a[0]->id.id->token;
5738 } else /* GEL_STRING_NODE */ {
5739 fname1 = a[0]->str.str;
5740 }
5741
5742 if (a[1]->type == GEL_IDENTIFIER_NODE) {
5743 fname2 = a[1]->id.id->token;
5744 } else /* GEL_STRING_NODE */ {
5745 fname2 = a[1]->str.str;
5746 }
5747
5748 gel_add_alias (fname1, fname2);
5749
5750 return gel_makenum_null();
5751 }
5752
5753 static GelETree *
Identity_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5754 Identity_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
5755 {
5756 /*
5757 * Evil optimization to avoid copying the node from the argument
5758 */
5759 return gel_stealnode (a[0]);
5760 }
5761
5762 static GelETree *
etree_out_of_int_vector(int * vec,int len)5763 etree_out_of_int_vector (int *vec, int len)
5764 {
5765 GelMatrix *mm;
5766 int i;
5767 GelETree *n;
5768
5769 mm = gel_matrix_new ();
5770 gel_matrix_set_size (mm, len, 1, FALSE /* padding */);
5771
5772 for (i = 0; i < len; i++) {
5773 gel_matrix_index (mm, i, 0) = gel_makenum_si (vec[i]);
5774 }
5775
5776 GEL_GET_NEW_NODE (n);
5777 n->type = GEL_MATRIX_NODE;
5778 n->mat.matrix = gel_matrixw_new_with_matrix_value_only_integer (mm);
5779 n->mat.quoted = FALSE;
5780
5781 return n;
5782 }
5783
5784 /* eats the glist and frees it */
5785 static GelETree *
etree_out_of_etree_list(GSList * list,int len)5786 etree_out_of_etree_list (GSList *list, int len)
5787 {
5788 GelMatrix *mm;
5789 GSList *li;
5790 int i;
5791 GelETree *n;
5792
5793 mm = gel_matrix_new ();
5794 gel_matrix_set_size (mm, len, 1, FALSE /* padding */);
5795
5796 li = list;
5797 for (i = 0; i < len; i++) {
5798 gel_matrix_index (mm, i, 0) = li->data;
5799 li = li->next;
5800 }
5801 g_slist_free (list);
5802
5803 GEL_GET_NEW_NODE (n);
5804 n->type = GEL_MATRIX_NODE;
5805 n->mat.matrix = gel_matrixw_new_with_matrix (mm);
5806 n->mat.quoted = FALSE;
5807
5808 return n;
5809 }
5810
5811 static gboolean
comb_get_next_combination(int * vec,int len,int n)5812 comb_get_next_combination (int *vec, int len, int n)
5813 {
5814 int i = len;
5815 int j;
5816
5817 /* do you like my gel -> C porting? */
5818
5819 while (i > 0 && vec[i-1] == n-(len-i)) {
5820 i--;
5821 }
5822 if (i == 0) {
5823 return FALSE;
5824 } else {
5825 vec[i-1] ++;
5826 for (j = i+1; j <= len; j++)
5827 vec[j-1] = vec[j-2]+1;
5828 }
5829 return TRUE;
5830 }
5831
5832 static gboolean
perm_is_pos_mobile(int * perm,char * arrow,int pos,int n)5833 perm_is_pos_mobile (int *perm, char *arrow, int pos, int n)
5834 {
5835 if (arrow[pos]=='L' && pos==0)
5836 return FALSE;
5837 else if (arrow[pos]=='R' && pos==n-1)
5838 return FALSE;
5839 else if (arrow[pos]=='L' && perm[pos] > perm[pos-1])
5840 return TRUE;
5841 else if (arrow[pos]=='R' && perm[pos] > perm[pos+1])
5842 return TRUE;
5843 else
5844 return FALSE;
5845 }
5846
5847 static int
perm_get_highest_mobile(int * perm,char * arrow,int n)5848 perm_get_highest_mobile (int *perm, char *arrow, int n)
5849 {
5850 int highest = -1;
5851 int i;
5852 for (i = 0; i < n; i++) {
5853 if (perm_is_pos_mobile (perm, arrow, i, n) &&
5854 (highest == -1 || perm[highest] < perm[i]))
5855 highest = i;
5856 }
5857 return highest;
5858 }
5859
5860 static void
perm_move_pos(int * perm,char * arrow,int pos,int n)5861 perm_move_pos (int *perm, char *arrow, int pos, int n)
5862 {
5863 if (arrow[pos] == 'L') {
5864 char t;
5865 g_assert (pos > 0);
5866 t = perm[pos];
5867 perm[pos] = perm[pos-1];
5868 perm[pos-1] = t;
5869 t = arrow[pos];
5870 arrow[pos] = arrow[pos-1];
5871 arrow[pos-1] = t;
5872 } else {
5873 char t;
5874 g_assert (pos < n-1);
5875 t = perm[pos];
5876 perm[pos] = perm[pos+1];
5877 perm[pos+1] = t;
5878 t = arrow[pos];
5879 arrow[pos] = arrow[pos+1];
5880 arrow[pos+1] = t;
5881 }
5882 }
5883
5884 static void
perm_switch_all_above(int * perm,char * arrow,int pos,int n)5885 perm_switch_all_above (int *perm, char *arrow, int pos, int n)
5886 {
5887 int i;
5888 for (i = 0; i < n; i++) {
5889 if (perm[i] > perm[pos]) {
5890 if (arrow[i] == 'L')
5891 arrow[i] = 'R';
5892 else
5893 arrow[i] = 'L';
5894 }
5895 }
5896 }
5897
5898 static int
nPr(unsigned int n,unsigned int k)5899 nPr (unsigned int n, unsigned int k)
5900 {
5901 /* assume k+1 <= n */
5902 guint64 m = 1;
5903 guint s = n-k+1;
5904 while (s <= n) {
5905 m *= (guint64)s;
5906 if (m > G_MAXINT32) return -1;
5907 s += 1;
5908 }
5909 return (int)m;
5910 }
5911
5912 static int
nCr(unsigned int n,unsigned int k)5913 nCr (unsigned int n, unsigned int k)
5914 {
5915 mpz_t ret;
5916 int r;
5917 mpz_init (ret);
5918
5919 mpz_bin_uiui (ret, n, k);
5920 if (mpz_fits_sint_p (ret)) {
5921 r = mpz_get_si (ret);
5922 } else {
5923 r = -1;
5924 }
5925 mpz_clear (ret);
5926 return r;
5927 }
5928
5929 static GelETree *
Combinations_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5930 Combinations_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
5931 {
5932 long k, n;
5933 int *comb;
5934 int i;
5935 int len;
5936 GelMatrix *mm;
5937 GelETree *r;
5938
5939 if G_UNLIKELY ( ! check_argument_integer (a, 0, "Combinations") ||
5940 ! check_argument_integer (a, 1, "Combinations"))
5941 return NULL;
5942
5943 gel_error_num = 0;
5944 k = mpw_get_long(a[0]->val.value);
5945 if G_UNLIKELY (gel_error_num != 0) {
5946 gel_error_num = 0;
5947 return NULL;
5948 }
5949 n = mpw_get_long(a[1]->val.value);
5950 if G_UNLIKELY (gel_error_num != 0) {
5951 gel_error_num = 0;
5952 return NULL;
5953 }
5954 if G_UNLIKELY (n < 1 || n > G_MAXINT || k < 1 || k > n) {
5955 gel_errorout (_("%s: value out of range"),
5956 "Combinations");
5957 return NULL;
5958 }
5959
5960 len = nCr (n, k);
5961 if (len < 0) {
5962 gel_errorout (_("%s: value out of range"),
5963 "Combinations");
5964 return NULL;
5965 }
5966
5967 comb = g_new (int, k);
5968 for (i = 0; i < k; i++)
5969 comb[i] = i+1;
5970
5971 mm = gel_matrix_new ();
5972 gel_matrix_set_size (mm, len, 1, FALSE /* padding */);
5973
5974 GEL_GET_NEW_NODE (r);
5975 r->type = GEL_MATRIX_NODE;
5976 r->mat.matrix = gel_matrixw_new_with_matrix (mm);
5977 r->mat.quoted = FALSE;
5978
5979 i = 0;
5980 do {
5981 gel_matrix_index (mm, i, 0) = etree_out_of_int_vector (comb, k);
5982 i++;
5983 } while (comb_get_next_combination (comb, k, n));
5984
5985 g_free (comb);
5986
5987 return r;
5988 }
5989
5990 static GelETree *
Permutations_op(GelCtx * ctx,GelETree ** a,gboolean * exception)5991 Permutations_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
5992 {
5993 GelETree *r;
5994 long k, n, len;
5995 int *comb;
5996 int *perm;
5997 char *arrow;
5998 int i, j;
5999 GelMatrix *mm;
6000
6001 if G_UNLIKELY ( ! check_argument_integer (a, 0, "Permutations") ||
6002 ! check_argument_integer (a, 1, "Permutations"))
6003 return NULL;
6004
6005 gel_error_num = 0;
6006 k = mpw_get_long(a[0]->val.value);
6007 if G_UNLIKELY (gel_error_num != 0) {
6008 gel_error_num = 0;
6009 return NULL;
6010 }
6011 n = mpw_get_long(a[1]->val.value);
6012 if G_UNLIKELY (gel_error_num != 0) {
6013 gel_error_num = 0;
6014 return NULL;
6015 }
6016 if G_UNLIKELY (n < 1 || n > G_MAXINT || k < 1 || k > n) {
6017 gel_errorout (_("%s: value out of range"),
6018 "Permutations");
6019 return NULL;
6020 }
6021
6022 len = nPr (n, k);
6023 if (len < 0) {
6024 gel_errorout (_("%s: value out of range"),
6025 "Permutations");
6026 return NULL;
6027 }
6028
6029 arrow = g_new (char, k);
6030 perm = g_new (int, k);
6031 comb = g_new (int, k);
6032
6033 for (i = 0; i < k; i++)
6034 comb[i] = i+1;
6035
6036 mm = gel_matrix_new ();
6037 gel_matrix_set_size (mm, len, 1, FALSE /* padding */);
6038
6039 GEL_GET_NEW_NODE (r);
6040 r->type = GEL_MATRIX_NODE;
6041 r->mat.matrix = gel_matrixw_new_with_matrix (mm);
6042 r->mat.quoted = FALSE;
6043
6044 j = 0;
6045 do {
6046 for (i = 0; i < k; i++)
6047 perm[i] = comb[i];
6048 for (i = 0; i < k; i++)
6049 arrow[i] = 'L';
6050 for (;;) {
6051 int m;
6052
6053 gel_matrix_index (mm, j, 0) =
6054 etree_out_of_int_vector (perm, k);
6055 j++;
6056
6057 m = perm_get_highest_mobile (perm, arrow, k);
6058 if (m == -1)
6059 break;
6060 perm_switch_all_above (perm, arrow, m, k);
6061 perm_move_pos (perm, arrow, m, k);
6062 }
6063 } while (comb_get_next_combination (comb, k, n));
6064
6065 g_free (comb);
6066 g_free (perm);
6067 g_free (arrow);
6068
6069 return r;
6070 }
6071
6072 static GelETree *
NextCombination_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6073 NextCombination_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
6074 {
6075 long k, n;
6076 int *comb;
6077 int i;
6078 GelETree *r;
6079 GelMatrixW *m;
6080
6081 if G_UNLIKELY ( ! check_argument_value_only_matrix (a, 0, "NextCombination") ||
6082 ! check_argument_integer (a, 1, "NextCombination"))
6083 return NULL;
6084
6085 m = a[0]->mat.matrix;
6086 k = gel_matrixw_elements (m);
6087
6088 gel_error_num = 0;
6089 n = mpw_get_long(a[1]->val.value);
6090 if G_UNLIKELY (gel_error_num != 0) {
6091 gel_error_num = 0;
6092 return NULL;
6093 }
6094 if G_UNLIKELY (n < 1 || n > G_MAXINT || k < 1 || k > n) {
6095 gel_errorout (_("%s: value out of range"),
6096 "NextCombination");
6097 return NULL;
6098 }
6099
6100 comb = g_new (int, k);
6101 for (i = 0; i < k; i++) {
6102 int j = mpw_get_long (gel_matrixw_vindex (m, i)->val.value);
6103 if G_UNLIKELY (gel_error_num != 0) {
6104 gel_error_num = 0;
6105 g_free (comb);
6106 return NULL;
6107 } else if G_UNLIKELY (j < 1 || j > n) {
6108 g_free (comb);
6109 gel_errorout (_("%s: value out of range"),
6110 "NextCombination");
6111 return NULL;
6112 }
6113 comb[i] = j;
6114 }
6115 if (comb_get_next_combination (comb, k, n))
6116 r = etree_out_of_int_vector (comb, k);
6117 else
6118 r = gel_makenum_null ();
6119 g_free (comb);
6120
6121 return r;
6122 }
6123
6124
6125 static GelETree *
nCr_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6126 nCr_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
6127 {
6128 unsigned long r;
6129
6130 if (a[0]->type == GEL_MATRIX_NODE ||
6131 a[1]->type == GEL_MATRIX_NODE)
6132 return gel_apply_func_to_matrixen (ctx, a[0], a[1],
6133 nCr_op,
6134 "nCr",
6135 exception);
6136
6137 if G_UNLIKELY ( ! check_argument_real_number (a, 0, "nCr") ||
6138 ! check_argument_nonnegative_integer (a, 1, "nCr"))
6139 return NULL;
6140
6141 gel_error_num = 0;
6142 r = mpw_get_ulong(a[1]->val.value);
6143 if G_UNLIKELY (gel_error_num != 0) {
6144 gel_error_num = 0;
6145 return NULL;
6146 }
6147
6148 if (mpw_is_integer (a[0]->val.value)) {
6149 mpw_t num;
6150 mpw_init (num);
6151 mpw_bin_ui (num, a[0]->val.value, r);
6152 return gel_makenum_use(num);
6153 } else {
6154 unsigned long i;
6155 mpw_t num, nm;
6156 mpw_init (num);
6157 mpw_set_ui (num, 1);
6158 mpw_init_set (nm, a[0]->val.value);
6159 for (i=0;i<=r-1;i++) {
6160 mpw_mul (num, num, nm);
6161 mpw_sub_ui (nm, nm, 1);
6162 }
6163 mpw_fac_ui (nm, r);
6164 mpw_div (num, num, nm);
6165 mpw_clear (nm);
6166 return gel_makenum_use(num);
6167 }
6168 }
6169
6170 static GelETree *
NonzeroColumns_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6171 NonzeroColumns_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
6172 {
6173 GelMatrixW *m;
6174 int i, j, w, h;
6175 int cnt;
6176 GSList *cols;
6177
6178 if G_UNLIKELY ( ! check_argument_matrix_or_null (a, 0, "NonzeroColumns"))
6179 return NULL;
6180
6181 if (a[0]->type == GEL_NULL_NODE)
6182 return gel_makenum_null ();
6183
6184 m = a[0]->mat.matrix;
6185 w = gel_matrixw_width (m);
6186 h = gel_matrixw_height (m);
6187 cnt = 0;
6188 cols = NULL;
6189 /* Must be done in this order and not rowise as is usual for genius! */
6190 for (i = 0; i < w; i++) {
6191 for (j = 0; j < h; j++) {
6192 GelETree *t = gel_matrixw_get_index (m, i, j);
6193 if ( ! ( t == NULL ||
6194 t->type == GEL_NULL_NODE ||
6195 (t->type == GEL_VALUE_NODE &&
6196 mpw_zero_p (t->val.value)))) {
6197 cols = g_slist_prepend (cols,
6198 gel_makenum_ui(i+1));
6199 cnt++;
6200 break;
6201 }
6202 }
6203 }
6204
6205 if (cnt == 0) {
6206 return gel_makenum_null ();
6207 } else {
6208 cols = g_slist_reverse (cols);
6209 return etree_out_of_etree_list (cols, cnt);
6210 }
6211 }
6212
6213 static GelETree *
NonzeroElements_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6214 NonzeroElements_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
6215 {
6216 GelMatrixW *m;
6217 int i, e;
6218 int cnt;
6219 GSList *elts;
6220
6221 if G_UNLIKELY ( ! check_argument_matrix_or_null (a, 0, "NonzeroElements"))
6222 return NULL;
6223
6224 if (a[0]->type == GEL_NULL_NODE)
6225 return gel_makenum_null ();
6226
6227 m = a[0]->mat.matrix;
6228 e = gel_matrixw_elements (m);
6229 cnt = 0;
6230 elts = NULL;
6231 /* Must be done in this order and not rowise as is usual for genius! */
6232 for (i = 0; i < e; i++) {
6233 GelETree *t = gel_matrixw_get_vindex (m, i);
6234 if ( ! (t == NULL ||
6235 t->type == GEL_NULL_NODE ||
6236 (t->type == GEL_VALUE_NODE &&
6237 mpw_zero_p (t->val.value)))) {
6238 elts = g_slist_prepend (elts,
6239 gel_makenum_ui(i+1));
6240 cnt++;
6241 }
6242 }
6243
6244 if (cnt == 0) {
6245 return gel_makenum_null ();
6246 } else {
6247 elts = g_slist_reverse (elts);
6248 return etree_out_of_etree_list (elts, cnt);
6249 }
6250 }
6251
6252 static GelETree *
protect_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6253 protect_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
6254 {
6255 GelToken *tok;
6256
6257 if (a[0]->type == GEL_MATRIX_NODE)
6258 return gel_apply_func_to_matrix
6259 (ctx, a[0], protect_op, "protect",
6260 exception);
6261
6262 if G_UNLIKELY ( ! check_argument_string_or_identifier (a, 0, "protect"))
6263 return NULL;
6264
6265 if (a[0]->type == GEL_IDENTIFIER_NODE) {
6266 tok = a[0]->id.id;
6267 } else /* GEL_STRING_NODE */ {
6268 tok = d_intern (a[0]->str.str);
6269 }
6270
6271 tok->protected_ = 1;
6272
6273 return gel_makenum_null();
6274 }
6275
6276 static GelETree *
unprotect_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6277 unprotect_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
6278 {
6279 GelToken *tok;
6280
6281 if (a[0]->type == GEL_MATRIX_NODE)
6282 return gel_apply_func_to_matrix
6283 (ctx, a[0], unprotect_op, "unprotect",
6284 exception);
6285
6286 if G_UNLIKELY ( ! check_argument_string_or_identifier (a, 0, "unprotect"))
6287 return NULL;
6288
6289 if (a[0]->type == GEL_IDENTIFIER_NODE) {
6290 tok = a[0]->id.id;
6291 } else /* GEL_STRING_NODE */ {
6292 tok = d_intern (a[0]->str.str);
6293 }
6294
6295 tok->protected_ = 0;
6296
6297 return gel_makenum_null();
6298 }
6299
6300 static GelETree *
SetFunctionFlags_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6301 SetFunctionFlags_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
6302 {
6303 GelEFunc *f;
6304 GelToken *tok;
6305 int i;
6306
6307 if G_UNLIKELY ( ! check_argument_string_or_identifier (a, 0, "SetFunctionFlags"))
6308 return NULL;
6309
6310 if (a[0]->type == GEL_IDENTIFIER_NODE) {
6311 tok = a[0]->id.id;
6312 } else /* GEL_STRING_NODE */ {
6313 tok = d_intern (a[0]->str.str);
6314 }
6315
6316 f = d_lookup_global (tok);
6317 if G_UNLIKELY (f == NULL) {
6318 gel_errorout (_("%s: undefined function"), "SetFunctionFlags");
6319 return NULL;
6320 }
6321
6322 for (i = 1; a[i] != NULL; i++) {
6323 if G_UNLIKELY (a[i]->type != GEL_STRING_NODE) {
6324 gel_errorout (_("%s: flags argument must be a string"),
6325 "SetFunctionFlags");
6326 } else if (a[i]->str.str != NULL) {
6327 if (g_ascii_strcasecmp (a[i]->str.str, "PropagateMod") == 0)
6328 f->propagate_mod = 1;
6329 else if (g_ascii_strcasecmp (a[i]->str.str, "NoModuloArguments") == 0)
6330 f->no_mod_all_args = 1;
6331 }
6332 }
6333
6334 return gel_makenum_null();
6335 }
6336
6337 static GelETree *
GetCurrentModulo_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6338 GetCurrentModulo_op(GelCtx *ctx, GelETree * * a, gboolean *exception)
6339 {
6340 mpw_ptr modulo = gel_find_pre_function_modulo (ctx);
6341 if (modulo == NULL)
6342 return gel_makenum_null ();
6343 else
6344 return gel_makenum (modulo);
6345 }
6346
6347 static gboolean
call_func(GelCtx * ctx,mpw_ptr retn,GelEFunc * func,mpw_ptr argnum)6348 call_func (GelCtx *ctx,
6349 mpw_ptr retn,
6350 GelEFunc *func,
6351 mpw_ptr argnum)
6352 {
6353 GelETree arg;
6354 GelETree *ret;
6355 GelETree *args[2];
6356
6357 arg.type = GEL_VALUE_NODE;
6358 arg.val.next = NULL;
6359 mpw_init_set (arg.val.value, argnum);
6360
6361 args[0] = &arg;
6362 args[1] = NULL;
6363
6364 ret = gel_funccall (ctx, func, args, 1);
6365
6366 mpw_clear (arg.val.value);
6367
6368 if G_UNLIKELY (gel_error_num != 0 ||
6369 ret == NULL ||
6370 ret->type != GEL_VALUE_NODE) {
6371 gel_freetree (ret);
6372 return FALSE;
6373 }
6374
6375 mpw_set (retn, ret->val.value);
6376
6377 gel_freetree (ret);
6378 return TRUE;
6379 }
6380
6381 /*
6382 # The algorithms are described in:
6383 # Numerical Analysis, 5th edition
6384 # by Richard L. Burden and J. Douglas Faires
6385 # PWS Publishing Company, Boston, 1993.
6386 # Library of congress: QA 297 B84 1993
6387
6388 # In the below, f indicates the function whose integral we wish to determine,
6389 # a,b indicate the left and right endpoints of the interval over which
6390 # we wish to integrate, and n is the number of intervals into which we
6391 # divide [a,b]
6392
6393 # These methods all return one value, the value of the integral
6394
6395 # Currently only works for real functions of a real variable
6396
6397 # Composite Simpson's Rule, Section 4.4, Algorithm 4.1, p. 186
6398 # Note that this has error term = max(f'''')*h^4*(b-a)/180,
6399 # where h=(b-a)/n
6400 # If we can get maximums and derivatives, this would allow us to determine
6401 # automatically what n should be.
6402 */
6403
6404 /* ported from the GEL version for speed */
6405 static GelETree *
CompositeSimpsonsRule_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6406 CompositeSimpsonsRule_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
6407 {
6408 GelEFunc *f;
6409 mpw_ptr ia, ib, in;
6410 long n, i;
6411 mpw_t X, XI0, XI1, XI2, h, fret;
6412 GelETree *ret = NULL;
6413 gboolean do_neg = FALSE;
6414
6415 if G_UNLIKELY ( ! check_argument_function_or_identifier (a, 0, "CompositeSimpsonsRule") ||
6416 ! check_argument_real_number (a, 1, "CompositeSimpsonsRule") ||
6417 ! check_argument_real_number (a, 2, "CompositeSimpsonsRule") ||
6418 ! check_argument_positive_integer (a, 3, "CompositeSimpsonsRule"))
6419 return NULL;
6420
6421 ia = a[1]->val.value;
6422 ib = a[2]->val.value;
6423 in = a[3]->val.value;
6424 if (mpw_odd_p (in))
6425 mpw_add_ui (in, in, 1);
6426
6427 n = mpw_get_long (in);
6428 if G_UNLIKELY (gel_error_num) {
6429 gel_error_num = 0;
6430 return NULL;
6431 }
6432
6433 if (mpw_cmp (ia, ib) == 0) {
6434 return gel_makenum_ui (0);
6435 }
6436
6437 if (mpw_cmp (ia, ib) > 0) {
6438 mpw_ptr tmp = ia;
6439 ia = ib;
6440 ib = tmp;
6441 do_neg = TRUE;
6442 }
6443
6444 if (a[0]->type == GEL_FUNCTION_NODE) {
6445 f = a[0]->func.func;
6446 } else /* (a[0]->type == GEL_IDENTIFIER_NODE) */ {
6447 f = d_lookup_global (a[0]->id.id);
6448 }
6449
6450 if G_UNLIKELY (f == NULL ||
6451 f->nargs != 1) {
6452 gel_errorout (_("%s: argument not a function of one variable"),
6453 "CompositeSimpsonsRule");
6454 return NULL;
6455 }
6456
6457 mpw_init (fret);
6458 mpw_init (X);
6459 mpw_init (XI0);
6460 mpw_init (XI1);
6461 mpw_init (XI2);
6462 mpw_init (h);
6463
6464 /*
6465 h=(b-a)/n; # Subdivision interval
6466 */
6467 mpw_sub (h, ib, ia);
6468 mpw_div (h, h, in);
6469 mpw_make_float (h);
6470
6471 /*
6472 XI0=f(a)+f(b); # End points
6473 */
6474 if ( ! call_func (ctx, XI0, f, ia))
6475 goto end_of_simpson;
6476 if ( ! call_func (ctx, fret, f, ib))
6477 goto end_of_simpson;
6478 mpw_add (XI0, XI0, fret);
6479
6480 /*
6481 XI1=0; # odd points
6482 XI2=0; # even points
6483 X=a; # current position
6484 */
6485 mpw_set_d (XI1, 0);
6486 mpw_set_d (XI2, 0);
6487 mpw_set (X, ia);
6488 mpw_make_float (X);
6489
6490 /* FIXME: */
6491 for (i = 1; i < n; i++) {
6492 /*
6493 X=X+h;
6494 if i%2 == 0
6495 then XI2=XI2+f(X)
6496 else XI1=XI1+f(X)
6497 */
6498 mpw_add (X, X, h);
6499 if ( ! call_func (ctx, fret, f, X))
6500 goto end_of_simpson;
6501 if (i & 0x1 /* odd */) {
6502 mpw_add (XI1, XI1, fret);
6503 } else /* even */ {
6504 mpw_add (XI2, XI2, fret);
6505 }
6506
6507 if (gel_evalnode_hook) {
6508 if G_UNLIKELY ((i & 0x3FF) == 0x3FF) {
6509 (*gel_evalnode_hook)();
6510 }
6511 }
6512 }
6513
6514 /*
6515 h*(XI0+2*XI2+4*XI1)/3
6516 */
6517 mpw_mul_ui (XI1, XI1, 4);
6518 mpw_mul_ui (XI2, XI2, 2);
6519 mpw_add (fret, XI0, XI1);
6520 mpw_add (fret, fret, XI2);
6521 mpw_mul (fret, fret, h);
6522 mpw_div_ui (fret, fret, 3);
6523
6524 if (do_neg)
6525 mpw_neg (fret, fret);
6526
6527 ret = gel_makenum (fret);
6528
6529 end_of_simpson:
6530 mpw_clear (X);
6531 mpw_clear (fret);
6532 mpw_clear (XI0);
6533 mpw_clear (XI1);
6534 mpw_clear (XI2);
6535 mpw_clear (h);
6536
6537 return ret;
6538 }
6539
6540 static GelETree *
Parse_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6541 Parse_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
6542 {
6543 GelETree *r;
6544
6545 if (a[0]->type == GEL_NULL_NODE)
6546 return gel_makenum_null ();
6547
6548 if G_UNLIKELY ( ! check_argument_string (a, 0, "Parse"))
6549 return NULL;
6550
6551 r = gel_parseexp (a[0]->str.str,
6552 NULL /* infile */,
6553 FALSE /* exec_commands */,
6554 FALSE /* testparse */,
6555 NULL /* finished */,
6556 NULL /* dirprefix */);
6557
6558 /* Have to reset the error here, else we may die */
6559 gel_error_num = GEL_NO_ERROR;
6560 gel_got_eof = FALSE;
6561
6562 return r;
6563 }
6564
6565 static GelETree *
Evaluate_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6566 Evaluate_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
6567 {
6568 GelETree *et;
6569
6570 if (a[0]->type == GEL_NULL_NODE)
6571 return gel_makenum_null ();
6572
6573 if G_UNLIKELY ( ! check_argument_string (a, 0, "Evaluate"))
6574 return NULL;
6575
6576 et = gel_parseexp (a[0]->str.str,
6577 NULL /* infile */,
6578 FALSE /* exec_commands */,
6579 FALSE /* testparse */,
6580 NULL /* finished */,
6581 NULL /* dirprefix */);
6582
6583 /* Have to reset the error here, else we may die */
6584 gel_error_num = GEL_NO_ERROR;
6585 gel_got_eof = FALSE;
6586
6587 if (et == NULL)
6588 return NULL;
6589
6590
6591 return gel_eval_etree (ctx, et);
6592 }
6593
6594 static GelETree *
AskString_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6595 AskString_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
6596 {
6597 char *txt;
6598 const char *def = NULL;
6599
6600 if G_UNLIKELY ( ! check_argument_string (a, 0, "AskString"))
6601 return NULL;
6602
6603 if (a[1] != NULL) {
6604 if G_UNLIKELY ( ! check_argument_string (a, 1, "AskString"))
6605 return NULL;
6606 def = a[1]->str.str;
6607 }
6608
6609 txt = gel_ask_string (a[0]->str.str, def);
6610
6611 if (txt == NULL)
6612 return gel_makenum_null ();
6613 else
6614 return gel_makenum_string_use (txt);
6615 }
6616
6617 static GelETree *
AskButtons_op(GelCtx * ctx,GelETree ** a,gboolean * exception)6618 AskButtons_op (GelCtx *ctx, GelETree * * a, gboolean *exception)
6619 {
6620 GSList *buttons = NULL;
6621 int i;
6622 int ret;
6623
6624 if G_UNLIKELY ( ! check_argument_string (a, 0, "AskButtons"))
6625 return NULL;
6626
6627 i = 1;
6628 while (a != NULL && a[i] != NULL) {
6629 if G_UNLIKELY ( ! check_argument_string (a, i, "AskButtons")) {
6630 g_slist_free_full (buttons, g_free);
6631 return NULL;
6632 }
6633 buttons = g_slist_append (buttons, g_strdup (a[i]->str.str));
6634 i++;
6635 }
6636
6637 ret = gel_ask_buttons (a[0]->str.str, buttons);
6638
6639 g_slist_free_full (buttons, g_free);
6640
6641 if (ret < 0)
6642 return gel_makenum_null ();
6643 else
6644 return gel_makenum_ui (ret);
6645 }
6646
6647
6648 static GelETree *
set_FloatPrecision(GelETree * a)6649 set_FloatPrecision (GelETree * a)
6650 {
6651 long bits;
6652
6653 if G_UNLIKELY ( ! check_argument_integer (&a, 0, "set_FloatPrecision"))
6654 return NULL;
6655
6656 bits = mpw_get_long(a->val.value);
6657 if G_UNLIKELY (gel_error_num) {
6658 gel_error_num = 0;
6659 return NULL;
6660 }
6661 if G_UNLIKELY (bits < 60 || bits > 16384) {
6662 gel_errorout (_("%s: argument should be between %d and %d"),
6663 "set_FloatPrecision", 60, 16384);
6664 return NULL;
6665 }
6666
6667 if(gel_calcstate.float_prec != bits) {
6668 gel_calcstate.float_prec = bits;
6669 mpw_set_default_prec (gel_calcstate.float_prec);
6670 gel_break_fp_caches ();
6671 gel_set_state (gel_calcstate);
6672 }
6673
6674 return gel_makenum_ui(gel_calcstate.float_prec);
6675 }
6676
6677 static GelETree *
get_FloatPrecision(void)6678 get_FloatPrecision (void)
6679 {
6680 return gel_makenum_ui(gel_calcstate.float_prec);
6681 }
6682
6683 static GelETree *
set_MaxDigits(GelETree * a)6684 set_MaxDigits (GelETree * a)
6685 {
6686 long digits;
6687
6688 if G_UNLIKELY ( ! check_argument_integer (&a, 0, "set_MaxDigits"))
6689 return NULL;
6690
6691 digits = mpw_get_long(a->val.value);
6692 if G_UNLIKELY (gel_error_num) {
6693 gel_error_num = 0;
6694 return NULL;
6695 }
6696 if G_UNLIKELY (digits < 0 || digits > 256) {
6697 gel_errorout (_("%s: argument should be between %d and %d"),
6698 "set_MaxDigits", 0, 256);
6699 return NULL;
6700 }
6701
6702 if(gel_calcstate.max_digits != digits) {
6703 gel_calcstate.max_digits = digits;
6704 gel_set_state (gel_calcstate);
6705 }
6706
6707 return gel_makenum_ui(gel_calcstate.max_digits);
6708 }
6709
6710 static GelETree *
get_MaxDigits(void)6711 get_MaxDigits (void)
6712 {
6713 return gel_makenum_ui(gel_calcstate.max_digits);
6714 }
6715
6716 static GelETree *
set_OutputChopExponent(GelETree * a)6717 set_OutputChopExponent (GelETree * a)
6718 {
6719 long e;
6720
6721 if G_UNLIKELY ( ! check_argument_nonnegative_integer (&a, 0, "set_OutputChopExponent"))
6722 return NULL;
6723
6724 e = mpw_get_long(a->val.value);
6725 if G_UNLIKELY (gel_error_num) {
6726 gel_error_num = 0;
6727 return NULL;
6728 }
6729
6730 if(gel_calcstate.chop != e) {
6731 gel_calcstate.chop = e;
6732 gel_set_state (gel_calcstate);
6733 }
6734
6735 return gel_makenum_ui(gel_calcstate.chop);
6736 }
6737
6738 static GelETree *
get_OutputChopExponent(void)6739 get_OutputChopExponent (void)
6740 {
6741 return gel_makenum_ui(gel_calcstate.chop);
6742 }
6743
6744 static GelETree *
set_OutputChopWhenExponent(GelETree * a)6745 set_OutputChopWhenExponent (GelETree * a)
6746 {
6747 long e;
6748
6749 if G_UNLIKELY ( ! check_argument_nonnegative_integer (&a, 0, "set_OutputChopWhenExponent"))
6750 return NULL;
6751
6752 e = mpw_get_long(a->val.value);
6753 if G_UNLIKELY (gel_error_num) {
6754 gel_error_num = 0;
6755 return NULL;
6756 }
6757
6758 if(gel_calcstate.chop_when != e) {
6759 gel_calcstate.chop_when = e;
6760 gel_set_state (gel_calcstate);
6761 }
6762
6763 return gel_makenum_ui(gel_calcstate.chop_when);
6764 }
6765
6766 static GelETree *
get_OutputChopWhenExponent(void)6767 get_OutputChopWhenExponent (void)
6768 {
6769 return gel_makenum_ui(gel_calcstate.chop_when);
6770 }
6771
6772 static GelETree *
set_ResultsAsFloats(GelETree * a)6773 set_ResultsAsFloats (GelETree * a)
6774 {
6775 if G_UNLIKELY ( ! check_argument_bool (&a, 0, "set_ResultsAsFloats"))
6776 return NULL;
6777 if (a->type == GEL_VALUE_NODE)
6778 gel_calcstate.results_as_floats = ! mpw_zero_p (a->val.value);
6779 else /* a->type == GEL_BOOL_NODE */
6780 gel_calcstate.results_as_floats = a->bool_.bool_;
6781 gel_set_state (gel_calcstate);
6782
6783 return gel_makenum_bool (gel_calcstate.results_as_floats);
6784 }
6785 static GelETree *
get_ResultsAsFloats(void)6786 get_ResultsAsFloats (void)
6787 {
6788 return gel_makenum_bool (gel_calcstate.results_as_floats);
6789 }
6790 static GelETree *
set_ScientificNotation(GelETree * a)6791 set_ScientificNotation (GelETree * a)
6792 {
6793 if G_UNLIKELY ( ! check_argument_bool (&a, 0, "set_ScientificNotation"))
6794 return NULL;
6795 if (a->type == GEL_VALUE_NODE)
6796 gel_calcstate.scientific_notation = ! mpw_zero_p (a->val.value);
6797 else /* a->type == GEL_BOOL_NODE */
6798 gel_calcstate.scientific_notation = a->bool_.bool_;
6799 gel_set_state (gel_calcstate);
6800
6801 return gel_makenum_bool (gel_calcstate.scientific_notation);
6802 }
6803 static GelETree *
get_ScientificNotation(void)6804 get_ScientificNotation (void)
6805 {
6806 return gel_makenum_bool (gel_calcstate.scientific_notation);
6807 }
6808 static GelETree *
set_FullExpressions(GelETree * a)6809 set_FullExpressions (GelETree * a)
6810 {
6811 if G_UNLIKELY ( ! check_argument_bool (&a, 0, "set_FullExpressions"))
6812 return NULL;
6813 if (a->type == GEL_VALUE_NODE)
6814 gel_calcstate.full_expressions = ! mpw_zero_p (a->val.value);
6815 else /* a->type == GEL_BOOL_NODE */
6816 gel_calcstate.full_expressions = a->bool_.bool_;
6817 gel_set_state (gel_calcstate);
6818
6819 return gel_makenum_bool (gel_calcstate.full_expressions);
6820 }
6821 static GelETree *
get_FullExpressions(void)6822 get_FullExpressions (void)
6823 {
6824 return gel_makenum_bool (gel_calcstate.full_expressions);
6825 }
6826
6827 static GelETree *
set_OutputStyle(GelETree * a)6828 set_OutputStyle (GelETree * a)
6829 {
6830 const char *token;
6831 GelOutputStyle output_style = GEL_OUTPUT_NORMAL;
6832
6833 if G_UNLIKELY ( ! check_argument_string_or_identifier (&a, 0, "set_OutputStyle"))
6834 return NULL;
6835
6836 if (a->type == GEL_STRING_NODE)
6837 token = a->str.str;
6838 else
6839 token = a->id.id->token;
6840
6841 if (token != NULL && g_ascii_strcasecmp (token, "normal") == 0) {
6842 output_style = GEL_OUTPUT_NORMAL;
6843 } else if (token != NULL && g_ascii_strcasecmp (token, "troff") == 0) {
6844 output_style = GEL_OUTPUT_TROFF;
6845 } else if (token != NULL && g_ascii_strcasecmp (token, "latex") == 0) {
6846 output_style = GEL_OUTPUT_LATEX;
6847 } else if (token != NULL && g_ascii_strcasecmp (token, "mathml") == 0) {
6848 output_style = GEL_OUTPUT_MATHML;
6849 } else {
6850 gel_errorout (_("OutputStyle must be one of normal, troff, latex or mathml"));
6851 return NULL;
6852 }
6853
6854 gel_calcstate.output_style = output_style;
6855 gel_set_state (gel_calcstate);
6856
6857 return gel_makenum_string (token);
6858 }
6859
6860 static GelETree *
get_OutputStyle(void)6861 get_OutputStyle (void)
6862 {
6863 const char *token;
6864
6865 token = "normal";
6866 if (gel_calcstate.output_style == GEL_OUTPUT_TROFF)
6867 token = "troff";
6868 else if (gel_calcstate.output_style == GEL_OUTPUT_LATEX)
6869 token = "latex";
6870 else if (gel_calcstate.output_style == GEL_OUTPUT_MATHML)
6871 token = "mathml";
6872
6873 return gel_makenum_string (token);
6874 }
6875
6876 static GelETree *
set_MaxErrors(GelETree * a)6877 set_MaxErrors (GelETree * a)
6878 {
6879 long errors;
6880
6881 if G_UNLIKELY ( ! check_argument_integer (&a, 0, "set_MaxErrors"))
6882 return NULL;
6883
6884 errors = mpw_get_long(a->val.value);
6885 if G_UNLIKELY (gel_error_num) {
6886 gel_error_num = 0;
6887 return NULL;
6888 }
6889 if G_UNLIKELY (errors < 0) {
6890 gel_errorout (_("%s: argument should be larger or equal to 0"),
6891 "MaxErrors");
6892 return NULL;
6893 }
6894
6895 if(gel_calcstate.max_errors != errors) {
6896 gel_calcstate.max_errors = errors;
6897 gel_set_state (gel_calcstate);
6898 }
6899
6900 return gel_makenum_ui(gel_calcstate.max_errors);
6901 }
6902
6903 static GelETree *
get_MaxErrors(void)6904 get_MaxErrors (void)
6905 {
6906 return gel_makenum_ui(gel_calcstate.max_errors);
6907 }
6908
6909 static GelETree *
set_MixedFractions(GelETree * a)6910 set_MixedFractions (GelETree * a)
6911 {
6912 if G_UNLIKELY ( ! check_argument_bool (&a, 0, "set_MixedFractions"))
6913 return NULL;
6914 if (a->type == GEL_VALUE_NODE)
6915 gel_calcstate.mixed_fractions = ! mpw_zero_p (a->val.value);
6916 else /* a->type == GEL_BOOL_NODE */
6917 gel_calcstate.mixed_fractions = a->bool_.bool_;
6918 gel_set_state (gel_calcstate);
6919
6920 return gel_makenum_bool (gel_calcstate.mixed_fractions);
6921 }
6922 static GelETree *
get_MixedFractions(void)6923 get_MixedFractions (void)
6924 {
6925 return gel_makenum_bool (gel_calcstate.mixed_fractions);
6926 }
6927
6928 static GelETree *
set_IntegerOutputBase(GelETree * a)6929 set_IntegerOutputBase (GelETree * a)
6930 {
6931 long base;
6932
6933 if G_UNLIKELY ( ! check_argument_integer (&a, 0, "set_IntegerOutputBase"))
6934 return NULL;
6935
6936 base = mpw_get_long(a->val.value);
6937 if G_UNLIKELY (gel_error_num) {
6938 gel_error_num = 0;
6939 return NULL;
6940 }
6941 if G_UNLIKELY (base < 2 || base > 36) {
6942 gel_errorout (_("%s: argument should be between %d and %d"),
6943 "IntegerOutputBase", 2, 36);
6944 return NULL;
6945 }
6946
6947 if(gel_calcstate.integer_output_base != base) {
6948 gel_calcstate.integer_output_base = base;
6949 gel_set_state (gel_calcstate);
6950 }
6951
6952 return gel_makenum_ui(gel_calcstate.integer_output_base);
6953 }
6954
6955 static GelETree *
get_IntegerOutputBase(void)6956 get_IntegerOutputBase (void)
6957 {
6958 return gel_makenum_ui(gel_calcstate.integer_output_base);
6959 }
6960
6961 static GelETree *
set_IsPrimeMillerRabinReps(GelETree * a)6962 set_IsPrimeMillerRabinReps (GelETree * a)
6963 {
6964 long reps;
6965
6966 if G_UNLIKELY ( ! check_argument_positive_integer (&a, 0, "set_IsPrimeMillerRabinReps"))
6967 return NULL;
6968
6969 reps = mpw_get_long (a->val.value);
6970 if G_UNLIKELY (gel_error_num) {
6971 gel_error_num = 0;
6972 return NULL;
6973 }
6974
6975 mympz_is_prime_miller_rabin_reps = reps;
6976 return gel_makenum_ui (mympz_is_prime_miller_rabin_reps);
6977 }
6978 static GelETree *
get_IsPrimeMillerRabinReps(void)6979 get_IsPrimeMillerRabinReps (void)
6980 {
6981 return gel_makenum_ui (mympz_is_prime_miller_rabin_reps);
6982 }
6983
6984 int
gel_count_arguments(GelETree ** a)6985 gel_count_arguments (GelETree **a)
6986 {
6987 int args;
6988
6989 args = 0;
6990 while (a != NULL && a[args] != NULL)
6991 args++;
6992
6993 return args;
6994 }
6995
6996 /*add the routines to the dictionary*/
6997 void
gel_funclib_addall(void)6998 gel_funclib_addall(void)
6999 {
7000 GelEFunc *f;
7001 GelToken *id;
7002
7003 gel_new_category ("basic", N_("Basic"), TRUE /* internal */);
7004 gel_new_category ("parameters", N_("Parameters"), TRUE /* internal */);
7005 gel_new_category ("constants", N_("Constants"), TRUE /* internal */);
7006 gel_new_category ("numeric", N_("Numeric"), TRUE /* internal */);
7007 gel_new_category ("trigonometry", N_("Trigonometry"), TRUE /* internal */);
7008 gel_new_category ("number_theory", N_("Number Theory"), TRUE /* internal */);
7009 gel_new_category ("matrix", N_("Matrix Manipulation"), TRUE /* internal */);
7010 gel_new_category ("linear_algebra", N_("Linear Algebra"), TRUE /* internal */);
7011 gel_new_category ("combinatorics", N_("Combinatorics"), TRUE /* internal */);
7012 gel_new_category ("calculus", N_("Calculus"), TRUE /* internal */);
7013 gel_new_category ("functions", N_("Functions"), TRUE /* internal */);
7014 gel_new_category ("equation_solving", N_("Equation Solving"), TRUE /* internal */);
7015 gel_new_category ("statistics", N_("Statistics"), TRUE /* internal */);
7016 gel_new_category ("polynomial", N_("Polynomials"), TRUE /* internal */);
7017 gel_new_category ("sets", N_("Set Theory"), TRUE /* internal */);
7018 gel_new_category ("commutative_algebra", N_("Commutative Algebra"), TRUE /* internal */);
7019 gel_new_category ("misc", N_("Miscellaneous"), TRUE /* internal */);
7020
7021 FUNC (manual, 0, "", "basic", N_("Displays the user manual"));
7022 FUNC (warranty, 0, "", "basic", N_("Gives the warranty information"));
7023 FUNC (version, 0, "", "basic", N_("Return version as a 3-vector"));
7024 FUNC (exit, 0, "", "basic", N_("Exits the program"));
7025 ALIAS (quit, 0, exit);
7026 FUNC (error, 1, "str", "basic", N_("Prints a string to the error stream"));
7027 FUNC (wait, 1, "secs", "basic", N_("Waits a specified number of seconds"));
7028 FUNC (true, 0, "", "basic", N_("The true boolean value"));
7029 ALIAS (True, 0, true);
7030 FUNC (false, 0, "", "basic", N_("The false boolean value"));
7031 ALIAS (False, 0, false);
7032
7033 FUNC (CurrentTime, 0, "", "basic", N_("Unix time in seconds as a floating point number"));
7034
7035 /* FIXME: TRUE, FALSE aliases can't be done with the macros in funclibhelper.cP! */
7036 d_addfunc (d_makebifunc (d_intern ("TRUE"), true_op, 0));
7037 gel_add_alias ("true", "TRUE");
7038 d_addfunc (d_makebifunc (d_intern ("FALSE"), false_op, 0));
7039 gel_add_alias ("false", "FALSE");
7040
7041 FUNC (IntegerFromBoolean, 1, "bval", "basic", N_("Make integer (0 or 1) from a boolean value"));
7042
7043 FUNC (print, 1, "str", "basic", N_("Prints an expression"));
7044 FUNC (chdir, 1, "dir", "basic", N_("Changes current directory"));
7045 FUNC (printn, 1, "str", "basic", N_("Prints an expression without a trailing newline"));
7046 FUNC (display, 2, "str,expr", "basic", N_("Display a string and an expression"));
7047 FUNC (set, 2, "id,val", "basic", N_("Set a global variable"));
7048 FUNC (SetElement, 4, "id,row,col,val", "basic", N_("Set an element in a global variable which is a matrix"));
7049 FUNC (SetVElement, 3, "id,elt,val", "basic", N_("Set an element in a global variable which is a vector"));
7050 VFUNC (DisplayVariables, 1, "var", "basic", N_("Display values of variables, or all if called without arguments"));
7051
7052 FUNC (SetHelp, 3, "id,category,desc", "basic", N_("Set the category and help description line for a function"));
7053 FUNC (SetHelpAlias, 2, "id,alias", "basic", N_("Sets up a help alias"));
7054
7055 FUNC (Identity, 1, "x", "basic", N_("Identity function, returns its argument"));
7056
7057 VFUNC (rand, 1, "size", "numeric", N_("Generate random float between 0 and 1, or if size given generate vector or matrix of random floats"));
7058 f->no_mod_all_args = 1;
7059 VFUNC (randint, 2, "max,size", "numeric", N_("Generate random integer between 0 and max-1 inclusive, or if size given generate vector or matrix of random integers"));
7060 f->no_mod_all_args = 1;
7061
7062 PARAMETER (FloatPrecision, N_("Floating point precision"));
7063 PARAMETER (OutputChopExponent,
7064 N_("Display 0.0 when floating point number is less than 10^-x "
7065 "(0=never chop)"));
7066 PARAMETER (OutputChopWhenExponent,
7067 N_("Only chop numbers when another number is greater than 10^-x"));
7068 PARAMETER (MaxDigits, N_("Maximum digits to display"));
7069 PARAMETER (MaxErrors, N_("Maximum errors to display"));
7070 PARAMETER (OutputStyle, N_("Output style: normal, latex, mathml or troff"));
7071 PARAMETER (IntegerOutputBase, N_("Integer output base"));
7072 PARAMETER (MixedFractions, N_("If true, mixed fractions are printed"));
7073 PARAMETER (FullExpressions, N_("Print full expressions, even if more than a line"));
7074 PARAMETER (ResultsAsFloats, N_("Convert all results to floats before printing"));
7075 PARAMETER (ScientificNotation, N_("Use scientific notation"));
7076
7077 PARAMETER (IsPrimeMillerRabinReps, N_("Number of extra Miller-Rabin tests to run on a number before declaring it a prime in IsPrime"));
7078
7079 /* secret functions */
7080 d_addfunc(d_makebifunc(d_intern("ninini"),ninini_op,0));
7081 d_addfunc(d_makebifunc(d_intern("shrubbery"),shrubbery_op,0));
7082
7083 FUNC (ExpandMatrix, 1, "M", "matrix", N_("Expands a matrix just like we do on unquoted matrix input"));
7084 FUNC (RowsOf, 1, "M", "matrix", N_("Gets the rows of a matrix as a vertical vector"));
7085 FUNC (ColumnsOf, 1, "M", "matrix", N_("Gets the columns of a matrix as a horizontal vector"));
7086 FUNC (DiagonalOf, 1, "M", "matrix", N_("Gets the diagonal entries of a matrix as a column vector"));
7087 FUNC (CountZeroColumns, 1, "M", "matrix", N_("Count the number of zero columns in a matrix"));
7088 FUNC (StripZeroColumns, 1, "M", "matrix", N_("Removes any all-zero columns of M"));
7089 FUNC (NonzeroColumns, 1, "M", "matrix", N_("Return a vector with the indices of the nonzero columns in a matrix"));
7090 FUNC (NonzeroElements, 1, "v", "matrix", N_("Return a vector with the indices of the nonzero elements in a vector"));
7091
7092 FUNC (ComplexConjugate, 1, "M", "numeric", N_("Calculates the conjugate"));
7093 conj_function = f;
7094 ALIAS (conj, 1, ComplexConjugate);
7095 ALIAS (Conj, 1, ComplexConjugate);
7096
7097 FUNC (sin, 1, "x", "trigonometry", N_("Calculates the sine function"));
7098 f->no_mod_all_args = 1;
7099 sin_function = f;
7100 FUNC (cos, 1, "x", "trigonometry", N_("Calculates the cosine function"));
7101 f->no_mod_all_args = 1;
7102 cos_function = f;
7103 FUNC (sinh, 1, "x", "trigonometry", N_("Calculates the hyperbolic sine function"));
7104 f->no_mod_all_args = 1;
7105 sinh_function = f;
7106 FUNC (cosh, 1, "x", "trigonometry", N_("Calculates the hyperbolic cosine function"));
7107 f->no_mod_all_args = 1;
7108 cosh_function = f;
7109 FUNC (tan, 1, "x", "trigonometry", N_("Calculates the tan function"));
7110 f->no_mod_all_args = 1;
7111 tan_function = f;
7112 FUNC (atan, 1, "x", "trigonometry", N_("Calculates the arctan function"));
7113 f->no_mod_all_args = 1;
7114 atan_function = f;
7115 ALIAS (arctan, 1, atan);
7116
7117 FUNC (sinc, 1, "x", "functions", N_("Calculates the sinc function, that is sin(x)/x"));
7118 f->no_mod_all_args = 1;
7119 sinc_function = f;
7120
7121 FUNC (atan2, 2, "y,x", "trigonometry", N_("Calculates the arctan2 function (arctan(y/x) if x>0)"));
7122 f->no_mod_all_args = 1;
7123 ALIAS (arctan2, 1, atan2);
7124
7125 FUNC (pi, 0, "", "constants", N_("The number pi"));
7126 pi_function = f;
7127 FUNC (e, 0, "", "constants", N_("The natural number e"));
7128 e_function = f;
7129 FUNC (GoldenRatio, 0, "", "constants", N_("The Golden Ratio"));
7130 GoldenRatio_function = f;
7131 FUNC (Gravity, 0, "", "constants", N_("Free fall acceleration"));
7132 Gravity_function = f;
7133 FUNC (EulerConstant, 0, "", "constants",
7134 N_("Euler's Constant gamma"));
7135 ALIAS (gamma, 0, EulerConstant);
7136 EulerConstant_function = f;
7137 FUNC (CatalanConstant, 0, "", "constants",
7138 N_("Catalan's Constant (0.915...)"));
7139
7140 FUNC (ErrorFunction, 1, "x", "functions", N_("The error function, 2/sqrt(pi) * int_0^x e^(-t^2) dt"));
7141 ErrorFunction_function = f;
7142 ALIAS (erf, 1, ErrorFunction);
7143 FUNC (RiemannZeta, 1, "x", "functions", N_("The Riemann zeta function (only real values implemented)"));
7144 f->no_mod_all_args = 1;
7145 RiemannZeta_function = f;
7146 ALIAS (zeta, 1, RiemannZeta);
7147 FUNC (GammaFunction, 1, "x", "functions", N_("The Gamma function (only real values implemented)"));
7148 f->no_mod_all_args = 1;
7149 GammaFunction_function = f;
7150 ALIAS (Gamma, 1, GammaFunction);
7151
7152 FUNC (BesselJ0, 1, "x", "functions", N_("The Bessel function of first kind of order 0"));
7153 f->no_mod_all_args = 1;
7154 BesselJ0_function = f;
7155 FUNC (BesselJ1, 1, "x", "functions", N_("The Bessel function of first kind of order 1"));
7156 f->no_mod_all_args = 1;
7157 BesselJ1_function = f;
7158 FUNC (BesselJn, 2, "n,x", "functions", N_("The Bessel function of first kind of order n"));
7159 f->no_mod_all_args = 1;
7160
7161 FUNC (BesselY0, 1, "x", "functions", N_("The Bessel function of second kind of order 0"));
7162 f->no_mod_all_args = 1;
7163 BesselJ0_function = f;
7164 FUNC (BesselY1, 1, "x", "functions", N_("The Bessel function of second kind of order 1"));
7165 f->no_mod_all_args = 1;
7166 BesselJ1_function = f;
7167 FUNC (BesselYn, 2, "n,x", "functions", N_("The Bessel function of second kind of integer order n"));
7168 f->no_mod_all_args = 1;
7169
7170 FUNC (sqrt, 1, "x", "numeric", N_("The square root"));
7171 f->propagate_mod = 1;
7172 sqrt_function = f;
7173 ALIAS (SquareRoot, 1, sqrt);
7174 FUNC (exp, 1, "x", "numeric", N_("The exponential function"));
7175 f->no_mod_all_args = 1;
7176 exp_function = f;
7177 FUNC (ln, 1, "x", "numeric", N_("The natural logarithm"));
7178 f->no_mod_all_args = 1;
7179 ln_function = f;
7180 FUNC (log2, 1, "x", "numeric", N_("Logarithm of x base 2"));
7181 f->no_mod_all_args = 1;
7182 log2_function = f;
7183 ALIAS (lg, 1, log2);
7184 f->no_mod_all_args = 1;
7185 FUNC (log10, 1, "x", "numeric", N_("Logarithm of x base 10"));
7186 f->no_mod_all_args = 1;
7187 log10_function = f;
7188 FUNC (round, 1, "x", "numeric", N_("Round a number"));
7189 f->no_mod_all_args = 1;
7190 round_function = f;
7191 ALIAS (Round, 1, round);
7192 FUNC (floor, 1, "x", "numeric", N_("Get the highest integer less than or equal to n"));
7193 f->no_mod_all_args = 1;
7194 floor_function = f;
7195 ALIAS (Floor, 1, floor);
7196 FUNC (ceil, 1, "x", "numeric", N_("Get the lowest integer more than or equal to n"));
7197 f->no_mod_all_args = 1;
7198 ceil_function = f;
7199 ALIAS (Ceiling, 1, ceil);
7200 FUNC (trunc, 1, "x", "numeric", N_("Truncate number to an integer (return the integer part)"));
7201 f->no_mod_all_args = 1;
7202 trunc_function = f;
7203 ALIAS (Truncate, 1, trunc);
7204 ALIAS (IntegerPart, 1, trunc);
7205 FUNC (float, 1, "x", "numeric", N_("Make number a float"));
7206 f->no_mod_all_args = 1;
7207 float_function = f;
7208 FUNC (Numerator, 1, "x", "numeric", N_("Get the numerator of a rational number"));
7209 Numerator_function = f;
7210 FUNC (Denominator, 1, "x", "numeric", N_("Get the denominator of a rational number"));
7211 Denominator_function = f;
7212
7213 VFUNC (gcd, 2, "a,args", "number_theory", N_("Greatest common divisor"));
7214 VALIAS (GCD, 2, gcd);
7215 VFUNC (lcm, 2, "a,args", "number_theory", N_("Least common multiplier"));
7216 VALIAS (LCM, 2, lcm);
7217 FUNC (IsPerfectSquare, 1, "n", "number_theory", N_("Check a number for being a perfect square"));
7218 FUNC (IsPerfectPower, 1, "n", "number_theory", N_("Check a number for being any perfect power (a^b)"));
7219 FUNC (Prime, 1, "n", "number_theory", N_("Return the nth prime (up to a limit)"));
7220 ALIAS (prime, 1, Prime);
7221 FUNC (IsEven, 1, "n", "number_theory", N_("Tests if an integer is even"));
7222 FUNC (IsOdd, 1, "n", "number_theory", N_("Tests if an integer is odd"));
7223
7224 FUNC (NextPrime, 1, "n", "number_theory", N_("Returns the least prime greater than n (if n is positive)"));
7225 FUNC (LucasNumber, 1, "n", "number_theory", N_("Returns the nth Lucas number"));
7226 FUNC (ModInvert, 2, "n,m", "number_theory", N_("Returns inverse of n mod m"));
7227 FUNC (Divides, 2, "m,n", "number_theory", N_("Checks divisibility (if m divides n)"));
7228 FUNC (ExactDivision, 2, "n,d", "number_theory", N_("Return n/d but only if d divides n else returns garbage (this is faster than writing n/d)"));
7229 FUNC (IsPrime, 1, "n", "number_theory", N_("Tests primality of integers, for numbers greater than 25*10^9 false positive is with low probability depending on IsPrimeMillerRabinReps"));
7230 FUNC (StrongPseudoprimeTest, 2, "n,b", "number_theory", N_("Run the strong pseudoprime test base b on n"));
7231 FUNC (MillerRabinTest, 2, "n,reps", "number_theory", N_("Use the Miller-Rabin primality test on n, reps number of times. The probability of false positive is (1/4)^reps"));
7232 FUNC (MillerRabinTestSure, 1, "n", "number_theory", N_("Use the Miller-Rabin primality test on n with enough bases that assuming the Generalized Riemann Hypothesis the result is deterministic"));
7233 FUNC (Factorize, 1, "n", "number_theory", N_("Return factorization of a number as a matrix"));
7234
7235 VFUNC (max, 2, "a,args", "numeric", N_("Returns the maximum of arguments or matrix"));
7236 VALIAS (Max, 2, max);
7237 VALIAS (Maximum, 2, max);
7238 VFUNC (min, 2, "a,args", "numeric", N_("Returns the minimum of arguments or matrix"));
7239 VALIAS (Min, 2, min);
7240 VALIAS (Minimum, 2, min);
7241
7242 FUNC (IntegerQuotient, 2, "a,b", "numeric", N_("Division w/o remainder, equivalent to floor(a/b)"));
7243
7244 FUNC (Jacobi, 2, "a,b", "number_theory", N_("Calculate the Jacobi symbol (a/b) (b should be odd)"));
7245 ALIAS (JacobiSymbol, 2, Jacobi);
7246 FUNC (JacobiKronecker, 2, "a,b", "number_theory", N_("Calculate the Jacobi symbol (a/b) with the Kronecker extension (a/2)=(2/a) when a odd, or (a/2)=0 when a even"));
7247 ALIAS (JacobiKroneckerSymbol, 2, JacobiKronecker);
7248 FUNC (Legendre, 2, "a,p", "number_theory", N_("Calculate the Legendre symbol (a/p)"));
7249 ALIAS (LegendreSymbol, 2, Legendre);
7250
7251 FUNC (Re, 1, "z", "numeric", N_("Get the real part of a complex number"));
7252 Re_function = f;
7253 ALIAS (RealPart, 1, Re);
7254 FUNC (Im, 1, "z", "numeric", N_("Get the imaginary part of a complex number"));
7255 Im_function = f;
7256 ALIAS (ImaginaryPart, 1, Im);
7257
7258 FUNC (I, 1, "n", "matrix", N_("Make an identity matrix of a given size"));
7259 f->no_mod_all_args = 1;
7260 ALIAS (eye, 1, I);
7261 VFUNC (zeros, 2, "rows,columns", "matrix", N_("Make an matrix of all zeros (or a row vector)"));
7262 f->no_mod_all_args = 1;
7263 VFUNC (ones, 2, "rows,columns", "matrix", N_("Make an matrix of all ones (or a row vector)"));
7264 f->no_mod_all_args = 1;
7265
7266 FUNC (AppendElement, 2, "v,e", "matrix", N_("Append an element to a vector (treating 1x1 matrix as a row vector)"));
7267
7268 FUNC (rows, 1, "M", "matrix", N_("Get the number of rows of a matrix"));
7269 FUNC (columns, 1, "M", "matrix", N_("Get the number of columns of a matrix"));
7270 FUNC (IsMatrixSquare, 1, "M", "matrix", N_("Is a matrix square"));
7271 FUNC (IsVector, 1, "v", "matrix", N_("Is argument a horizontal or a vertical vector"));
7272 FUNC (IsUpperTriangular, 1, "M", "matrix", N_("Is a matrix upper triangular"));
7273 FUNC (IsLowerTriangular, 1, "M", "matrix", N_("Is a matrix lower triangular"));
7274 FUNC (IsDiagonal, 1, "M", "matrix", N_("Is a matrix diagonal"));
7275 FUNC (elements, 1, "M", "matrix", N_("Get the number of elements of a matrix"));
7276
7277 FUNC (ref, 1, "M", "linear_algebra", N_("Get the row echelon form of a matrix"));
7278 f->propagate_mod = 1;
7279 ALIAS (REF, 1, ref);
7280 ALIAS (RowEchelonForm, 1, ref);
7281 FUNC (rref, 1, "M", "linear_algebra", N_("Get the reduced row echelon form of a matrix"));
7282 f->propagate_mod = 1;
7283 ALIAS (RREF, 1, rref);
7284 ALIAS (ReducedRowEchelonForm, 1, rref);
7285 VFUNC (SolveLinearSystem, 3, "M,V,args", "linear_algebra", N_("Solve linear system Mx=V, return solution V if there is a unique solution, null otherwise. Extra two reference parameters can optionally be used to get the reduced M and V."));
7286 f->propagate_mod = 1;
7287
7288 FUNC (det, 1, "M", "linear_algebra", N_("Get the determinant of a matrix"));
7289 ALIAS (Determinant, 1, det);
7290
7291 FUNC (PivotColumns, 1, "M", "linear_algebra", N_("Return pivot columns of a matrix, that is columns which have a leading 1 in rref form, also returns the row where they occur"));
7292
7293 FUNC (NullSpace, 1, "M", "linear_algebra", N_("Get the nullspace of a matrix"))
7294
7295 FUNC (SetMatrixSize, 3, "M,rows,columns", "matrix", N_("Make new matrix of given size from old one"));
7296 FUNC (IndexComplement, 2, "vec,msize", "matrix", N_("Return the index complement of a vector of indexes"));
7297 FUNC (HermitianProduct, 2, "u,v", "matrix", N_("Get the Hermitian product of two vectors"));
7298 ALIAS (InnerProduct, 2, HermitianProduct);
7299
7300 FUNC (IsValueOnly, 1, "M", "matrix", N_("Check if a matrix is a matrix of numbers"));
7301 FUNC (IsMatrixInteger, 1, "M", "matrix", N_("Check if a matrix is an integer (non-complex) matrix"));
7302 FUNC (IsMatrixRational, 1, "M", "matrix", N_("Check if a matrix is a rational (non-complex) matrix"));
7303 FUNC (IsMatrixReal, 1, "M", "matrix", N_("Check if a matrix is a real (non-complex) matrix"));
7304 FUNC (IsMatrixPositive, 1, "M", "matrix", N_("Check if a matrix is positive, that is if each element is positive"));
7305 FUNC (IsMatrixNonnegative, 1, "M", "matrix", N_("Check if a matrix is nonnegative, that is if each element is nonnegative"));
7306
7307 FUNC (IsZero, 1, "x", "matrix", N_("Check if a number or a matrix is all zeros"));
7308 FUNC (IsIdentity, 1, "x", "matrix", N_("Check if a number or a matrix is 1 or identity respectively"));
7309
7310 FUNC (IsIn, 2, "x,X", "sets", N_("Returns true if the element x is in the set X (where X is a vector pretending to be a set)"));
7311 FUNC (IsSubset, 2, "X,Y", "sets", N_("Returns true if X is a subset of Y"));
7312 FUNC (SetMinus, 2, "X,Y", "sets", N_("Returns a set theoretic difference X-Y (X and Y are vectors pretending to be sets)"));
7313 FUNC (Intersection, 2, "X,Y", "sets", N_("Returns a set theoretic intersection of X and Y (X and Y are vectors pretending to be sets)"));
7314
7315 FUNC (IsNull, 1, "arg", "basic", N_("Check if argument is a null"));
7316 FUNC (IsValue, 1, "arg", "basic", N_("Check if argument is a number"));
7317 FUNC (IsBoolean, 1, "arg", "basic", N_("Check if argument is a boolean (and not a number)"));
7318 FUNC (IsString, 1, "arg", "basic", N_("Check if argument is a text string"));
7319 FUNC (IsMatrix, 1, "arg", "basic", N_("Check if argument is a matrix"));
7320 FUNC (IsFunction, 1, "arg", "basic", N_("Check if argument is a function"));
7321 FUNC (IsFunctionOrIdentifier, 1, "arg", "basic", N_("Check if argument is a function or an identifier"));
7322 FUNC (IsFunctionRef, 1, "arg", "basic", N_("Check if argument is a function reference"));
7323
7324 FUNC (IsComplex, 1, "num", "numeric", N_("Check if argument is a complex (non-real) number"));
7325 FUNC (IsReal, 1, "num", "numeric", N_("Check if argument is a real number"));
7326 FUNC (IsInteger, 1, "num", "numeric", N_("Check if argument is an integer (non-complex)"));
7327 FUNC (IsPositiveInteger, 1, "num", "numeric", N_("Check if argument is a positive real integer"));
7328 ALIAS (IsNaturalNumber, 1, IsPositiveInteger);
7329 FUNC (IsNonNegativeInteger, 1, "num", "numeric", N_("Check if argument is a non-negative real integer"));
7330 FUNC (IsGaussInteger, 1, "num", "numeric", N_("Check if argument is a possibly complex integer"));
7331 ALIAS (IsComplexInteger, 1, IsGaussInteger);
7332 FUNC (IsRational, 1, "num", "numeric", N_("Check if argument is a rational number (non-complex)"));
7333 FUNC (IsComplexRational, 1, "num", "numeric", N_("Check if argument is a possibly complex rational number"));
7334 FUNC (IsFloat, 1, "num", "numeric", N_("Check if argument is a floating point number (non-complex)"));
7335
7336 FUNC (AddPoly, 2, "p1,p2", "polynomial", N_("Add two polynomials (vectors)"));
7337 FUNC (SubtractPoly, 2, "p1,p2", "polynomial", N_("Subtract two polynomials (as vectors)"));
7338 FUNC (MultiplyPoly, 2, "p1,p2", "polynomial", N_("Multiply two polynomials (as vectors)"));
7339 VFUNC (DividePoly, 3, "p,q,r", "polynomial", N_("Divide polynomial p by q, return the remainder in r"));
7340 FUNC (PolyDerivative, 1, "p", "polynomial", N_("Take polynomial (as vector) derivative"));
7341 FUNC (Poly2ndDerivative, 1, "p", "polynomial", N_("Take second polynomial (as vector) derivative"));
7342 FUNC (TrimPoly, 1, "p", "polynomial", N_("Trim zeros from a vector pretending to be a polynomial, that is trim trailing zero elements"));
7343 FUNC (IsPoly, 1, "p", "polynomial", N_("Check if a vector is usable as a polynomial"));
7344 VFUNC (PolyToString, 2, "p,var", "polynomial", N_("Make string out of a polynomial (as vector)"));
7345 FUNC (PolyToFunction, 1, "p", "polynomial", N_("Make function out of a polynomial (as vector)"));
7346
7347 FUNC (QuadraticFormula, 1, "p", "equation_solving", N_("Find roots of a quadratic polynomial (given as vector of coefficients)"));
7348
7349 FUNC (Combinations, 2, "k,n", "combinatorics", N_("Get all combinations of k numbers from 1 to n as a vector of vectors"));
7350 FUNC (NextCombination, 2, "v,n", "combinatorics", N_("Get combination that would come after v in call to combinations, first combination should be [1:k]."));
7351 FUNC (Permutations, 2, "k,n", "combinatorics", N_("Get all permutations of k numbers from 1 to n as a vector of vectors"));
7352
7353 FUNC (nCr, 2, "n,r", "combinatorics", N_("Calculate combinations (binomial coefficient)"));
7354 ALIAS (Binomial, 2, nCr);
7355
7356 FUNC (StringToASCII, 1, "str", "misc", N_("Convert a string to a vector of ASCII values"));
7357 FUNC (ASCIIToString, 1, "vec", "misc", N_("Convert a vector of ASCII values to a string"));
7358
7359 FUNC (StringToAlphabet, 2, "str,alphabet", "misc", N_("Convert a string to a vector of 0-based alphabet values (positions in the alphabet string), -1's for unknown letters"));
7360 FUNC (AlphabetToString, 2, "vec,alphabet", "misc", N_("Convert a vector of 0-based alphabet values (positions in the alphabet string) to a string"));
7361
7362 FUNC (protect, 1, "id", "basic", N_("Protect a variable from being modified. It will be treated as a system defined variable from now on. Protected parameters can still be modified."));
7363 FUNC (unprotect, 1, "id", "basic", N_("Unprotect a variable from being modified. It will be treated as a user defined variable from now on."));
7364 VFUNC (SetFunctionFlags, 2, "id,flags", "basic", N_("Set flags for a function, currently \"PropagateMod\" and \"NoModuloArguments\""));
7365 FUNC (GetCurrentModulo, 0, "", "basic", N_("Get current modulo from the context outside the function"));
7366 FUNC (IsDefined, 1, "id", "basic", N_("Check if a variable or function is defined"));
7367 FUNC (undefine, 1, "id", "basic", N_("Undefine a variable (including all locals and globals of the same name)"));
7368 ALIAS (Undefine, 1, undefine);
7369 FUNC (UndefineAll, 0, "", "basic", N_("Undefine all unprotected (user defined) global variables and parameters. Does not reset or change protected (system) parameters."));
7370 FUNC (ProtectAll, 0, "", "basic", N_("Mark all currently defined variables as protected. They will be treated as system defined variables from now on."));
7371 FUNC (UserVariables, 0, "", "basic", N_("Return a vector of all global unprotected (user defined) variable names."));
7372
7373 FUNC (Parse, 1, "str", "basic", N_("Parse a string (but do not execute)"));
7374 FUNC (Evaluate, 1, "str", "basic", N_("Parse and evaluate a string"));
7375
7376 VFUNC (AskString, 2, "query,...", "basic", N_("Ask a question and return a string. Optionally pass in a default."));
7377 VFUNC (AskButtons, 3, "query,button1,...", "basic", N_("Ask a question and present a list of buttons. Returns the 1-based index of the button pressed (or null on failure)."));
7378
7379 FUNC (CompositeSimpsonsRule, 4, "f,a,b,n", "calculus", N_("Integration of f by Composite Simpson's Rule on the interval [a,b] with n subintervals with error of max(f'''')*h^4*(b-a)/180, note that n should be even"));
7380 f->no_mod_all_args = 1;
7381
7382 /*temporary until well done internal functions are done*/
7383 /* Search also for _internal_exp_function above, it's done on
7384 * demand */
7385 #if 0
7386 _internal_ln_function = d_makeufunc(d_intern("<internal>ln"),
7387 /*FIXME:this is not the correct
7388 function*/
7389 gel_parseexp("error(\"ln not finished\")",
7390 NULL, FALSE, FALSE,
7391 NULL, NULL),
7392 g_slist_append(NULL,d_intern("x")),1,
7393 NULL);
7394 #endif
7395
7396 gel_add_symbolic_functions ();
7397
7398 /*protect EVERYthing up to this point*/
7399 d_protect_all ();
7400 }
7401