18780 lines
319 KiB
C
18780 lines
319 KiB
C
// Include MicroPython API.
|
|
#include "py/runtime.h"
|
|
|
|
// Used to get the time in the Timer class example.
|
|
#include "py/mphal.h"
|
|
|
|
|
|
/*
|
|
BSD 2-Clause License
|
|
|
|
Copyright (c) 2024, George Weigt
|
|
All rights reserved.
|
|
|
|
Redistribution and use in source and binary forms, with or without
|
|
modification, are permitted provided that the following conditions are met:
|
|
|
|
1. Redistributions of source code must retain the above copyright notice, this
|
|
list of conditions and the following disclaimer.
|
|
|
|
2. Redistributions in binary form must reproduce the above copyright notice,
|
|
this list of conditions and the following disclaimer in the documentation
|
|
and/or other materials provided with the distribution.
|
|
|
|
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
|
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
|
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
|
|
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
|
|
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
|
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
|
|
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
|
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
|
|
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
|
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
*/
|
|
#include <stdio.h>
|
|
#include <stdlib.h>
|
|
#include <stdint.h>
|
|
#include <ctype.h>
|
|
#include <fcntl.h>
|
|
#include <unistd.h>
|
|
#include <string.h>
|
|
#include <setjmp.h>
|
|
#include <math.h>
|
|
#include <errno.h>
|
|
#include <time.h>
|
|
|
|
#define STACKSIZE 100000 // evaluation stack
|
|
#define BLOCKSIZE 10000
|
|
#define MAXBLOCKS 2000
|
|
#define BUCKETSIZE 100
|
|
#define STRBUFLEN 1000
|
|
#define MAXDIM 24
|
|
|
|
// MAXBLOCKS * BLOCKSIZE = 20,000,000 atoms
|
|
|
|
// MAXBLOCKS * BLOCKSIZE * sizeof (struct atom) = 480,000,000 bytes
|
|
|
|
// Symbolic expressions are built by linking structs of type "atom".
|
|
//
|
|
// For example, the expression "a b + c" is built like this:
|
|
//
|
|
// _______ _______ _______ _______
|
|
// |CONS | |CONS | |CONS | |SYM |
|
|
// |car cdr|--->|car cdr|----------------------------->|car cdr|--->|"nil" |
|
|
// |_|_____| |_|_____| |_|_____| |_______|
|
|
// | | |
|
|
// | | _v_____
|
|
// | | |SYM |
|
|
// | | |"c" |
|
|
// | | |_______|
|
|
// | |
|
|
// _v_____ _v_____ _______ _______ _______
|
|
// |SYM | |CONS | |CONS | |CONS | |SYM |
|
|
// |"add" | |car cdr|--->|car cdr|--->|car cdr|--->|"nil" |
|
|
// |_______| |_|_____| |_|_____| |_|_____| |_______|
|
|
// | | |
|
|
// _v_____ _v_____ _v_____
|
|
// |SYM | |SYM | |SYM |
|
|
// |"mul" | |"a" | |"b" |
|
|
// |_______| |_______| |_______|
|
|
|
|
struct atom {
|
|
union {
|
|
struct {
|
|
struct atom *car;
|
|
struct atom *cdr;
|
|
} cons;
|
|
struct {
|
|
char *name;
|
|
void (*func)(struct atom *);
|
|
} ksym;
|
|
struct {
|
|
char *name;
|
|
uint32_t index;
|
|
} usym;
|
|
struct {
|
|
uint32_t *a; // rational number a over b
|
|
uint32_t *b;
|
|
} q;
|
|
double d;
|
|
char *str;
|
|
struct tensor *tensor;
|
|
struct atom *next;
|
|
} u;
|
|
uint8_t atomtype, tag, sign;
|
|
};
|
|
|
|
struct tensor {
|
|
int ndim;
|
|
int dim[MAXDIM];
|
|
int nelem;
|
|
struct atom *elem[1];
|
|
};
|
|
|
|
// atom types
|
|
|
|
#define FREEATOM 0
|
|
#define CONS 1
|
|
#define KSYM 2
|
|
#define USYM 3
|
|
#define RATIONAL 4
|
|
#define DOUBLE 5
|
|
#define STR 6
|
|
#define TENSOR 7
|
|
|
|
// symbol table
|
|
|
|
#define ABS (0 * BUCKETSIZE + 0)
|
|
#define ADJ (0 * BUCKETSIZE + 1)
|
|
#define AND (0 * BUCKETSIZE + 2)
|
|
#define ARCCOS (0 * BUCKETSIZE + 3)
|
|
#define ARCCOSH (0 * BUCKETSIZE + 4)
|
|
#define ARCSIN (0 * BUCKETSIZE + 5)
|
|
#define ARCSINH (0 * BUCKETSIZE + 6)
|
|
#define ARCTAN (0 * BUCKETSIZE + 7)
|
|
#define ARCTANH (0 * BUCKETSIZE + 8)
|
|
#define ARG (0 * BUCKETSIZE + 9)
|
|
|
|
#define BINDING (1 * BUCKETSIZE + 0)
|
|
#define BREAK (1 * BUCKETSIZE + 1)
|
|
|
|
#define C_UPPER (2 * BUCKETSIZE + 0)
|
|
#define C_LOWER (2 * BUCKETSIZE + 1)
|
|
#define CEILING (2 * BUCKETSIZE + 2)
|
|
#define CHECK (2 * BUCKETSIZE + 3)
|
|
#define CIRCEXP (2 * BUCKETSIZE + 4)
|
|
#define CLEAR (2 * BUCKETSIZE + 5)
|
|
#define CLOCK (2 * BUCKETSIZE + 6)
|
|
#define COFACTOR (2 * BUCKETSIZE + 7)
|
|
#define CONJ (2 * BUCKETSIZE + 8)
|
|
#define CONTRACT (2 * BUCKETSIZE + 9)
|
|
#define COS (2 * BUCKETSIZE + 10)
|
|
#define COSH (2 * BUCKETSIZE + 11)
|
|
|
|
#define D_UPPER (3 * BUCKETSIZE + 0)
|
|
#define D_LOWER (3 * BUCKETSIZE + 1)
|
|
#define DEFINT (3 * BUCKETSIZE + 2)
|
|
#define DENOMINATOR (3 * BUCKETSIZE + 3)
|
|
#define DERIVATIVE (3 * BUCKETSIZE + 4)
|
|
#define DET (3 * BUCKETSIZE + 5)
|
|
#define DIM (3 * BUCKETSIZE + 6)
|
|
#define DO (3 * BUCKETSIZE + 7)
|
|
#define DOT (3 * BUCKETSIZE + 8)
|
|
#define DRAW (3 * BUCKETSIZE + 9)
|
|
|
|
#define EIGENVEC (4 * BUCKETSIZE + 0)
|
|
#define ERF (4 * BUCKETSIZE + 1)
|
|
#define ERFC (4 * BUCKETSIZE + 2)
|
|
#define EVAL (4 * BUCKETSIZE + 3)
|
|
#define EXIT (4 * BUCKETSIZE + 4)
|
|
#define EXP (4 * BUCKETSIZE + 5)
|
|
#define EXPCOS (4 * BUCKETSIZE + 6)
|
|
#define EXPCOSH (4 * BUCKETSIZE + 7)
|
|
#define EXPFORM (4 * BUCKETSIZE + 8)
|
|
#define EXPSIN (4 * BUCKETSIZE + 9)
|
|
#define EXPSINH (4 * BUCKETSIZE + 10)
|
|
#define EXPTAN (4 * BUCKETSIZE + 11)
|
|
#define EXPTANH (4 * BUCKETSIZE + 12)
|
|
|
|
#define FACTORIAL (5 * BUCKETSIZE + 0)
|
|
#define FLOATF (5 * BUCKETSIZE + 1)
|
|
#define FLOOR (5 * BUCKETSIZE + 2)
|
|
#define FOR (5 * BUCKETSIZE + 3)
|
|
|
|
#define H_UPPER (7 * BUCKETSIZE + 0)
|
|
#define H_LOWER (7 * BUCKETSIZE + 1)
|
|
#define HADAMARD (7 * BUCKETSIZE + 2)
|
|
|
|
#define I_UPPER (8 * BUCKETSIZE + 0)
|
|
#define I_LOWER (8 * BUCKETSIZE + 1)
|
|
#define IMAG (8 * BUCKETSIZE + 2)
|
|
#define INFIXFORM (8 * BUCKETSIZE + 3)
|
|
#define INNER (8 * BUCKETSIZE + 4)
|
|
#define INTEGRAL (8 * BUCKETSIZE + 5)
|
|
#define INV (8 * BUCKETSIZE + 6)
|
|
|
|
#define J_UPPER (9 * BUCKETSIZE + 0)
|
|
#define J_LOWER (9 * BUCKETSIZE + 1)
|
|
|
|
#define KRONECKER (10 * BUCKETSIZE + 0)
|
|
|
|
#define LAST (11 * BUCKETSIZE + 0)
|
|
#define LGAMMA (11 * BUCKETSIZE + 1)
|
|
#define LOG (11 * BUCKETSIZE + 2)
|
|
#define LOOP (11 * BUCKETSIZE + 3)
|
|
|
|
#define MAG (12 * BUCKETSIZE + 0)
|
|
#define MINOR (12 * BUCKETSIZE + 1)
|
|
#define MINORMATRIX (12 * BUCKETSIZE + 2)
|
|
#define MOD (12 * BUCKETSIZE + 3)
|
|
|
|
#define NIL (13 * BUCKETSIZE + 0)
|
|
#define NOEXPAND (13 * BUCKETSIZE + 1)
|
|
#define NOT (13 * BUCKETSIZE + 2)
|
|
#define NROOTS (13 * BUCKETSIZE + 3)
|
|
#define NUMBER (13 * BUCKETSIZE + 4)
|
|
#define NUMERATOR (13 * BUCKETSIZE + 5)
|
|
|
|
#define OR (14 * BUCKETSIZE + 0)
|
|
#define OUTER (14 * BUCKETSIZE + 1)
|
|
|
|
#define P_UPPER (15 * BUCKETSIZE + 0)
|
|
#define P_LOWER (15 * BUCKETSIZE + 1)
|
|
#define PI (15 * BUCKETSIZE + 2)
|
|
#define POLAR (15 * BUCKETSIZE + 3)
|
|
#define PREFIXFORM (15 * BUCKETSIZE + 4)
|
|
#define PRINT (15 * BUCKETSIZE + 5)
|
|
#define PRODUCT (15 * BUCKETSIZE + 6)
|
|
|
|
#define Q_UPPER (16 * BUCKETSIZE + 0)
|
|
#define Q_LOWER (16 * BUCKETSIZE + 1)
|
|
#define QUOTE (16 * BUCKETSIZE + 2)
|
|
|
|
#define R_UPPER (17 * BUCKETSIZE + 0)
|
|
#define R_LOWER (17 * BUCKETSIZE + 1)
|
|
#define RAND (17 * BUCKETSIZE + 2)
|
|
#define RANK (17 * BUCKETSIZE + 3)
|
|
#define RATIONALIZE (17 * BUCKETSIZE + 4)
|
|
#define REAL (17 * BUCKETSIZE + 5)
|
|
#define RECTF (17 * BUCKETSIZE + 6)
|
|
#define ROOTS (17 * BUCKETSIZE + 7)
|
|
#define ROTATE (17 * BUCKETSIZE + 8)
|
|
#define RUN (17 * BUCKETSIZE + 9)
|
|
|
|
#define S_UPPER (18 * BUCKETSIZE + 0)
|
|
#define S_LOWER (18 * BUCKETSIZE + 1)
|
|
#define SGN (18 * BUCKETSIZE + 2)
|
|
#define SIMPLIFY (18 * BUCKETSIZE + 3)
|
|
#define SIN (18 * BUCKETSIZE + 4)
|
|
#define SINH (18 * BUCKETSIZE + 5)
|
|
#define SQRT (18 * BUCKETSIZE + 6)
|
|
#define STATUS (18 * BUCKETSIZE + 7)
|
|
#define STOP (18 * BUCKETSIZE + 8)
|
|
#define SUM (18 * BUCKETSIZE + 9)
|
|
|
|
#define T_UPPER (19 * BUCKETSIZE + 0)
|
|
#define T_LOWER (19 * BUCKETSIZE + 1)
|
|
#define TAN (19 * BUCKETSIZE + 2)
|
|
#define TANH (19 * BUCKETSIZE + 3)
|
|
#define TAYLOR (19 * BUCKETSIZE + 4)
|
|
#define TEST (19 * BUCKETSIZE + 5)
|
|
#define TESTEQ (19 * BUCKETSIZE + 6)
|
|
#define TESTGE (19 * BUCKETSIZE + 7)
|
|
#define TESTGT (19 * BUCKETSIZE + 8)
|
|
#define TESTLE (19 * BUCKETSIZE + 9)
|
|
#define TESTLT (19 * BUCKETSIZE + 10)
|
|
#define TGAMMA (19 * BUCKETSIZE + 11)
|
|
#define TRACE (19 * BUCKETSIZE + 12)
|
|
#define TRANSPOSE (19 * BUCKETSIZE + 13)
|
|
#define TTY (19 * BUCKETSIZE + 14)
|
|
|
|
#define U_UPPER (20 * BUCKETSIZE + 0)
|
|
#define U_LOWER (20 * BUCKETSIZE + 1)
|
|
#define UNIT (20 * BUCKETSIZE + 2)
|
|
|
|
#define V_UPPER (21 * BUCKETSIZE + 0)
|
|
#define V_LOWER (21 * BUCKETSIZE + 1)
|
|
|
|
#define W_UPPER (22 * BUCKETSIZE + 0)
|
|
#define W_LOWER (22 * BUCKETSIZE + 1)
|
|
|
|
#define X_UPPER (23 * BUCKETSIZE + 0)
|
|
#define X_LOWER (23 * BUCKETSIZE + 1)
|
|
|
|
#define Y_UPPER (24 * BUCKETSIZE + 0)
|
|
#define Y_LOWER (24 * BUCKETSIZE + 1)
|
|
|
|
#define Z_UPPER (25 * BUCKETSIZE + 0)
|
|
#define Z_LOWER (25 * BUCKETSIZE + 1)
|
|
#define ZERO (25 * BUCKETSIZE + 2)
|
|
|
|
#define ADD (26 * BUCKETSIZE + 0)
|
|
#define MULTIPLY (26 * BUCKETSIZE + 1)
|
|
#define POWER (26 * BUCKETSIZE + 2)
|
|
#define INDEX (26 * BUCKETSIZE + 3)
|
|
#define SETQ (26 * BUCKETSIZE + 4)
|
|
#define EXP1 (26 * BUCKETSIZE + 5)
|
|
#define SA (26 * BUCKETSIZE + 6)
|
|
#define SB (26 * BUCKETSIZE + 7)
|
|
#define SX (26 * BUCKETSIZE + 8)
|
|
#define ARG1 (26 * BUCKETSIZE + 9)
|
|
#define ARG2 (26 * BUCKETSIZE + 10)
|
|
#define ARG3 (26 * BUCKETSIZE + 11)
|
|
#define ARG4 (26 * BUCKETSIZE + 12)
|
|
#define ARG5 (26 * BUCKETSIZE + 13)
|
|
#define ARG6 (26 * BUCKETSIZE + 14)
|
|
#define ARG7 (26 * BUCKETSIZE + 15)
|
|
#define ARG8 (26 * BUCKETSIZE + 16)
|
|
#define ARG9 (26 * BUCKETSIZE + 17)
|
|
|
|
#define symbol(x) symtab[x]
|
|
#define push_symbol(x) push(symbol(x))
|
|
#define iscons(p) ((p)->atomtype == CONS)
|
|
#define isrational(p) ((p)->atomtype == RATIONAL)
|
|
#define isdouble(p) ((p)->atomtype == DOUBLE)
|
|
#define isnum(p) (isrational(p) || isdouble(p))
|
|
#define isstr(p) ((p)->atomtype == STR)
|
|
#define istensor(p) ((p)->atomtype == TENSOR)
|
|
#define iskeyword(p) ((p)->atomtype == KSYM)
|
|
#define isusersymbol(p) ((p)->atomtype == USYM)
|
|
#define issymbol(p) (iskeyword(p) || isusersymbol(p))
|
|
#define equal(p1, p2) (cmp(p1, p2) == 0)
|
|
#define lessp(p1, p2) (cmp(p1, p2) < 0)
|
|
|
|
#define car(p) (iscons(p) ? (p)->u.cons.car : symbol(NIL))
|
|
#define cdr(p) (iscons(p) ? (p)->u.cons.cdr : symbol(NIL))
|
|
#define caar(p) car(car(p))
|
|
#define cadr(p) car(cdr(p))
|
|
#define cdar(p) cdr(car(p))
|
|
#define cddr(p) cdr(cdr(p))
|
|
#define caadr(p) car(car(cdr(p)))
|
|
#define caddr(p) car(cdr(cdr(p)))
|
|
#define cadar(p) car(cdr(car(p)))
|
|
#define cdadr(p) cdr(car(cdr(p)))
|
|
#define cddar(p) cdr(cdr(car(p)))
|
|
#define cdddr(p) cdr(cdr(cdr(p)))
|
|
#define caaddr(p) car(car(cdr(cdr(p))))
|
|
#define cadadr(p) car(cdr(car(cdr(p))))
|
|
#define caddar(p) car(cdr(cdr(car(p))))
|
|
#define cadddr(p) car(cdr(cdr(cdr(p))))
|
|
#define cdaddr(p) cdr(car(cdr(cdr(p))))
|
|
#define cddadr(p) cdr(cdr(car(cdr(p))))
|
|
#define cddddr(p) cdr(cdr(cdr(cdr(p))))
|
|
#define caddddr(p) car(cdr(cdr(cdr(cdr(p)))))
|
|
#define cadaddr(p) car(cdr(car(cdr(cdr(p)))))
|
|
#define cddaddr(p) cdr(cdr(car(cdr(cdr(p)))))
|
|
#define caddadr(p) car(cdr(cdr(car(cdr(p)))))
|
|
#define cdddaddr(p) cdr(cdr(cdr(car(cdr(cdr(p))))))
|
|
#define caddaddr(p) car(cdr(cdr(car(cdr(cdr(p))))))
|
|
|
|
#define MPLUS 0
|
|
#define MMINUS 1
|
|
#define MLENGTH(p) (((int *) (p))[-1])
|
|
#define MZERO(p) (MLENGTH(p) == 1 && (p)[0] == 0)
|
|
#define MEQUAL(p, n) (MLENGTH(p) == 1 && (p)[0] == (n))
|
|
|
|
#define BLACK 0
|
|
#define BLUE 1
|
|
#define RED 2
|
|
|
|
#define Trace fprintf(stderr, "%s %d\n", __func__, __LINE__);
|
|
|
|
extern struct atom *mem[MAXBLOCKS]; // an array of pointers
|
|
extern struct atom *free_list;
|
|
extern int tos; // top of stack
|
|
extern struct atom *stack[STACKSIZE];
|
|
extern struct atom *symtab[27 * BUCKETSIZE];
|
|
extern struct atom *binding[27 * BUCKETSIZE];
|
|
extern struct atom *usrfunc[27 * BUCKETSIZE];
|
|
extern struct atom *zero;
|
|
extern struct atom *one;
|
|
extern struct atom *minusone;
|
|
extern struct atom *imaginaryunit;
|
|
extern int eval_level;
|
|
extern int gc_level;
|
|
extern int expanding;
|
|
extern int drawing;
|
|
extern int interrupt;
|
|
extern int shuntflag;
|
|
extern int breakflag;
|
|
extern int errorflag;
|
|
extern jmp_buf jmpbuf;
|
|
extern char *trace1;
|
|
extern char *trace2;
|
|
extern int alloc_count;
|
|
extern int block_count;
|
|
extern int free_count;
|
|
extern int gc_count;
|
|
extern int bignum_count;
|
|
extern int ksym_count;
|
|
extern int usym_count;
|
|
extern int string_count;
|
|
extern int tensor_count;
|
|
extern int max_eval_level;
|
|
extern int max_tos;
|
|
extern int max_tof;
|
|
extern char strbuf[];
|
|
extern char *outbuf;
|
|
extern int outbuf_index;
|
|
extern int outbuf_length;
|
|
struct atom * alloc_atom(void);
|
|
void alloc_block(void);
|
|
struct atom * alloc_vector(int nrow);
|
|
struct atom * alloc_matrix(int nrow, int ncol);
|
|
struct atom * alloc_tensor(int nelem);
|
|
struct atom * alloc_str(void);
|
|
void * alloc_mem(int n);
|
|
double mfloat(uint32_t *p);
|
|
void msetbit(uint32_t *x, uint32_t k);
|
|
void mclrbit(uint32_t *x, uint32_t k);
|
|
uint32_t * mscan(char *s);
|
|
char * mstr(uint32_t *u);
|
|
int mdivby1billion(uint32_t *u);
|
|
uint32_t * madd(uint32_t *u, uint32_t *v);
|
|
uint32_t * msub(uint32_t *u, uint32_t *v);
|
|
uint32_t * mmul(uint32_t *u, uint32_t *v);
|
|
uint32_t * mdiv(uint32_t *u, uint32_t *v);
|
|
uint32_t * mmod(uint32_t *u, uint32_t *v);
|
|
uint32_t * mpow(uint32_t *u, uint32_t *v);
|
|
void mshr(uint32_t *u);
|
|
int mcmp(uint32_t *u, uint32_t *v);
|
|
int meq(uint32_t *u, uint32_t *v);
|
|
uint32_t * mint(uint32_t n);
|
|
uint32_t * mnew(int n);
|
|
void mfree(uint32_t *u);
|
|
uint32_t * mcopy(uint32_t *u);
|
|
void mnorm(uint32_t *u);
|
|
uint32_t * mgcd(uint32_t *u, uint32_t *v);
|
|
uint32_t * mroot(uint32_t *a, uint32_t *n);
|
|
void list(int n);
|
|
void cons(void);
|
|
int lengthf(struct atom *p);
|
|
int findf(struct atom *p, struct atom *q);
|
|
void sort(int n);
|
|
int sort_func(const void *p1, const void *p2);
|
|
int cmp(struct atom *p1, struct atom *p2);
|
|
int cmp_numbers(struct atom *p1, struct atom *p2);
|
|
int cmp_rationals(struct atom *a, struct atom *b);
|
|
int cmp_tensors(struct atom *p1, struct atom *p2);
|
|
int find_denominator(struct atom *p);
|
|
int count_denominators(struct atom *p);
|
|
int count_numerators(struct atom *p);
|
|
void subst(void);
|
|
void eval_abs(struct atom *p1);
|
|
void absfunc(void);
|
|
void eval_add(struct atom *p1);
|
|
void add(void);
|
|
void add_terms(int n);
|
|
void flatten_terms(int h);
|
|
struct atom * combine_tensors(int h);
|
|
void add_tensors(void);
|
|
void combine_terms(int h);
|
|
int combine_terms_nib(int i);
|
|
void sort_terms(int h);
|
|
int sort_terms_func(const void *q1, const void *q2);
|
|
int cmp_terms(struct atom *p1, struct atom *p2);
|
|
void normalize_terms(int h);
|
|
void add_numbers(struct atom *p1, struct atom *p2);
|
|
void add_rationals(struct atom *p1, struct atom *p2);
|
|
void add_integers(struct atom *p1, struct atom *p2);
|
|
void subtract(void);
|
|
void eval_adj(struct atom *p1);
|
|
void adj(void);
|
|
void eval_and(struct atom *p1);
|
|
void eval_arccos(struct atom *p1);
|
|
void arccos(void);
|
|
void eval_arccosh(struct atom *p1);
|
|
void arccosh(void);
|
|
void eval_arcsin(struct atom *p1);
|
|
void arcsin(void);
|
|
void eval_arcsinh(struct atom *p1);
|
|
void arcsinh(void);
|
|
void eval_arctan(struct atom *p1);
|
|
void arctan(void);
|
|
void arctan_numbers(struct atom *X, struct atom *Y);
|
|
void eval_arctanh(struct atom *p1);
|
|
void arctanh(void);
|
|
void eval_arg(struct atom *p1);
|
|
void argfunc(void);
|
|
void arg_nib(void);
|
|
void eval_binding(struct atom *p1);
|
|
void eval_break(struct atom *p1);
|
|
void eval_ceiling(struct atom *p1);
|
|
void ceilingfunc(void);
|
|
void eval_check(struct atom *p1);
|
|
void eval_clear(struct atom *p1);
|
|
void eval_clock(struct atom *p1);
|
|
void clockfunc(void);
|
|
void eval_cofactor(struct atom *p1);
|
|
void eval_conj(struct atom *p1);
|
|
void conjfunc(void);
|
|
void conjfunc_subst(void);
|
|
void eval_contract(struct atom *p1);
|
|
void contract(void);
|
|
void eval_cos(struct atom *p1);
|
|
void cosfunc(void);
|
|
void cosfunc_sum(struct atom *p1);
|
|
void eval_cosh(struct atom *p1);
|
|
void coshfunc(void);
|
|
void eval_defint(struct atom *p1);
|
|
void eval_denominator(struct atom *p1);
|
|
void denominator(void);
|
|
void eval_derivative(struct atom *p1);
|
|
void derivative(void);
|
|
void d_scalar_scalar(struct atom *F, struct atom *X);
|
|
void dsum(struct atom *p1, struct atom *p2);
|
|
void dproduct(struct atom *p1, struct atom *p2);
|
|
void dpower(struct atom *F, struct atom *X);
|
|
void dlog(struct atom *p1, struct atom *p2);
|
|
void dfunction(struct atom *p1, struct atom *p2);
|
|
void dsin(struct atom *p1, struct atom *p2);
|
|
void dcos(struct atom *p1, struct atom *p2);
|
|
void dtan(struct atom *p1, struct atom *p2);
|
|
void darcsin(struct atom *p1, struct atom *p2);
|
|
void darccos(struct atom *p1, struct atom *p2);
|
|
void darctan(struct atom *p1, struct atom *p2);
|
|
void dsinh(struct atom *p1, struct atom *p2);
|
|
void dcosh(struct atom *p1, struct atom *p2);
|
|
void dtanh(struct atom *p1, struct atom *p2);
|
|
void darcsinh(struct atom *p1, struct atom *p2);
|
|
void darccosh(struct atom *p1, struct atom *p2);
|
|
void darctanh(struct atom *p1, struct atom *p2);
|
|
void derf(struct atom *p1, struct atom *p2);
|
|
void derfc(struct atom *p1, struct atom *p2);
|
|
void d_tensor_tensor(struct atom *p1, struct atom *p2);
|
|
void d_scalar_tensor(struct atom *p1, struct atom *p2);
|
|
void d_tensor_scalar(struct atom *p1, struct atom *p2);
|
|
void derivative_of_derivative(struct atom *F, struct atom *X);
|
|
void derivative_of_integral(struct atom *F, struct atom *X);
|
|
void eval_det(struct atom *p1);
|
|
void det(void);
|
|
void eval_dim(struct atom *p1);
|
|
void eval_do(struct atom *p1);
|
|
void eval_eigenvec(struct atom *p1);
|
|
void eigenvec(double *D, double *Q, int n);
|
|
int eigenvec_step(double *D, double *Q, int n);
|
|
void eigenvec_step_nib(double *D, double *Q, int n, int p, int q);
|
|
void eval_erf(struct atom *p1);
|
|
void erffunc(void);
|
|
void eval_erfc(struct atom *p1);
|
|
void erfcfunc(void);
|
|
void eval_eval(struct atom *p1);
|
|
void asubst(void);
|
|
int addcmp(struct atom *p1, struct atom *p2);
|
|
int mulcmp(struct atom *p1, struct atom *p2);
|
|
int powcmp(struct atom *p1, struct atom *p2);
|
|
void eval_exp(struct atom *p1);
|
|
void expfunc(void);
|
|
void eval_expcos(struct atom *p1);
|
|
void expcos(void);
|
|
void eval_expcosh(struct atom *p1);
|
|
void expcosh(void);
|
|
void eval_expform(struct atom *p1);
|
|
void expform(void);
|
|
void eval_expsin(struct atom *p1);
|
|
void expsin(void);
|
|
void eval_expsinh(struct atom *p1);
|
|
void expsinh(void);
|
|
void eval_exptan(struct atom *p1);
|
|
void exptan(void);
|
|
void eval_exptanh(struct atom *p1);
|
|
void exptanh(void);
|
|
void eval_factorial(struct atom *p1);
|
|
void factorial(void);
|
|
void eval_float(struct atom *p1);
|
|
void floatfunc(void);
|
|
void floatfunc_subst(void);
|
|
void eval_floor(struct atom *p1);
|
|
void floorfunc(void);
|
|
void eval_for(struct atom *p1);
|
|
void eval_hadamard(struct atom *p1);
|
|
void hadamard(void);
|
|
void eval_imag(struct atom *p1);
|
|
void imag(void);
|
|
void eval_index(struct atom *p1);
|
|
void indexfunc(struct atom *T, int h);
|
|
void eval_infixform(struct atom *p1);
|
|
void print_infixform(struct atom *p);
|
|
void infixform_subexpr(struct atom *p);
|
|
void infixform_expr(struct atom *p);
|
|
void infixform_expr_nib(struct atom *p);
|
|
void infixform_term(struct atom *p);
|
|
void infixform_term_nib(struct atom *p);
|
|
void infixform_numerators(struct atom *p);
|
|
void infixform_denominators(struct atom *p);
|
|
void infixform_factor(struct atom *p);
|
|
void infixform_power(struct atom *p);
|
|
void infixform_reciprocal(struct atom *p);
|
|
void infixform_factorial(struct atom *p);
|
|
void infixform_index(struct atom *p);
|
|
void infixform_arglist(struct atom *p);
|
|
void infixform_rational(struct atom *p);
|
|
void infixform_double(struct atom *p);
|
|
void infixform_base(struct atom *p);
|
|
void infixform_numeric_base(struct atom *p);
|
|
void infixform_numeric_exponent(struct atom *p);
|
|
void infixform_tensor(struct atom *p);
|
|
void infixform_tensor_nib(struct atom *p, int d, int k);
|
|
void eval_inner(struct atom *p1);
|
|
void inner(void);
|
|
void eval_integral(struct atom *p1);
|
|
void integral(void);
|
|
void integral_solve(struct atom *F, struct atom *X);
|
|
void integral_solve_nib(struct atom *F, struct atom *X);
|
|
int integral_classify(struct atom *p);
|
|
int integral_search(int h, struct atom *F, char **table, int n);
|
|
int integral_search_nib(int h, struct atom *F, struct atom *I, struct atom *C);
|
|
void decomp(void);
|
|
void decomp_sum(struct atom *F, struct atom *X);
|
|
void decomp_product(struct atom *F, struct atom *X);
|
|
void partition_term(void);
|
|
void integral_of_integral(struct atom *F, struct atom *X);
|
|
void integral_of_derivative(struct atom *F, struct atom *X);
|
|
void eval_inv(struct atom *p1);
|
|
void inv(void);
|
|
void eval_kronecker(struct atom *p1);
|
|
void kronecker(void);
|
|
void eval_lgamma(struct atom *p1);
|
|
void lgammafunc(void);
|
|
void eval_log(struct atom *p1);
|
|
void logfunc(void);
|
|
void eval_loop(struct atom *p1);
|
|
void eval_mag(struct atom *p1);
|
|
void magfunc(void);
|
|
void magfunc_nib(void);
|
|
void eval_minor(struct atom *p1);
|
|
void eval_minormatrix(struct atom *p1);
|
|
void minormatrix(int row, int col);
|
|
void eval_mod(struct atom *p1);
|
|
void modfunc(void);
|
|
void mod_rationals(struct atom *p1, struct atom *p2);
|
|
void mod_integers(struct atom *p1, struct atom *p2);
|
|
void eval_multiply(struct atom *p1);
|
|
void multiply(void);
|
|
void multiply_factors(int n);
|
|
void flatten_factors(int h);
|
|
struct atom * multiply_tensor_factors(int h);
|
|
void multiply_scalar_factors(int h);
|
|
struct atom * combine_numerical_factors(int h, struct atom *COEF);
|
|
void combine_factors(int h);
|
|
int combine_factors_nib(int i, int j);
|
|
void sort_factors_provisional(int h);
|
|
int sort_factors_provisional_func(const void *q1, const void *q2);
|
|
int cmp_factors_provisional(struct atom *p1, struct atom *p2);
|
|
void normalize_power_factors(int h);
|
|
void expand_sum_factors(int h);
|
|
void sort_factors(int n);
|
|
int sort_factors_func(const void *q1, const void *q2);
|
|
int cmp_factors(struct atom *p1, struct atom *p2);
|
|
int order_factor(struct atom *p);
|
|
void multiply_numbers(struct atom *p1, struct atom *p2);
|
|
void multiply_rationals(struct atom *p1, struct atom *p2);
|
|
struct atom * reduce_radical_factors(int h, struct atom *COEF);
|
|
int any_radical_factors(int h);
|
|
struct atom * reduce_radical_double(int h, struct atom *COEF);
|
|
struct atom * reduce_radical_rational(int h, struct atom *COEF);
|
|
void multiply_expand(void);
|
|
void multiply_noexpand(void);
|
|
void negate(void);
|
|
void reciprocate(void);
|
|
void divide(void);
|
|
void eval_nil(struct atom *p1);
|
|
void eval_noexpand(struct atom *p1);
|
|
void eval_not(struct atom *p1);
|
|
void eval_nroots(struct atom *p1);
|
|
void nroots(void);
|
|
void nfindroot(double cr[], double ci[], int n, double *par, double *pai);
|
|
void fata(double cr[], double ci[], int n, double ar, double ai, double *far, double *fai);
|
|
void nreduce(double cr[], double ci[], int n, double ar, double ai);
|
|
double zabs(double r, double i);
|
|
double urandom(void);
|
|
void eval_number(struct atom *p1);
|
|
void eval_numerator(struct atom *p1);
|
|
void numerator(void);
|
|
void eval_or(struct atom *p1);
|
|
void eval_outer(struct atom *p1);
|
|
void outer(void);
|
|
void eval_polar(struct atom *p1);
|
|
void polar(void);
|
|
void eval_power(struct atom *p1);
|
|
void power(void);
|
|
void power_numbers(struct atom *BASE, struct atom *EXPO);
|
|
void power_numbers_factor(struct atom *BASE, struct atom *EXPO);
|
|
void power_double(struct atom *BASE, struct atom *EXPO);
|
|
void power_minusone(struct atom *EXPO);
|
|
void normalize_clock_rational(struct atom *EXPO);
|
|
void normalize_clock_double(struct atom *EXPO);
|
|
void power_natural_number(struct atom *EXPO);
|
|
void normalize_polar(struct atom *EXPO);
|
|
void normalize_polar_term(struct atom *EXPO);
|
|
void normalize_polar_term_rational(struct atom *R);
|
|
void normalize_polar_term_double(struct atom *R);
|
|
void power_sum(struct atom *BASE, struct atom *EXPO);
|
|
void power_complex_number(struct atom *BASE, struct atom *EXPO);
|
|
void power_complex_plus(struct atom *X, struct atom *Y, int n);
|
|
void power_complex_minus(struct atom *X, struct atom *Y, int n);
|
|
void power_complex_double(struct atom *X, struct atom *Y, struct atom *EXPO);
|
|
void power_complex_rational(struct atom *X, struct atom *Y, struct atom *EXPO);
|
|
void eval_prefixform(struct atom *p1);
|
|
void print_prefixform(struct atom *p);
|
|
void prefixform(struct atom *p);
|
|
void eval_print(struct atom *p1);
|
|
void print_result(void);
|
|
int annotate_result(struct atom *p1, struct atom *p2);
|
|
void eval_product(struct atom *p1);
|
|
void eval_quote(struct atom *p1);
|
|
void eval_rand(struct atom *p1);
|
|
void eval_rank(struct atom *p1);
|
|
void eval_rationalize(struct atom *p1);
|
|
void rationalize(void);
|
|
void eval_real(struct atom *p1);
|
|
void real(void);
|
|
void eval_rect(struct atom *p1);
|
|
void rect(void);
|
|
void eval_roots(struct atom *p1);
|
|
void roots(void);
|
|
int findroot(int h, int n);
|
|
void horner(int h, int n, struct atom *A);
|
|
void divisors(int n);
|
|
void divisors_nib(int h, int k);
|
|
void reduce(int h, int n, struct atom *A);
|
|
void coeffs(struct atom *P, struct atom *X);
|
|
void eval_rotate(struct atom *p1);
|
|
void rotate_h(struct atom *PSI, uint32_t c, int n);
|
|
void rotate_p(struct atom *PSI, struct atom *PHASE, uint32_t c, int n);
|
|
void rotate_w(struct atom *PSI, uint32_t c, int m, int n);
|
|
void rotate_x(struct atom *PSI, uint32_t c, int n);
|
|
void rotate_y(struct atom *PSI, uint32_t c, int n);
|
|
void rotate_z(struct atom *PSI, uint32_t c, int n);
|
|
void rotate_q(struct atom *PSI, int n);
|
|
void rotate_v(struct atom *PSI, int n);
|
|
void eval_run(struct atom *p1);
|
|
char * read_file(char *filename);
|
|
void eval_setq(struct atom *p1);
|
|
void setq_indexed(struct atom *p1);
|
|
void set_component(struct atom *LVAL, struct atom *RVAL, int h);
|
|
void setq_usrfunc(struct atom *p1);
|
|
void convert_body(struct atom *A);
|
|
void eval_sgn(struct atom *p1);
|
|
void sgnfunc(void);
|
|
void eval_simplify(struct atom *p1);
|
|
void simplify(void);
|
|
void simplify_nib(void);
|
|
void simplify_trig(void);
|
|
int simpler(struct atom *p1, struct atom *p2);
|
|
int diameter(struct atom *p);
|
|
int mass(struct atom *p);
|
|
void eval_sin(struct atom *p1);
|
|
void sinfunc(void);
|
|
void sinfunc_sum(struct atom *p1);
|
|
void eval_sinh(struct atom *p1);
|
|
void sinhfunc(void);
|
|
void eval_sqrt(struct atom *p1);
|
|
void sqrtfunc(void);
|
|
void eval_status(struct atom *p1);
|
|
void eval_stop(struct atom *p1);
|
|
void eval_sum(struct atom *p1);
|
|
void eval_tan(struct atom *p1);
|
|
void tanfunc(void);
|
|
void tanfunc_sum(struct atom *p1);
|
|
void eval_tanh(struct atom *p1);
|
|
void tanhfunc(void);
|
|
void eval_taylor(struct atom *p1);
|
|
void eval_tensor(struct atom *p1);
|
|
void promote_tensor(void);
|
|
int compatible_dimensions(struct atom *p, struct atom *q);
|
|
struct atom * copy_tensor(struct atom *p1);
|
|
void eval_test(struct atom *p1);
|
|
void eval_testeq(struct atom *p1);
|
|
void eval_testge(struct atom *p1);
|
|
void eval_testgt(struct atom *p1);
|
|
void eval_testle(struct atom *p1);
|
|
void eval_testlt(struct atom *p1);
|
|
int cmp_args(struct atom *p1);
|
|
void eval_tgamma(struct atom *p1);
|
|
void tgammafunc(void);
|
|
void eval_transpose(struct atom *p1);
|
|
void transpose(int n, int m);
|
|
void eval_unit(struct atom *p1);
|
|
void eval_user_function(struct atom *p1);
|
|
void eval_user_symbol(struct atom *p1);
|
|
void eval_zero(struct atom *p1);
|
|
void evalg(void);
|
|
void evalf(void);
|
|
void evalf_nib(struct atom *p1);
|
|
void evalp(void);
|
|
void factor_factor(void);
|
|
void factor_bignum(uint32_t *N, struct atom *M);
|
|
void factor_int(int n);
|
|
void fmt(void);
|
|
void fmt_args(struct atom *p);
|
|
void fmt_base(struct atom *p);
|
|
void fmt_denominators(struct atom *p);
|
|
void fmt_double(struct atom *p);
|
|
void fmt_exponent(struct atom *p);
|
|
void fmt_expr(struct atom *p);
|
|
void fmt_expr_nib(struct atom *p);
|
|
void fmt_factor(struct atom *p);
|
|
void fmt_frac(struct atom *p);
|
|
void fmt_function(struct atom *p);
|
|
void fmt_indices(struct atom *p);
|
|
void fmt_infix_operator(int c);
|
|
void fmt_list(struct atom *p);
|
|
void fmt_matrix(struct atom *p, int d, int k);
|
|
void fmt_numerators(struct atom *p);
|
|
void fmt_numeric_exponent(struct atom *p);
|
|
void fmt_power(struct atom *p);
|
|
void fmt_rational(struct atom *p);
|
|
void fmt_reciprocal(struct atom *p);
|
|
void fmt_roman_char(int c);
|
|
void fmt_roman_string(char *s);
|
|
void fmt_space(void);
|
|
void fmt_string(struct atom *p);
|
|
void fmt_subexpr(struct atom *p);
|
|
void fmt_symbol(struct atom *p);
|
|
int fmt_symbol_fragment(char *s, int k);
|
|
void fmt_table(int x, int y, struct atom *p);
|
|
void fmt_tensor(struct atom *p);
|
|
void fmt_term(struct atom *p);
|
|
void fmt_term_nib(struct atom *p);
|
|
void fmt_update_fraction(void);
|
|
void fmt_update_list(int t);
|
|
void fmt_update_subexpr(void);
|
|
void fmt_update_subscript(void);
|
|
void fmt_update_superscript(void);
|
|
void fmt_update_table(int n, int m);
|
|
void fmt_vector(struct atom *p);
|
|
void fmt_draw(int x, int y, struct atom *p);
|
|
void fmt_draw_char(int x, int y, int c);
|
|
void fmt_draw_delims(int x, int y, int h, int d, int w);
|
|
void fmt_draw_ldelim(int x, int y, int h, int d);
|
|
void fmt_draw_rdelim(int x, int y, int h, int d);
|
|
void fmt_draw_table(int x, int y, struct atom *p);
|
|
void fmt_putw(uint32_t w);
|
|
void gc(void);
|
|
void untag(struct atom *p);
|
|
void run_infile(char *infile);
|
|
void run_stdin(void);
|
|
void display(void);
|
|
void printbuf(char *s, int color);
|
|
void eval_draw(struct atom *p1);
|
|
void eval_exit(struct atom *p1);
|
|
void numden(void);
|
|
int numden_find_divisor(struct atom *p);
|
|
int numden_find_divisor_term(struct atom *p);
|
|
int numden_find_divisor_factor(struct atom *p);
|
|
void numden_cancel_factor(void);
|
|
void outbuf_init(void);
|
|
void outbuf_puts(char *s);
|
|
void outbuf_putc(int c);
|
|
int iszero(struct atom *p);
|
|
int isequaln(struct atom *p, int n);
|
|
int isequalq(struct atom *p, int a, int b);
|
|
int isplusone(struct atom *p);
|
|
int isminusone(struct atom *p);
|
|
int isinteger(struct atom *p);
|
|
int isfraction(struct atom *p);
|
|
int isposint(struct atom *p);
|
|
int isradicalterm(struct atom *p);
|
|
int isradical(struct atom *p);
|
|
int isnegativeterm(struct atom *p);
|
|
int isnegativenumber(struct atom *p);
|
|
int isimaginaryterm(struct atom *p);
|
|
int isimaginaryfactor(struct atom *p);
|
|
int iscomplexnumber(struct atom *p);
|
|
int isimaginarynumber(struct atom *p);
|
|
int isimaginaryunit(struct atom *p);
|
|
int isoneoversqrttwo(struct atom *p);
|
|
int isminusoneoversqrttwo(struct atom *p);
|
|
int isdoublez(struct atom *p);
|
|
int isdenominator(struct atom *p);
|
|
int isnumerator(struct atom *p);
|
|
int hasdouble(struct atom *p);
|
|
int isdenormalpolar(struct atom *p);
|
|
int isdenormalpolarterm(struct atom *p);
|
|
int issquarematrix(struct atom *p);
|
|
int issmallinteger(struct atom *p);
|
|
int dependent(struct atom *f, struct atom *x);
|
|
void run(char *buf);
|
|
void run_buf(char *buf);
|
|
char * scan_input(char *s);
|
|
void print_trace(int color);
|
|
void run_init_script(void);
|
|
void stopf(char *s);
|
|
char * scan(char *s);
|
|
char * scan1(char *s);
|
|
char * scan_nib(char *s);
|
|
void scan_stmt(void);
|
|
void scan_comparison(void);
|
|
void scan_expression(void);
|
|
int another_factor_pending(void);
|
|
void scan_term(void);
|
|
void scan_power(void);
|
|
void scan_factor(void);
|
|
void scan_symbol(void);
|
|
void scan_string(void);
|
|
void scan_function_call(void);
|
|
void scan_integer(void);
|
|
void scan_subexpr(void);
|
|
void get_token_skip_newlines(void);
|
|
void get_token(void);
|
|
void get_token_nib(void);
|
|
void update_token_buf(char *a, char *b);
|
|
void scan_error(char *errmsg);
|
|
void static_negate(void);
|
|
void static_reciprocate(void);
|
|
void push(struct atom *p);
|
|
struct atom * pop(void);
|
|
void save_symbol(struct atom *p);
|
|
void restore_symbol(void);
|
|
void dupl(void);
|
|
void swap(void);
|
|
void push_integer(int n);
|
|
void push_rational(int a, int b);
|
|
void push_bignum(int sign, uint32_t *a, uint32_t *b);
|
|
int pop_integer(void);
|
|
void push_double(double d);
|
|
double pop_double(void);
|
|
void push_string(char *s);
|
|
void slice(int h, int n);
|
|
struct atom * lookup(char *s);
|
|
char * printname(struct atom *p);
|
|
void set_symbol(struct atom *p1, struct atom *p2, struct atom *p3);
|
|
struct atom * get_binding(struct atom *p1);
|
|
struct atom * get_usrfunc(struct atom *p);
|
|
void init_symbol_table(void);
|
|
struct atom *
|
|
alloc_atom(void)
|
|
{
|
|
struct atom *p;
|
|
|
|
if (free_count == 0)
|
|
alloc_block();
|
|
|
|
p = free_list;
|
|
free_list = p->u.next;
|
|
|
|
free_count--;
|
|
alloc_count++;
|
|
|
|
return p;
|
|
}
|
|
|
|
void
|
|
alloc_block(void)
|
|
{
|
|
int i;
|
|
struct atom *p;
|
|
|
|
if (block_count == MAXBLOCKS) {
|
|
tos = 0;
|
|
gc(); // prep for next run
|
|
stopf("out of memory");
|
|
}
|
|
|
|
p = alloc_mem(BLOCKSIZE * sizeof (struct atom));
|
|
|
|
mem[block_count++] = p;
|
|
|
|
for (i = 0; i < BLOCKSIZE - 1; i++) {
|
|
p[i].atomtype = FREEATOM;
|
|
p[i].u.next = p + i + 1;
|
|
}
|
|
|
|
p[i].atomtype = FREEATOM;
|
|
p[i].u.next = NULL;
|
|
|
|
free_list = p;
|
|
free_count = BLOCKSIZE;
|
|
}
|
|
|
|
struct atom *
|
|
alloc_vector(int nrow)
|
|
{
|
|
struct atom *p = alloc_tensor(nrow);
|
|
p->u.tensor->ndim = 1;
|
|
p->u.tensor->dim[0] = nrow;
|
|
return p;
|
|
}
|
|
|
|
struct atom *
|
|
alloc_matrix(int nrow, int ncol)
|
|
{
|
|
struct atom *p = alloc_tensor(nrow * ncol);
|
|
p->u.tensor->ndim = 2;
|
|
p->u.tensor->dim[0] = nrow;
|
|
p->u.tensor->dim[1] = ncol;
|
|
return p;
|
|
}
|
|
|
|
struct atom *
|
|
alloc_tensor(int nelem)
|
|
{
|
|
int i;
|
|
struct atom *p;
|
|
struct tensor *t;
|
|
p = alloc_atom();
|
|
t = alloc_mem(sizeof (struct tensor) + nelem * sizeof (struct atom *));
|
|
p->atomtype = TENSOR;
|
|
p->u.tensor = t;
|
|
t->nelem = nelem;
|
|
for (i = 0; i < nelem; i++)
|
|
t->elem[i] = zero;
|
|
tensor_count++;
|
|
return p;
|
|
}
|
|
|
|
struct atom *
|
|
alloc_str(void)
|
|
{
|
|
struct atom *p;
|
|
p = alloc_atom();
|
|
p->atomtype = STR;
|
|
p->u.str = NULL;
|
|
string_count++;
|
|
return p;
|
|
}
|
|
|
|
void *
|
|
alloc_mem(int n)
|
|
{
|
|
void *p = malloc(n);
|
|
if (p == NULL)
|
|
exit(1);
|
|
return p;
|
|
}
|
|
double
|
|
mfloat(uint32_t *p)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
n = MLENGTH(p);
|
|
d = 0.0;
|
|
for (i = 0; i < n; i++)
|
|
d += scalbn((double) p[i], 32 * i);
|
|
return d;
|
|
}
|
|
|
|
void
|
|
msetbit(uint32_t *x, uint32_t k)
|
|
{
|
|
x[k / 32] |= 1 << (k % 32);
|
|
}
|
|
|
|
void
|
|
mclrbit(uint32_t *x, uint32_t k)
|
|
{
|
|
x[k / 32] &= ~(1 << (k % 32));
|
|
}
|
|
|
|
// convert string to bignum (9 decimal digits fits in 32 bits)
|
|
|
|
uint32_t *
|
|
mscan(char *s)
|
|
{
|
|
int i, k, len;
|
|
uint32_t *a, *b, *t;
|
|
a = mint(0);
|
|
len = (int) strlen(s);
|
|
if (len == 0)
|
|
return a;
|
|
k = len % 9;
|
|
if (k == 0)
|
|
k = 9;
|
|
for (i = 0; i < k; i++)
|
|
a[0] = 10 * a[0] + s[i] - '0';
|
|
if (k == len)
|
|
return a;
|
|
b = mint(0);
|
|
while (k < len) {
|
|
b[0] = 1000000000; // 10^9
|
|
t = mmul(a, b);
|
|
mfree(a);
|
|
a = t;
|
|
b[0] = 0;
|
|
for (i = 0; i < 9; i++)
|
|
b[0] = 10 * b[0] + s[k++] - '0';
|
|
t = madd(a, b);
|
|
mfree(a);
|
|
a = t;
|
|
}
|
|
mfree(b);
|
|
return a;
|
|
}
|
|
|
|
// convert bignum to string (returned value points to static buffer)
|
|
|
|
char *
|
|
mstr(uint32_t *u)
|
|
{
|
|
int i, k, n, r;
|
|
static char *buf;
|
|
static int len;
|
|
|
|
// estimate string length
|
|
|
|
// note that 0xffffffff -> 000000004 294967295
|
|
|
|
// hence space for 8 leading zeroes is required
|
|
|
|
n = 10 * MLENGTH(u) + 10;
|
|
|
|
n = 1000 * (n / 1000 + 1);
|
|
|
|
if (n > len) {
|
|
if (buf)
|
|
free(buf);
|
|
buf = alloc_mem(n);
|
|
len = n;
|
|
}
|
|
|
|
u = mcopy(u);
|
|
|
|
k = len - 1;
|
|
buf[k] = '\0'; // string terminator
|
|
|
|
for (;;) {
|
|
r = mdivby1billion(u);
|
|
for (i = 0; i < 9; i++) {
|
|
buf[--k] = r % 10 + '0';
|
|
r /= 10;
|
|
}
|
|
if (MZERO(u))
|
|
break;
|
|
}
|
|
|
|
mfree(u);
|
|
|
|
// remove leading zeroes
|
|
|
|
while (buf[k] == '0' && buf[k + 1])
|
|
k++;
|
|
|
|
return buf + k;
|
|
}
|
|
|
|
// returns remainder, quotient returned in u
|
|
|
|
int
|
|
mdivby1billion(uint32_t *u)
|
|
{
|
|
int i;
|
|
uint64_t r = 0;
|
|
for (i = MLENGTH(u) - 1; i >= 0; i--) {
|
|
r = r << 32 | u[i];
|
|
u[i] = (uint32_t) (r / 1000000000);
|
|
r -= (uint64_t) 1000000000 * u[i];
|
|
}
|
|
mnorm(u);
|
|
return (int) r;
|
|
}
|
|
|
|
// returns u + v
|
|
|
|
uint32_t *
|
|
madd(uint32_t *u, uint32_t *v)
|
|
{
|
|
int i, nu, nv, nw;
|
|
uint64_t t;
|
|
uint32_t *w;
|
|
nu = MLENGTH(u);
|
|
nv = MLENGTH(v);
|
|
if (nu > nv)
|
|
nw = nu + 1;
|
|
else
|
|
nw = nv + 1;
|
|
w = mnew(nw);
|
|
for (i = 0; i < nu; i++)
|
|
w[i] = u[i];
|
|
for (i = nu; i < nw; i++)
|
|
w[i] = 0;
|
|
t = 0;
|
|
for (i = 0; i < nv; i++) {
|
|
t += (uint64_t) w[i] + v[i];
|
|
w[i] = (uint32_t) t;
|
|
t >>= 32;
|
|
}
|
|
for (i = nv; i < nw; i++) {
|
|
t += w[i];
|
|
w[i] = (uint32_t) t;
|
|
t >>= 32;
|
|
}
|
|
mnorm(w);
|
|
return w;
|
|
}
|
|
|
|
// returns u - v
|
|
|
|
uint32_t *
|
|
msub(uint32_t *u, uint32_t *v)
|
|
{
|
|
int i, nu, nv, nw;
|
|
uint64_t t;
|
|
uint32_t *w;
|
|
nu = MLENGTH(u);
|
|
nv = MLENGTH(v);
|
|
if (nu > nv)
|
|
nw = nu;
|
|
else
|
|
nw = nv;
|
|
w = mnew(nw);
|
|
for (i = 0; i < nu; i++)
|
|
w[i] = u[i];
|
|
for (i = nu; i < nw; i++)
|
|
w[i] = 0;
|
|
t = 0;
|
|
for (i = 0; i < nv; i++) {
|
|
t += (uint64_t) w[i] - v[i];
|
|
w[i] = (uint32_t) t;
|
|
t = (int64_t) t >> 32; // cast to extend sign
|
|
}
|
|
for (i = nv; i < nw; i++) {
|
|
t += w[i];
|
|
w[i] = (uint32_t) t;
|
|
t = (int64_t) t >> 32; // cast to extend sign
|
|
}
|
|
mnorm(w);
|
|
return w;
|
|
}
|
|
|
|
// returns u * v
|
|
|
|
uint32_t *
|
|
mmul(uint32_t *u, uint32_t *v)
|
|
{
|
|
int i, j, nu, nv, nw;
|
|
uint64_t t;
|
|
uint32_t *w;
|
|
nu = MLENGTH(u);
|
|
nv = MLENGTH(v);
|
|
nw = nu + nv;
|
|
w = mnew(nw);
|
|
for (i = 0; i < nw; i++)
|
|
w[i] = 0;
|
|
for (i = 0; i < nu; i++) {
|
|
t = 0;
|
|
for (j = 0; j < nv; j++) {
|
|
t += (uint64_t) u[i] * v[j] + w[i + j];
|
|
w[i + j] = (uint32_t) t;
|
|
t >>= 32;
|
|
}
|
|
w[i + j] = (uint32_t) t;
|
|
}
|
|
mnorm(w);
|
|
return w;
|
|
}
|
|
|
|
// returns floor(u / v)
|
|
|
|
uint32_t *
|
|
mdiv(uint32_t *u, uint32_t *v)
|
|
{
|
|
int i, k, nu, nv;
|
|
uint32_t *q, qhat, *w;
|
|
uint64_t a, b, t;
|
|
mnorm(u);
|
|
mnorm(v);
|
|
if (MLENGTH(v) == 1 && v[0] == 0)
|
|
stopf("divide by zero"); // v = 0
|
|
nu = MLENGTH(u);
|
|
nv = MLENGTH(v);
|
|
k = nu - nv;
|
|
if (k < 0) {
|
|
q = mnew(1);
|
|
q[0] = 0;
|
|
return q; // u < v, return zero
|
|
}
|
|
u = mcopy(u);
|
|
q = mnew(k + 1);
|
|
w = mnew(nv + 1);
|
|
b = v[nv - 1];
|
|
do {
|
|
q[k] = 0;
|
|
while (nu >= nv + k) {
|
|
// estimate 32-bit partial quotient
|
|
a = u[nu - 1];
|
|
if (nu > nv + k)
|
|
a = a << 32 | u[nu - 2];
|
|
if (a < b)
|
|
break;
|
|
qhat = (uint32_t) (a / (b + 1));
|
|
if (qhat == 0)
|
|
qhat = 1;
|
|
// w = qhat * v
|
|
t = 0;
|
|
for (i = 0; i < nv; i++) {
|
|
t += (uint64_t) qhat * v[i];
|
|
w[i] = (uint32_t) t;
|
|
t >>= 32;
|
|
}
|
|
w[nv] = (uint32_t) t;
|
|
// u = u - w
|
|
t = 0;
|
|
for (i = k; i < nu; i++) {
|
|
t += (uint64_t) u[i] - w[i - k];
|
|
u[i] = (uint32_t) t;
|
|
t = (int64_t) t >> 32; // cast to extend sign
|
|
}
|
|
if (t) {
|
|
// u is negative, restore u
|
|
t = 0;
|
|
for (i = k; i < nu; i++) {
|
|
t += (uint64_t) u[i] + w[i - k];
|
|
u[i] = (uint32_t) t;
|
|
t >>= 32;
|
|
}
|
|
break;
|
|
}
|
|
q[k] += qhat;
|
|
mnorm(u);
|
|
nu = MLENGTH(u);
|
|
}
|
|
} while (--k >= 0);
|
|
mnorm(q);
|
|
mfree(u);
|
|
mfree(w);
|
|
return q;
|
|
}
|
|
|
|
// returns u mod v
|
|
|
|
uint32_t *
|
|
mmod(uint32_t *u, uint32_t *v)
|
|
{
|
|
int i, k, nu, nv;
|
|
uint32_t qhat, *w;
|
|
uint64_t a, b, t;
|
|
mnorm(u);
|
|
mnorm(v);
|
|
if (MLENGTH(v) == 1 && v[0] == 0)
|
|
stopf("divide by zero"); // v = 0
|
|
u = mcopy(u);
|
|
nu = MLENGTH(u);
|
|
nv = MLENGTH(v);
|
|
k = nu - nv;
|
|
if (k < 0)
|
|
return u; // u < v
|
|
w = mnew(nv + 1);
|
|
b = v[nv - 1];
|
|
do {
|
|
while (nu >= nv + k) {
|
|
// estimate 32-bit partial quotient
|
|
a = u[nu - 1];
|
|
if (nu > nv + k)
|
|
a = a << 32 | u[nu - 2];
|
|
if (a < b)
|
|
break;
|
|
qhat = (uint32_t) (a / (b + 1));
|
|
if (qhat == 0)
|
|
qhat = 1;
|
|
// w = qhat * v
|
|
t = 0;
|
|
for (i = 0; i < nv; i++) {
|
|
t += (uint64_t) qhat * v[i];
|
|
w[i] = (uint32_t) t;
|
|
t >>= 32;
|
|
}
|
|
w[nv] = (uint32_t) t;
|
|
// u = u - w
|
|
t = 0;
|
|
for (i = k; i < nu; i++) {
|
|
t += (uint64_t) u[i] - w[i - k];
|
|
u[i] = (uint32_t) t;
|
|
t = (int64_t) t >> 32; // cast to extend sign
|
|
}
|
|
if (t) {
|
|
// u is negative, restore u
|
|
t = 0;
|
|
for (i = k; i < nu; i++) {
|
|
t += (uint64_t) u[i] + w[i - k];
|
|
u[i] = (uint32_t) t;
|
|
t >>= 32;
|
|
}
|
|
break;
|
|
}
|
|
mnorm(u);
|
|
nu = MLENGTH(u);
|
|
}
|
|
} while (--k >= 0);
|
|
mfree(w);
|
|
return u;
|
|
}
|
|
|
|
// returns u ** v
|
|
|
|
uint32_t *
|
|
mpow(uint32_t *u, uint32_t *v)
|
|
{
|
|
uint32_t *t, *w;
|
|
u = mcopy(u);
|
|
v = mcopy(v);
|
|
// w = 1
|
|
w = mnew(1);
|
|
w[0] = 1;
|
|
for (;;) {
|
|
if (v[0] & 1) {
|
|
// w = w * u
|
|
t = mmul(w, u);
|
|
mfree(w);
|
|
w = t;
|
|
}
|
|
// v = v >> 1
|
|
mshr(v);
|
|
// v = 0?
|
|
if (MLENGTH(v) == 1 && v[0] == 0)
|
|
break;
|
|
// u = u * u
|
|
t = mmul(u, u);
|
|
mfree(u);
|
|
u = t;
|
|
}
|
|
mfree(u);
|
|
mfree(v);
|
|
return w;
|
|
}
|
|
|
|
// u = u >> 1
|
|
|
|
void
|
|
mshr(uint32_t *u)
|
|
{
|
|
int i;
|
|
for (i = 0; i < MLENGTH(u) - 1; i++) {
|
|
u[i] >>= 1;
|
|
if (u[i + 1] & 1)
|
|
u[i] |= 0x80000000;
|
|
}
|
|
u[i] >>= 1;
|
|
mnorm(u);
|
|
}
|
|
|
|
// compare u and v
|
|
|
|
int
|
|
mcmp(uint32_t *u, uint32_t *v)
|
|
{
|
|
int i;
|
|
mnorm(u);
|
|
mnorm(v);
|
|
if (MLENGTH(u) < MLENGTH(v))
|
|
return -1;
|
|
if (MLENGTH(u) > MLENGTH(v))
|
|
return 1;
|
|
for (i = MLENGTH(u) - 1; i >= 0; i--) {
|
|
if (u[i] < v[i])
|
|
return -1;
|
|
if (u[i] > v[i])
|
|
return 1;
|
|
}
|
|
return 0; // u = v
|
|
}
|
|
|
|
int
|
|
meq(uint32_t *u, uint32_t *v)
|
|
{
|
|
int i;
|
|
if (MLENGTH(u) != MLENGTH(v))
|
|
return 0;
|
|
for (i = 0; i < MLENGTH(u); i++)
|
|
if (u[i] != v[i])
|
|
return 0;
|
|
return 1;
|
|
}
|
|
|
|
// convert unsigned to bignum
|
|
|
|
uint32_t *
|
|
mint(uint32_t n)
|
|
{
|
|
uint32_t *p;
|
|
p = mnew(1);
|
|
p[0] = n;
|
|
return p;
|
|
}
|
|
|
|
uint32_t *
|
|
mnew(int n)
|
|
{
|
|
uint32_t *u;
|
|
u = alloc_mem((n + 1) * sizeof (uint32_t));
|
|
bignum_count++;
|
|
*u = n;
|
|
return u + 1;
|
|
}
|
|
|
|
void
|
|
mfree(uint32_t *u)
|
|
{
|
|
free(u - 1);
|
|
bignum_count--;
|
|
}
|
|
|
|
uint32_t *
|
|
mcopy(uint32_t *u)
|
|
{
|
|
int i;
|
|
uint32_t *v;
|
|
v = mnew(MLENGTH(u));
|
|
for (i = 0; i < MLENGTH(u); i++)
|
|
v[i] = u[i];
|
|
return v;
|
|
}
|
|
|
|
// remove leading zeroes
|
|
|
|
void
|
|
mnorm(uint32_t *u)
|
|
{
|
|
while (MLENGTH(u) > 1 && u[MLENGTH(u) - 1] == 0)
|
|
MLENGTH(u)--;
|
|
}
|
|
|
|
uint32_t *
|
|
mgcd(uint32_t *u, uint32_t *v)
|
|
{
|
|
int i, k, n, sign;
|
|
uint32_t *t;
|
|
|
|
if (MZERO(u)) {
|
|
t = mcopy(v);
|
|
return t;
|
|
}
|
|
|
|
if (MZERO(v)) {
|
|
t = mcopy(u);
|
|
return t;
|
|
}
|
|
|
|
u = mcopy(u);
|
|
v = mcopy(v);
|
|
|
|
k = 0;
|
|
|
|
while ((u[0] & 1) == 0 && (v[0] & 1) == 0) {
|
|
mshr(u);
|
|
mshr(v);
|
|
k++;
|
|
}
|
|
|
|
if (u[0] & 1) {
|
|
t = mcopy(v);
|
|
sign = -1;
|
|
} else {
|
|
t = mcopy(u);
|
|
sign = 1;
|
|
}
|
|
|
|
while (1) {
|
|
|
|
while ((t[0] & 1) == 0)
|
|
mshr(t);
|
|
|
|
if (sign == 1) {
|
|
mfree(u);
|
|
u = mcopy(t);
|
|
} else {
|
|
mfree(v);
|
|
v = mcopy(t);
|
|
}
|
|
|
|
mfree(t);
|
|
|
|
if (mcmp(u, v) < 0) {
|
|
t = msub(v, u);
|
|
sign = -1;
|
|
} else {
|
|
t = msub(u, v);
|
|
sign = 1;
|
|
}
|
|
|
|
if (MZERO(t)) {
|
|
mfree(t);
|
|
mfree(v);
|
|
n = (k / 32) + 1;
|
|
v = mnew(n);
|
|
for (i = 0; i < n; i++)
|
|
v[i] = 0;
|
|
msetbit(v, k);
|
|
t = mmul(u, v);
|
|
mfree(u);
|
|
mfree(v);
|
|
return t;
|
|
}
|
|
}
|
|
}
|
|
|
|
// returns NULL if not perfect root, otherwise returns a^(1/n)
|
|
|
|
uint32_t *
|
|
mroot(uint32_t *a, uint32_t *n)
|
|
{
|
|
int i, j, k;
|
|
uint32_t *b, *c, m;
|
|
|
|
if (MLENGTH(n) > 1 || n[0] == 0)
|
|
return NULL;
|
|
|
|
// k is bit length of a
|
|
|
|
k = 32 * (MLENGTH(a) - 1);
|
|
|
|
m = a[MLENGTH(a) - 1];
|
|
|
|
while (m) {
|
|
m >>= 1;
|
|
k++;
|
|
}
|
|
|
|
if (k == 0)
|
|
return mint(0);
|
|
|
|
// initial guess of index of ms bit in result
|
|
|
|
k = (k - 1) / n[0];
|
|
|
|
j = k / 32 + 1; // k is bit index, not number of bits
|
|
|
|
b = mnew(j);
|
|
|
|
for (i = 0; i < j; i++)
|
|
b[i] = 0;
|
|
|
|
while (k >= 0) {
|
|
msetbit(b, k);
|
|
mnorm(b);
|
|
c = mpow(b, n);
|
|
switch (mcmp(c, a)) {
|
|
case -1:
|
|
break;
|
|
case 0:
|
|
mfree(c);
|
|
return b;
|
|
case 1:
|
|
mclrbit(b, k);
|
|
break;
|
|
}
|
|
mfree(c);
|
|
k--;
|
|
}
|
|
|
|
mfree(b);
|
|
|
|
return NULL;
|
|
}
|
|
// create a list from n things on the stack
|
|
|
|
void
|
|
list(int n)
|
|
{
|
|
int i;
|
|
push_symbol(NIL);
|
|
for (i = 0; i < n; i++)
|
|
cons();
|
|
}
|
|
|
|
void
|
|
cons(void)
|
|
{
|
|
struct atom *p;
|
|
p = alloc_atom();
|
|
p->atomtype = CONS;
|
|
p->u.cons.cdr = pop();
|
|
p->u.cons.car = pop();
|
|
push(p);
|
|
}
|
|
|
|
int
|
|
lengthf(struct atom *p)
|
|
{
|
|
int n = 0;
|
|
while (iscons(p)) {
|
|
n++;
|
|
p = cdr(p);
|
|
}
|
|
return n;
|
|
}
|
|
|
|
// returns 1 if expr p contains expr q, otherwise returns 0
|
|
|
|
int
|
|
findf(struct atom *p, struct atom *q)
|
|
{
|
|
int i;
|
|
|
|
if (equal(p, q))
|
|
return 1;
|
|
|
|
if (istensor(p)) {
|
|
for (i = 0; i < p->u.tensor->nelem; i++)
|
|
if (findf(p->u.tensor->elem[i], q))
|
|
return 1;
|
|
return 0;
|
|
}
|
|
|
|
while (iscons(p)) {
|
|
if (findf(car(p), q))
|
|
return 1;
|
|
p = cdr(p);
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
// sort n things on the stack
|
|
|
|
void
|
|
sort(int n)
|
|
{
|
|
qsort(stack + tos - n, n, sizeof (struct atom *), sort_func);
|
|
}
|
|
|
|
int
|
|
sort_func(const void *p1, const void *p2)
|
|
{
|
|
return cmp(*((struct atom **) p1), *((struct atom **) p2));
|
|
}
|
|
|
|
int
|
|
cmp(struct atom *p1, struct atom *p2)
|
|
{
|
|
int t;
|
|
|
|
if (p1 == p2)
|
|
return 0;
|
|
|
|
if (p1 == symbol(NIL))
|
|
return -1;
|
|
|
|
if (p2 == symbol(NIL))
|
|
return 1;
|
|
|
|
if (isnum(p1) && isnum(p2))
|
|
return cmp_numbers(p1, p2);
|
|
|
|
if (isnum(p1))
|
|
return -1;
|
|
|
|
if (isnum(p2))
|
|
return 1;
|
|
|
|
if (isstr(p1) && isstr(p2))
|
|
return strcmp(p1->u.str, p2->u.str);
|
|
|
|
if (isstr(p1))
|
|
return -1;
|
|
|
|
if (isstr(p2))
|
|
return 1;
|
|
|
|
if (issymbol(p1) && issymbol(p2))
|
|
return strcmp(printname(p1), printname(p2));
|
|
|
|
if (issymbol(p1))
|
|
return -1;
|
|
|
|
if (issymbol(p2))
|
|
return 1;
|
|
|
|
if (istensor(p1) && istensor(p2))
|
|
return cmp_tensors(p1, p2);
|
|
|
|
if (istensor(p1))
|
|
return -1;
|
|
|
|
if (istensor(p2))
|
|
return 1;
|
|
|
|
while (iscons(p1) && iscons(p2)) {
|
|
t = cmp(car(p1), car(p2));
|
|
if (t)
|
|
return t;
|
|
p1 = cdr(p1);
|
|
p2 = cdr(p2);
|
|
}
|
|
|
|
if (iscons(p2))
|
|
return -1; // lengthf(p1) < lengthf(p2)
|
|
|
|
if (iscons(p1))
|
|
return 1; // lengthf(p1) > lengthf(p2)
|
|
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
cmp_numbers(struct atom *p1, struct atom *p2)
|
|
{
|
|
double d1, d2;
|
|
|
|
if (isrational(p1) && isrational(p2))
|
|
return cmp_rationals(p1, p2);
|
|
|
|
push(p1);
|
|
d1 = pop_double();
|
|
|
|
push(p2);
|
|
d2 = pop_double();
|
|
|
|
if (d1 < d2)
|
|
return -1;
|
|
|
|
if (d1 > d2)
|
|
return 1;
|
|
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
cmp_rationals(struct atom *a, struct atom *b)
|
|
{
|
|
int t;
|
|
uint32_t *ab, *ba;
|
|
if (a->sign == MMINUS && b->sign == MPLUS)
|
|
return -1;
|
|
if (a->sign == MPLUS && b->sign == MMINUS)
|
|
return 1;
|
|
if (isinteger(a) && isinteger(b)) {
|
|
if (a->sign == MMINUS)
|
|
return mcmp(b->u.q.a, a->u.q.a);
|
|
else
|
|
return mcmp(a->u.q.a, b->u.q.a);
|
|
}
|
|
ab = mmul(a->u.q.a, b->u.q.b);
|
|
ba = mmul(a->u.q.b, b->u.q.a);
|
|
if (a->sign == MMINUS)
|
|
t = mcmp(ba, ab);
|
|
else
|
|
t = mcmp(ab, ba);
|
|
mfree(ab);
|
|
mfree(ba);
|
|
return t;
|
|
}
|
|
|
|
int
|
|
cmp_tensors(struct atom *p1, struct atom *p2)
|
|
{
|
|
int i, t;
|
|
|
|
t = p1->u.tensor->ndim - p2->u.tensor->ndim;
|
|
|
|
if (t)
|
|
return t;
|
|
|
|
for (i = 0; i < p1->u.tensor->ndim; i++) {
|
|
t = p1->u.tensor->dim[i] - p2->u.tensor->dim[i];
|
|
if (t)
|
|
return t;
|
|
}
|
|
|
|
for (i = 0; i < p1->u.tensor->nelem; i++) {
|
|
t = cmp(p1->u.tensor->elem[i], p2->u.tensor->elem[i]);
|
|
if (t)
|
|
return t;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
find_denominator(struct atom *p)
|
|
{
|
|
struct atom *q;
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
q = car(p);
|
|
if (car(q) == symbol(POWER) && isnegativenumber(caddr(q)))
|
|
return 1;
|
|
p = cdr(p);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
count_denominators(struct atom *p)
|
|
{
|
|
int n = 0;
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
if (isdenominator(car(p)))
|
|
n++;
|
|
p = cdr(p);
|
|
}
|
|
return n;
|
|
}
|
|
|
|
int
|
|
count_numerators(struct atom *p)
|
|
{
|
|
int n = 0;
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
if (isnumerator(car(p)))
|
|
n++;
|
|
p = cdr(p);
|
|
}
|
|
return n;
|
|
}
|
|
|
|
// cannot do any evalf in subst because subst is used by func defn
|
|
|
|
void
|
|
subst(void)
|
|
{
|
|
int h, i, n;
|
|
struct atom *p1, *p2, *p3;
|
|
|
|
p3 = pop(); // new expr
|
|
p2 = pop(); // old expr
|
|
p1 = pop(); // expr
|
|
|
|
if (p2 == symbol(NIL) || p3 == symbol(NIL)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
push(p2);
|
|
push(p3);
|
|
subst();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (equal(p1, p2)) {
|
|
push(p3);
|
|
return;
|
|
}
|
|
|
|
if (!iscons(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
// depth first
|
|
|
|
h = tos;
|
|
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
push(p2);
|
|
push(p3);
|
|
subst();
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
list(tos - h);
|
|
}
|
|
// automatic variables not visible to the garbage collector are reclaimed
|
|
|
|
void
|
|
evalg(void)
|
|
{
|
|
if (gc_level == eval_level && alloc_count > MAXBLOCKS * BLOCKSIZE / 10)
|
|
gc();
|
|
gc_level++;
|
|
evalf();
|
|
gc_level--;
|
|
}
|
|
|
|
// call evalf instead of evalg to evaluate without garbage collection
|
|
|
|
void
|
|
evalf(void)
|
|
{
|
|
struct atom *p;
|
|
eval_level++;
|
|
p = pop();
|
|
push(p); // make visible to garbage collector
|
|
evalf_nib(p);
|
|
p = pop();
|
|
pop(); // remove
|
|
push(p);
|
|
eval_level--;
|
|
}
|
|
|
|
void
|
|
evalf_nib(struct atom *p1)
|
|
{
|
|
if (interrupt)
|
|
stopf("interrupt");
|
|
|
|
// this is needed to prevent seg fault (STACKSIZE is greater than process stack)
|
|
|
|
if (eval_level > 1000)
|
|
stopf("evaluation depth exceeded, possibly due to recursive function or circular symbol definition");
|
|
|
|
if (eval_level > max_eval_level)
|
|
max_eval_level = eval_level;
|
|
|
|
if (iscons(p1) && iskeyword(car(p1))) {
|
|
expanding++;
|
|
car(p1)->u.ksym.func(p1); // call through function pointer
|
|
expanding--;
|
|
return;
|
|
}
|
|
|
|
if (iscons(p1) && isusersymbol(car(p1))) {
|
|
eval_user_function(p1);
|
|
return;
|
|
}
|
|
|
|
if (iskeyword(p1)) { // bare keyword
|
|
push(p1);
|
|
push_symbol(LAST); // default arg
|
|
list(2);
|
|
evalg();
|
|
return;
|
|
}
|
|
|
|
if (isusersymbol(p1)) {
|
|
eval_user_symbol(p1);
|
|
return;
|
|
}
|
|
|
|
if (istensor(p1)) {
|
|
eval_tensor(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1); // rational, double, or string
|
|
}
|
|
|
|
// evaluate '=' as '=='
|
|
|
|
void
|
|
evalp(void)
|
|
{
|
|
struct atom *p1;
|
|
p1 = pop();
|
|
if (car(p1) == symbol(SETQ)) {
|
|
push_symbol(TESTEQ);
|
|
push(cadr(p1));
|
|
push(caddr(p1));
|
|
list(3);
|
|
p1 = pop();
|
|
}
|
|
push(p1);
|
|
evalg();
|
|
}
|
|
void
|
|
eval_abs(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
absfunc();
|
|
}
|
|
|
|
void
|
|
absfunc(void)
|
|
{
|
|
int h;
|
|
struct atom *p1, *p2, *p3;
|
|
|
|
p1 = pop();
|
|
|
|
if (isnum(p1)) {
|
|
push(p1);
|
|
if (isnegativenumber(p1))
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
if (istensor(p1)) {
|
|
if (p1->u.tensor->ndim > 1) {
|
|
push_symbol(ABS);
|
|
push(p1);
|
|
list(2);
|
|
return;
|
|
}
|
|
push(p1);
|
|
push(p1);
|
|
conjfunc();
|
|
inner();
|
|
push_rational(1, 2);
|
|
power();
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
push(p1);
|
|
conjfunc();
|
|
multiply();
|
|
push_rational(1, 2);
|
|
power();
|
|
|
|
p2 = pop();
|
|
push(p2);
|
|
floatfunc();
|
|
p3 = pop();
|
|
if (isdouble(p3)) {
|
|
push(p2);
|
|
if (isnegativenumber(p3))
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
// abs(1/a) evaluates to 1/abs(a)
|
|
|
|
if (car(p1) == symbol(POWER) && isnegativeterm(caddr(p1))) {
|
|
push(p1);
|
|
reciprocate();
|
|
absfunc();
|
|
reciprocate();
|
|
return;
|
|
}
|
|
|
|
// abs(a*b) evaluates to abs(a)*abs(b)
|
|
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
h = tos;
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
absfunc();
|
|
p1 = cdr(p1);
|
|
}
|
|
multiply_factors(tos - h);
|
|
return;
|
|
}
|
|
|
|
if (isnegativeterm(p1) || (car(p1) == symbol(ADD) && isnegativeterm(cadr(p1)))) {
|
|
push(p1);
|
|
negate();
|
|
p1 = pop();
|
|
}
|
|
|
|
push_symbol(ABS);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_add(struct atom *p1)
|
|
{
|
|
int h = tos;
|
|
expanding--; // undo expanding++ in evalf
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalg();
|
|
p1 = cdr(p1);
|
|
}
|
|
add_terms(tos - h);
|
|
expanding++;
|
|
}
|
|
|
|
void
|
|
add(void)
|
|
{
|
|
add_terms(2);
|
|
}
|
|
|
|
void
|
|
add_terms(int n)
|
|
{
|
|
int h, i;
|
|
struct atom *p, *T;
|
|
|
|
if (n < 2)
|
|
return;
|
|
|
|
h = tos - n;
|
|
|
|
flatten_terms(h);
|
|
|
|
T = combine_tensors(h);
|
|
|
|
combine_terms(h);
|
|
normalize_terms(h);
|
|
|
|
n = tos - h;
|
|
|
|
if (n == 0) {
|
|
if (istensor(T))
|
|
push(T);
|
|
else
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
if (n > 1) {
|
|
list(n);
|
|
push_symbol(ADD);
|
|
swap();
|
|
cons(); // prepend ADD to list
|
|
}
|
|
|
|
if (!istensor(T))
|
|
return;
|
|
|
|
// add scalar p to every element of T, as is done in R
|
|
|
|
p = pop();
|
|
T = copy_tensor(T);
|
|
n = T->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(T->u.tensor->elem[i]);
|
|
push(p);
|
|
add();
|
|
T->u.tensor->elem[i] = pop();
|
|
}
|
|
push(T);
|
|
}
|
|
|
|
void
|
|
flatten_terms(int h)
|
|
{
|
|
int i, n;
|
|
struct atom *p1;
|
|
n = tos;
|
|
for (i = h; i < n; i++) {
|
|
p1 = stack[i];
|
|
if (car(p1) == symbol(ADD)) {
|
|
stack[i] = cadr(p1);
|
|
p1 = cddr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
struct atom *
|
|
combine_tensors(int h)
|
|
{
|
|
int i;
|
|
struct atom *p1, *T;
|
|
T = symbol(NIL);
|
|
for (i = h; i < tos; i++) {
|
|
p1 = stack[i];
|
|
if (istensor(p1)) {
|
|
if (istensor(T)) {
|
|
push(T);
|
|
push(p1);
|
|
add_tensors();
|
|
T = pop();
|
|
} else
|
|
T = p1;
|
|
slice(i, 1);
|
|
i--; // use same index again
|
|
}
|
|
}
|
|
return T;
|
|
}
|
|
|
|
void
|
|
add_tensors(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1, *p2;
|
|
|
|
p2 = pop();
|
|
p1 = pop();
|
|
|
|
if (!compatible_dimensions(p1, p2))
|
|
stopf("incompatible tensor arithmetic");
|
|
|
|
p1 = copy_tensor(p1);
|
|
|
|
n = p1->u.tensor->nelem;
|
|
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
push(p2->u.tensor->elem[i]);
|
|
add();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
|
|
push(p1);
|
|
}
|
|
|
|
void
|
|
combine_terms(int h)
|
|
{
|
|
int i;
|
|
sort_terms(h);
|
|
for (i = h; i < tos; i++) {
|
|
if (iszero(stack[i])) {
|
|
slice(i, 1); // remove
|
|
i--; // use same index again
|
|
} else if (i + 1 < tos && combine_terms_nib(i)) {
|
|
slice(i + 1, 1); // remove
|
|
i--; // use same index again
|
|
}
|
|
}
|
|
}
|
|
|
|
int
|
|
combine_terms_nib(int i)
|
|
{
|
|
int denorm;
|
|
struct atom *coeff1, *coeff2, *p1, *p2;
|
|
|
|
p1 = stack[i];
|
|
p2 = stack[i + 1];
|
|
|
|
if (isnum(p1) && isnum(p2)) {
|
|
add_numbers(p1, p2);
|
|
stack[i] = pop();
|
|
return 1;
|
|
}
|
|
|
|
if (isnum(p1) || isnum(p2))
|
|
return 0; // cannot add number and something else
|
|
|
|
coeff1 = one;
|
|
coeff2 = one;
|
|
|
|
denorm = 0;
|
|
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
p1 = cdr(p1);
|
|
denorm = 1;
|
|
if (isnum(car(p1))) {
|
|
coeff1 = car(p1);
|
|
p1 = cdr(p1);
|
|
if (cdr(p1) == symbol(NIL)) {
|
|
p1 = car(p1);
|
|
denorm = 0;
|
|
}
|
|
}
|
|
}
|
|
|
|
if (car(p2) == symbol(MULTIPLY)) {
|
|
p2 = cdr(p2);
|
|
if (isnum(car(p2))) {
|
|
coeff2 = car(p2);
|
|
p2 = cdr(p2);
|
|
if (cdr(p2) == symbol(NIL))
|
|
p2 = car(p2);
|
|
}
|
|
}
|
|
|
|
if (!equal(p1, p2))
|
|
return 0;
|
|
|
|
add_numbers(coeff1, coeff2);
|
|
|
|
coeff1 = pop();
|
|
|
|
if (iszero(coeff1)) {
|
|
stack[i] = coeff1;
|
|
return 1;
|
|
}
|
|
|
|
if (isplusone(coeff1) && !isdouble(coeff1)) {
|
|
if (denorm) {
|
|
push_symbol(MULTIPLY);
|
|
push(p1); // p1 is a list, not an atom
|
|
cons(); // prepend MULTIPLY
|
|
} else
|
|
push(p1);
|
|
} else {
|
|
if (denorm) {
|
|
push_symbol(MULTIPLY);
|
|
push(coeff1);
|
|
push(p1); // p1 is a list, not an atom
|
|
cons(); // prepend coeff1
|
|
cons(); // prepend MULTIPLY
|
|
} else {
|
|
push_symbol(MULTIPLY);
|
|
push(coeff1);
|
|
push(p1);
|
|
list(3);
|
|
}
|
|
}
|
|
|
|
stack[i] = pop();
|
|
|
|
return 1;
|
|
}
|
|
|
|
void
|
|
sort_terms(int h)
|
|
{
|
|
qsort(stack + h, tos - h, sizeof (struct atom *), sort_terms_func);
|
|
}
|
|
|
|
int
|
|
sort_terms_func(const void *q1, const void *q2)
|
|
{
|
|
return cmp_terms(*((struct atom **) q1), *((struct atom **) q2));
|
|
}
|
|
|
|
int
|
|
cmp_terms(struct atom *p1, struct atom *p2)
|
|
{
|
|
int a, b, c;
|
|
|
|
// 1st level: imaginary terms on the right
|
|
|
|
a = isimaginaryterm(p1);
|
|
b = isimaginaryterm(p2);
|
|
|
|
if (a == 0 && b == 1)
|
|
return -1; // ok
|
|
|
|
if (a == 1 && b == 0)
|
|
return 1; // out of order
|
|
|
|
// 2nd level: numericals on the right
|
|
|
|
if (isnum(p1) && isnum(p2))
|
|
return 0; // don't care about order, save time, don't compare
|
|
|
|
if (isnum(p1))
|
|
return 1; // out of order
|
|
|
|
if (isnum(p2))
|
|
return -1; // ok
|
|
|
|
// 3rd level: sort by factors
|
|
|
|
a = 0;
|
|
b = 0;
|
|
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
p1 = cdr(p1);
|
|
a = 1; // p1 is a list of factors
|
|
if (isnum(car(p1))) {
|
|
// skip over coeff
|
|
p1 = cdr(p1);
|
|
if (cdr(p1) == symbol(NIL)) {
|
|
p1 = car(p1);
|
|
a = 0;
|
|
}
|
|
}
|
|
}
|
|
|
|
if (car(p2) == symbol(MULTIPLY)) {
|
|
p2 = cdr(p2);
|
|
b = 1; // p2 is a list of factors
|
|
if (isnum(car(p2))) {
|
|
// skip over coeff
|
|
p2 = cdr(p2);
|
|
if (cdr(p2) == symbol(NIL)) {
|
|
p2 = car(p2);
|
|
b = 0;
|
|
}
|
|
}
|
|
}
|
|
|
|
if (a == 0 && b == 0)
|
|
return cmp_factors(p1, p2);
|
|
|
|
if (a == 0 && b == 1) {
|
|
c = cmp_factors(p1, car(p2));
|
|
if (c == 0)
|
|
c = -1; // lengthf(p1) < lengthf(p2)
|
|
return c;
|
|
}
|
|
|
|
if (a == 1 && b == 0) {
|
|
c = cmp_factors(car(p1), p2);
|
|
if (c == 0)
|
|
c = 1; // lengthf(p1) > lengthf(p2)
|
|
return c;
|
|
}
|
|
|
|
while (iscons(p1) && iscons(p2)) {
|
|
c = cmp_factors(car(p1), car(p2));
|
|
if (c)
|
|
return c;
|
|
p1 = cdr(p1);
|
|
p2 = cdr(p2);
|
|
}
|
|
|
|
if (iscons(p1))
|
|
return 1; // lengthf(p1) > lengthf(p2)
|
|
|
|
if (iscons(p2))
|
|
return -1; // lengthf(p1) < lengthf(p2)
|
|
|
|
return 0;
|
|
}
|
|
|
|
// for example, sqrt(1/2) + sqrt(1/2) -> 2 sqrt(1/2) -> sqrt(2)
|
|
|
|
void
|
|
normalize_terms(int h)
|
|
{
|
|
int i, n;
|
|
struct atom *p;
|
|
n = 0;
|
|
for (i = h; i < tos; i++) {
|
|
p = stack[i];
|
|
if (isradicalterm(p)) {
|
|
push(p);
|
|
evalf();
|
|
stack[i] = pop();
|
|
n++;
|
|
}
|
|
}
|
|
if (n)
|
|
combine_terms(h);
|
|
}
|
|
|
|
void
|
|
add_numbers(struct atom *p1, struct atom *p2)
|
|
{
|
|
double d1, d2;
|
|
|
|
if (isrational(p1) && isrational(p2)) {
|
|
add_rationals(p1, p2);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
d1 = pop_double();
|
|
|
|
push(p2);
|
|
d2 = pop_double();
|
|
|
|
push_double(d1 + d2);
|
|
}
|
|
|
|
void
|
|
add_rationals(struct atom *p1, struct atom *p2)
|
|
{
|
|
int sign;
|
|
uint32_t *a, *ab, *b, *ba, *c;
|
|
|
|
if (iszero(p1)) {
|
|
push(p2);
|
|
return;
|
|
}
|
|
|
|
if (iszero(p2)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isinteger(p1) && isinteger(p2)) {
|
|
add_integers(p1, p2);
|
|
return;
|
|
}
|
|
|
|
ab = mmul(p1->u.q.a, p2->u.q.b);
|
|
ba = mmul(p1->u.q.b, p2->u.q.a);
|
|
|
|
if (p1->sign == p2->sign) {
|
|
a = madd(ab, ba);
|
|
sign = p1->sign;
|
|
} else {
|
|
switch (mcmp(ab, ba)) {
|
|
case 1:
|
|
a = msub(ab, ba);
|
|
sign = p1->sign;
|
|
break;
|
|
case 0:
|
|
push_integer(0);
|
|
mfree(ab);
|
|
mfree(ba);
|
|
return;
|
|
case -1:
|
|
a = msub(ba, ab);
|
|
sign = p2->sign;
|
|
break;
|
|
default:
|
|
// never gets here, fix compiler warning
|
|
return;
|
|
}
|
|
}
|
|
|
|
mfree(ab);
|
|
mfree(ba);
|
|
|
|
b = mmul(p1->u.q.b, p2->u.q.b);
|
|
c = mgcd(a, b);
|
|
|
|
push_bignum(sign, mdiv(a, c), mdiv(b, c));
|
|
|
|
mfree(a);
|
|
mfree(b);
|
|
mfree(c);
|
|
}
|
|
|
|
void
|
|
add_integers(struct atom *p1, struct atom *p2)
|
|
{
|
|
int sign = 0; // compiler nag
|
|
uint32_t *c = NULL; // compiler nag
|
|
if (p1->sign == p2->sign) {
|
|
c = madd(p1->u.q.a, p2->u.q.a);
|
|
sign = p1->sign;
|
|
} else {
|
|
switch (mcmp(p1->u.q.a, p2->u.q.a)) {
|
|
case 1:
|
|
c = msub(p1->u.q.a, p2->u.q.a);
|
|
sign = p1->sign;
|
|
break;
|
|
case 0:
|
|
push_integer(0);
|
|
return;
|
|
case -1:
|
|
c = msub(p2->u.q.a, p1->u.q.a);
|
|
sign = p2->sign;
|
|
break;
|
|
default:
|
|
stopf("error");
|
|
}
|
|
}
|
|
push_bignum(sign, c, mint(1));
|
|
}
|
|
|
|
void
|
|
subtract(void)
|
|
{
|
|
negate();
|
|
add();
|
|
}
|
|
void
|
|
eval_adj(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
adj();
|
|
}
|
|
|
|
void
|
|
adj(void)
|
|
{
|
|
int col, i, j, k, n, row;
|
|
struct atom *p1, *p2, *p3;
|
|
|
|
p1 = pop();
|
|
|
|
if (!istensor(p1)) {
|
|
push_integer(1); // adj of scalar is 1 because adj = det inv
|
|
return;
|
|
}
|
|
|
|
if (!issquarematrix(p1))
|
|
stopf("adj: square matrix expected");
|
|
|
|
n = p1->u.tensor->dim[0];
|
|
|
|
// p2 is the adjunct matrix
|
|
|
|
p2 = alloc_matrix(n, n);
|
|
|
|
if (n == 2) {
|
|
p2->u.tensor->elem[0] = p1->u.tensor->elem[3];
|
|
push(p1->u.tensor->elem[1]);
|
|
negate();
|
|
p2->u.tensor->elem[1] = pop();
|
|
push(p1->u.tensor->elem[2]);
|
|
negate();
|
|
p2->u.tensor->elem[2] = pop();
|
|
p2->u.tensor->elem[3] = p1->u.tensor->elem[0];
|
|
push(p2);
|
|
return;
|
|
}
|
|
|
|
// p3 is for computing cofactors
|
|
|
|
p3 = alloc_matrix(n - 1, n - 1);
|
|
|
|
for (row = 0; row < n; row++) {
|
|
for (col = 0; col < n; col++) {
|
|
k = 0;
|
|
for (i = 0; i < n; i++)
|
|
for (j = 0; j < n; j++)
|
|
if (i != row && j != col)
|
|
p3->u.tensor->elem[k++] = p1->u.tensor->elem[n * i + j];
|
|
push(p3);
|
|
det();
|
|
if ((row + col) % 2)
|
|
negate();
|
|
p2->u.tensor->elem[n * col + row] = pop(); // transpose
|
|
}
|
|
}
|
|
|
|
push(p2);
|
|
}
|
|
void
|
|
eval_and(struct atom *p1)
|
|
{
|
|
struct atom *p2;
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalp();
|
|
p2 = pop();
|
|
if (iszero(p2)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
p1 = cdr(p1);
|
|
}
|
|
push_integer(1);
|
|
}
|
|
void
|
|
eval_arccos(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
arccos();
|
|
}
|
|
|
|
void
|
|
arccos(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
arccos();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
if (-1.0 <= d && d <= 1.0) {
|
|
d = acos(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
}
|
|
|
|
// arccos(z) = -i log(z + i sqrt(1 - z^2))
|
|
|
|
if (isdouble(p1) || isdoublez(p1)) {
|
|
push_double(1.0);
|
|
push(p1);
|
|
push(p1);
|
|
multiply();
|
|
subtract();
|
|
sqrtfunc();
|
|
push(imaginaryunit);
|
|
multiply();
|
|
push(p1);
|
|
add();
|
|
logfunc();
|
|
push(imaginaryunit);
|
|
multiply();
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
// arccos(1 / sqrt(2)) = 1/4 pi
|
|
|
|
if (isoneoversqrttwo(p1)) {
|
|
push_rational(1, 4);
|
|
push_symbol(PI);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// arccos(-1 / sqrt(2)) = 3/4 pi
|
|
|
|
if (isminusoneoversqrttwo(p1)) {
|
|
push_rational(3, 4);
|
|
push_symbol(PI);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// arccos(0) = 1/2 pi
|
|
|
|
if (iszero(p1)) {
|
|
push_rational(1, 2);
|
|
push_symbol(PI);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// arccos(1/2) = 1/3 pi
|
|
|
|
if (isequalq(p1, 1 ,2)) {
|
|
push_rational(1, 3);
|
|
push_symbol(PI);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// arccos(1) = 0
|
|
|
|
if (isplusone(p1)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
// arccos(-1/2) = 2/3 pi
|
|
|
|
if (isequalq(p1, -1, 2)) {
|
|
push_rational(2, 3);
|
|
push_symbol(PI);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// arccos(-1) = pi
|
|
|
|
if (isminusone(p1)) {
|
|
push_symbol(PI);
|
|
return;
|
|
}
|
|
|
|
push_symbol(ARCCOS);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_arccosh(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
arccosh();
|
|
}
|
|
|
|
void
|
|
arccosh(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
arccosh();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
if (d >= 1.0) {
|
|
d = acosh(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
}
|
|
|
|
// arccosh(z) = log(sqrt(z^2 - 1) + z)
|
|
|
|
if (isdouble(p1) || isdoublez(p1)) {
|
|
push(p1);
|
|
push(p1);
|
|
multiply();
|
|
push_double(-1.0);
|
|
add();
|
|
sqrtfunc();
|
|
push(p1);
|
|
add();
|
|
logfunc();
|
|
return;
|
|
}
|
|
|
|
if (isplusone(p1)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(COSH)) {
|
|
push(cadr(p1));
|
|
return;
|
|
}
|
|
|
|
push_symbol(ARCCOSH);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_arcsin(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
arcsin();
|
|
}
|
|
|
|
void
|
|
arcsin(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
arcsin();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
if (-1.0 <= d && d <= 1.0) {
|
|
d = asin(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
}
|
|
|
|
// arcsin(z) = -i log(i z + sqrt(1 - z^2))
|
|
|
|
if (isdouble(p1) || isdoublez(p1)) {
|
|
push(imaginaryunit);
|
|
negate();
|
|
push(imaginaryunit);
|
|
push(p1);
|
|
multiply();
|
|
push_double(1.0);
|
|
push(p1);
|
|
push(p1);
|
|
multiply();
|
|
subtract();
|
|
sqrtfunc();
|
|
add();
|
|
logfunc();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// arcsin(-x) = -arcsin(x)
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push(p1);
|
|
negate();
|
|
arcsin();
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
// arcsin(1 / sqrt(2)) = 1/4 pi
|
|
|
|
if (isoneoversqrttwo(p1)) {
|
|
push_rational(1, 4);
|
|
push_symbol(PI);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// arcsin(0) = 0
|
|
|
|
if (iszero(p1)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
// arcsin(1/2) = 1/6 pi
|
|
|
|
if (isequalq(p1, 1, 2)) {
|
|
push_rational(1, 6);
|
|
push_symbol(PI);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// arcsin(1) = 1/2 pi
|
|
|
|
if (isplusone(p1)) {
|
|
push_rational(1, 2);
|
|
push_symbol(PI);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
push_symbol(ARCSIN);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_arcsinh(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
arcsinh();
|
|
}
|
|
|
|
void
|
|
arcsinh(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
arcsinh();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
d = asinh(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
// arcsinh(z) = log(sqrt(z^2 + 1) + z)
|
|
|
|
if (isdoublez(p1)) {
|
|
push(p1);
|
|
push(p1);
|
|
multiply();
|
|
push_double(1.0);
|
|
add();
|
|
sqrtfunc();
|
|
push(p1);
|
|
add();
|
|
logfunc();
|
|
return;
|
|
}
|
|
|
|
if (iszero(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
// arcsinh(-x) = -arcsinh(x)
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push(p1);
|
|
negate();
|
|
arcsinh();
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(SINH)) {
|
|
push(cadr(p1));
|
|
return;
|
|
}
|
|
|
|
push_symbol(ARCSINH);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_arctan(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
|
|
p1 = cddr(p1);
|
|
|
|
if (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
} else
|
|
push_integer(1);
|
|
|
|
arctan();
|
|
}
|
|
|
|
void
|
|
arctan(void)
|
|
{
|
|
int i, n;
|
|
struct atom *X, *Y, *Z;
|
|
|
|
X = pop();
|
|
Y = pop();
|
|
|
|
if (istensor(Y)) {
|
|
Y = copy_tensor(Y);
|
|
n = Y->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(Y->u.tensor->elem[i]);
|
|
push(X);
|
|
arctan();
|
|
Y->u.tensor->elem[i] = pop();
|
|
}
|
|
push(Y);
|
|
return;
|
|
}
|
|
|
|
if (isnum(X) && isnum(Y)) {
|
|
arctan_numbers(X, Y);
|
|
return;
|
|
}
|
|
|
|
// arctan(z) = -1/2 i log((i - z) / (i + z))
|
|
|
|
if (!iszero(X) && (isdoublez(X) || isdoublez(Y))) {
|
|
push(Y);
|
|
push(X);
|
|
divide();
|
|
Z = pop();
|
|
push_double(-0.5);
|
|
push(imaginaryunit);
|
|
multiply();
|
|
push(imaginaryunit);
|
|
push(Z);
|
|
subtract();
|
|
push(imaginaryunit);
|
|
push(Z);
|
|
add();
|
|
divide();
|
|
logfunc();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// arctan(-y,x) = -arctan(y,x)
|
|
|
|
if (isnegativeterm(Y)) {
|
|
push(Y);
|
|
negate();
|
|
push(X);
|
|
arctan();
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
if (car(Y) == symbol(TAN) && isplusone(X)) {
|
|
push(cadr(Y)); // x of tan(x)
|
|
return;
|
|
}
|
|
|
|
push_symbol(ARCTAN);
|
|
push(Y);
|
|
push(X);
|
|
list(3);
|
|
}
|
|
|
|
void
|
|
arctan_numbers(struct atom *X, struct atom *Y)
|
|
{
|
|
double x, y;
|
|
struct atom *T;
|
|
|
|
if (iszero(X) && iszero(Y)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(X) || isdouble(Y)) {
|
|
push(X);
|
|
x = pop_double();
|
|
push(Y);
|
|
y = pop_double();
|
|
if (y == 0.0) {
|
|
if (x < 0.0)
|
|
push_double(-M_PI);
|
|
else
|
|
push_double(0.0);
|
|
} else
|
|
push_double(atan2(y, x));
|
|
return;
|
|
}
|
|
|
|
// X and Y are rational numbers
|
|
|
|
if (iszero(Y)) {
|
|
if (isnegativenumber(X)) {
|
|
push_symbol(PI);
|
|
negate();
|
|
} else
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
if (iszero(X)) {
|
|
if (isnegativenumber(Y))
|
|
push_rational(-1, 2);
|
|
else
|
|
push_rational(1, 2);
|
|
push_symbol(PI);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// convert fractions to integers
|
|
|
|
push(Y);
|
|
push(X);
|
|
divide();
|
|
absfunc();
|
|
T = pop();
|
|
|
|
push(T);
|
|
numerator();
|
|
if (isnegativenumber(Y))
|
|
negate();
|
|
Y = pop();
|
|
|
|
push(T);
|
|
denominator();
|
|
if (isnegativenumber(X))
|
|
negate();
|
|
X = pop();
|
|
|
|
// compare numerators and denominators, ignore signs
|
|
|
|
if (mcmp(X->u.q.a, Y->u.q.a) != 0 || mcmp(X->u.q.b, Y->u.q.b) != 0) {
|
|
// not equal
|
|
if (isnegativenumber(Y)) {
|
|
push_symbol(ARCTAN);
|
|
push(Y);
|
|
negate();
|
|
push(X);
|
|
list(3);
|
|
negate();
|
|
} else {
|
|
push_symbol(ARCTAN);
|
|
push(Y);
|
|
push(X);
|
|
list(3);
|
|
}
|
|
return;
|
|
}
|
|
|
|
// X = Y modulo sign
|
|
|
|
if (isnegativenumber(X)) {
|
|
if (isnegativenumber(Y))
|
|
push_rational(-3, 4);
|
|
else
|
|
push_rational(3, 4);
|
|
} else {
|
|
if (isnegativenumber(Y))
|
|
push_rational(-1, 4);
|
|
else
|
|
push_rational(1, 4);
|
|
}
|
|
|
|
push_symbol(PI);
|
|
multiply();
|
|
}
|
|
void
|
|
eval_arctanh(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
arctanh();
|
|
}
|
|
|
|
void
|
|
arctanh(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
arctanh();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isplusone(p1) || isminusone(p1)) {
|
|
push_symbol(ARCTANH);
|
|
push(p1);
|
|
list(2);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
if (-1.0 < d && d < 1.0) {
|
|
d = atanh(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
}
|
|
|
|
// arctanh(z) = 1/2 log(1 + z) - 1/2 log(1 - z)
|
|
|
|
if (isdouble(p1) || isdoublez(p1)) {
|
|
push_double(1.0);
|
|
push(p1);
|
|
add();
|
|
logfunc();
|
|
push_double(1.0);
|
|
push(p1);
|
|
subtract();
|
|
logfunc();
|
|
subtract();
|
|
push_double(0.5);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
if (iszero(p1)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
// arctanh(-x) = -arctanh(x)
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push(p1);
|
|
negate();
|
|
arctanh();
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(TANH)) {
|
|
push(cadr(p1));
|
|
return;
|
|
}
|
|
|
|
push_symbol(ARCTANH);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_arg(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
polar(); // normalize
|
|
argfunc();
|
|
}
|
|
|
|
// may return a denormalized angle
|
|
|
|
void
|
|
argfunc(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1, *p2, *num, *den;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
argfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
numden();
|
|
num = pop();
|
|
den = pop();
|
|
push(num);
|
|
arg_nib();
|
|
push(den);
|
|
arg_nib();
|
|
subtract();
|
|
|
|
p2 = pop();
|
|
|
|
if (hasdouble(p1) && findf(p2, symbol(PI))) {
|
|
push(p2);
|
|
push_symbol(PI);
|
|
push_double(M_PI);
|
|
subst();
|
|
evalf();
|
|
} else
|
|
push(p2);
|
|
}
|
|
|
|
// This is why Eigenmath returns -pi for the arg of a negative number:
|
|
// arg(-i) == arg(-1) + arg(i) == -pi + 1/2 pi == -1/2 pi
|
|
|
|
void
|
|
arg_nib(void)
|
|
{
|
|
int h;
|
|
struct atom *p1, *x, *y;
|
|
|
|
p1 = pop();
|
|
|
|
if (isrational(p1)) {
|
|
if (isnegativenumber(p1)) {
|
|
push_symbol(PI);
|
|
negate(); // see comment above
|
|
} else
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
if (isnegativenumber(p1))
|
|
push_double(-M_PI);
|
|
else
|
|
push_double(0.0);
|
|
return;
|
|
}
|
|
|
|
// (-1) ^ expr
|
|
|
|
if (car(p1) == symbol(POWER) && isminusone(cadr(p1))) {
|
|
push_symbol(PI);
|
|
push(caddr(p1));
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// e ^ expr
|
|
|
|
if (car(p1) == symbol(POWER) && cadr(p1) == symbol(EXP1)) {
|
|
push(caddr(p1));
|
|
imag();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
h = tos;
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
arg_nib();
|
|
p1 = cdr(p1);
|
|
}
|
|
add_terms(tos - h);
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(ADD)) {
|
|
push(p1);
|
|
real();
|
|
x = pop();
|
|
push(p1);
|
|
imag();
|
|
y = pop();
|
|
if (iszero(y)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
if (iszero(x)) {
|
|
push_rational(1, 2);
|
|
push_symbol(PI);
|
|
multiply();
|
|
return;
|
|
}
|
|
push(y);
|
|
push(x);
|
|
arctan();
|
|
return;
|
|
}
|
|
|
|
push_integer(0); // p1 is real
|
|
}
|
|
void
|
|
eval_binding(struct atom *p1)
|
|
{
|
|
push(get_binding(cadr(p1)));
|
|
}
|
|
void
|
|
eval_break(struct atom *p1)
|
|
{
|
|
breakflag = 1;
|
|
push_symbol(NIL);
|
|
}
|
|
void
|
|
eval_ceiling(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
ceilingfunc();
|
|
}
|
|
|
|
void
|
|
ceilingfunc(void)
|
|
{
|
|
int i, n;
|
|
uint32_t *a, *b;
|
|
double d;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
ceilingfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isinteger(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isrational(p1)) {
|
|
a = mdiv(p1->u.q.a, p1->u.q.b);
|
|
b = mint(1);
|
|
if (isnegativenumber(p1))
|
|
push_bignum(MMINUS, a, b);
|
|
else {
|
|
push_bignum(MPLUS, a, b);
|
|
push_integer(1);
|
|
add();
|
|
}
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
d = ceil(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
push_symbol(CEILING);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_check(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalp();
|
|
p1 = pop();
|
|
if (iszero(p1))
|
|
stopf("check");
|
|
push_symbol(NIL); // no result is printed
|
|
}
|
|
void
|
|
eval_clear(struct atom *p1)
|
|
{
|
|
int i;
|
|
|
|
(void) p1; // silence compiler
|
|
|
|
save_symbol(symbol(TRACE));
|
|
save_symbol(symbol(TTY));
|
|
|
|
for (i = 0; i < 27 * BUCKETSIZE; i++) {
|
|
binding[i] = NULL;
|
|
usrfunc[i] = NULL;
|
|
}
|
|
|
|
run_init_script();
|
|
|
|
restore_symbol();
|
|
restore_symbol();
|
|
|
|
if (gc_level == eval_level)
|
|
gc();
|
|
|
|
push_symbol(NIL); // result
|
|
}
|
|
void
|
|
eval_clock(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
clockfunc();
|
|
}
|
|
|
|
void
|
|
clockfunc(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
clockfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
magfunc();
|
|
|
|
push_integer(-1); // base
|
|
|
|
push(p1);
|
|
argfunc();
|
|
push_symbol(PI);
|
|
divide();
|
|
|
|
power();
|
|
|
|
multiply();
|
|
}
|
|
void
|
|
eval_cofactor(struct atom *p1)
|
|
{
|
|
int i, j;
|
|
struct atom *p2;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
p2 = pop();
|
|
|
|
push(caddr(p1));
|
|
evalf();
|
|
i = pop_integer();
|
|
|
|
push(cadddr(p1));
|
|
evalf();
|
|
j = pop_integer();
|
|
|
|
if (!issquarematrix(p2))
|
|
stopf("cofactor: square matrix expected");
|
|
|
|
if (i < 1 || i > p2->u.tensor->dim[0] || j < 0 || j > p2->u.tensor->dim[1])
|
|
stopf("cofactor: index err");
|
|
|
|
push(p2);
|
|
|
|
minormatrix(i, j);
|
|
|
|
det();
|
|
|
|
if ((i + j) % 2)
|
|
negate();
|
|
}
|
|
void
|
|
eval_conj(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
conjfunc();
|
|
}
|
|
|
|
void
|
|
conjfunc(void)
|
|
{
|
|
conjfunc_subst();
|
|
evalf();
|
|
}
|
|
|
|
void
|
|
conjfunc_subst(void)
|
|
{
|
|
int h, i, n;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
conjfunc_subst();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
// (-1) ^ expr
|
|
|
|
if (car(p1) == symbol(POWER) && isminusone(cadr(p1))) {
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push(caddr(p1));
|
|
negate();
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
if (iscons(p1)) {
|
|
h = tos;
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
conjfunc_subst();
|
|
p1 = cdr(p1);
|
|
}
|
|
list(tos - h);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
}
|
|
void
|
|
eval_contract(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
|
|
p1 = cddr(p1);
|
|
|
|
if (!iscons(p1)) {
|
|
push_integer(1);
|
|
push_integer(2);
|
|
contract();
|
|
return;
|
|
}
|
|
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
push(cadr(p1));
|
|
evalf();
|
|
contract();
|
|
p1 = cddr(p1);
|
|
}
|
|
}
|
|
|
|
void
|
|
contract(void)
|
|
{
|
|
int h, i, j, k, m, n, ncol, ndim, nelem, nrow;
|
|
int index[MAXDIM];
|
|
struct atom *p1, *p2, *p3;
|
|
|
|
p3 = pop();
|
|
p2 = pop();
|
|
p1 = pop();
|
|
|
|
if (!istensor(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
ndim = p1->u.tensor->ndim;
|
|
|
|
push(p2);
|
|
n = pop_integer();
|
|
|
|
push(p3);
|
|
m = pop_integer();
|
|
|
|
if (n < 1 || n > ndim || m < 1 || m > ndim || n == m)
|
|
stopf("contract: index error");
|
|
|
|
n--; // make zero based
|
|
m--;
|
|
|
|
ncol = p1->u.tensor->dim[n];
|
|
nrow = p1->u.tensor->dim[m];
|
|
|
|
if (ncol != nrow)
|
|
stopf("contract: unequal tensor dimensions");
|
|
|
|
// nelem is the number of elements in result
|
|
|
|
nelem = p1->u.tensor->nelem / ncol / nrow;
|
|
|
|
p2 = alloc_tensor(nelem);
|
|
|
|
for (i = 0; i < ndim; i++)
|
|
index[i] = 0;
|
|
|
|
for (i = 0; i < nelem; i++) {
|
|
|
|
for (j = 0; j < ncol; j++) {
|
|
index[n] = j;
|
|
index[m] = j;
|
|
k = index[0];
|
|
for (h = 1; h < ndim; h++)
|
|
k = k * p1->u.tensor->dim[h] + index[h];
|
|
push(p1->u.tensor->elem[k]);
|
|
}
|
|
|
|
add_terms(ncol);
|
|
|
|
p2->u.tensor->elem[i] = pop();
|
|
|
|
// increment index
|
|
|
|
for (j = ndim - 1; j >= 0; j--) {
|
|
if (j == n || j == m)
|
|
continue;
|
|
if (++index[j] < p1->u.tensor->dim[j])
|
|
break;
|
|
index[j] = 0;
|
|
}
|
|
}
|
|
|
|
if (nelem == 1) {
|
|
push(p2->u.tensor->elem[0]);
|
|
return;
|
|
}
|
|
|
|
// add dim info
|
|
|
|
p2->u.tensor->ndim = ndim - 2;
|
|
|
|
k = 0;
|
|
|
|
for (i = 0; i < ndim; i++)
|
|
if (i != n && i != m)
|
|
p2->u.tensor->dim[k++] = p1->u.tensor->dim[i];
|
|
|
|
push(p2);
|
|
}
|
|
void
|
|
eval_cos(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
cosfunc();
|
|
}
|
|
|
|
void
|
|
cosfunc(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1, *p2, *X, *Y;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
cosfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
d = cos(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
// cos(z) = 1/2 exp(i z) + 1/2 exp(-i z)
|
|
|
|
if (isdoublez(p1)) {
|
|
push_double(0.5);
|
|
push(imaginaryunit);
|
|
push(p1);
|
|
multiply();
|
|
expfunc();
|
|
push(imaginaryunit);
|
|
negate();
|
|
push(p1);
|
|
multiply();
|
|
expfunc();
|
|
add();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// cos(-x) = cos(x)
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push(p1);
|
|
negate();
|
|
cosfunc();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(ADD)) {
|
|
cosfunc_sum(p1);
|
|
return;
|
|
}
|
|
|
|
// cos(arctan(y,x)) = x (x^2 + y^2)^(-1/2)
|
|
|
|
if (car(p1) == symbol(ARCTAN)) {
|
|
X = caddr(p1);
|
|
Y = cadr(p1);
|
|
push(X);
|
|
push(X);
|
|
push(X);
|
|
multiply();
|
|
push(Y);
|
|
push(Y);
|
|
multiply();
|
|
add();
|
|
push_rational(-1, 2);
|
|
power();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// cos(arcsin(x)) = sqrt(1 - x^2)
|
|
|
|
if (car(p1) == symbol(ARCSIN)) {
|
|
push_integer(1);
|
|
push(cadr(p1));
|
|
push_integer(2);
|
|
power();
|
|
subtract();
|
|
push_rational(1, 2);
|
|
power();
|
|
return;
|
|
}
|
|
|
|
// n pi ?
|
|
|
|
push(p1);
|
|
push_symbol(PI);
|
|
divide();
|
|
p2 = pop();
|
|
|
|
if (!isnum(p2)) {
|
|
push_symbol(COS);
|
|
push(p1);
|
|
list(2);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p2)) {
|
|
push(p2);
|
|
d = pop_double();
|
|
d = cos(d * M_PI);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
push(p2); // nonnegative by cos(-x) = cos(x) above
|
|
push_integer(180);
|
|
multiply();
|
|
p2 = pop();
|
|
|
|
if (!isinteger(p2)) {
|
|
push_symbol(COS);
|
|
push(p1);
|
|
list(2);
|
|
return;
|
|
}
|
|
|
|
push(p2);
|
|
push_integer(360);
|
|
modfunc();
|
|
n = pop_integer();
|
|
|
|
switch (n) {
|
|
case 90:
|
|
case 270:
|
|
push_integer(0);
|
|
break;
|
|
case 60:
|
|
case 300:
|
|
push_rational(1, 2);
|
|
break;
|
|
case 120:
|
|
case 240:
|
|
push_rational(-1, 2);
|
|
break;
|
|
case 45:
|
|
case 315:
|
|
push_rational(1, 2);
|
|
push_integer(2);
|
|
push_rational(1, 2);
|
|
power();
|
|
multiply();
|
|
break;
|
|
case 135:
|
|
case 225:
|
|
push_rational(-1, 2);
|
|
push_integer(2);
|
|
push_rational(1, 2);
|
|
power();
|
|
multiply();
|
|
break;
|
|
case 30:
|
|
case 330:
|
|
push_rational(1, 2);
|
|
push_integer(3);
|
|
push_rational(1, 2);
|
|
power();
|
|
multiply();
|
|
break;
|
|
case 150:
|
|
case 210:
|
|
push_rational(-1, 2);
|
|
push_integer(3);
|
|
push_rational(1, 2);
|
|
power();
|
|
multiply();
|
|
break;
|
|
case 0:
|
|
push_integer(1);
|
|
break;
|
|
case 180:
|
|
push_integer(-1);
|
|
break;
|
|
default:
|
|
push_symbol(COS);
|
|
push(p1);
|
|
list(2);
|
|
break;
|
|
}
|
|
}
|
|
|
|
// cos(x + n/2 pi) = cos(x) cos(n/2 pi) - sin(x) sin(n/2 pi)
|
|
|
|
void
|
|
cosfunc_sum(struct atom *p1)
|
|
{
|
|
struct atom *p2, *p3;
|
|
p2 = cdr(p1);
|
|
while (iscons(p2)) {
|
|
push_integer(2);
|
|
push(car(p2));
|
|
multiply();
|
|
push_symbol(PI);
|
|
divide();
|
|
p3 = pop();
|
|
if (isinteger(p3)) {
|
|
push(p1);
|
|
push(car(p2));
|
|
subtract();
|
|
p3 = pop();
|
|
push(p3);
|
|
cosfunc();
|
|
push(car(p2));
|
|
cosfunc();
|
|
multiply();
|
|
push(p3);
|
|
sinfunc();
|
|
push(car(p2));
|
|
sinfunc();
|
|
multiply();
|
|
subtract();
|
|
return;
|
|
}
|
|
p2 = cdr(p2);
|
|
}
|
|
push_symbol(COS);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_cosh(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
coshfunc();
|
|
}
|
|
|
|
void
|
|
coshfunc(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
coshfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
d = cosh(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
// cosh(z) = 1/2 exp(z) + 1/2 exp(-z)
|
|
|
|
if (isdoublez(p1)) {
|
|
push_rational(1, 2);
|
|
push(p1);
|
|
expfunc();
|
|
push(p1);
|
|
negate();
|
|
expfunc();
|
|
add();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
if (iszero(p1)) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
// cosh(-x) = cosh(x)
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push(p1);
|
|
negate();
|
|
coshfunc();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(ARCCOSH)) {
|
|
push(cadr(p1));
|
|
return;
|
|
}
|
|
|
|
push_symbol(COSH);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_defint(struct atom *p1)
|
|
{
|
|
struct atom *F, *X, *A, *B;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
F = pop();
|
|
|
|
p1 = cddr(p1);
|
|
|
|
while (iscons(p1)) {
|
|
|
|
push(car(p1));
|
|
evalf();
|
|
X = pop();
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
A = pop();
|
|
|
|
push(caddr(p1));
|
|
evalf();
|
|
B = pop();
|
|
|
|
push(F);
|
|
push(X);
|
|
integral();
|
|
F = pop();
|
|
|
|
if (findf(F, symbol(INTEGRAL)))
|
|
stopf("defint: unsolved integral");
|
|
|
|
push(F);
|
|
push(X);
|
|
push(B);
|
|
subst();
|
|
evalf();
|
|
|
|
push(F);
|
|
push(X);
|
|
push(A);
|
|
subst();
|
|
evalf();
|
|
|
|
subtract();
|
|
F = pop();
|
|
|
|
p1 = cdddr(p1);
|
|
}
|
|
|
|
push(F);
|
|
}
|
|
void
|
|
eval_denominator(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
denominator();
|
|
}
|
|
|
|
void
|
|
denominator(void)
|
|
{
|
|
numden();
|
|
pop(); // discard numerator
|
|
}
|
|
void
|
|
eval_derivative(struct atom *p1)
|
|
{
|
|
int flag, i, n;
|
|
struct atom *X, *Y = NULL; // silence compiler
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = cddr(p1);
|
|
|
|
if (!iscons(p1)) {
|
|
push_symbol(X_LOWER);
|
|
derivative();
|
|
return;
|
|
}
|
|
|
|
flag = 0;
|
|
|
|
while (iscons(p1) || flag) {
|
|
|
|
if (flag) {
|
|
X = Y;
|
|
flag = 0;
|
|
} else {
|
|
push(car(p1));
|
|
evalf();
|
|
X = pop();
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
if (isnum(X)) {
|
|
push(X);
|
|
n = pop_integer();
|
|
push_symbol(X_LOWER);
|
|
X = pop();
|
|
for (i = 0; i < n; i++) {
|
|
push(X);
|
|
derivative();
|
|
}
|
|
continue;
|
|
}
|
|
|
|
if (iscons(p1)) {
|
|
|
|
push(car(p1));
|
|
evalf();
|
|
Y = pop();
|
|
p1 = cdr(p1);
|
|
|
|
if (isnum(Y)) {
|
|
push(Y);
|
|
n = pop_integer();
|
|
for (i = 0; i < n; i++) {
|
|
push(X);
|
|
derivative();
|
|
}
|
|
continue;
|
|
}
|
|
|
|
flag = 1;
|
|
}
|
|
|
|
push(X);
|
|
derivative();
|
|
}
|
|
}
|
|
|
|
void
|
|
derivative(void)
|
|
{
|
|
struct atom *F, *X;
|
|
|
|
X = pop();
|
|
F = pop();
|
|
|
|
if (istensor(F)) {
|
|
if (istensor(X))
|
|
d_tensor_tensor(F, X);
|
|
else
|
|
d_tensor_scalar(F, X);
|
|
} else {
|
|
if (istensor(X))
|
|
d_scalar_tensor(F, X);
|
|
else
|
|
d_scalar_scalar(F, X);
|
|
}
|
|
}
|
|
|
|
void
|
|
d_scalar_scalar(struct atom *F, struct atom *X)
|
|
{
|
|
if (!isusersymbol(X))
|
|
stopf("derivative: symbol expected");
|
|
|
|
if (car(F) == symbol(DERIVATIVE)) {
|
|
derivative_of_derivative(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(INTEGRAL)) {
|
|
derivative_of_integral(F, X);
|
|
return;
|
|
}
|
|
|
|
// d(x,x)?
|
|
|
|
if (equal(F, X)) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
// d(a,x)?
|
|
|
|
if (!iscons(F)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(ADD)) {
|
|
dsum(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(MULTIPLY)) {
|
|
dproduct(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(POWER)) {
|
|
dpower(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(LOG)) {
|
|
dlog(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(SIN)) {
|
|
dsin(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(COS)) {
|
|
dcos(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(TAN)) {
|
|
dtan(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(ARCSIN)) {
|
|
darcsin(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(ARCCOS)) {
|
|
darccos(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(ARCTAN)) {
|
|
darctan(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(SINH)) {
|
|
dsinh(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(COSH)) {
|
|
dcosh(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(TANH)) {
|
|
dtanh(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(ARCSINH)) {
|
|
darcsinh(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(ARCCOSH)) {
|
|
darccosh(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(ARCTANH)) {
|
|
darctanh(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(ERF)) {
|
|
derf(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(ERFC)) {
|
|
derfc(F, X);
|
|
return;
|
|
}
|
|
|
|
dfunction(F, X);
|
|
}
|
|
|
|
void
|
|
dsum(struct atom *p1, struct atom *p2)
|
|
{
|
|
int h = tos;
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
push(p2);
|
|
derivative();
|
|
p1 = cdr(p1);
|
|
}
|
|
add_terms(tos - h);
|
|
}
|
|
|
|
void
|
|
dproduct(struct atom *p1, struct atom *p2)
|
|
{
|
|
int i, j, n;
|
|
struct atom *p3;
|
|
n = lengthf(p1) - 1;
|
|
for (i = 0; i < n; i++) {
|
|
p3 = cdr(p1);
|
|
for (j = 0; j < n; j++) {
|
|
push(car(p3));
|
|
if (i == j) {
|
|
push(p2);
|
|
derivative();
|
|
}
|
|
p3 = cdr(p3);
|
|
}
|
|
multiply_factors(n);
|
|
}
|
|
add_terms(n);
|
|
}
|
|
|
|
// v
|
|
// y = u
|
|
//
|
|
// log y = v log u
|
|
//
|
|
// 1 dy v du dv
|
|
// - -- = - -- + (log u) --
|
|
// y dx u dx dx
|
|
//
|
|
// dy v v du dv
|
|
// -- = u (- -- + (log u) --)
|
|
// dx u dx dx
|
|
|
|
void
|
|
dpower(struct atom *F, struct atom *X)
|
|
{
|
|
if (isnum(cadr(F)) && isnum(caddr(F))) {
|
|
push_integer(0); // irr or imag
|
|
return;
|
|
}
|
|
|
|
push(caddr(F)); // v/u
|
|
push(cadr(F));
|
|
divide();
|
|
|
|
push(cadr(F)); // du/dx
|
|
push(X);
|
|
derivative();
|
|
|
|
multiply();
|
|
|
|
push(cadr(F)); // log u
|
|
logfunc();
|
|
|
|
push(caddr(F)); // dv/dx
|
|
push(X);
|
|
derivative();
|
|
|
|
multiply();
|
|
|
|
add();
|
|
|
|
push(F); // u^v
|
|
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
dlog(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push(cadr(p1));
|
|
divide();
|
|
}
|
|
|
|
// derivative of a generic function
|
|
|
|
void
|
|
dfunction(struct atom *p1, struct atom *p2)
|
|
{
|
|
struct atom *p3;
|
|
|
|
p3 = cdr(p1); // p3 is the argument list for the function
|
|
|
|
if (p3 == symbol(NIL) || findf(p3, p2)) {
|
|
push_symbol(DERIVATIVE);
|
|
push(p1);
|
|
push(p2);
|
|
list(3);
|
|
} else
|
|
push_integer(0);
|
|
}
|
|
|
|
void
|
|
dsin(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push(cadr(p1));
|
|
cosfunc();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
dcos(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push(cadr(p1));
|
|
sinfunc();
|
|
multiply();
|
|
negate();
|
|
}
|
|
|
|
void
|
|
dtan(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push(cadr(p1));
|
|
cosfunc();
|
|
push_integer(-2);
|
|
power();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
darcsin(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push_integer(1);
|
|
push(cadr(p1));
|
|
push_integer(2);
|
|
power();
|
|
subtract();
|
|
push_rational(-1, 2);
|
|
power();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
darccos(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push_integer(1);
|
|
push(cadr(p1));
|
|
push_integer(2);
|
|
power();
|
|
subtract();
|
|
push_rational(-1, 2);
|
|
power();
|
|
multiply();
|
|
negate();
|
|
}
|
|
|
|
void
|
|
darctan(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push_integer(1);
|
|
push(cadr(p1));
|
|
push_integer(2);
|
|
power();
|
|
add();
|
|
reciprocate();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
dsinh(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push(cadr(p1));
|
|
coshfunc();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
dcosh(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push(cadr(p1));
|
|
sinhfunc();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
dtanh(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push(cadr(p1));
|
|
coshfunc();
|
|
push_integer(-2);
|
|
power();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
darcsinh(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push(cadr(p1));
|
|
push_integer(2);
|
|
power();
|
|
push_integer(1);
|
|
add();
|
|
push_rational(-1, 2);
|
|
power();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
darccosh(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push(cadr(p1));
|
|
push_integer(2);
|
|
power();
|
|
push_integer(-1);
|
|
add();
|
|
push_rational(-1, 2);
|
|
power();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
darctanh(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
push_integer(1);
|
|
push(cadr(p1));
|
|
push_integer(2);
|
|
power();
|
|
subtract();
|
|
reciprocate();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
derf(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push_integer(2);
|
|
power();
|
|
push_integer(-1);
|
|
multiply();
|
|
expfunc();
|
|
push_symbol(PI);
|
|
push_rational(-1, 2);
|
|
power();
|
|
multiply();
|
|
push_integer(2);
|
|
multiply();
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
derfc(struct atom *p1, struct atom *p2)
|
|
{
|
|
push(cadr(p1));
|
|
push_integer(2);
|
|
power();
|
|
push_integer(-1);
|
|
multiply();
|
|
expfunc();
|
|
push_symbol(PI);
|
|
push_rational(-1,2);
|
|
power();
|
|
multiply();
|
|
push_integer(-2);
|
|
multiply();
|
|
push(cadr(p1));
|
|
push(p2);
|
|
derivative();
|
|
multiply();
|
|
}
|
|
|
|
// gradient of tensor p1 wrt tensor p2
|
|
|
|
void
|
|
d_tensor_tensor(struct atom *p1, struct atom *p2)
|
|
{
|
|
int i, j, k, m, n;
|
|
struct atom *p3;
|
|
|
|
if (p1->u.tensor->ndim + p2->u.tensor->ndim > MAXDIM)
|
|
stopf("rank exceeds max");
|
|
|
|
n = p1->u.tensor->nelem;
|
|
m = p2->u.tensor->nelem;
|
|
|
|
p3 = alloc_tensor(n * m);
|
|
|
|
for (i = 0; i < n; i++) {
|
|
for (j = 0; j < m; j++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
push(p2->u.tensor->elem[j]);
|
|
derivative();
|
|
p3->u.tensor->elem[m * i + j] = pop();
|
|
}
|
|
}
|
|
|
|
// dim info
|
|
|
|
p3->u.tensor->ndim = p1->u.tensor->ndim + p2->u.tensor->ndim;
|
|
|
|
k = 0;
|
|
|
|
n = p1->u.tensor->ndim;
|
|
|
|
for (i = 0; i < n; i++)
|
|
p3->u.tensor->dim[k++] = p1->u.tensor->dim[i];
|
|
|
|
n = p2->u.tensor->ndim;
|
|
|
|
for (i = 0; i < n; i++)
|
|
p3->u.tensor->dim[k++] = p2->u.tensor->dim[i];
|
|
|
|
push(p3);
|
|
}
|
|
|
|
// gradient of scalar p1 wrt tensor p2
|
|
|
|
void
|
|
d_scalar_tensor(struct atom *p1, struct atom *p2)
|
|
{
|
|
int i, n;
|
|
struct atom *p3;
|
|
|
|
p3 = copy_tensor(p2);
|
|
|
|
n = p2->u.tensor->nelem;
|
|
|
|
for (i = 0; i < n; i++) {
|
|
push(p1);
|
|
push(p2->u.tensor->elem[i]);
|
|
derivative();
|
|
p3->u.tensor->elem[i] = pop();
|
|
}
|
|
|
|
push(p3);
|
|
}
|
|
|
|
// derivative of tensor p1 wrt scalar p2
|
|
|
|
void
|
|
d_tensor_scalar(struct atom *p1, struct atom *p2)
|
|
{
|
|
int i, n;
|
|
struct atom *p3;
|
|
|
|
p3 = copy_tensor(p1);
|
|
|
|
n = p1->u.tensor->nelem;
|
|
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
push(p2);
|
|
derivative();
|
|
p3->u.tensor->elem[i] = pop();
|
|
}
|
|
|
|
push(p3);
|
|
}
|
|
|
|
void
|
|
derivative_of_derivative(struct atom *F, struct atom *X)
|
|
{
|
|
struct atom *G, *Y;
|
|
|
|
G = cadr(F);
|
|
Y = caddr(F);
|
|
|
|
if (X == Y) {
|
|
push_symbol(DERIVATIVE);
|
|
push(F);
|
|
push(X);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
push(G);
|
|
push(X);
|
|
derivative();
|
|
|
|
G = pop();
|
|
|
|
if (car(G) == symbol(DERIVATIVE)) {
|
|
|
|
// sort derivatives
|
|
|
|
F = cadr(G);
|
|
X = caddr(G);
|
|
|
|
push_symbol(DERIVATIVE);
|
|
push_symbol(DERIVATIVE);
|
|
push(F);
|
|
|
|
if (lessp(X, Y)) {
|
|
push(X);
|
|
list(3);
|
|
push(Y);
|
|
list(3);
|
|
} else {
|
|
push(Y);
|
|
list(3);
|
|
push(X);
|
|
list(3);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
push(G);
|
|
push(Y);
|
|
derivative();
|
|
}
|
|
|
|
void
|
|
derivative_of_integral(struct atom *F, struct atom *X)
|
|
{
|
|
struct atom *G, *Y;
|
|
|
|
G = cadr(F);
|
|
Y = caddr(F);
|
|
|
|
if (X == Y) {
|
|
push(G); // derivative and integral cancel
|
|
return;
|
|
}
|
|
|
|
push(G);
|
|
push(X);
|
|
derivative();
|
|
push(Y);
|
|
integral();
|
|
}
|
|
void
|
|
eval_det(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
det();
|
|
}
|
|
|
|
void
|
|
det(void)
|
|
{
|
|
int h, i, j, k, m, n;
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
if (!istensor(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (!issquarematrix(p1))
|
|
stopf("det: square matrix expected");
|
|
|
|
n = p1->u.tensor->dim[0];
|
|
|
|
switch (n) {
|
|
case 1:
|
|
push(p1->u.tensor->elem[0]);
|
|
return;
|
|
case 2:
|
|
push(p1->u.tensor->elem[0]);
|
|
push(p1->u.tensor->elem[3]);
|
|
multiply();
|
|
push(p1->u.tensor->elem[1]);
|
|
push(p1->u.tensor->elem[2]);
|
|
multiply();
|
|
subtract();
|
|
return;
|
|
case 3:
|
|
push(p1->u.tensor->elem[0]);
|
|
push(p1->u.tensor->elem[4]);
|
|
push(p1->u.tensor->elem[8]);
|
|
multiply_factors(3);
|
|
push(p1->u.tensor->elem[1]);
|
|
push(p1->u.tensor->elem[5]);
|
|
push(p1->u.tensor->elem[6]);
|
|
multiply_factors(3);
|
|
push(p1->u.tensor->elem[2]);
|
|
push(p1->u.tensor->elem[3]);
|
|
push(p1->u.tensor->elem[7]);
|
|
multiply_factors(3);
|
|
push_integer(-1);
|
|
push(p1->u.tensor->elem[2]);
|
|
push(p1->u.tensor->elem[4]);
|
|
push(p1->u.tensor->elem[6]);
|
|
multiply_factors(4);
|
|
push_integer(-1);
|
|
push(p1->u.tensor->elem[1]);
|
|
push(p1->u.tensor->elem[3]);
|
|
push(p1->u.tensor->elem[8]);
|
|
multiply_factors(4);
|
|
push_integer(-1);
|
|
push(p1->u.tensor->elem[0]);
|
|
push(p1->u.tensor->elem[5]);
|
|
push(p1->u.tensor->elem[7]);
|
|
multiply_factors(4);
|
|
add_terms(6);
|
|
return;
|
|
default:
|
|
break;
|
|
}
|
|
|
|
p2 = alloc_matrix(n - 1, n - 1);
|
|
|
|
h = tos;
|
|
|
|
for (m = 0; m < n; m++) {
|
|
if (iszero(p1->u.tensor->elem[m]))
|
|
continue;
|
|
k = 0;
|
|
for (i = 1; i < n; i++)
|
|
for (j = 0; j < n; j++)
|
|
if (j != m)
|
|
p2->u.tensor->elem[k++] = p1->u.tensor->elem[n * i + j];
|
|
push(p2);
|
|
det();
|
|
push(p1->u.tensor->elem[m]);
|
|
multiply();
|
|
if (m % 2)
|
|
negate();
|
|
}
|
|
|
|
n = tos - h;
|
|
|
|
if (n == 0)
|
|
push_integer(0);
|
|
else
|
|
add_terms(n);
|
|
}
|
|
void
|
|
eval_dim(struct atom *p1)
|
|
{
|
|
int k;
|
|
struct atom *p2;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
p2 = pop();
|
|
|
|
if (!istensor(p2)) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
if (lengthf(p1) == 2)
|
|
k = 1;
|
|
else {
|
|
push(caddr(p1));
|
|
evalf();
|
|
k = pop_integer();
|
|
}
|
|
|
|
if (k < 1 || k > p2->u.tensor->ndim)
|
|
stopf("dim 2nd arg: error");
|
|
|
|
push_integer(p2->u.tensor->dim[k - 1]);
|
|
}
|
|
void
|
|
eval_do(struct atom *p1)
|
|
{
|
|
push_symbol(NIL);
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
pop(); // discard previous result
|
|
push(car(p1));
|
|
evalg();
|
|
p1 = cdr(p1);
|
|
}
|
|
}
|
|
void
|
|
eval_eigenvec(struct atom *p1)
|
|
{
|
|
int i, j, n;
|
|
static double *D, *Q;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
floatfunc();
|
|
p1 = pop();
|
|
|
|
if (!issquarematrix(p1))
|
|
stopf("eigenvec");
|
|
|
|
n = p1->u.tensor->dim[0];
|
|
|
|
for (i = 0; i < n; i++)
|
|
for (j = 0; j < n; j++)
|
|
if (!isdouble(p1->u.tensor->elem[n * i + j]))
|
|
stopf("eigenvec");
|
|
|
|
for (i = 0; i < n - 1; i++)
|
|
for (j = i + 1; j < n; j++)
|
|
if (fabs(p1->u.tensor->elem[n * i + j]->u.d - p1->u.tensor->elem[n * j + i]->u.d) > 1e-10)
|
|
stopf("eigenvec");
|
|
|
|
if (D)
|
|
free(D);
|
|
if (Q)
|
|
free(Q);
|
|
|
|
D = alloc_mem(n * n * sizeof (double));
|
|
Q = alloc_mem(n * n * sizeof (double));
|
|
|
|
// initialize D
|
|
|
|
for (i = 0; i < n; i++) {
|
|
D[n * i + i] = p1->u.tensor->elem[n * i + i]->u.d;
|
|
for (j = i + 1; j < n; j++) {
|
|
D[n * i + j] = p1->u.tensor->elem[n * i + j]->u.d;
|
|
D[n * j + i] = p1->u.tensor->elem[n * i + j]->u.d;
|
|
}
|
|
}
|
|
|
|
// initialize Q
|
|
|
|
for (i = 0; i < n; i++) {
|
|
Q[n * i + i] = 1.0;
|
|
for (j = i + 1; j < n; j++) {
|
|
Q[n * i + j] = 0.0;
|
|
Q[n * j + i] = 0.0;
|
|
}
|
|
}
|
|
|
|
eigenvec(D, Q, n);
|
|
|
|
p1 = alloc_matrix(n, n);
|
|
|
|
for (i = 0; i < n; i++) {
|
|
for (j = 0; j < n; j++) {
|
|
push_double(Q[n * j + i]); // transpose
|
|
p1->u.tensor->elem[n * i + j] = pop();
|
|
}
|
|
}
|
|
|
|
push(p1);
|
|
}
|
|
|
|
void
|
|
eigenvec(double *D, double *Q, int n)
|
|
{
|
|
int i;
|
|
|
|
for (i = 0; i < 100; i++)
|
|
if (eigenvec_step(D, Q, n) == 0)
|
|
return;
|
|
|
|
stopf("eigenvec: convergence error");
|
|
}
|
|
|
|
// Example: p = 1, q = 3
|
|
//
|
|
// c 0 s 0
|
|
//
|
|
// 0 1 0 0
|
|
// G =
|
|
// -s 0 c 0
|
|
//
|
|
// 0 0 0 1
|
|
//
|
|
// The effect of multiplying G times A is...
|
|
//
|
|
// row 1 of A = c (row 1 of A ) + s (row 3 of A )
|
|
// n+1 n n
|
|
//
|
|
// row 3 of A = c (row 3 of A ) - s (row 1 of A )
|
|
// n+1 n n
|
|
//
|
|
// In terms of components the overall effect is...
|
|
//
|
|
// row 1 = c row 1 + s row 3
|
|
//
|
|
// A[1,1] = c A[1,1] + s A[3,1]
|
|
//
|
|
// A[1,2] = c A[1,2] + s A[3,2]
|
|
//
|
|
// A[1,3] = c A[1,3] + s A[3,3]
|
|
//
|
|
// A[1,4] = c A[1,4] + s A[3,4]
|
|
//
|
|
// row 3 = c row 3 - s row 1
|
|
//
|
|
// A[3,1] = c A[3,1] - s A[1,1]
|
|
//
|
|
// A[3,2] = c A[3,2] - s A[1,2]
|
|
//
|
|
// A[3,3] = c A[3,3] - s A[1,3]
|
|
//
|
|
// A[3,4] = c A[3,4] - s A[1,4]
|
|
//
|
|
// T
|
|
// The effect of multiplying A times G is...
|
|
//
|
|
// col 1 of A = c (col 1 of A ) + s (col 3 of A )
|
|
// n+1 n n
|
|
//
|
|
// col 3 of A = c (col 3 of A ) - s (col 1 of A )
|
|
// n+1 n n
|
|
//
|
|
// In terms of components the overall effect is...
|
|
//
|
|
// col 1 = c col 1 + s col 3
|
|
//
|
|
// A[1,1] = c A[1,1] + s A[1,3]
|
|
//
|
|
// A[2,1] = c A[2,1] + s A[2,3]
|
|
//
|
|
// A[3,1] = c A[3,1] + s A[3,3]
|
|
//
|
|
// A[4,1] = c A[4,1] + s A[4,3]
|
|
//
|
|
// col 3 = c col 3 - s col 1
|
|
//
|
|
// A[1,3] = c A[1,3] - s A[1,1]
|
|
//
|
|
// A[2,3] = c A[2,3] - s A[2,1]
|
|
//
|
|
// A[3,3] = c A[3,3] - s A[3,1]
|
|
//
|
|
// A[4,3] = c A[4,3] - s A[4,1]
|
|
//
|
|
// What we want to do is just compute the upper triangle of A since we
|
|
// know the lower triangle is identical.
|
|
//
|
|
// In other words, we just want to update components A[i,j] where i < j.
|
|
//
|
|
//
|
|
//
|
|
// Example: p = 2, q = 5
|
|
//
|
|
// p q
|
|
//
|
|
// j=1 j=2 j=3 j=4 j=5 j=6
|
|
//
|
|
// i=1 . A[1,2] . . A[1,5] .
|
|
//
|
|
// p i=2 A[2,1] A[2,2] A[2,3] A[2,4] A[2,5] A[2,6]
|
|
//
|
|
// i=3 . A[3,2] . . A[3,5] .
|
|
//
|
|
// i=4 . A[4,2] . . A[4,5] .
|
|
//
|
|
// q i=5 A[5,1] A[5,2] A[5,3] A[5,4] A[5,5] A[5,6]
|
|
//
|
|
// i=6 . A[6,2] . . A[6,5] .
|
|
//
|
|
//
|
|
//
|
|
// This is what B = GA does:
|
|
//
|
|
// row 2 = c row 2 + s row 5
|
|
//
|
|
// B[2,1] = c * A[2,1] + s * A[5,1]
|
|
// B[2,2] = c * A[2,2] + s * A[5,2]
|
|
// B[2,3] = c * A[2,3] + s * A[5,3]
|
|
// B[2,4] = c * A[2,4] + s * A[5,4]
|
|
// B[2,5] = c * A[2,5] + s * A[5,5]
|
|
// B[2,6] = c * A[2,6] + s * A[5,6]
|
|
//
|
|
// row 5 = c row 5 - s row 2
|
|
//
|
|
// B[5,1] = c * A[5,1] + s * A[2,1]
|
|
// B[5,2] = c * A[5,2] + s * A[2,2]
|
|
// B[5,3] = c * A[5,3] + s * A[2,3]
|
|
// B[5,4] = c * A[5,4] + s * A[2,4]
|
|
// B[5,5] = c * A[5,5] + s * A[2,5]
|
|
// B[5,6] = c * A[5,6] + s * A[2,6]
|
|
//
|
|
// T
|
|
// This is what BG does:
|
|
//
|
|
// col 2 = c col 2 + s col 5
|
|
//
|
|
// B[1,2] = c * A[1,2] + s * A[1,5]
|
|
// B[2,2] = c * A[2,2] + s * A[2,5]
|
|
// B[3,2] = c * A[3,2] + s * A[3,5]
|
|
// B[4,2] = c * A[4,2] + s * A[4,5]
|
|
// B[5,2] = c * A[5,2] + s * A[5,5]
|
|
// B[6,2] = c * A[6,2] + s * A[6,5]
|
|
//
|
|
// col 5 = c col 5 - s col 2
|
|
//
|
|
// B[1,5] = c * A[1,5] - s * A[1,2]
|
|
// B[2,5] = c * A[2,5] - s * A[2,2]
|
|
// B[3,5] = c * A[3,5] - s * A[3,2]
|
|
// B[4,5] = c * A[4,5] - s * A[4,2]
|
|
// B[5,5] = c * A[5,5] - s * A[5,2]
|
|
// B[6,5] = c * A[6,5] - s * A[6,2]
|
|
//
|
|
//
|
|
//
|
|
// Step 1: Just do upper triangle (i < j), B[2,5] = 0
|
|
//
|
|
// B[1,2] = c * A[1,2] + s * A[1,5]
|
|
//
|
|
// B[2,3] = c * A[2,3] + s * A[5,3]
|
|
// B[2,4] = c * A[2,4] + s * A[5,4]
|
|
// B[2,6] = c * A[2,6] + s * A[5,6]
|
|
//
|
|
// B[1,5] = c * A[1,5] - s * A[1,2]
|
|
// B[3,5] = c * A[3,5] - s * A[3,2]
|
|
// B[4,5] = c * A[4,5] - s * A[4,2]
|
|
//
|
|
// B[5,6] = c * A[5,6] + s * A[2,6]
|
|
//
|
|
//
|
|
//
|
|
// Step 2: Transpose where i > j since A[i,j] == A[j,i]
|
|
//
|
|
// B[1,2] = c * A[1,2] + s * A[1,5]
|
|
//
|
|
// B[2,3] = c * A[2,3] + s * A[3,5]
|
|
// B[2,4] = c * A[2,4] + s * A[4,5]
|
|
// B[2,6] = c * A[2,6] + s * A[5,6]
|
|
//
|
|
// B[1,5] = c * A[1,5] - s * A[1,2]
|
|
// B[3,5] = c * A[3,5] - s * A[2,3]
|
|
// B[4,5] = c * A[4,5] - s * A[2,4]
|
|
//
|
|
// B[5,6] = c * A[5,6] + s * A[2,6]
|
|
//
|
|
//
|
|
//
|
|
// Step 3: Same as above except reorder
|
|
//
|
|
// k < p (k = 1)
|
|
//
|
|
// A[1,2] = c * A[1,2] + s * A[1,5]
|
|
// A[1,5] = c * A[1,5] - s * A[1,2]
|
|
//
|
|
// p < k < q (k = 3..4)
|
|
//
|
|
// A[2,3] = c * A[2,3] + s * A[3,5]
|
|
// A[3,5] = c * A[3,5] - s * A[2,3]
|
|
//
|
|
// A[2,4] = c * A[2,4] + s * A[4,5]
|
|
// A[4,5] = c * A[4,5] - s * A[2,4]
|
|
//
|
|
// q < k (k = 6)
|
|
//
|
|
// A[2,6] = c * A[2,6] + s * A[5,6]
|
|
// A[5,6] = c * A[5,6] - s * A[2,6]
|
|
|
|
int
|
|
eigenvec_step(double *D, double *Q, int n)
|
|
{
|
|
int count, i, j;
|
|
|
|
count = 0;
|
|
|
|
// for each upper triangle "off-diagonal" component do step_nib
|
|
|
|
for (i = 0; i < n - 1; i++) {
|
|
for (j = i + 1; j < n; j++) {
|
|
if (D[n * i + j] != 0.0) {
|
|
eigenvec_step_nib(D, Q, n, i, j);
|
|
count++;
|
|
}
|
|
}
|
|
}
|
|
|
|
return count;
|
|
}
|
|
|
|
void
|
|
eigenvec_step_nib(double *D, double *Q, int n, int p, int q)
|
|
{
|
|
int k;
|
|
double t, theta;
|
|
double c, cc, s, ss;
|
|
|
|
// compute c and s
|
|
|
|
// from Numerical Recipes (except they have a_qq - a_pp)
|
|
|
|
theta = 0.5 * (D[n * p + p] - D[n * q + q]) / D[n * p + q];
|
|
|
|
t = 1.0 / (fabs(theta) + sqrt(theta * theta + 1.0));
|
|
|
|
if (theta < 0.0)
|
|
t = -t;
|
|
|
|
c = 1.0 / sqrt(t * t + 1.0);
|
|
|
|
s = t * c;
|
|
|
|
// D = GD
|
|
|
|
// which means "add rows"
|
|
|
|
for (k = 0; k < n; k++) {
|
|
cc = D[n * p + k];
|
|
ss = D[n * q + k];
|
|
D[n * p + k] = c * cc + s * ss;
|
|
D[n * q + k] = c * ss - s * cc;
|
|
}
|
|
|
|
// D = D transpose(G)
|
|
|
|
// which means "add columns"
|
|
|
|
for (k = 0; k < n; k++) {
|
|
cc = D[n * k + p];
|
|
ss = D[n * k + q];
|
|
D[n * k + p] = c * cc + s * ss;
|
|
D[n * k + q] = c * ss - s * cc;
|
|
}
|
|
|
|
// Q = GQ
|
|
|
|
// which means "add rows"
|
|
|
|
for (k = 0; k < n; k++) {
|
|
cc = Q[n * p + k];
|
|
ss = Q[n * q + k];
|
|
Q[n * p + k] = c * cc + s * ss;
|
|
Q[n * q + k] = c * ss - s * cc;
|
|
}
|
|
|
|
D[n * p + q] = 0.0;
|
|
D[n * q + p] = 0.0;
|
|
}
|
|
// first author: github.com/phbillet
|
|
|
|
void
|
|
eval_erf(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
erffunc();
|
|
}
|
|
|
|
void
|
|
erffunc(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
erffunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
floatfunc();
|
|
p2 = pop();
|
|
|
|
if (isnum(p2)) {
|
|
push(p2);
|
|
d = pop_double();
|
|
d = erf(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push_symbol(ERF);
|
|
push(p1);
|
|
negate();
|
|
list(2);
|
|
negate();
|
|
} else {
|
|
push_symbol(ERF);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
}
|
|
// first author: github.com/phbillet
|
|
|
|
void
|
|
eval_erfc(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
erfcfunc();
|
|
}
|
|
|
|
void
|
|
erfcfunc(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
erfcfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
floatfunc();
|
|
p2 = pop();
|
|
|
|
if (isnum(p2)) {
|
|
push(p2);
|
|
d = pop_double();
|
|
d = erfc(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push_symbol(ERF);
|
|
push(p1);
|
|
negate();
|
|
list(2);
|
|
} else {
|
|
push_symbol(ERF);
|
|
push(p1);
|
|
list(2);
|
|
negate();
|
|
}
|
|
|
|
push_integer(1);
|
|
add();
|
|
}
|
|
void
|
|
eval_eval(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = cddr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
push(cadr(p1));
|
|
evalf();
|
|
asubst();
|
|
p1 = cddr(p1);
|
|
}
|
|
}
|
|
|
|
// arithmetic subst
|
|
|
|
void
|
|
asubst(void)
|
|
{
|
|
int h, i, n;
|
|
struct atom *p1, *p2, *p3;
|
|
|
|
p3 = pop(); // new expr
|
|
p2 = pop(); // old expr
|
|
p1 = pop(); // expr
|
|
|
|
if (p2 == symbol(NIL) || p3 == symbol(NIL)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
push(p2);
|
|
push(p3);
|
|
asubst();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (equal(p1, p2)) {
|
|
push(p3);
|
|
return;
|
|
}
|
|
|
|
if (!iscons(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
// depth first
|
|
|
|
h = tos;
|
|
|
|
push(car(p1)); // func name
|
|
p1 = cdr(p1);
|
|
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
push(p2);
|
|
push(p3);
|
|
asubst();
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
list(tos - h);
|
|
|
|
evalf(); // normalize
|
|
|
|
p1 = pop();
|
|
|
|
if (addcmp(p1, p2)) {
|
|
push(p1);
|
|
push(p2);
|
|
subtract();
|
|
push(p3);
|
|
add();
|
|
return;
|
|
}
|
|
|
|
if (mulcmp(p1, p2) || powcmp(p1, p2)) {
|
|
push(p1);
|
|
push(p2);
|
|
divide();
|
|
push(p3);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
}
|
|
|
|
int
|
|
addcmp(struct atom *p1, struct atom *p2)
|
|
{
|
|
if (car(p1) != symbol(ADD) || car(p2) != symbol(ADD))
|
|
return 0;
|
|
p1 = cdr(p1);
|
|
p2 = cdr(p2);
|
|
while (iscons(p1) && iscons(p2)) {
|
|
if (equal(car(p1), car(p2)))
|
|
p2 = cdr(p2); // next term on list
|
|
p1 = cdr(p1);
|
|
}
|
|
if (iscons(p2))
|
|
return 0;
|
|
else
|
|
return 1; // all terms matched
|
|
}
|
|
|
|
int
|
|
mulcmp(struct atom *p1, struct atom *p2)
|
|
{
|
|
if (car(p1) != symbol(MULTIPLY) || car(p2) != symbol(MULTIPLY))
|
|
return 0;
|
|
p1 = cdr(p1);
|
|
p2 = cdr(p2);
|
|
while (iscons(p1) && iscons(p2)) {
|
|
if (equal(car(p1), car(p2)) || powcmp(car(p1), car(p2)))
|
|
p2 = cdr(p2); // next factor on list
|
|
p1 = cdr(p1);
|
|
}
|
|
if (iscons(p2))
|
|
return 0;
|
|
else
|
|
return 1; // all factors matched
|
|
}
|
|
|
|
int
|
|
powcmp(struct atom *p1, struct atom *p2)
|
|
{
|
|
if (car(p1) != symbol(POWER) || car(p2) != symbol(POWER))
|
|
return 0;
|
|
if (!equal(cadr(p1), cadr(p2)))
|
|
return 0; // bases don't match
|
|
p1 = caddr(p1); // exponent
|
|
p2 = caddr(p2); // exponent
|
|
if (car(p1) != symbol(ADD))
|
|
return 0; // p1 and p2 already failed exact match
|
|
if (car(p2) == symbol(ADD))
|
|
return addcmp(p1, p2);
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
if (equal(car(p1), p2))
|
|
return 1;
|
|
p1 = cdr(p1);
|
|
}
|
|
return 0;
|
|
}
|
|
void
|
|
eval_exp(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
expfunc();
|
|
}
|
|
|
|
void
|
|
expfunc(void)
|
|
{
|
|
push_symbol(EXP1);
|
|
swap();
|
|
power();
|
|
}
|
|
void
|
|
eval_expcos(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
expcos();
|
|
}
|
|
|
|
void
|
|
expcos(void)
|
|
{
|
|
struct atom *p1;
|
|
p1 = pop();
|
|
|
|
push(imaginaryunit);
|
|
push(p1);
|
|
multiply();
|
|
expfunc();
|
|
push_rational(1, 2);
|
|
multiply();
|
|
|
|
push(imaginaryunit);
|
|
negate();
|
|
push(p1);
|
|
multiply();
|
|
expfunc();
|
|
push_rational(1, 2);
|
|
multiply();
|
|
|
|
add();
|
|
}
|
|
void
|
|
eval_expcosh(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
expcosh();
|
|
}
|
|
|
|
void
|
|
expcosh(void)
|
|
{
|
|
struct atom *p1;
|
|
p1 = pop();
|
|
push(p1);
|
|
expfunc();
|
|
push(p1);
|
|
negate();
|
|
expfunc();
|
|
add();
|
|
push_rational(1, 2);
|
|
multiply();
|
|
}
|
|
void
|
|
eval_expform(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
expform();
|
|
}
|
|
|
|
void
|
|
expform(void)
|
|
{
|
|
int h, i, n;
|
|
struct atom *p1, *num, *den;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
expform();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (!iscons(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(ADD)) {
|
|
h = tos;
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
expform();
|
|
p1 = cdr(p1);
|
|
}
|
|
add_terms(tos - h);
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
|
|
push(p1);
|
|
numden();
|
|
num = pop();
|
|
den = pop();
|
|
|
|
p1 = num;
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
h = tos;
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
expform();
|
|
p1 = cdr(p1);
|
|
}
|
|
multiply_factors(tos - h);
|
|
} else {
|
|
push(p1);
|
|
expform();
|
|
}
|
|
num = pop();
|
|
|
|
p1 = den;
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
h = tos;
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
expform();
|
|
p1 = cdr(p1);
|
|
}
|
|
multiply_factors(tos - h);
|
|
} else {
|
|
push(p1);
|
|
expform();
|
|
}
|
|
den = pop();
|
|
|
|
push(num);
|
|
push(den);
|
|
divide();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(POWER)) {
|
|
push(cadr(p1));
|
|
expform();
|
|
push(caddr(p1));
|
|
expform();
|
|
power();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(COS)) {
|
|
push(cadr(p1));
|
|
expform();
|
|
expcos();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(SIN)) {
|
|
push(cadr(p1));
|
|
expform();
|
|
expsin();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(TAN)) {
|
|
push(cadr(p1));
|
|
expform();
|
|
exptan();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(COSH)) {
|
|
push(cadr(p1));
|
|
expform();
|
|
expcosh();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(SINH)) {
|
|
push(cadr(p1));
|
|
expform();
|
|
expsinh();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(TANH)) {
|
|
push(cadr(p1));
|
|
expform();
|
|
exptanh();
|
|
return;
|
|
}
|
|
|
|
h = tos;
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
expform();
|
|
p1 = cdr(p1);
|
|
}
|
|
list(tos - h);
|
|
evalf();
|
|
}
|
|
void
|
|
eval_expsin(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
expsin();
|
|
}
|
|
|
|
void
|
|
expsin(void)
|
|
{
|
|
struct atom *p1;
|
|
p1 = pop();
|
|
|
|
push(imaginaryunit);
|
|
push(p1);
|
|
multiply();
|
|
expfunc();
|
|
push(imaginaryunit);
|
|
divide();
|
|
push_rational(1, 2);
|
|
multiply();
|
|
|
|
push(imaginaryunit);
|
|
negate();
|
|
push(p1);
|
|
multiply();
|
|
expfunc();
|
|
push(imaginaryunit);
|
|
divide();
|
|
push_rational(1, 2);
|
|
multiply();
|
|
|
|
subtract();
|
|
}
|
|
void
|
|
eval_expsinh(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
expsinh();
|
|
}
|
|
|
|
void
|
|
expsinh(void)
|
|
{
|
|
struct atom *p1;
|
|
p1 = pop();
|
|
push(p1);
|
|
expfunc();
|
|
push(p1);
|
|
negate();
|
|
expfunc();
|
|
subtract();
|
|
push_rational(1, 2);
|
|
multiply();
|
|
}
|
|
// tan(z) = (i - i exp(2 i z)) / (exp(2 i z) + 1)
|
|
|
|
void
|
|
eval_exptan(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
exptan();
|
|
}
|
|
|
|
void
|
|
exptan(void)
|
|
{
|
|
struct atom *p1;
|
|
|
|
push_integer(2);
|
|
push(imaginaryunit);
|
|
multiply_factors(3);
|
|
expfunc();
|
|
|
|
p1 = pop();
|
|
|
|
push(imaginaryunit);
|
|
push(imaginaryunit);
|
|
push(p1);
|
|
multiply();
|
|
subtract();
|
|
|
|
push(p1);
|
|
push_integer(1);
|
|
add();
|
|
|
|
divide();
|
|
}
|
|
void
|
|
eval_exptanh(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
exptanh();
|
|
}
|
|
|
|
void
|
|
exptanh(void)
|
|
{
|
|
struct atom *p1;
|
|
push_integer(2);
|
|
multiply();
|
|
expfunc();
|
|
p1 = pop();
|
|
push(p1);
|
|
push_integer(1);
|
|
subtract();
|
|
push(p1);
|
|
push_integer(1);
|
|
add();
|
|
divide();
|
|
}
|
|
void
|
|
eval_factorial(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
factorial();
|
|
}
|
|
|
|
void
|
|
factorial(void)
|
|
{
|
|
int i, n;
|
|
double m;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (isposint(p1)) {
|
|
push(p1);
|
|
n = pop_integer();
|
|
push_integer(1);
|
|
for (i = 2; i <= n; i++) {
|
|
push_integer(i);
|
|
multiply();
|
|
}
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1) && p1->u.d >= 0 && floor(p1->u.d) == p1->u.d) {
|
|
push(p1);
|
|
n = pop_integer();
|
|
m = 1.0;
|
|
for (i = 2; i <= n; i++)
|
|
m *= i;
|
|
push_double(m);
|
|
return;
|
|
}
|
|
|
|
push_symbol(FACTORIAL);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_float(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
floatfunc();
|
|
}
|
|
|
|
void
|
|
floatfunc(void)
|
|
{
|
|
floatfunc_subst();
|
|
evalf();
|
|
floatfunc_subst(); // in case pi popped up
|
|
evalf();
|
|
}
|
|
|
|
void
|
|
floatfunc_subst(void)
|
|
{
|
|
int h, i, n;
|
|
double a, b;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
floatfunc_subst();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (p1 == symbol(PI)) {
|
|
push_double(M_PI);
|
|
return;
|
|
}
|
|
|
|
if (p1 == symbol(EXP1)) {
|
|
push_double(M_E);
|
|
return;
|
|
}
|
|
|
|
if (isrational(p1)) {
|
|
a = mfloat(p1->u.q.a);
|
|
b = mfloat(p1->u.q.b);
|
|
if (isnegativenumber(p1))
|
|
a = -a;
|
|
push_double(a / b);
|
|
return;
|
|
}
|
|
|
|
// don't float exponential
|
|
|
|
if (car(p1) == symbol(POWER) && cadr(p1) == symbol(EXP1)) {
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push(caddr(p1));
|
|
floatfunc_subst();
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
// don't float imaginary unit, but multiply it by 1.0
|
|
|
|
if (car(p1) == symbol(POWER) && isminusone(cadr(p1))) {
|
|
push_symbol(MULTIPLY);
|
|
push_double(1.0);
|
|
push_symbol(POWER);
|
|
push(cadr(p1));
|
|
push(caddr(p1));
|
|
floatfunc_subst();
|
|
list(3);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
if (iscons(p1)) {
|
|
h = tos;
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
floatfunc_subst();
|
|
p1 = cdr(p1);
|
|
}
|
|
list(tos - h);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
}
|
|
void
|
|
eval_floor(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
floorfunc();
|
|
}
|
|
|
|
void
|
|
floorfunc(void)
|
|
{
|
|
int i, n;
|
|
uint32_t *a, *b;
|
|
double d;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
floorfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isinteger(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isrational(p1)) {
|
|
a = mdiv(p1->u.q.a, p1->u.q.b);
|
|
b = mint(1);
|
|
if (isnegativenumber(p1)) {
|
|
push_bignum(MMINUS, a, b);
|
|
push_integer(-1);
|
|
add();
|
|
} else
|
|
push_bignum(MPLUS, a, b);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
d = floor(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
push_symbol(FLOOR);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_for(struct atom *p1)
|
|
{
|
|
int j, k, t;
|
|
struct atom *p2, *p3;
|
|
|
|
p2 = cadr(p1);
|
|
if (!isusersymbol(p2))
|
|
stopf("for: index symbol err");
|
|
|
|
push(caddr(p1));
|
|
evalf();
|
|
p3 = pop();
|
|
if (!issmallinteger(p3))
|
|
stopf("for: index range err");
|
|
push(p3);
|
|
j = pop_integer();
|
|
|
|
push(cadddr(p1));
|
|
evalf();
|
|
p3 = pop();
|
|
if (!issmallinteger(p3))
|
|
stopf("for: index range err");
|
|
push(p3);
|
|
k = pop_integer();
|
|
|
|
p1 = cddddr(p1);
|
|
|
|
save_symbol(p2);
|
|
|
|
t = breakflag;
|
|
breakflag = 0;
|
|
|
|
for (;;) {
|
|
push_integer(j);
|
|
p3 = pop();
|
|
set_symbol(p2, p3, symbol(NIL));
|
|
p3 = p1;
|
|
while (iscons(p3)) {
|
|
push(car(p3));
|
|
evalg();
|
|
pop();
|
|
p3 = cdr(p3);
|
|
if (breakflag || errorflag) {
|
|
breakflag = t;
|
|
restore_symbol();
|
|
push_symbol(NIL);
|
|
return;
|
|
}
|
|
}
|
|
if (j == k)
|
|
break;
|
|
if (j < k)
|
|
j++;
|
|
else
|
|
j--;
|
|
}
|
|
|
|
breakflag = t;
|
|
restore_symbol();
|
|
push_symbol(NIL);
|
|
}
|
|
void
|
|
eval_hadamard(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = cddr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
hadamard();
|
|
p1 = cdr(p1);
|
|
}
|
|
}
|
|
|
|
void
|
|
hadamard(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1, *p2;
|
|
|
|
p2 = pop();
|
|
p1 = pop();
|
|
|
|
if (!istensor(p1) || !istensor(p2)) {
|
|
push(p1);
|
|
push(p2);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
if (p1->u.tensor->ndim != p2->u.tensor->ndim)
|
|
stopf("hadamard");
|
|
|
|
n = p1->u.tensor->ndim;
|
|
|
|
for (i = 0; i < n; i++)
|
|
if (p1->u.tensor->dim[i] != p2->u.tensor->dim[i])
|
|
stopf("hadamard");
|
|
|
|
p1 = copy_tensor(p1);
|
|
|
|
n = p1->u.tensor->nelem;
|
|
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
push(p2->u.tensor->elem[i]);
|
|
multiply();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
|
|
push(p1);
|
|
}
|
|
void
|
|
eval_imag(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
imag();
|
|
}
|
|
|
|
void
|
|
imag(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
imag();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
rect();
|
|
p1 = pop();
|
|
push_rational(-1, 2);
|
|
push(imaginaryunit);
|
|
push(p1);
|
|
push(p1);
|
|
conjfunc();
|
|
subtract();
|
|
multiply_factors(3);
|
|
}
|
|
void
|
|
eval_index(struct atom *p1)
|
|
{
|
|
int h, n;
|
|
struct atom *T;
|
|
|
|
T = cadr(p1);
|
|
|
|
p1 = cddr(p1);
|
|
|
|
h = tos;
|
|
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
// try to optimize by indexing before eval
|
|
|
|
if (isusersymbol(T)) {
|
|
p1 = get_binding(T);
|
|
n = tos - h;
|
|
if (istensor(p1) && n <= p1->u.tensor->ndim) {
|
|
T = p1;
|
|
indexfunc(T, h);
|
|
evalf();
|
|
return;
|
|
}
|
|
}
|
|
|
|
push(T);
|
|
evalf();
|
|
T = pop();
|
|
|
|
if (!istensor(T)) {
|
|
tos = h; // pop all
|
|
push(T); // quirky, but EVA2.txt depends on it
|
|
return;
|
|
}
|
|
|
|
indexfunc(T, h);
|
|
}
|
|
|
|
void
|
|
indexfunc(struct atom *T, int h)
|
|
{
|
|
int i, k, m, n, r, t, w;
|
|
struct atom *p1;
|
|
|
|
m = T->u.tensor->ndim;
|
|
|
|
n = tos - h;
|
|
|
|
r = m - n; // rank of result
|
|
|
|
if (r < 0)
|
|
stopf("index error");
|
|
|
|
k = 0;
|
|
|
|
for (i = 0; i < n; i++) {
|
|
push(stack[h + i]);
|
|
t = pop_integer();
|
|
if (t < 1 || t > T->u.tensor->dim[i]) {
|
|
if (shuntflag) {
|
|
errorflag = 1;
|
|
t = 1;
|
|
} else
|
|
stopf("index error");
|
|
}
|
|
k = k * T->u.tensor->dim[i] + t - 1;
|
|
}
|
|
|
|
tos = h; // pop all
|
|
|
|
if (r == 0) {
|
|
push(T->u.tensor->elem[k]); // scalar result
|
|
return;
|
|
}
|
|
|
|
w = 1;
|
|
|
|
for (i = n; i < m; i++)
|
|
w *= T->u.tensor->dim[i];
|
|
|
|
k *= w;
|
|
|
|
p1 = alloc_tensor(w);
|
|
|
|
for (i = 0; i < w; i++)
|
|
p1->u.tensor->elem[i] = T->u.tensor->elem[k + i];
|
|
|
|
p1->u.tensor->ndim = r;
|
|
|
|
for (i = 0; i < r; i++)
|
|
p1->u.tensor->dim[i] = T->u.tensor->dim[n + i];
|
|
|
|
push(p1);
|
|
}
|
|
void
|
|
eval_infixform(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = pop();
|
|
|
|
outbuf_init();
|
|
infixform_expr(p1);
|
|
|
|
push_string(outbuf);
|
|
}
|
|
|
|
// for tty mode and debugging
|
|
|
|
void
|
|
print_infixform(struct atom *p)
|
|
{
|
|
outbuf_init();
|
|
infixform_expr(p);
|
|
outbuf_puts("\n");
|
|
printbuf(outbuf, BLACK);
|
|
}
|
|
|
|
void
|
|
infixform_subexpr(struct atom *p)
|
|
{
|
|
outbuf_puts("(");
|
|
infixform_expr(p);
|
|
outbuf_puts(")");
|
|
}
|
|
|
|
void
|
|
infixform_expr(struct atom *p)
|
|
{
|
|
if (isnegativeterm(p) || (car(p) == symbol(ADD) && isnegativeterm(cadr(p))))
|
|
outbuf_puts("-");
|
|
if (car(p) == symbol(ADD))
|
|
infixform_expr_nib(p);
|
|
else
|
|
infixform_term(p);
|
|
}
|
|
|
|
void
|
|
infixform_expr_nib(struct atom *p)
|
|
{
|
|
infixform_term(cadr(p));
|
|
p = cddr(p);
|
|
while (iscons(p)) {
|
|
if (isnegativeterm(car(p)))
|
|
outbuf_puts(" - ");
|
|
else
|
|
outbuf_puts(" + ");
|
|
infixform_term(car(p));
|
|
p = cdr(p);
|
|
}
|
|
}
|
|
|
|
void
|
|
infixform_term(struct atom *p)
|
|
{
|
|
if (car(p) == symbol(MULTIPLY))
|
|
infixform_term_nib(p);
|
|
else
|
|
infixform_factor(p);
|
|
}
|
|
|
|
void
|
|
infixform_term_nib(struct atom *p)
|
|
{
|
|
if (find_denominator(p)) {
|
|
infixform_numerators(p);
|
|
outbuf_puts(" / ");
|
|
infixform_denominators(p);
|
|
return;
|
|
}
|
|
|
|
// no denominators
|
|
|
|
p = cdr(p);
|
|
|
|
if (isminusone(car(p)))
|
|
p = cdr(p); // sign already emitted
|
|
|
|
infixform_factor(car(p));
|
|
|
|
p = cdr(p);
|
|
|
|
while (iscons(p)) {
|
|
outbuf_puts(" "); // space in between factors
|
|
infixform_factor(car(p));
|
|
p = cdr(p);
|
|
}
|
|
}
|
|
|
|
void
|
|
infixform_numerators(struct atom *p)
|
|
{
|
|
int k;
|
|
char *s;
|
|
struct atom *q;
|
|
|
|
k = 0;
|
|
|
|
p = cdr(p);
|
|
|
|
while (iscons(p)) {
|
|
|
|
q = car(p);
|
|
p = cdr(p);
|
|
|
|
if (!isnumerator(q))
|
|
continue;
|
|
|
|
if (++k > 1)
|
|
outbuf_puts(" "); // space in between factors
|
|
|
|
if (isrational(q)) {
|
|
s = mstr(q->u.q.a);
|
|
outbuf_puts(s);
|
|
continue;
|
|
}
|
|
|
|
infixform_factor(q);
|
|
}
|
|
|
|
if (k == 0)
|
|
outbuf_puts("1");
|
|
}
|
|
|
|
void
|
|
infixform_denominators(struct atom *p)
|
|
{
|
|
int k, n;
|
|
char *s;
|
|
struct atom *q;
|
|
|
|
n = count_denominators(p);
|
|
|
|
if (n > 1)
|
|
outbuf_puts("(");
|
|
|
|
k = 0;
|
|
|
|
p = cdr(p);
|
|
|
|
while (iscons(p)) {
|
|
|
|
q = car(p);
|
|
p = cdr(p);
|
|
|
|
if (!isdenominator(q))
|
|
continue;
|
|
|
|
if (++k > 1)
|
|
outbuf_puts(" "); // space in between factors
|
|
|
|
if (isrational(q)) {
|
|
s = mstr(q->u.q.b);
|
|
outbuf_puts(s);
|
|
continue;
|
|
}
|
|
|
|
if (isminusone(caddr(q))) {
|
|
q = cadr(q);
|
|
infixform_factor(q);
|
|
} else {
|
|
infixform_base(cadr(q));
|
|
outbuf_puts("^");
|
|
infixform_numeric_exponent(caddr(q)); // sign is not emitted
|
|
}
|
|
}
|
|
|
|
if (n > 1)
|
|
outbuf_puts(")");
|
|
}
|
|
|
|
void
|
|
infixform_factor(struct atom *p)
|
|
{
|
|
if (isrational(p)) {
|
|
infixform_rational(p);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p)) {
|
|
infixform_double(p);
|
|
return;
|
|
}
|
|
|
|
if (issymbol(p)) {
|
|
if (p == symbol(EXP1))
|
|
outbuf_puts("exp(1)");
|
|
else
|
|
outbuf_puts(printname(p));
|
|
return;
|
|
}
|
|
|
|
if (isstr(p)) {
|
|
outbuf_puts(p->u.str);
|
|
return;
|
|
}
|
|
|
|
if (istensor(p)) {
|
|
infixform_tensor(p);
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(ADD) || car(p) == symbol(MULTIPLY)) {
|
|
infixform_subexpr(p);
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(POWER)) {
|
|
infixform_power(p);
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(FACTORIAL)) {
|
|
infixform_factorial(p);
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(INDEX)) {
|
|
infixform_index(p);
|
|
return;
|
|
}
|
|
|
|
// use d if for derivative if d not defined
|
|
|
|
if (car(p) == symbol(DERIVATIVE) && get_usrfunc(symbol(D_LOWER)) == symbol(NIL)) {
|
|
outbuf_puts("d");
|
|
infixform_arglist(p);
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(SETQ)) {
|
|
infixform_expr(cadr(p));
|
|
outbuf_puts(" = ");
|
|
infixform_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(TESTEQ)) {
|
|
infixform_expr(cadr(p));
|
|
outbuf_puts(" == ");
|
|
infixform_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(TESTGE)) {
|
|
infixform_expr(cadr(p));
|
|
outbuf_puts(" >= ");
|
|
infixform_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(TESTGT)) {
|
|
infixform_expr(cadr(p));
|
|
outbuf_puts(" > ");
|
|
infixform_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(TESTLE)) {
|
|
infixform_expr(cadr(p));
|
|
outbuf_puts(" <= ");
|
|
infixform_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(TESTLT)) {
|
|
infixform_expr(cadr(p));
|
|
outbuf_puts(" < ");
|
|
infixform_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
// other function
|
|
|
|
if (iscons(p)) {
|
|
infixform_base(car(p));
|
|
infixform_arglist(p);
|
|
return;
|
|
}
|
|
|
|
outbuf_puts(" ? ");
|
|
}
|
|
|
|
void
|
|
infixform_power(struct atom *p)
|
|
{
|
|
if (cadr(p) == symbol(EXP1)) {
|
|
outbuf_puts("exp(");
|
|
infixform_expr(caddr(p));
|
|
outbuf_puts(")");
|
|
return;
|
|
}
|
|
|
|
if (isimaginaryunit(p)) {
|
|
if (isimaginaryunit(get_binding(symbol(J_LOWER)))) {
|
|
outbuf_puts("j");
|
|
return;
|
|
}
|
|
if (isimaginaryunit(get_binding(symbol(I_LOWER)))) {
|
|
outbuf_puts("i");
|
|
return;
|
|
}
|
|
}
|
|
|
|
if (isnegativenumber(caddr(p))) {
|
|
infixform_reciprocal(p);
|
|
return;
|
|
}
|
|
|
|
infixform_base(cadr(p));
|
|
|
|
outbuf_puts("^");
|
|
|
|
p = caddr(p); // p now points to exponent
|
|
|
|
if (isnum(p))
|
|
infixform_numeric_exponent(p);
|
|
else if (car(p) == symbol(ADD) || car(p) == symbol(MULTIPLY) || car(p) == symbol(POWER) || car(p) == symbol(FACTORIAL))
|
|
infixform_subexpr(p);
|
|
else
|
|
infixform_expr(p);
|
|
}
|
|
|
|
// p = y^x where x is a negative number
|
|
|
|
void
|
|
infixform_reciprocal(struct atom *p)
|
|
{
|
|
outbuf_puts("1 / "); // numerator
|
|
if (isminusone(caddr(p))) {
|
|
p = cadr(p);
|
|
infixform_factor(p);
|
|
} else {
|
|
infixform_base(cadr(p));
|
|
outbuf_puts("^");
|
|
infixform_numeric_exponent(caddr(p)); // sign is not emitted
|
|
}
|
|
}
|
|
|
|
void
|
|
infixform_factorial(struct atom *p)
|
|
{
|
|
infixform_base(cadr(p));
|
|
outbuf_puts("!");
|
|
}
|
|
|
|
void
|
|
infixform_index(struct atom *p)
|
|
{
|
|
infixform_base(cadr(p));
|
|
outbuf_puts("[");
|
|
p = cddr(p);
|
|
if (iscons(p)) {
|
|
infixform_expr(car(p));
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
outbuf_puts(",");
|
|
infixform_expr(car(p));
|
|
p = cdr(p);
|
|
}
|
|
}
|
|
outbuf_puts("]");
|
|
}
|
|
|
|
void
|
|
infixform_arglist(struct atom *p)
|
|
{
|
|
outbuf_puts("(");
|
|
p = cdr(p);
|
|
if (iscons(p)) {
|
|
infixform_expr(car(p));
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
outbuf_puts(",");
|
|
infixform_expr(car(p));
|
|
p = cdr(p);
|
|
}
|
|
}
|
|
outbuf_puts(")");
|
|
}
|
|
|
|
// sign is not emitted
|
|
|
|
void
|
|
infixform_rational(struct atom *p)
|
|
{
|
|
char *s;
|
|
|
|
s = mstr(p->u.q.a);
|
|
outbuf_puts(s);
|
|
|
|
s = mstr(p->u.q.b);
|
|
|
|
if (strcmp(s, "1") == 0)
|
|
return;
|
|
|
|
outbuf_puts("/");
|
|
|
|
outbuf_puts(s);
|
|
}
|
|
|
|
// sign is not emitted
|
|
|
|
void
|
|
infixform_double(struct atom *p)
|
|
{
|
|
char *s;
|
|
|
|
snprintf(strbuf, STRBUFLEN, "%g", fabs(p->u.d));
|
|
|
|
s = strbuf;
|
|
|
|
while (*s && *s != 'E' && *s != 'e')
|
|
outbuf_putc(*s++);
|
|
|
|
if (!*s)
|
|
return;
|
|
|
|
s++;
|
|
|
|
outbuf_puts(" 10^");
|
|
|
|
if (*s == '-') {
|
|
outbuf_puts("(-");
|
|
s++;
|
|
while (*s == '0')
|
|
s++; // skip leading zeroes
|
|
outbuf_puts(s);
|
|
outbuf_puts(")");
|
|
} else {
|
|
if (*s == '+')
|
|
s++;
|
|
while (*s == '0')
|
|
s++; // skip leading zeroes
|
|
outbuf_puts(s);
|
|
}
|
|
}
|
|
|
|
void
|
|
infixform_base(struct atom *p)
|
|
{
|
|
if (isnum(p))
|
|
infixform_numeric_base(p);
|
|
else if (car(p) == symbol(ADD) || car(p) == symbol(MULTIPLY) || car(p) == symbol(POWER) || car(p) == symbol(FACTORIAL))
|
|
infixform_subexpr(p);
|
|
else
|
|
infixform_expr(p);
|
|
}
|
|
|
|
void
|
|
infixform_numeric_base(struct atom *p)
|
|
{
|
|
if (isposint(p))
|
|
infixform_rational(p);
|
|
else
|
|
infixform_subexpr(p);
|
|
}
|
|
|
|
// sign is not emitted
|
|
|
|
void
|
|
infixform_numeric_exponent(struct atom *p)
|
|
{
|
|
if (isdouble(p)) {
|
|
outbuf_puts("(");
|
|
infixform_double(p);
|
|
outbuf_puts(")");
|
|
return;
|
|
}
|
|
|
|
if (isinteger(p)) {
|
|
infixform_rational(p);
|
|
return;
|
|
}
|
|
|
|
outbuf_puts("(");
|
|
infixform_rational(p);
|
|
outbuf_puts(")");
|
|
}
|
|
|
|
void
|
|
infixform_tensor(struct atom *p)
|
|
{
|
|
infixform_tensor_nib(p, 0, 0);
|
|
}
|
|
|
|
void
|
|
infixform_tensor_nib(struct atom *p, int d, int k)
|
|
{
|
|
int i, n, span;
|
|
|
|
if (d == p->u.tensor->ndim) {
|
|
infixform_expr(p->u.tensor->elem[k]);
|
|
return;
|
|
}
|
|
|
|
span = 1;
|
|
|
|
n = p->u.tensor->ndim;
|
|
|
|
for (i = d + 1; i < n; i++)
|
|
span *= p->u.tensor->dim[i];
|
|
|
|
outbuf_puts("(");
|
|
|
|
n = p->u.tensor->dim[d];
|
|
|
|
for (i = 0; i < n; i++) {
|
|
|
|
infixform_tensor_nib(p, d + 1, k);
|
|
|
|
if (i < n - 1)
|
|
outbuf_puts(",");
|
|
|
|
k += span;
|
|
}
|
|
|
|
outbuf_puts(")");
|
|
}
|
|
void
|
|
eval_inner(struct atom *p1)
|
|
{
|
|
int h = tos;
|
|
|
|
// evaluate from right to left
|
|
|
|
p1 = cdr(p1);
|
|
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
if (h == tos)
|
|
stopf("inner: no args");
|
|
|
|
evalg();
|
|
|
|
while (tos - h > 1) {
|
|
swap();
|
|
evalg();
|
|
swap();
|
|
inner();
|
|
}
|
|
}
|
|
|
|
void
|
|
inner(void)
|
|
{
|
|
int i, j, k, n, mcol, mrow, ncol, ndim, nrow;
|
|
struct atom *p1, *p2, *p3;
|
|
|
|
p2 = pop();
|
|
p1 = pop();
|
|
|
|
if (!istensor(p1) && !istensor(p2)) {
|
|
push(p1);
|
|
push(p2);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
if (istensor(p1) && !istensor(p2)) {
|
|
p3 = p1;
|
|
p1 = p2;
|
|
p2 = p3;
|
|
}
|
|
|
|
if (!istensor(p1) && istensor(p2)) {
|
|
p2 = copy_tensor(p2);
|
|
n = p2->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1);
|
|
push(p2->u.tensor->elem[i]);
|
|
multiply();
|
|
p2->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p2);
|
|
return;
|
|
}
|
|
|
|
k = p1->u.tensor->ndim - 1;
|
|
|
|
ncol = p1->u.tensor->dim[k];
|
|
mrow = p2->u.tensor->dim[0];
|
|
|
|
if (ncol != mrow)
|
|
stopf("inner: dimension err");
|
|
|
|
ndim = p1->u.tensor->ndim + p2->u.tensor->ndim - 2;
|
|
|
|
if (ndim > MAXDIM)
|
|
stopf("inner: rank exceeds max");
|
|
|
|
// nrow is the number of rows in p1
|
|
//
|
|
// mcol is the number of columns p2
|
|
//
|
|
// Example:
|
|
//
|
|
// A[3][3][4] B[4][4][3]
|
|
//
|
|
// 3 3 nrow = 3 * 3 = 9
|
|
//
|
|
// 4 3 mcol = 4 * 3 = 12
|
|
|
|
nrow = p1->u.tensor->nelem / ncol;
|
|
mcol = p2->u.tensor->nelem / mrow;
|
|
|
|
p3 = alloc_tensor(nrow * mcol);
|
|
|
|
for (i = 0; i < nrow; i++) {
|
|
for (j = 0; j < mcol; j++) {
|
|
for (k = 0; k < ncol; k++) {
|
|
push(p1->u.tensor->elem[i * ncol + k]);
|
|
push(p2->u.tensor->elem[k * mcol + j]);
|
|
multiply();
|
|
}
|
|
add_terms(ncol);
|
|
p3->u.tensor->elem[i * mcol + j] = pop();
|
|
}
|
|
}
|
|
|
|
if (ndim == 0) {
|
|
push(p3->u.tensor->elem[0]); // scalar result
|
|
return;
|
|
}
|
|
|
|
// dim info
|
|
|
|
p3->u.tensor->ndim = ndim;
|
|
|
|
k = 0;
|
|
|
|
n = p1->u.tensor->ndim - 1;
|
|
|
|
for (i = 0; i < n; i++)
|
|
p3->u.tensor->dim[k++] = p1->u.tensor->dim[i];
|
|
|
|
n = p2->u.tensor->ndim;
|
|
|
|
for (i = 1; i < n; i++)
|
|
p3->u.tensor->dim[k++] = p2->u.tensor->dim[i];
|
|
|
|
push(p3);
|
|
}
|
|
char *integral_tab_exp[] = {
|
|
|
|
// x^n exp(a x + b)
|
|
|
|
"exp(a x)",
|
|
"exp(a x) / a",
|
|
"1",
|
|
|
|
"exp(a x + b)",
|
|
"exp(a x + b) / a",
|
|
"1",
|
|
|
|
"x exp(a x)",
|
|
"exp(a x) (a x - 1) / (a^2)",
|
|
"1",
|
|
|
|
"x exp(a x + b)",
|
|
"exp(a x + b) (a x - 1) / (a^2)",
|
|
"1",
|
|
|
|
"x^2 exp(a x)",
|
|
"exp(a x) (a^2 x^2 - 2 a x + 2) / (a^3)",
|
|
"1",
|
|
|
|
"x^2 exp(a x + b)",
|
|
"exp(a x + b) (a^2 x^2 - 2 a x + 2) / (a^3)",
|
|
"1",
|
|
|
|
"x^3 exp(a x)",
|
|
"(a^3 x^3 - 3 a^2 x^2 + 6 a x - 6) exp(a x) / a^4",
|
|
"1",
|
|
|
|
"x^3 exp(a x + b)",
|
|
"(a^3 x^3 - 3 a^2 x^2 + 6 a x - 6) exp(a x + b) / a^4",
|
|
"1",
|
|
|
|
"x^4 exp(a x)",
|
|
"((a^4*x^4-4*a^3*x^3+12*a^2*x^2-24*a*x+24)*exp(a*x))/a^5",
|
|
"1",
|
|
|
|
"x^4 exp(a x + b)",
|
|
"((a^4*x^4-4*a^3*x^3+12*a^2*x^2-24*a*x+24)*exp(a*x+b))/a^5",
|
|
"1",
|
|
|
|
"x^5 exp(a x)",
|
|
"((a^5*x^5-5*a^4*x^4+20*a^3*x^3-60*a^2*x^2+120*a*x-120)*exp(a*x))/a^6",
|
|
"1",
|
|
|
|
"x^5 exp(a x + b)",
|
|
"((a^5*x^5-5*a^4*x^4+20*a^3*x^3-60*a^2*x^2+120*a*x-120)*exp(a*x+b))/a^6",
|
|
"1",
|
|
|
|
"x^6 exp(a x)",
|
|
"((a^6*x^6-6*a^5*x^5+30*a^4*x^4-120*a^3*x^3+360*a^2*x^2-720*a*x+720)*exp(a*x))/a^7",
|
|
"1",
|
|
|
|
"x^6 exp(a x + b)",
|
|
"((a^6*x^6-6*a^5*x^5+30*a^4*x^4-120*a^3*x^3+360*a^2*x^2-720*a*x+720)*exp(a*x+b))/a^7",
|
|
"1",
|
|
|
|
"x^7 exp(a x)",
|
|
"((a^7*x^7-7*a^6*x^6+42*a^5*x^5-210*a^4*x^4+840*a^3*x^3-2520*a^2*x^2+5040*a*x-5040)*exp(a*x))/a^8",
|
|
"1",
|
|
|
|
"x^7 exp(a x + b)",
|
|
"((a^7*x^7-7*a^6*x^6+42*a^5*x^5-210*a^4*x^4+840*a^3*x^3-2520*a^2*x^2+5040*a*x-5040)*exp(a*x+b))/a^8",
|
|
"1",
|
|
|
|
"x^8 exp(a x)",
|
|
"((a^8*x^8-8*a^7*x^7+56*a^6*x^6-336*a^5*x^5+1680*a^4*x^4-6720*a^3*x^3+20160*a^2*x^2-40320*a*x+40320)*exp(a*x))/a^9",
|
|
"1",
|
|
|
|
"x^8 exp(a x + b)",
|
|
"((a^8*x^8-8*a^7*x^7+56*a^6*x^6-336*a^5*x^5+1680*a^4*x^4-6720*a^3*x^3+20160*a^2*x^2-40320*a*x+40320)*exp(a*x+b))/a^9",
|
|
"1",
|
|
|
|
"x^9 exp(a x)",
|
|
"x^9 exp(a x) / a - 9 x^8 exp(a x) / a^2 + 72 x^7 exp(a x) / a^3 - 504 x^6 exp(a x) / a^4 + 3024 x^5 exp(a x) / a^5 - 15120 x^4 exp(a x) / a^6 + 60480 x^3 exp(a x) / a^7 - 181440 x^2 exp(a x) / a^8 + 362880 x exp(a x) / a^9 - 362880 exp(a x) / a^10",
|
|
"1",
|
|
|
|
"x^9 exp(a x + b)",
|
|
"x^9 exp(a x + b) / a - 9 x^8 exp(a x + b) / a^2 + 72 x^7 exp(a x + b) / a^3 - 504 x^6 exp(a x + b) / a^4 + 3024 x^5 exp(a x + b) / a^5 - 15120 x^4 exp(a x + b) / a^6 + 60480 x^3 exp(a x + b) / a^7 - 181440 x^2 exp(a x + b) / a^8 + 362880 x exp(a x + b) / a^9 - 362880 exp(a x + b) / a^10",
|
|
"1",
|
|
|
|
"x^10 exp(a x)",
|
|
"x^10 exp(a x) / a - 10 x^9 exp(a x) / a^2 + 90 x^8 exp(a x) / a^3 - 720 x^7 exp(a x) / a^4 + 5040 x^6 exp(a x) / a^5 - 30240 x^5 exp(a x) / a^6 + 151200 x^4 exp(a x) / a^7 - 604800 x^3 exp(a x) / a^8 + 1814400 x^2 exp(a x) / a^9 - 3628800 x exp(a x) / a^10 + 3628800 exp(a x) / a^11",
|
|
"1",
|
|
|
|
"x^10 exp(a x + b)",
|
|
"x^10 exp(a x + b) / a - 10 x^9 exp(a x + b) / a^2 + 90 x^8 exp(a x + b) / a^3 - 720 x^7 exp(a x + b) / a^4 + 5040 x^6 exp(a x + b) / a^5 - 30240 x^5 exp(a x + b) / a^6 + 151200 x^4 exp(a x + b) / a^7 - 604800 x^3 exp(a x + b) / a^8 + 1814400 x^2 exp(a x + b) / a^9 - 3628800 x exp(a x + b) / a^10 + 3628800 exp(a x + b) / a^11",
|
|
"1",
|
|
|
|
"x^11 exp(a x)",
|
|
"x^11 exp(a x) / a - 11 x^10 exp(a x) / a^2 + 110 x^9 exp(a x) / a^3 - 990 x^8 exp(a x) / a^4 + 7920 x^7 exp(a x) / a^5 - 55440 x^6 exp(a x) / a^6 + 332640 x^5 exp(a x) / a^7 - 1663200 x^4 exp(a x) / a^8 + 6652800 x^3 exp(a x) / a^9 - 19958400 x^2 exp(a x) / a^10 + 39916800 x exp(a x) / a^11 - 39916800 exp(a x) / a^12",
|
|
"1",
|
|
|
|
"x^11 exp(a x + b)",
|
|
"x^11 exp(a x + b) / a - 11 x^10 exp(a x + b) / a^2 + 110 x^9 exp(a x + b) / a^3 - 990 x^8 exp(a x + b) / a^4 + 7920 x^7 exp(a x + b) / a^5 - 55440 x^6 exp(a x + b) / a^6 + 332640 x^5 exp(a x + b) / a^7 - 1663200 x^4 exp(a x + b) / a^8 + 6652800 x^3 exp(a x + b) / a^9 - 19958400 x^2 exp(a x + b) / a^10 + 39916800 x exp(a x + b) / a^11 - 39916800 exp(a x + b) / a^12",
|
|
"1",
|
|
|
|
// sin exp
|
|
|
|
"sin(x) exp(a x)",
|
|
"a sin(x) exp(a x) / (a^2 + 1) - cos(x) exp(a x) / (a^2 + 1)",
|
|
"a^2 + 1", // denominator not zero
|
|
|
|
"sin(x) exp(a x + b)",
|
|
"a sin(x) exp(a x + b) / (a^2 + 1) - cos(x) exp(a x + b) / (a^2 + 1)",
|
|
"a^2 + 1", // denominator not zero
|
|
|
|
"sin(x) exp(i x)",
|
|
"-1/4 exp(2 i x) + 1/2 i x",
|
|
"1",
|
|
|
|
"sin(x) exp(i x + b)",
|
|
"-1/4 exp(b + 2 i x) + 1/2 i x exp(b)",
|
|
"1",
|
|
|
|
"sin(x) exp(-i x)",
|
|
"-1/4 exp(-2 i x) - 1/2 i x",
|
|
"1",
|
|
|
|
"sin(x) exp(-i x + b)",
|
|
"-1/4 exp(b - 2 i x) - 1/2 i x exp(b)",
|
|
"1",
|
|
|
|
// cos exp
|
|
|
|
"cos(x) exp(a x)",
|
|
"a cos(x) exp(a x) / (a^2 + 1) + sin(x) exp(a x) / (a^2 + 1)",
|
|
"a^2 + 1", // denominator not zero
|
|
|
|
"cos(x) exp(a x + b)",
|
|
"a cos(x) exp(a x + b) / (a^2 + 1) + sin(x) exp(a x + b) / (a^2 + 1)",
|
|
"a^2 + 1", // denominator not zero
|
|
|
|
"cos(x) exp(i x)",
|
|
"1/2 x - 1/4 i exp(2 i x)",
|
|
"1",
|
|
|
|
"cos(x) exp(i x + b)",
|
|
"1/2 x exp(b) - 1/4 i exp(b + 2 i x)",
|
|
"1",
|
|
|
|
"cos(x) exp(-i x)",
|
|
"1/2 x + 1/4 i exp(-2 i x)",
|
|
"1",
|
|
|
|
"cos(x) exp(-i x + b)",
|
|
"1/2 x exp(b) + 1/4 i exp(b - 2 i x)",
|
|
"1",
|
|
|
|
// sin cos exp
|
|
|
|
"sin(x) cos(x) exp(a x)",
|
|
"a sin(2 x) exp(a x) / (2 (a^2 + 4)) - cos(2 x) exp(a x) / (a^2 + 4)",
|
|
"a^2 + 4", // denominator not zero
|
|
|
|
// x^n exp(a x^2 + b)
|
|
|
|
"exp(a x^2)",
|
|
"-1/2 i sqrt(pi) erf(i sqrt(a) x) / sqrt(a)",
|
|
"1",
|
|
|
|
"exp(a x^2 + b)",
|
|
"-1/2 i sqrt(pi) exp(b) erf(i sqrt(a) x) / sqrt(a)",
|
|
"1",
|
|
|
|
"x exp(a x^2)",
|
|
"1/2 exp(a x^2) / a",
|
|
"1",
|
|
|
|
"x exp(a x^2 + b)",
|
|
"1/2 exp(a x^2 + b) / a",
|
|
"1",
|
|
|
|
"x^2 exp(a x^2)",
|
|
"1/2 x exp(a x^2) / a + 1/4 i sqrt(pi) erf(i sqrt(a) x) / a^(3/2)",
|
|
"1",
|
|
|
|
"x^2 exp(a x^2 + b)",
|
|
"1/2 x exp(a x^2 + b) / a + 1/4 i sqrt(pi) exp(b) erf(i sqrt(a) x) / a^(3/2)",
|
|
"1",
|
|
|
|
"x^3 exp(a x^2)",
|
|
"1/2 exp(a x^2) (x^2 / a - 1 / a^2)",
|
|
"1",
|
|
|
|
"x^3 exp(a x^2 + b)",
|
|
"1/2 exp(a x^2) exp(b) (x^2 / a - 1 / a^2)",
|
|
"1",
|
|
|
|
"x^4 exp(a x^2)",
|
|
"x^3 exp(a x^2) / (2 a) - 3 x exp(a x^2) / (4 a^2) - 3 i pi^(1/2) erf(i a^(1/2) x) / (8 a^(5/2))",
|
|
"1",
|
|
|
|
"x^4 exp(a x^2 + b)",
|
|
"x^3 exp(a x^2 + b) / (2 a) - 3 x exp(a x^2 + b) / (4 a^2) - 3 i pi^(1/2) erf(i a^(1/2) x) exp(b) / (8 a^(5/2))",
|
|
"1",
|
|
|
|
"x^5 exp(a x^2)",
|
|
"x^4 exp(a x^2) / (2 a) - x^2 exp(a x^2) / a^2 + exp(a x^2) / a^3",
|
|
"1",
|
|
|
|
"x^5 exp(a x^2 + b)",
|
|
"x^4 exp(a x^2 + b) / (2 a) - x^2 exp(a x^2 + b) / a^2 + exp(a x^2 + b) / a^3",
|
|
"1",
|
|
|
|
"x^6 exp(a x^2)",
|
|
"x^5 exp(a x^2) / (2 a) - 5 x^3 exp(a x^2) / (4 a^2) + 15 x exp(a x^2) / (8 a^3) + 15 i pi^(1/2) erf(i a^(1/2) x) / (16 a^(7/2))",
|
|
"1",
|
|
|
|
"x^6 exp(a x^2 + b)",
|
|
"x^5 exp(a x^2 + b) / (2 a) - 5 x^3 exp(a x^2 + b) / (4 a^2) + 15 x exp(a x^2 + b) / (8 a^3) + 15 i pi^(1/2) erf(i a^(1/2) x) exp(b) / (16 a^(7/2))",
|
|
"1",
|
|
|
|
"x^7 exp(a x^2)",
|
|
"x^6 exp(a x^2) / (2 a) - 3 x^4 exp(a x^2) / (2 a^2) + 3 x^2 exp(a x^2) / a^3 - 3 exp(a x^2) / a^4",
|
|
"1",
|
|
|
|
"x^7 exp(a x^2 + b)",
|
|
"x^6 exp(a x^2 + b) / (2 a) - 3 x^4 exp(a x^2 + b) / (2 a^2) + 3 x^2 exp(a x^2 + b) / a^3 - 3 exp(a x^2 + b) / a^4",
|
|
"1",
|
|
|
|
"x^8 exp(a x^2)",
|
|
"x^7 exp(a x^2) / (2 a) - 7 x^5 exp(a x^2) / (4 a^2) + 35 x^3 exp(a x^2) / (8 a^3) - 105 x exp(a x^2) / (16 a^4) - 105 i pi^(1/2) erf(i a^(1/2) x) / (32 a^(9/2))",
|
|
"1",
|
|
|
|
"x^8 exp(a x^2 + b)",
|
|
"x^7 exp(a x^2 + b) / (2 a) - 7 x^5 exp(a x^2 + b) / (4 a^2) + 35 x^3 exp(a x^2 + b) / (8 a^3) - 105 x exp(a x^2 + b) / (16 a^4) - 105 i pi^(1/2) erf(i a^(1/2) x) exp(b) / (32 a^(9/2))",
|
|
"1",
|
|
|
|
"x^9 exp(a x^2)",
|
|
"x^8 exp(a x^2) / (2 a) - 2 x^6 exp(a x^2) / a^2 + 6 x^4 exp(a x^2) / a^3 - 12 x^2 exp(a x^2) / a^4 + 12 exp(a x^2) / a^5",
|
|
"1",
|
|
|
|
"x^9 exp(a x^2 + b)",
|
|
"x^8 exp(a x^2 + b) / (2 a) - 2 x^6 exp(a x^2 + b) / a^2 + 6 x^4 exp(a x^2 + b) / a^3 - 12 x^2 exp(a x^2 + b) / a^4 + 12 exp(a x^2 + b) / a^5",
|
|
"1",
|
|
};
|
|
|
|
// log(a x) is transformed to log(a) + log(x)
|
|
|
|
char *integral_tab_log[] = {
|
|
|
|
"log(x)",
|
|
"x log(x) - x",
|
|
"1",
|
|
|
|
"log(a x + b)",
|
|
"x log(a x + b) + b log(a x + b) / a - x",
|
|
"1",
|
|
|
|
"x log(x)",
|
|
"x^2 log(x) 1/2 - x^2 1/4",
|
|
"1",
|
|
|
|
"x log(a x + b)",
|
|
"1/2 (a x - b) (a x + b) log(a x + b) / a^2 - 1/4 x (a x - 2 b) / a",
|
|
"1",
|
|
|
|
"x^2 log(x)",
|
|
"x^3 log(x) 1/3 - 1/9 x^3",
|
|
"1",
|
|
|
|
"x^2 log(a x + b)",
|
|
"1/3 (a x + b) (a^2 x^2 - a b x + b^2) log(a x + b) / a^3 - 1/18 x (2 a^2 x^2 - 3 a b x + 6 b^2) / a^2",
|
|
"1",
|
|
|
|
"log(x)^2",
|
|
"x log(x)^2 - 2 x log(x) + 2 x",
|
|
"1",
|
|
|
|
"log(a x + b)^2",
|
|
"(a x + b) (log(a x + b)^2 - 2 log(a x + b) + 2) / a",
|
|
"1",
|
|
|
|
"log(x) / x^2",
|
|
"-(log(x) + 1) / x",
|
|
"1",
|
|
|
|
"log(a x + b) / x^2",
|
|
"a log(x) / b - (a x + b) log(a x + b) / (b x)",
|
|
"1",
|
|
|
|
"1 / (x (a + log(x)))",
|
|
"log(a + log(x))",
|
|
"1",
|
|
};
|
|
|
|
char *integral_tab_trig[] = {
|
|
|
|
"sin(a x)",
|
|
"-cos(a x) / a",
|
|
"1",
|
|
|
|
"cos(a x)",
|
|
"sin(a x) / a",
|
|
"1",
|
|
|
|
"tan(a x)",
|
|
"-log(cos(a x)) / a",
|
|
"1",
|
|
|
|
// sin(a x)^n
|
|
|
|
"sin(a x)^2",
|
|
"-sin(2 a x) / (4 a) + 1/2 x",
|
|
"1",
|
|
|
|
"sin(a x)^3",
|
|
"-2 cos(a x) / (3 a) - cos(a x) sin(a x)^2 / (3 a)",
|
|
"1",
|
|
|
|
"sin(a x)^4",
|
|
"-sin(2 a x) / (4 a) + sin(4 a x) / (32 a) + 3/8 x",
|
|
"1",
|
|
|
|
"sin(a x)^5",
|
|
"-cos(a x)^5 / (5 a) + 2 cos(a x)^3 / (3 a) - cos(a x) / a",
|
|
"1",
|
|
|
|
"sin(a x)^6",
|
|
"sin(2 a x)^3 / (48 a) - sin(2 a x) / (4 a) + 3 sin(4 a x) / (64 a) + 5/16 x",
|
|
"1",
|
|
|
|
// cos(a x)^n
|
|
|
|
"cos(a x)^2",
|
|
"sin(2 a x) / (4 a) + 1/2 x",
|
|
"1",
|
|
|
|
"cos(a x)^3",
|
|
"cos(a x)^2 sin(a x) / (3 a) + 2 sin(a x) / (3 a)",
|
|
"1",
|
|
|
|
"cos(a x)^4",
|
|
"sin(2 a x) / (4 a) + sin(4 a x) / (32 a) + 3/8 x",
|
|
"1",
|
|
|
|
"cos(a x)^5",
|
|
"sin(a x)^5 / (5 a) - 2 sin(a x)^3 / (3 a) + sin(a x) / a",
|
|
"1",
|
|
|
|
"cos(a x)^6",
|
|
"-sin(2 a x)^3 / (48 a) + sin(2 a x) / (4 a) + 3 sin(4 a x) / (64 a) + 5/16 x",
|
|
"1",
|
|
|
|
//
|
|
|
|
"sin(a x) cos(a x)",
|
|
"1/2 sin(a x)^2 / a",
|
|
"1",
|
|
|
|
"sin(a x) cos(a x)^2",
|
|
"-1/3 cos(a x)^3 / a",
|
|
"1",
|
|
|
|
"sin(a x)^2 cos(a x)",
|
|
"1/3 sin(a x)^3 / a",
|
|
"1",
|
|
|
|
"sin(a x)^2 cos(a x)^2",
|
|
"1/8 x - 1/32 sin(4 a x) / a",
|
|
"1",
|
|
// 329
|
|
"1 / sin(a x) / cos(a x)",
|
|
"log(tan(a x)) / a",
|
|
"1",
|
|
// 330
|
|
"1 / sin(a x) / cos(a x)^2",
|
|
"(1 / cos(a x) + log(tan(a x 1/2))) / a",
|
|
"1",
|
|
// 331
|
|
"1 / sin(a x)^2 / cos(a x)",
|
|
"(log(tan(pi 1/4 + a x 1/2)) - 1 / sin(a x)) / a",
|
|
"1",
|
|
// 333
|
|
"1 / sin(a x)^2 / cos(a x)^2",
|
|
"-2 / (a tan(2 a x))",
|
|
"1",
|
|
//
|
|
"sin(a x) / cos(a x)",
|
|
"-log(cos(a x)) / a",
|
|
"1",
|
|
|
|
"sin(a x) / cos(a x)^2",
|
|
"1 / a / cos(a x)",
|
|
"1",
|
|
|
|
"sin(a x)^2 / cos(a x)",
|
|
"-(sin(a x) + log(cos(a x / 2) - sin(a x / 2)) - log(sin(a x / 2) + cos(a x / 2))) / a",
|
|
"1",
|
|
|
|
"sin(a x)^2 / cos(a x)^2",
|
|
"tan(a x) / a - x",
|
|
"1",
|
|
|
|
"cos(a x) / sin(a x)",
|
|
"log(sin(a x)) / a",
|
|
"1",
|
|
|
|
"cos(a x) / sin(a x)^2",
|
|
"-1 / (a sin(a x))",
|
|
"1",
|
|
|
|
"cos(a x)^2 / sin(a x)^2",
|
|
"-x - cos(a x) / sin(a x) / a",
|
|
"1",
|
|
|
|
"sin(a + b x)",
|
|
"-cos(a + b x) / b",
|
|
"1",
|
|
|
|
"cos(a + b x)",
|
|
"sin(a + b x) / b",
|
|
"1",
|
|
|
|
"x sin(a x)",
|
|
"sin(a x) / (a^2) - x cos(a x) / a",
|
|
"1",
|
|
|
|
"x^2 sin(a x)",
|
|
"2 x sin(a x) / (a^2) - (a^2 x^2 - 2) cos(a x) / (a^3)",
|
|
"1",
|
|
|
|
"x cos(a x)",
|
|
"cos(a x) / (a^2) + x sin(a x) / a",
|
|
"1",
|
|
|
|
"x^2 cos(a x)",
|
|
"2 x cos(a x) / (a^2) + (a^2 x^2 - 2) sin(a x) / (a^3)",
|
|
"1",
|
|
|
|
"1 / tan(a x)",
|
|
"log(sin(a x)) / a",
|
|
"1",
|
|
|
|
"1 / cos(a x)",
|
|
"log(tan(pi 1/4 + a x 1/2)) / a",
|
|
"1",
|
|
|
|
"1 / sin(a x)",
|
|
"log(tan(a x 1/2)) / a",
|
|
"1",
|
|
|
|
"1 / sin(a x)^2",
|
|
"-1 / (a tan(a x))",
|
|
"1",
|
|
|
|
"1 / cos(a x)^2",
|
|
"tan(a x) / a",
|
|
"1",
|
|
|
|
"1 / (b + b sin(a x))",
|
|
"-tan(pi 1/4 - a x 1/2) / (a b)",
|
|
"1",
|
|
|
|
"1 / (b - b sin(a x))",
|
|
"tan(pi 1/4 + a x 1/2) / (a b)",
|
|
"1",
|
|
|
|
"1 / (b + b cos(a x))",
|
|
"tan(a x 1/2) / (a b)",
|
|
"1",
|
|
|
|
"1 / (b - b cos(a x))",
|
|
"-1 / (tan(a x 1/2) a b)",
|
|
"1",
|
|
|
|
"1 / (a + b sin(x))",
|
|
"log((a tan(x 1/2) + b - sqrt(b^2 - a^2)) / (a tan(x 1/2) + b + sqrt(b^2 - a^2))) / sqrt(b^2 - a^2)",
|
|
"b^2 - a^2",
|
|
|
|
"1 / (a + b cos(x))",
|
|
"log((sqrt(b^2 - a^2) tan(x 1/2) + a + b) / (sqrt(b^2 - a^2) tan(x 1/2) - a - b)) / sqrt(b^2 - a^2)",
|
|
"b^2 - a^2",
|
|
|
|
"x sin(a x) sin(b x)",
|
|
"1/2 ((x sin(x (a - b)))/(a - b) - (x sin(x (a + b)))/(a + b) + cos(x (a - b))/(a - b)^2 - cos(x (a + b))/(a + b)^2)",
|
|
"and(not(a + b == 0),not(a - b == 0))",
|
|
|
|
"sin(a x)/(cos(a x) - 1)^2",
|
|
"1/a * 1/(cos(a x) - 1)",
|
|
"1",
|
|
|
|
"sin(a x)/(1 - cos(a x))^2",
|
|
"1/a * 1/(cos(a x) - 1)",
|
|
"1",
|
|
|
|
"cos(x)^3 sin(x)",
|
|
"-1/4 cos(x)^4",
|
|
"1",
|
|
|
|
"cos(a x)^5",
|
|
"sin(a x)^5 / (5 a) - 2 sin(a x)^3 / (3 a) + sin(a x) / a",
|
|
"1",
|
|
|
|
"cos(a x)^5 / sin(a x)^2",
|
|
"sin(a x)^3 / (3 a) - 2 sin(a x) / a - 1 / (a sin(a x))",
|
|
"1",
|
|
|
|
"cos(a x)^3 / sin(a x)^2",
|
|
"-sin(a x) / a - 1 / (a sin(a x))",
|
|
"1",
|
|
|
|
"cos(a x)^5 / sin(a x)",
|
|
"log(sin(a x)) / a + sin(a x)^4 / (4 a) - sin(a x)^2 / a",
|
|
"1",
|
|
|
|
"cos(a x)^3 / sin(a x)",
|
|
"log(sin(a x)) / a - sin(a x)^2 / (2 a)",
|
|
"1",
|
|
|
|
"cos(a x) sin(a x)^3",
|
|
"sin(a x)^4 / (4 a)",
|
|
"1",
|
|
|
|
"cos(a x)^3 sin(a x)^2",
|
|
"-sin(a x)^5 / (5 a) + sin(a x)^3 / (3 a)",
|
|
"1",
|
|
|
|
"cos(a x)^2 sin(a x)^3",
|
|
"cos(a x)^5 / (5 a) - cos(a x)^3 / (3 a)",
|
|
"1",
|
|
|
|
"cos(a x)^4 sin(a x)",
|
|
"-cos(a x)^5 / (5 a)",
|
|
"1",
|
|
|
|
"cos(a x)^7 / sin(a x)^2",
|
|
"-sin(a x)^5 / (5 a) + sin(a x)^3 / a - 3 sin(a x) / a - 1 / (a sin(a x))",
|
|
"1",
|
|
|
|
// cos(a x)^n / sin(a x)
|
|
|
|
"cos(a x)^2 / sin(a x)",
|
|
"cos(a x) / a + log(tan(1/2 a x)) / a",
|
|
"1",
|
|
|
|
"cos(a x)^4 / sin(a x)",
|
|
"4 cos(a x) / (3 a) - cos(a x) sin(a x)^2 / (3 a) + log(tan(1/2 a x)) / a",
|
|
"1",
|
|
|
|
"cos(a x)^6 / sin(a x)",
|
|
"cos(a x)^5 / (5 a) - 2 cos(a x)^3 / (3 a) + 2 cos(a x) / a - cos(a x) sin(a x)^2 / a + log(tan(1/2 a x)) / a",
|
|
"1",
|
|
};
|
|
|
|
char *integral_tab_power[] = {
|
|
|
|
"a", // for forms c^d where both c and d are constant expressions
|
|
"a x",
|
|
"1",
|
|
|
|
"1 / x",
|
|
"log(x)",
|
|
"1",
|
|
|
|
"x^a", // integrand
|
|
"x^(a + 1) / (a + 1)", // answer
|
|
"not(a = -1)", // condition
|
|
|
|
"a^x",
|
|
"a^x / log(a)",
|
|
"or(not(number(a)),a>0)",
|
|
|
|
"1 / (a + b x)",
|
|
"log(a + b x) / b",
|
|
"1",
|
|
// 124
|
|
"sqrt(a x + b)",
|
|
"2/3 (a x + b)^(3/2) / a",
|
|
"1",
|
|
// 138
|
|
"sqrt(a x^2 + b)",
|
|
"1/2 x sqrt(a x^2 + b) + 1/2 b log(sqrt(a) sqrt(a x^2 + b) + a x) / sqrt(a)",
|
|
"1",
|
|
// 131
|
|
"1 / sqrt(a x + b)",
|
|
"2 sqrt(a x + b) / a",
|
|
"1",
|
|
|
|
"1 / ((a + b x)^2)",
|
|
"-1 / (b (a + b x))",
|
|
"1",
|
|
|
|
"1 / ((a + b x)^3)",
|
|
"-1 / ((2 b) ((a + b x)^2))",
|
|
"1",
|
|
// 16
|
|
"1 / (a x^2 + b)",
|
|
"arctan(sqrt(a) x / sqrt(b)) / sqrt(a) / sqrt(b)",
|
|
"1",
|
|
// 17
|
|
"1 / sqrt(1 - x^2)",
|
|
"arcsin(x)",
|
|
"1",
|
|
|
|
"sqrt(1 + x^2 / (1 - x^2))",
|
|
"arcsin(x)",
|
|
"1",
|
|
|
|
"1 / sqrt(a x^2 + b)",
|
|
"log(sqrt(a) sqrt(a x^2 + b) + a x) / sqrt(a)",
|
|
"1",
|
|
// 65
|
|
"1 / (a x^2 + b)^2",
|
|
"1/2 ((arctan((sqrt(a) x) / sqrt(b))) / (sqrt(a) b^(3/2)) + x / (a b x^2 + b^2))",
|
|
"1",
|
|
// 67 (m=2)
|
|
"1 / (a + b x^2)^3",
|
|
"x / (a + b x^2)^2 / (4 a) + 3 x / (8 a (a^2 + a b x^2)) + 3 arctan(b^(1/2) x / a^(1/2),1) / (8 a^(5/2) b^(1/2))",
|
|
"1",
|
|
// 67 (m=3)
|
|
"1 / (a + b x^2)^4",
|
|
"11 x / (16 a (a + b x^2)^3) + 5 b x^3 / (6 a^2 (a + b x^2)^3) + 5 b^2 x^5 / (16 a^3 (a + b x^2)^3) + 5 arctan(b^(1/2) x / a^(1/2),1) / (16 a^(7/2) b^(1/2))",
|
|
"1",
|
|
// 165
|
|
"(a x^2 + b)^(-3/2)",
|
|
"x / b / sqrt(a x^2 + b)",
|
|
"1",
|
|
// 74
|
|
"1 / (a x^3 + b)",
|
|
"-log(a^(2/3) x^2 - a^(1/3) b^(1/3) x + b^(2/3))/(6 a^(1/3) b^(2/3))"
|
|
" + log(a^(1/3) x + b^(1/3))/(3 a^(1/3) b^(2/3))"
|
|
" - (i log(1 - (i (1 - (2 a^(1/3) x)/b^(1/3)))/sqrt(3)))/(2 sqrt(3) a^(1/3) b^(2/3))"
|
|
" + (i log(1 + (i (1 - (2 a^(1/3) x)/b^(1/3)))/sqrt(3)))/(2 sqrt(3) a^(1/3) b^(2/3))", // from Wolfram Alpha
|
|
"1",
|
|
// 77 78
|
|
"1 / (a x^4 + b)",
|
|
"-log(-sqrt(2) a^(1/4) b^(1/4) x + sqrt(a) x^2 + sqrt(b))/(4 sqrt(2) a^(1/4) b^(3/4))"
|
|
" + log(sqrt(2) a^(1/4) b^(1/4) x + sqrt(a) x^2 + sqrt(b))/(4 sqrt(2) a^(1/4) b^(3/4))"
|
|
" - (i log(1 - i (1 - (sqrt(2) a^(1/4) x)/b^(1/4))))/(4 sqrt(2) a^(1/4) b^(3/4))"
|
|
" + (i log(1 + i (1 - (sqrt(2) a^(1/4) x)/b^(1/4))))/(4 sqrt(2) a^(1/4) b^(3/4))"
|
|
" + (i log(1 - i ((sqrt(2) a^(1/4) x)/b^(1/4) + 1)))/(4 sqrt(2) a^(1/4) b^(3/4))"
|
|
" - (i log(1 + i ((sqrt(2) a^(1/4) x)/b^(1/4) + 1)))/(4 sqrt(2) a^(1/4) b^(3/4))", // from Wolfram Alpha
|
|
"1",
|
|
//
|
|
"1 / (a x^5 + b)",
|
|
"(sqrt(5) log(2 a^(2/5) x^2 + (sqrt(5) - 1) a^(1/5) b^(1/5) x + 2 b^(2/5))"
|
|
" - log(2 a^(2/5) x^2 + (sqrt(5) - 1) a^(1/5) b^(1/5) x + 2 b^(2/5))"
|
|
" - sqrt(5) log(2 a^(2/5) x^2 - (1 + sqrt(5)) a^(1/5) b^(1/5) x + 2 b^(2/5))"
|
|
" - log(2 a^(2/5) x^2 - (1 + sqrt(5)) a^(1/5) b^(1/5) x + 2 b^(2/5))"
|
|
" + 4 log(a^(1/5) x + b^(1/5))"
|
|
" + 2 sqrt(2 (5 + sqrt(5))) arctan((4 a^(1/5) x + (sqrt(5) - 1) b^(1/5))/(sqrt(2 (5 + sqrt(5))) b^(1/5)))"
|
|
" + 2 sqrt(10 - 2 sqrt(5)) arctan((4 a^(1/5) x - (1 + sqrt(5)) b^(1/5))/(sqrt(10 - 2 sqrt(5)) b^(1/5))))/(20 a^(1/5) b^(4/5))", // from Wolfram Alpha
|
|
"1",
|
|
// 164
|
|
"sqrt(a + x^6 + 3 a^(1/3) x^4 + 3 a^(2/3) x^2)",
|
|
"1/4 (x sqrt((x^2 + a^(1/3))^3) + 3/2 a^(1/3) x sqrt(x^2 + a^(1/3)) + 3/2 a^(2/3) log(x + sqrt(x^2 + a^(1/3))))",
|
|
"1",
|
|
// 165
|
|
"sqrt(-a + x^6 - 3 a^(1/3) x^4 + 3 a^(2/3) x^2)",
|
|
"1/4 (x sqrt((x^2 - a^(1/3))^3) - 3/2 a^(1/3) x sqrt(x^2 - a^(1/3)) + 3/2 a^(2/3) log(x + sqrt(x^2 - a^(1/3))))",
|
|
"1",
|
|
|
|
"sinh(x)^2",
|
|
"sinh(2 x) 1/4 - x 1/2",
|
|
"1",
|
|
|
|
"tanh(x)^2",
|
|
"x - tanh(x)",
|
|
"1",
|
|
|
|
"cosh(x)^2",
|
|
"sinh(2 x) 1/4 + x 1/2",
|
|
"1",
|
|
};
|
|
|
|
char *integral_tab[] = {
|
|
|
|
"a",
|
|
"a x",
|
|
"1",
|
|
|
|
"x",
|
|
"1/2 x^2",
|
|
"1",
|
|
// 18
|
|
"x / sqrt(a x^2 + b)",
|
|
"sqrt(a x^2 + b) / a",
|
|
"1",
|
|
|
|
"x / (a + b x)",
|
|
"x / b - a log(a + b x) / (b b)",
|
|
"1",
|
|
|
|
"x / ((a + b x)^2)",
|
|
"(log(a + b x) + a / (a + b x)) / (b^2)",
|
|
"1",
|
|
// 33
|
|
"x^2 / (a + b x)",
|
|
"a^2 log(a + b x) / b^3 + x (b x - 2 a) / (2 b^2)",
|
|
"1",
|
|
// 34
|
|
"x^2 / (a + b x)^2",
|
|
"(-a^2 / (a + b x) - 2 a log(a + b x) + b x) / b^3",
|
|
"1",
|
|
|
|
"x^2 / (a + b x)^3",
|
|
"(log(a + b x) + 2 a / (a + b x) - a^2 / (2 ((a + b x)^2))) / (b^3)",
|
|
"1",
|
|
|
|
"1 / x / (a + b x)",
|
|
"-log((a + b x) / x) / a",
|
|
"1",
|
|
|
|
"1 / x / (a + b x)^2",
|
|
"1 / (a (a + b x)) - log((a + b x) / x) / (a^2)",
|
|
"1",
|
|
|
|
"1 / x / (a + b x)^3",
|
|
"(1/2 ((2 a + b x) / (a + b x))^2 + log(x / (a + b x))) / (a^3)",
|
|
"1",
|
|
|
|
"1 / x^2 / (a + b x)",
|
|
"-1 / (a x) + b log((a + b x) / x) / (a^2)",
|
|
"1",
|
|
|
|
"1 / x^3 / (a + b x)",
|
|
"(2 b x - a) / (2 a^2 x^2) + b^2 log(x / (a + b x)) / (a^3)",
|
|
"1",
|
|
|
|
"1 / x^2 / (a + b x)^2",
|
|
"-(a + 2 b x) / (a^2 x (a + b x)) + 2 b log((a + b x) / x) / (a^3)",
|
|
"1",
|
|
|
|
"x / (a + b x^2)",
|
|
"log(a + b x^2) / (2 b)",
|
|
"1",
|
|
// 64
|
|
"x^2 / (a x^2 + b)",
|
|
"1/2 i a^(-3/2) sqrt(b) (log(1 + i sqrt(a) x / sqrt(b)) - log(1 - i sqrt(a) x / sqrt(b))) + x / a",
|
|
"1",
|
|
// 68 (m=1)
|
|
"x / (a + b x^2)^2",
|
|
"-1 / (2 b (a + b x^2))",
|
|
"1",
|
|
// 68 (m=2)
|
|
"x / (a + b x^2)^3",
|
|
"-1 / (4 b (a + b x^2)^2)",
|
|
"1",
|
|
// 68 (m=3)
|
|
"x / (a + b x^2)^4",
|
|
"-1 / (6 b (a + b x^2)^3)",
|
|
"1",
|
|
// 69 (m=1)
|
|
"x^2 / (a + b x^2)^2",
|
|
"-x / (2 b (a + b x^2)) + arctan(sqrt(b/a) x) / (2 sqrt(a b^3))",
|
|
"1",
|
|
// 69 (m=2)
|
|
"x^2 / (a + b x^2)^3",
|
|
"x^3 / (8 a (a + b x^2)^2) + arctan(b^(1/2) x / a^(1/2),1) / (8 a^(3/2) b^(3/2)) - x / (8 b (a + b x^2)^2)",
|
|
"1",
|
|
// 69 (m=3)
|
|
"x^2 / (a + b x^2)^4",
|
|
"x^3 / (6 a (a + b x^2)^3) + b x^5 / (16 a^2 (a + b x^2)^3) + arctan(b^(1/2) x / a^(1/2),1) / (16 a^(5/2) b^(3/2)) - x / (16 b (a + b x^2)^3)",
|
|
"1",
|
|
// 70
|
|
"1 / x * 1 / (a + b x^2)",
|
|
"1 log(x^2 / (a + b x^2)) / (2 a)",
|
|
"1",
|
|
// 71
|
|
"1 / x^2 * 1 / (a x^2 + b)",
|
|
"1/2 i sqrt(a) b^(-3/2) (log(1 + i sqrt(a) x / sqrt(b)) - log(1 - i sqrt(a) x / sqrt(b))) - 1 / (b x)",
|
|
"1",
|
|
// 75
|
|
"x / (a x^3 + b)",
|
|
"log(a^(2/3) x^2 - a^(1/3) b^(1/3) x + b^(2/3))/(6 a^(2/3) b^(1/3))"
|
|
" - log(a^(1/3) x + b^(1/3))/(3 a^(2/3) b^(1/3))"
|
|
" - (i log(1 - (i (1 - (2 a^(1/3) x)/b^(1/3)))/sqrt(3)))/(2 sqrt(3) a^(2/3) b^(1/3))"
|
|
" + (i log(1 + (i (1 - (2 a^(1/3) x)/b^(1/3)))/sqrt(3)))/(2 sqrt(3) a^(2/3) b^(1/3))", // from Wolfram Alpha
|
|
"1",
|
|
// 76
|
|
"x^2 / (a + b x^3)",
|
|
"1 log(a + b x^3) / (3 b)",
|
|
"1",
|
|
// 79 80
|
|
"x / (a x^4 + b)",
|
|
"(i log(1 - (i sqrt(a) x^2)/sqrt(b)))/(4 sqrt(a) sqrt(b))"
|
|
" - (i log(1 + (i sqrt(a) x^2)/sqrt(b)))/(4 sqrt(a) sqrt(b))", // from Wolfram Alpha
|
|
"1",
|
|
// 81 82
|
|
"x^2 / (a x^4 + b)",
|
|
"log(-sqrt(2) a^(1/4) b^(1/4) x + sqrt(a) x^2 + sqrt(b))/(4 sqrt(2) a^(3/4) b^(1/4))"
|
|
" - log(sqrt(2) a^(1/4) b^(1/4) x + sqrt(a) x^2 + sqrt(b))/(4 sqrt(2) a^(3/4) b^(1/4))"
|
|
" - (i log(1 - i (1 - (sqrt(2) a^(1/4) x)/b^(1/4))))/(4 sqrt(2) a^(3/4) b^(1/4))"
|
|
" + (i log(1 + i (1 - (sqrt(2) a^(1/4) x)/b^(1/4))))/(4 sqrt(2) a^(3/4) b^(1/4))"
|
|
" + (i log(1 - i ((sqrt(2) a^(1/4) x)/b^(1/4) + 1)))/(4 sqrt(2) a^(3/4) b^(1/4))"
|
|
" - (i log(1 + i ((sqrt(2) a^(1/4) x)/b^(1/4) + 1)))/(4 sqrt(2) a^(3/4) b^(1/4))", // from Wolfram Alpha
|
|
"1",
|
|
//
|
|
"x^3 / (a + b x^4)",
|
|
"1 log(a + b x^4) / (4 b)",
|
|
"1",
|
|
|
|
"x sqrt(a + b x)",
|
|
"-2 (2 a - 3 b x) sqrt((a + b x)^3) 1/15 / (b^2)",
|
|
"1",
|
|
|
|
"x^2 sqrt(a + b x)",
|
|
"2 (8 a^2 - 12 a b x + 15 b^2 x^2) sqrt((a + b x)^3) 1/105 / (b^3)",
|
|
"1",
|
|
|
|
"x^2 sqrt(a + b x^2)",
|
|
"(sqrt(b) x sqrt(a + b x^2) (a + 2 b x^2) - a^2 log(sqrt(b) sqrt(a + b x^2) + b x)) / (8 b^(3/2))",
|
|
"1",
|
|
// 128
|
|
"sqrt(a x + b) / x",
|
|
"2 sqrt(a x + b) - 2 sqrt(b) arctanh(sqrt(a x + b) / sqrt(b))",
|
|
"1",
|
|
// 129
|
|
"sqrt(a x + b) / x^2",
|
|
"-sqrt(a x + b) / x - a arctanh(sqrt(a x + b) / sqrt(b)) / sqrt(b)",
|
|
"1",
|
|
|
|
"x / sqrt(a + b x)",
|
|
"-2 (2 a - b x) sqrt(a + b x) / (3 (b^2))",
|
|
"1",
|
|
|
|
"x^2 / sqrt(a + b x)",
|
|
"2 (8 a^2 - 4 a b x + 3 b^2 x^2) sqrt(a + b x) / (15 (b^3))",
|
|
"1",
|
|
// 134
|
|
"1 / x / sqrt(a x + b)",
|
|
"-2 arctanh(sqrt(a x + b) / sqrt(b)) / sqrt(b)",
|
|
"1",
|
|
// 137
|
|
"1 / x^2 / sqrt(a x + b)",
|
|
"a arctanh(sqrt(a x + b) / sqrt(b)) / b^(3/2) - sqrt(a x + b) / (b x)",
|
|
"1",
|
|
// 158
|
|
"1 / x / sqrt(a x^2 + b)",
|
|
"(log(x) - log(sqrt(b) sqrt(a x^2 + b) + b)) / sqrt(b)",
|
|
"1",
|
|
// 160
|
|
"sqrt(a x^2 + b) / x",
|
|
"sqrt(a x^2 + b) - sqrt(b) log(sqrt(b) sqrt(a x^2 + b) + b) + sqrt(b) log(x)",
|
|
"1",
|
|
// 163
|
|
"x sqrt(a x^2 + b)",
|
|
"1/3 (a x^2 + b)^(3/2) / a",
|
|
"1",
|
|
// 166
|
|
"x (a x^2 + b)^(-3/2)",
|
|
"-1 / a / sqrt(a x^2 + b)",
|
|
"1",
|
|
|
|
"x sqrt(a + x^6 + 3 a^(1/3) x^4 + 3 a^(2/3) x^2)",
|
|
"1/5 sqrt((x^2 + a^(1/3))^5)",
|
|
"1",
|
|
// 168
|
|
"x^2 sqrt(a x^2 + b)",
|
|
"1/8 a^(-3/2) (sqrt(a) x sqrt(a x^2 + b) (2 a x^2 + b) - b^2 log(sqrt(a) sqrt(a x^2 + b) + a x))",
|
|
"and(number(a),a>0)",
|
|
// 169
|
|
"x^3 sqrt(a x^2 + b)",
|
|
"1/15 sqrt(a x^2 + b) (3 a^2 x^4 + a b x^2 - 2 b^2) / a^2",
|
|
"1",
|
|
// 171
|
|
"x^2 / sqrt(a x^2 + b)",
|
|
"1/2 a^(-3/2) (sqrt(a) x sqrt(a x^2 + b) - b log(sqrt(a) sqrt(a x^2 + b) + a x))",
|
|
"1",
|
|
// 172
|
|
"x^3 / sqrt(a x^2 + b)",
|
|
"1/3 (a x^2 - 2 b) sqrt(a x^2 + b) / a^2",
|
|
"1",
|
|
// 173
|
|
"1 / x^2 / sqrt(a x^2 + b)",
|
|
"-sqrt(a x^2 + b) / (b x)",
|
|
"1",
|
|
// 174
|
|
"1 / x^3 / sqrt(a x^2 + b)",
|
|
"-sqrt(a x^2 + b) / (2 b x^2) + a (log(sqrt(b) sqrt(a x^2 + b) + b) - log(x)) / (2 b^(3/2))",
|
|
"1",
|
|
// 216
|
|
"sqrt(a x^2 + b) / x^2",
|
|
"sqrt(a) log(sqrt(a) sqrt(a x^2 + b) + a x) - sqrt(a x^2 + b) / x",
|
|
"and(number(a),a>0)",
|
|
// 217
|
|
"sqrt(a x^2 + b) / x^3",
|
|
"1/2 (-sqrt(a x^2 + b) / x^2 - (a log(sqrt(b) sqrt(a x^2 + b) + b)) / sqrt(b) + (a log(x)) / sqrt(b))",
|
|
"and(number(b),b>0)",
|
|
|
|
"arcsin(a x)",
|
|
"x arcsin(a x) + sqrt(1 - a^2 x^2) / a",
|
|
"1",
|
|
|
|
"arccos(a x)",
|
|
"x arccos(a x) + sqrt(1 - a^2 x^2) / a",
|
|
"1",
|
|
|
|
"arctan(a x)",
|
|
"x arctan(a x) - log(1 + a^2 x^2) / (2 a)",
|
|
"1",
|
|
|
|
"sinh(x)",
|
|
"cosh(x)",
|
|
"1",
|
|
|
|
"cosh(x)",
|
|
"sinh(x)",
|
|
"1",
|
|
|
|
"tanh(x)",
|
|
"log(cosh(x))",
|
|
"1",
|
|
|
|
"x sinh(x)",
|
|
"x cosh(x) - sinh(x)",
|
|
"1",
|
|
|
|
"x cosh(x)",
|
|
"x sinh(x) - cosh(x)",
|
|
"1",
|
|
|
|
"erf(a x)",
|
|
"x erf(a x) + exp(-a^2 x^2) / (a sqrt(pi))",
|
|
"1",
|
|
|
|
"x^2 (1 - x^2)^(3/2)",
|
|
"(x sqrt(1 - x^2) (-8 x^4 + 14 x^2 - 3) + 3 arcsin(x)) 1/48",
|
|
"1",
|
|
|
|
"x^2 (1 - x^2)^(5/2)",
|
|
"(x sqrt(1 - x^2) (48 x^6 - 136 x^4 + 118 x^2 - 15) + 15 arcsin(x)) 1/384",
|
|
"1",
|
|
|
|
"x^4 (1 - x^2)^(3/2)",
|
|
"(-x sqrt(1 - x^2) (16 x^6 - 24 x^4 + 2 x^2 + 3) + 3 arcsin(x)) 1/128",
|
|
"1",
|
|
};
|
|
|
|
void
|
|
eval_integral(struct atom *p1)
|
|
{
|
|
int flag, i, n;
|
|
struct atom *X, *Y = NULL; // silence compiler
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
|
|
p1 = cddr(p1);
|
|
|
|
if (!iscons(p1)) {
|
|
push_symbol(X_LOWER);
|
|
integral();
|
|
return;
|
|
}
|
|
|
|
flag = 0;
|
|
|
|
while (iscons(p1) || flag) {
|
|
|
|
if (flag) {
|
|
X = Y;
|
|
flag = 0;
|
|
} else {
|
|
push(car(p1));
|
|
evalf();
|
|
X = pop();
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
if (isnum(X)) {
|
|
push(X);
|
|
n = pop_integer();
|
|
push_symbol(X_LOWER);
|
|
X = pop();
|
|
for (i = 0; i < n; i++) {
|
|
push(X);
|
|
integral();
|
|
}
|
|
continue;
|
|
}
|
|
|
|
if (!isusersymbol(X))
|
|
stopf("integral");
|
|
|
|
if (iscons(p1)) {
|
|
|
|
push(car(p1));
|
|
evalf();
|
|
Y = pop();
|
|
p1 = cdr(p1);
|
|
|
|
if (isnum(Y)) {
|
|
push(Y);
|
|
n = pop_integer();
|
|
for (i = 0; i < n; i++) {
|
|
push(X);
|
|
integral();
|
|
}
|
|
continue;
|
|
}
|
|
|
|
flag = 1;
|
|
}
|
|
|
|
push(X);
|
|
integral();
|
|
}
|
|
}
|
|
|
|
void
|
|
integral(void)
|
|
{
|
|
int h;
|
|
struct atom *p1, *F, *X;
|
|
|
|
X = pop();
|
|
F = pop();
|
|
|
|
if (!isusersymbol(X))
|
|
stopf("integral: symbol expected");
|
|
|
|
if (car(F) == symbol(ADD)) {
|
|
h = tos;
|
|
p1 = cdr(F);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
push(X);
|
|
integral();
|
|
p1 = cdr(p1);
|
|
}
|
|
add_terms(tos - h);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(MULTIPLY)) {
|
|
push(F);
|
|
push(X);
|
|
partition_term(); // push const part then push var part
|
|
F = pop(); // pop var part
|
|
integral_solve(F, X);
|
|
multiply(); // multiply by const part
|
|
return;
|
|
}
|
|
|
|
integral_solve(F, X);
|
|
}
|
|
|
|
void
|
|
integral_solve(struct atom *F, struct atom *X)
|
|
{
|
|
struct atom *p;
|
|
|
|
if (car(F) == symbol(INTEGRAL)) {
|
|
integral_of_integral(F, X);
|
|
return;
|
|
}
|
|
|
|
if (car(F) == symbol(DERIVATIVE)) {
|
|
integral_of_derivative(F, X);
|
|
return;
|
|
}
|
|
|
|
save_symbol(symbol(SA));
|
|
save_symbol(symbol(SB));
|
|
save_symbol(symbol(SX));
|
|
|
|
integral_solve_nib(F, X);
|
|
|
|
p = pop();
|
|
restore_symbol();
|
|
restore_symbol();
|
|
restore_symbol();
|
|
push(p);
|
|
}
|
|
|
|
void
|
|
integral_solve_nib(struct atom *F, struct atom *X)
|
|
{
|
|
int h, t;
|
|
|
|
set_symbol(symbol(SX), X, symbol(NIL));
|
|
|
|
h = tos;
|
|
|
|
push_integer(1); // 1 is a candidate for a and b
|
|
|
|
push(F);
|
|
push(X);
|
|
decomp(); // push possible substitutions for a and b
|
|
|
|
t = integral_classify(F);
|
|
|
|
if ((t & 1) && integral_search(h, F, integral_tab_exp, sizeof integral_tab_exp / sizeof (char *)))
|
|
return;
|
|
|
|
if ((t & 2) && integral_search(h, F, integral_tab_log, sizeof integral_tab_log / sizeof (char *)))
|
|
return;
|
|
|
|
if ((t & 4) && integral_search(h, F, integral_tab_trig, sizeof integral_tab_trig / sizeof (char *)))
|
|
return;
|
|
|
|
if (car(F) == symbol(POWER)) {
|
|
if (integral_search(h, F, integral_tab_power, sizeof integral_tab_power / sizeof (char *)))
|
|
return;
|
|
} else {
|
|
if (integral_search(h, F, integral_tab, sizeof integral_tab / sizeof (char *)))
|
|
return;
|
|
}
|
|
|
|
tos = h; // pop all
|
|
|
|
push_symbol(INTEGRAL);
|
|
push(F);
|
|
push(X);
|
|
list(3);
|
|
}
|
|
|
|
int
|
|
integral_classify(struct atom *p)
|
|
{
|
|
int t = 0;
|
|
|
|
if (iscons(p)) {
|
|
while (iscons(p)) {
|
|
t |= integral_classify(car(p));
|
|
p = cdr(p);
|
|
}
|
|
return t;
|
|
}
|
|
|
|
if (p == symbol(EXP1))
|
|
return 1;
|
|
|
|
if (p == symbol(LOG))
|
|
return 2;
|
|
|
|
if (p == symbol(SIN) || p == symbol(COS) || p == symbol(TAN))
|
|
return 4;
|
|
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
integral_search(int h, struct atom *F, char **table, int n)
|
|
{
|
|
int i;
|
|
struct atom *C, *I;
|
|
|
|
for (i = 0; i < n; i += 3) {
|
|
|
|
scan1(table[i + 0]); // integrand
|
|
I = pop();
|
|
|
|
scan1(table[i + 2]); // condition
|
|
C = pop();
|
|
|
|
if (integral_search_nib(h, F, I, C))
|
|
break;
|
|
}
|
|
|
|
if (i >= n)
|
|
return 0;
|
|
|
|
tos = h; // pop all
|
|
|
|
scan1(table[i + 1]); // answer
|
|
evalf();
|
|
|
|
return 1;
|
|
}
|
|
|
|
int
|
|
integral_search_nib(int h, struct atom *F, struct atom *I, struct atom *C)
|
|
{
|
|
int i, j;
|
|
struct atom *p1;
|
|
|
|
for (i = h; i < tos; i++) {
|
|
|
|
set_symbol(symbol(SA), stack[i], symbol(NIL));
|
|
|
|
for (j = h; j < tos; j++) {
|
|
|
|
set_symbol(symbol(SB), stack[j], symbol(NIL));
|
|
|
|
push(C); // condition ok?
|
|
evalf();
|
|
p1 = pop();
|
|
if (iszero(p1))
|
|
continue; // no, go to next j
|
|
|
|
push(F); // F = I?
|
|
push(I);
|
|
evalf();
|
|
subtract();
|
|
p1 = pop();
|
|
if (iszero(p1))
|
|
return 1; // yes
|
|
}
|
|
}
|
|
|
|
return 0; // no
|
|
}
|
|
|
|
// push const coeffs
|
|
|
|
void
|
|
decomp(void)
|
|
{
|
|
struct atom *p1, *F, *X;
|
|
|
|
X = pop();
|
|
F = pop();
|
|
|
|
// is the entire expression constant?
|
|
|
|
if (!dependent(F, X)) {
|
|
push(F);
|
|
return;
|
|
}
|
|
|
|
// sum?
|
|
|
|
if (car(F) == symbol(ADD)) {
|
|
decomp_sum(F, X);
|
|
return;
|
|
}
|
|
|
|
// product?
|
|
|
|
if (car(F) == symbol(MULTIPLY)) {
|
|
decomp_product(F, X);
|
|
return;
|
|
}
|
|
|
|
// naive decomp
|
|
|
|
p1 = cdr(F);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
push(X);
|
|
decomp();
|
|
p1 = cdr(p1);
|
|
}
|
|
}
|
|
|
|
void
|
|
decomp_sum(struct atom *F, struct atom *X)
|
|
{
|
|
int h, i, j, k, n;
|
|
struct atom *p1, *p2;
|
|
|
|
h = tos;
|
|
|
|
// partition terms
|
|
|
|
p1 = cdr(F);
|
|
|
|
while (iscons(p1)) {
|
|
p2 = car(p1);
|
|
if (dependent(p2, X)) {
|
|
if (car(p2) == symbol(MULTIPLY)) {
|
|
push(p2);
|
|
push(X);
|
|
partition_term(); // push const part then push var part
|
|
} else {
|
|
push_integer(1); // const part
|
|
push(p2); // var part
|
|
}
|
|
}
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
// combine const parts of matching var parts
|
|
|
|
n = tos - h;
|
|
|
|
for (i = 0; i < n - 2; i += 2)
|
|
for (j = i + 2; j < n; j += 2) {
|
|
if (!equal(stack[h + i + 1], stack[h + j + 1]))
|
|
continue;
|
|
push(stack[h + i]); // add const parts
|
|
push(stack[h + j]);
|
|
add();
|
|
stack[h + i] = pop();
|
|
for (k = j; k < n - 2; k++)
|
|
stack[h + k] = stack[h + k + 2];
|
|
j -= 2; // use same j again
|
|
n -= 2;
|
|
tos -= 2; // pop
|
|
}
|
|
|
|
// push const parts, decomp var parts
|
|
|
|
list(tos - h);
|
|
p1 = pop();
|
|
|
|
while (iscons(p1)) {
|
|
push(car(p1)); // const part
|
|
push(cadr(p1)); // var part
|
|
push(X);
|
|
decomp();
|
|
p1 = cddr(p1);
|
|
}
|
|
|
|
// add together all constant terms
|
|
|
|
h = tos;
|
|
p1 = cdr(F);
|
|
while (iscons(p1)) {
|
|
if (!dependent(car(p1), X))
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
n = tos - h;
|
|
|
|
if (n > 1) {
|
|
list(n);
|
|
push_symbol(ADD);
|
|
swap();
|
|
cons(); // makes ADD head of list
|
|
}
|
|
}
|
|
|
|
void
|
|
decomp_product(struct atom *F, struct atom *X)
|
|
{
|
|
int h, n;
|
|
struct atom *p1;
|
|
|
|
// decomp factors involving x
|
|
|
|
p1 = cdr(F);
|
|
while (iscons(p1)) {
|
|
if (dependent(car(p1), X)) {
|
|
push(car(p1));
|
|
push(X);
|
|
decomp();
|
|
}
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
// combine constant factors
|
|
|
|
h = tos;
|
|
p1 = cdr(F);
|
|
while (iscons(p1)) {
|
|
if (!dependent(car(p1), X))
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
n = tos - h;
|
|
|
|
if (n > 1) {
|
|
list(n);
|
|
push_symbol(MULTIPLY);
|
|
swap();
|
|
cons(); // makes MULTIPLY head of list
|
|
}
|
|
}
|
|
|
|
void
|
|
partition_term(void)
|
|
{
|
|
int h, n;
|
|
struct atom *p1, *F, *X;
|
|
|
|
X = pop();
|
|
F = pop();
|
|
|
|
// push const factors
|
|
|
|
h = tos;
|
|
p1 = cdr(F);
|
|
while (iscons(p1)) {
|
|
if (!dependent(car(p1), X))
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
n = tos - h;
|
|
|
|
if (n == 0)
|
|
push_integer(1);
|
|
else if (n > 1) {
|
|
list(n);
|
|
push_symbol(MULTIPLY);
|
|
swap();
|
|
cons(); // makes MULTIPLY head of list
|
|
}
|
|
|
|
// push var factors
|
|
|
|
h = tos;
|
|
p1 = cdr(F);
|
|
while (iscons(p1)) {
|
|
if (dependent(car(p1), X))
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
n = tos - h;
|
|
|
|
if (n == 0)
|
|
push_integer(1);
|
|
else if (n > 1) {
|
|
list(n);
|
|
push_symbol(MULTIPLY);
|
|
swap();
|
|
cons(); // makes MULTIPLY head of list
|
|
}
|
|
}
|
|
|
|
void
|
|
integral_of_integral(struct atom *F, struct atom *X)
|
|
{
|
|
struct atom *G, *Y;
|
|
|
|
G = cadr(F);
|
|
Y = caddr(F);
|
|
|
|
// if X == Y then F is not integrable for X
|
|
|
|
if (equal(X, Y)) {
|
|
push_symbol(INTEGRAL);
|
|
push(F);
|
|
push(X);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
push(G);
|
|
push(X);
|
|
integral();
|
|
|
|
G = pop();
|
|
|
|
if (car(G) == symbol(INTEGRAL)) {
|
|
|
|
// sort integrals by measure
|
|
|
|
F = cadr(G);
|
|
X = caddr(G);
|
|
|
|
push_symbol(INTEGRAL);
|
|
push_symbol(INTEGRAL);
|
|
push(F);
|
|
|
|
if (lessp(X, Y)) {
|
|
push(X);
|
|
list(3);
|
|
push(Y);
|
|
list(3);
|
|
} else {
|
|
push(Y);
|
|
list(3);
|
|
push(X);
|
|
list(3);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
push(G);
|
|
push(Y);
|
|
integral();
|
|
}
|
|
|
|
void
|
|
integral_of_derivative(struct atom *F, struct atom *X)
|
|
{
|
|
struct atom *G, *Y;
|
|
|
|
G = cadr(F);
|
|
Y = caddr(F);
|
|
|
|
if (equal(X, Y)) {
|
|
push(G); // integral and derivative cancel
|
|
return;
|
|
}
|
|
|
|
push(G);
|
|
push(X);
|
|
integral();
|
|
|
|
G = pop();
|
|
|
|
// integral before derivative
|
|
|
|
if (car(G) == symbol(INTEGRAL)) {
|
|
F = cadr(G);
|
|
X = caddr(G);
|
|
push_symbol(INTEGRAL);
|
|
push_symbol(DERIVATIVE);
|
|
push(F);
|
|
push(Y);
|
|
list(3);
|
|
push(X);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
push(G);
|
|
push(Y);
|
|
derivative();
|
|
}
|
|
void
|
|
eval_inv(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
inv();
|
|
}
|
|
|
|
void
|
|
inv(void)
|
|
{
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (!istensor(p1)) {
|
|
push(p1);
|
|
reciprocate();
|
|
return;
|
|
}
|
|
|
|
if (!issquarematrix(p1))
|
|
stopf("inv: square matrix expected");
|
|
|
|
push(p1);
|
|
adj();
|
|
|
|
push(p1);
|
|
det();
|
|
|
|
divide();
|
|
}
|
|
void
|
|
eval_kronecker(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = cddr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
kronecker();
|
|
p1 = cdr(p1);
|
|
}
|
|
}
|
|
|
|
void
|
|
kronecker(void)
|
|
{
|
|
int h, i, j, k, l, m, n, p, q;
|
|
struct atom *p1, *p2, *p3;
|
|
|
|
p2 = pop();
|
|
p1 = pop();
|
|
|
|
if (!istensor(p1) || !istensor(p2)) {
|
|
push(p1);
|
|
push(p2);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
if (p1->u.tensor->ndim > 2 || p2->u.tensor->ndim > 2)
|
|
stopf("kronecker");
|
|
|
|
m = p1->u.tensor->dim[0];
|
|
n = p1->u.tensor->ndim == 1 ? 1 : p1->u.tensor->dim[1];
|
|
|
|
p = p2->u.tensor->dim[0];
|
|
q = p2->u.tensor->ndim == 1 ? 1 : p2->u.tensor->dim[1];
|
|
|
|
p3 = alloc_tensor(m * n * p * q);
|
|
|
|
// result matrix has (m * p) rows and (n * q) columns
|
|
|
|
h = 0;
|
|
|
|
for (i = 0; i < m; i++)
|
|
for (j = 0; j < p; j++)
|
|
for (k = 0; k < n; k++)
|
|
for (l = 0; l < q; l++) {
|
|
push(p1->u.tensor->elem[n * i + k]);
|
|
push(p2->u.tensor->elem[q * j + l]);
|
|
multiply();
|
|
p3->u.tensor->elem[h++] = pop();
|
|
}
|
|
|
|
// dim info
|
|
|
|
p3->u.tensor->ndim = n * q == 1 ? 1 : 2;
|
|
|
|
p3->u.tensor->dim[0] = m * p;
|
|
|
|
if (n * q > 1)
|
|
p3->u.tensor->dim[1] = n * q;
|
|
|
|
push(p3);
|
|
}
|
|
void
|
|
eval_lgamma(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
lgammafunc();
|
|
}
|
|
|
|
void
|
|
lgammafunc(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
lgammafunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
floatfunc();
|
|
p2 = pop();
|
|
|
|
if (isnum(p2)) {
|
|
push(p2);
|
|
d = pop_double();
|
|
d = lgamma(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
push_symbol(LGAMMA);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_log(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
logfunc();
|
|
}
|
|
|
|
void
|
|
logfunc(void)
|
|
{
|
|
int h, i, n;
|
|
double d;
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
logfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (hasdouble(p1)) {
|
|
push(p1);
|
|
floatfunc();
|
|
p1 = pop();
|
|
}
|
|
|
|
if (iszero(p1)) {
|
|
push_symbol(LOG);
|
|
push_integer(0);
|
|
list(2);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
if (d > 0.0) {
|
|
push_double(log(d));
|
|
return;
|
|
}
|
|
}
|
|
|
|
// log(z) -> log(mag(z)) + i arg(z)
|
|
|
|
if (isdouble(p1) || isdoublez(p1)) {
|
|
push(p1);
|
|
magfunc();
|
|
logfunc();
|
|
push(p1);
|
|
argfunc();
|
|
push(imaginaryunit);
|
|
multiply();
|
|
add();
|
|
return;
|
|
}
|
|
|
|
// log(1) -> 0
|
|
|
|
if (isplusone(p1)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
// log(e) -> 1
|
|
|
|
if (p1 == symbol(EXP1)) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
if (isnegativenumber(p1)) {
|
|
push(p1);
|
|
negate();
|
|
logfunc();
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
multiply();
|
|
add();
|
|
return;
|
|
}
|
|
|
|
// log(10) -> log(2) + log(5)
|
|
|
|
if (isrational(p1)) {
|
|
h = tos;
|
|
push(p1);
|
|
factor_factor();
|
|
for (i = h; i < tos; i++) {
|
|
p2 = stack[i];
|
|
if (car(p2) == symbol(POWER)) {
|
|
push(caddr(p2)); // exponent
|
|
push_symbol(LOG);
|
|
push(cadr(p2)); // base
|
|
list(2);
|
|
multiply();
|
|
} else {
|
|
push_symbol(LOG);
|
|
push(p2);
|
|
list(2);
|
|
}
|
|
stack[i] = pop();
|
|
}
|
|
add_terms(tos - h);
|
|
return;
|
|
}
|
|
|
|
// log(a ^ b) -> b log(a)
|
|
|
|
if (car(p1) == symbol(POWER)) {
|
|
push(caddr(p1));
|
|
push(cadr(p1));
|
|
logfunc();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// log(a * b) -> log(a) + log(b)
|
|
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
h = tos;
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
logfunc();
|
|
p1 = cdr(p1);
|
|
}
|
|
add_terms(tos - h);
|
|
return;
|
|
}
|
|
|
|
push_symbol(LOG);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_loop(struct atom *p1)
|
|
{
|
|
int t;
|
|
struct atom *p2;
|
|
t = breakflag;
|
|
breakflag = 0;
|
|
if (lengthf(p1) < 2) {
|
|
push_symbol(NIL);
|
|
return;
|
|
}
|
|
for (;;) {
|
|
p2 = cdr(p1);
|
|
while (iscons(p2)) {
|
|
push(car(p2));
|
|
evalg();
|
|
pop();
|
|
p2 = cdr(p2);
|
|
if (breakflag || errorflag) {
|
|
breakflag = t;
|
|
push_symbol(NIL);
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
void
|
|
eval_mag(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
magfunc();
|
|
}
|
|
|
|
void
|
|
magfunc(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1, *num, *den;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
magfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
// use numden to handle (a + i b) / (c + i d)
|
|
|
|
push(p1);
|
|
numden();
|
|
num = pop();
|
|
den = pop();
|
|
push(num);
|
|
magfunc_nib();
|
|
push(den);
|
|
magfunc_nib();
|
|
divide();
|
|
}
|
|
|
|
void
|
|
magfunc_nib(void)
|
|
{
|
|
int h;
|
|
struct atom *p1, *x, *y;
|
|
|
|
p1 = pop();
|
|
|
|
if (isnum(p1)) {
|
|
push(p1);
|
|
absfunc();
|
|
return;
|
|
}
|
|
|
|
// -1 to a power
|
|
|
|
if (car(p1) == symbol(POWER) && isminusone(cadr(p1))) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
// exponential
|
|
|
|
if (car(p1) == symbol(POWER) && cadr(p1) == symbol(EXP1)) {
|
|
push(caddr(p1));
|
|
real();
|
|
expfunc();
|
|
return;
|
|
}
|
|
|
|
// product
|
|
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
p1 = cdr(p1);
|
|
h = tos;
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
magfunc_nib();
|
|
p1 = cdr(p1);
|
|
}
|
|
multiply_factors(tos - h);
|
|
return;
|
|
}
|
|
|
|
// sum
|
|
|
|
if (car(p1) == symbol(ADD)) {
|
|
push(p1);
|
|
rect(); // convert polar terms, if any
|
|
p1 = pop();
|
|
push(p1);
|
|
real();
|
|
x = pop();
|
|
push(p1);
|
|
imag();
|
|
y = pop();
|
|
if (iszero(y)) {
|
|
push(x);
|
|
return;
|
|
}
|
|
if (iszero(x)) {
|
|
push(y);
|
|
return;
|
|
}
|
|
push(x);
|
|
push(x);
|
|
multiply();
|
|
push(y);
|
|
push(y);
|
|
multiply();
|
|
add();
|
|
sqrtfunc();
|
|
return;
|
|
}
|
|
|
|
// real
|
|
|
|
push(p1);
|
|
}
|
|
void
|
|
eval_minor(struct atom *p1)
|
|
{
|
|
int i, j;
|
|
struct atom *p2;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
p2 = pop();
|
|
|
|
push(caddr(p1));
|
|
evalf();
|
|
i = pop_integer();
|
|
|
|
push(cadddr(p1));
|
|
evalf();
|
|
j = pop_integer();
|
|
|
|
if (!istensor(p2) || p2->u.tensor->ndim != 2 || p2->u.tensor->dim[0] != p2->u.tensor->dim[1])
|
|
stopf("minor");
|
|
|
|
if (i < 1 || i > p2->u.tensor->dim[0] || j < 0 || j > p2->u.tensor->dim[1])
|
|
stopf("minor");
|
|
|
|
push(p2);
|
|
|
|
minormatrix(i, j);
|
|
|
|
det();
|
|
}
|
|
void
|
|
eval_minormatrix(struct atom *p1)
|
|
{
|
|
int i, j;
|
|
struct atom *p2;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
p2 = pop();
|
|
|
|
push(caddr(p1));
|
|
evalf();
|
|
i = pop_integer();
|
|
|
|
push(cadddr(p1));
|
|
evalf();
|
|
j = pop_integer();
|
|
|
|
if (!istensor(p2) || p2->u.tensor->ndim != 2)
|
|
stopf("minormatrix: matrix expected");
|
|
|
|
if (i < 1 || i > p2->u.tensor->dim[0] || j < 0 || j > p2->u.tensor->dim[1])
|
|
stopf("minormatrix: index err");
|
|
|
|
push(p2);
|
|
|
|
minormatrix(i, j);
|
|
}
|
|
|
|
void
|
|
minormatrix(int row, int col)
|
|
{
|
|
int i, j, k, m, n;
|
|
struct atom *p1, *p2;
|
|
|
|
p2 = symbol(NIL); // silence compiler
|
|
|
|
p1 = pop();
|
|
|
|
n = p1->u.tensor->dim[0];
|
|
m = p1->u.tensor->dim[1];
|
|
|
|
if (n == 2 && m == 2) {
|
|
if (row == 1) {
|
|
if (col == 1)
|
|
push(p1->u.tensor->elem[3]);
|
|
else
|
|
push(p1->u.tensor->elem[2]);
|
|
} else {
|
|
if (col == 1)
|
|
push(p1->u.tensor->elem[1]);
|
|
else
|
|
push(p1->u.tensor->elem[0]);
|
|
}
|
|
return;
|
|
}
|
|
|
|
if (n == 2)
|
|
p2 = alloc_vector(m - 1);
|
|
|
|
if (m == 2)
|
|
p2 = alloc_vector(n - 1);
|
|
|
|
if (n > 2 && m > 2)
|
|
p2 = alloc_matrix(n - 1, m - 1);
|
|
|
|
row--;
|
|
col--;
|
|
|
|
k = 0;
|
|
|
|
for (i = 0; i < n; i++) {
|
|
|
|
if (i == row)
|
|
continue;
|
|
|
|
for (j = 0; j < m; j++) {
|
|
|
|
if (j == col)
|
|
continue;
|
|
|
|
p2->u.tensor->elem[k++] = p1->u.tensor->elem[m * i + j];
|
|
}
|
|
}
|
|
|
|
push(p2);
|
|
}
|
|
void
|
|
eval_mod(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
push(caddr(p1));
|
|
evalf();
|
|
modfunc();
|
|
}
|
|
|
|
void
|
|
modfunc(void)
|
|
{
|
|
int i, n;
|
|
double d1, d2;
|
|
struct atom *p1, *p2;
|
|
|
|
p2 = pop();
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
push(p2);
|
|
modfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (!isnum(p1) || !isnum(p2) || iszero(p2)) {
|
|
push_symbol(MOD);
|
|
push(p1);
|
|
push(p2);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
if (isrational(p1) && isrational(p2)) {
|
|
mod_rationals(p1, p2);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
d1 = pop_double();
|
|
|
|
push(p2);
|
|
d2 = pop_double();
|
|
|
|
push_double(fmod(d1, d2));
|
|
}
|
|
|
|
void
|
|
mod_rationals(struct atom *p1, struct atom *p2)
|
|
{
|
|
if (isinteger(p1) && isinteger(p2)) {
|
|
mod_integers(p1, p2);
|
|
return;
|
|
}
|
|
push(p1);
|
|
push(p1);
|
|
push(p2);
|
|
divide();
|
|
absfunc();
|
|
floorfunc();
|
|
push(p2);
|
|
multiply();
|
|
if (p1->sign == p2->sign)
|
|
negate();
|
|
add();
|
|
}
|
|
|
|
void
|
|
mod_integers(struct atom *p1, struct atom *p2)
|
|
{
|
|
uint32_t *a, *b;
|
|
a = mmod(p1->u.q.a, p2->u.q.a);
|
|
b = mint(1);
|
|
push_bignum(p1->sign, a, b);
|
|
}
|
|
void
|
|
eval_multiply(struct atom *p1)
|
|
{
|
|
int h = tos;
|
|
expanding--; // undo expanding++ in evalf
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalg();
|
|
p1 = cdr(p1);
|
|
}
|
|
multiply_factors(tos - h);
|
|
expanding++;
|
|
}
|
|
|
|
void
|
|
multiply(void)
|
|
{
|
|
multiply_factors(2);
|
|
}
|
|
|
|
void
|
|
multiply_factors(int n)
|
|
{
|
|
int h;
|
|
struct atom *T;
|
|
|
|
if (n < 2)
|
|
return;
|
|
|
|
h = tos - n;
|
|
|
|
flatten_factors(h);
|
|
|
|
T = multiply_tensor_factors(h);
|
|
|
|
multiply_scalar_factors(h);
|
|
|
|
if (istensor(T)) {
|
|
push(T);
|
|
inner();
|
|
}
|
|
}
|
|
|
|
void
|
|
flatten_factors(int h)
|
|
{
|
|
int i, n;
|
|
struct atom *p1;
|
|
n = tos;
|
|
for (i = h; i < n; i++) {
|
|
p1 = stack[i];
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
stack[i] = cadr(p1);
|
|
p1 = cddr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
struct atom *
|
|
multiply_tensor_factors(int h)
|
|
{
|
|
int i;
|
|
struct atom *p1, *T;
|
|
T = symbol(NIL);
|
|
for (i = h; i < tos; i++) {
|
|
p1 = stack[i];
|
|
if (!istensor(p1))
|
|
continue;
|
|
if (istensor(T)) {
|
|
push(T);
|
|
push(p1);
|
|
hadamard();
|
|
T = pop();
|
|
} else
|
|
T = p1;
|
|
slice(i, 1); // remove factor
|
|
i--; // use same index again
|
|
}
|
|
return T;
|
|
}
|
|
|
|
void
|
|
multiply_scalar_factors(int h)
|
|
{
|
|
int n;
|
|
struct atom *COEF;
|
|
|
|
COEF = combine_numerical_factors(h, one);
|
|
|
|
if (iszero(COEF) || h == tos) {
|
|
tos = h; // pop all
|
|
push(COEF);
|
|
return;
|
|
}
|
|
|
|
combine_factors(h);
|
|
normalize_power_factors(h);
|
|
|
|
// do again in case exp(1/2 i pi) changed to i
|
|
|
|
combine_factors(h);
|
|
normalize_power_factors(h);
|
|
|
|
COEF = combine_numerical_factors(h, COEF);
|
|
|
|
if (iszero(COEF) || h == tos) {
|
|
tos = h; // pop all
|
|
push(COEF);
|
|
return;
|
|
}
|
|
|
|
COEF = reduce_radical_factors(h, COEF);
|
|
|
|
if (isdouble(COEF) || !isplusone(COEF))
|
|
push(COEF);
|
|
|
|
if (expanding)
|
|
expand_sum_factors(h); // success leaves one expr on stack
|
|
|
|
n = tos - h;
|
|
|
|
switch (n) {
|
|
case 0:
|
|
push_integer(1); // all factors canceled
|
|
break;
|
|
case 1:
|
|
break;
|
|
default:
|
|
sort_factors(n); // previously sorted provisionally
|
|
list(n);
|
|
push_symbol(MULTIPLY);
|
|
swap();
|
|
cons(); // prepend MULTIPLY to list
|
|
break;
|
|
}
|
|
}
|
|
|
|
struct atom *
|
|
combine_numerical_factors(int h, struct atom *COEF)
|
|
{
|
|
int i;
|
|
struct atom *p1;
|
|
for (i = h; i < tos; i++) {
|
|
p1 = stack[i];
|
|
if (isnum(p1)) {
|
|
multiply_numbers(COEF, p1);
|
|
COEF = pop();
|
|
slice(i, 1); // remove factor
|
|
i--; // use same index again
|
|
}
|
|
}
|
|
return COEF;
|
|
}
|
|
|
|
// factors that have the same base are combined by adding exponents
|
|
|
|
void
|
|
combine_factors(int h)
|
|
{
|
|
int i;
|
|
sort_factors_provisional(h);
|
|
for (i = h; i < tos - 1; i++) {
|
|
if (combine_factors_nib(i, i + 1)) {
|
|
slice(i + 1, 1); // remove factor
|
|
i--; // use same index again
|
|
}
|
|
}
|
|
}
|
|
|
|
int
|
|
combine_factors_nib(int i, int j)
|
|
{
|
|
struct atom *p1, *p2, *BASE1, *EXPO1, *BASE2, *EXPO2;
|
|
|
|
p1 = stack[i];
|
|
p2 = stack[j];
|
|
|
|
if (car(p1) == symbol(POWER)) {
|
|
BASE1 = cadr(p1);
|
|
EXPO1 = caddr(p1);
|
|
} else {
|
|
BASE1 = p1;
|
|
EXPO1 = one;
|
|
}
|
|
|
|
if (car(p2) == symbol(POWER)) {
|
|
BASE2 = cadr(p2);
|
|
EXPO2 = caddr(p2);
|
|
} else {
|
|
BASE2 = p2;
|
|
EXPO2 = one;
|
|
}
|
|
|
|
if (!equal(BASE1, BASE2))
|
|
return 0;
|
|
|
|
if (isdouble(BASE2))
|
|
BASE1 = BASE2; // if mixed rational and double, use double
|
|
|
|
push_symbol(POWER);
|
|
push(BASE1);
|
|
push(EXPO1);
|
|
push(EXPO2);
|
|
add();
|
|
list(3);
|
|
|
|
stack[i] = pop();
|
|
|
|
return 1;
|
|
}
|
|
|
|
void
|
|
sort_factors_provisional(int h)
|
|
{
|
|
qsort(stack + h, tos - h, sizeof (struct atom *), sort_factors_provisional_func);
|
|
}
|
|
|
|
int
|
|
sort_factors_provisional_func(const void *q1, const void *q2)
|
|
{
|
|
return cmp_factors_provisional(*((struct atom **) q1), *((struct atom **) q2));
|
|
}
|
|
|
|
int
|
|
cmp_factors_provisional(struct atom *p1, struct atom *p2)
|
|
{
|
|
if (car(p1) == symbol(POWER))
|
|
p1 = cadr(p1); // p1 = base
|
|
|
|
if (car(p2) == symbol(POWER))
|
|
p2 = cadr(p2); // p2 = base
|
|
|
|
return cmp(p1, p2);
|
|
}
|
|
|
|
void
|
|
normalize_power_factors(int h)
|
|
{
|
|
int i, k;
|
|
struct atom *p1;
|
|
k = tos;
|
|
for (i = h; i < k; i++) {
|
|
p1 = stack[i];
|
|
if (car(p1) == symbol(POWER)) {
|
|
push(cadr(p1));
|
|
push(caddr(p1));
|
|
power();
|
|
p1 = pop();
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
stack[i] = cadr(p1);
|
|
p1 = cddr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
}
|
|
} else
|
|
stack[i] = p1;
|
|
}
|
|
}
|
|
}
|
|
|
|
void
|
|
expand_sum_factors(int h)
|
|
{
|
|
int i, n;
|
|
struct atom *p1, *p2;
|
|
// Here, compiler treats warning as error, we use NULL to supress compiler error.
|
|
p2 = NULL;
|
|
|
|
if (tos - h < 2)
|
|
return;
|
|
|
|
// search for a sum factor
|
|
|
|
for (i = h; i < tos; i++) {
|
|
p2 = stack[i];
|
|
if (car(p2) == symbol(ADD))
|
|
break;
|
|
}
|
|
|
|
if (i == tos)
|
|
return; // no sum factors
|
|
|
|
// remove the sum factor
|
|
|
|
slice(i, 1);
|
|
|
|
n = tos - h;
|
|
|
|
if (n > 1) {
|
|
sort_factors(n);
|
|
list(n);
|
|
push_symbol(MULTIPLY);
|
|
swap();
|
|
cons(); // prepend MULTIPLY to list
|
|
}
|
|
|
|
p1 = pop(); // p1 is the multiplier
|
|
|
|
p2 = cdr(p2); // p2 is the sum
|
|
|
|
while (iscons(p2)) {
|
|
push(p1);
|
|
push(car(p2));
|
|
multiply();
|
|
p2 = cdr(p2);
|
|
}
|
|
|
|
add_terms(tos - h);
|
|
}
|
|
|
|
void
|
|
sort_factors(int n)
|
|
{
|
|
qsort(stack + tos - n, n, sizeof (struct atom *), sort_factors_func);
|
|
}
|
|
|
|
int
|
|
sort_factors_func(const void *q1, const void *q2)
|
|
{
|
|
return cmp_factors(*((struct atom **) q1), *((struct atom **) q2));
|
|
}
|
|
|
|
int
|
|
cmp_factors(struct atom *p1, struct atom *p2)
|
|
{
|
|
int a, b, c;
|
|
struct atom *base1, *base2, *expo1, *expo2;
|
|
|
|
a = order_factor(p1);
|
|
b = order_factor(p2);
|
|
|
|
if (a < b)
|
|
return -1;
|
|
|
|
if (a > b)
|
|
return 1;
|
|
|
|
if (car(p1) == symbol(POWER)) {
|
|
base1 = cadr(p1);
|
|
expo1 = caddr(p1);
|
|
} else {
|
|
base1 = p1;
|
|
expo1 = one;
|
|
}
|
|
|
|
if (car(p2) == symbol(POWER)) {
|
|
base2 = cadr(p2);
|
|
expo2 = caddr(p2);
|
|
} else {
|
|
base2 = p2;
|
|
expo2 = one;
|
|
}
|
|
|
|
c = cmp(base1, base2);
|
|
|
|
if (c == 0)
|
|
c = cmp(expo2, expo1); // swapped to reverse sort order
|
|
|
|
return c;
|
|
}
|
|
|
|
// 1 number
|
|
// 2 number to power (root)
|
|
// 3 -1 to power (imaginary)
|
|
// 4 other factor (symbol, power, func, etc)
|
|
// 5 exponential
|
|
// 6 derivative
|
|
|
|
int
|
|
order_factor(struct atom *p)
|
|
{
|
|
if (isnum(p))
|
|
return 1;
|
|
|
|
if (p == symbol(EXP1))
|
|
return 5;
|
|
|
|
if (car(p) == symbol(DERIVATIVE) || car(p) == symbol(D_LOWER))
|
|
return 6;
|
|
|
|
if (car(p) == symbol(POWER)) {
|
|
|
|
p = cadr(p); // p = base
|
|
|
|
if (isminusone(p))
|
|
return 3;
|
|
|
|
if (isnum(p))
|
|
return 2;
|
|
|
|
if (p == symbol(EXP1))
|
|
return 5;
|
|
|
|
if (car(p) == symbol(DERIVATIVE) || car(p) == symbol(D_LOWER))
|
|
return 6;
|
|
}
|
|
|
|
return 4;
|
|
}
|
|
|
|
void
|
|
multiply_numbers(struct atom *p1, struct atom *p2)
|
|
{
|
|
double d1, d2;
|
|
|
|
if (isrational(p1) && isrational(p2)) {
|
|
multiply_rationals(p1, p2);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
d1 = pop_double();
|
|
|
|
push(p2);
|
|
d2 = pop_double();
|
|
|
|
push_double(d1 * d2);
|
|
}
|
|
|
|
void
|
|
multiply_rationals(struct atom *p1, struct atom *p2)
|
|
{
|
|
int sign;
|
|
uint32_t *a, *b, *c;
|
|
|
|
if (iszero(p1) || iszero(p2)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
if (p1->sign == p2->sign)
|
|
sign = MPLUS;
|
|
else
|
|
sign = MMINUS;
|
|
|
|
if (isinteger(p1) && isinteger(p2)) {
|
|
push_bignum(sign, mmul(p1->u.q.a, p2->u.q.a), mint(1));
|
|
return;
|
|
}
|
|
|
|
a = mmul(p1->u.q.a, p2->u.q.a);
|
|
b = mmul(p1->u.q.b, p2->u.q.b);
|
|
c = mgcd(a, b);
|
|
push_bignum(sign, mdiv(a, c), mdiv(b, c));
|
|
|
|
mfree(a);
|
|
mfree(b);
|
|
mfree(c);
|
|
}
|
|
|
|
// for example, 2 / sqrt(2) -> sqrt(2)
|
|
|
|
struct atom *
|
|
reduce_radical_factors(int h, struct atom *COEF)
|
|
{
|
|
if (!any_radical_factors(h))
|
|
return COEF;
|
|
|
|
if (isrational(COEF))
|
|
return reduce_radical_rational(h, COEF);
|
|
else
|
|
return reduce_radical_double(h, COEF);
|
|
}
|
|
|
|
int
|
|
any_radical_factors(int h)
|
|
{
|
|
int i;
|
|
for (i = h; i < tos; i++)
|
|
if (isradical(stack[i]))
|
|
return 1;
|
|
return 0;
|
|
}
|
|
|
|
struct atom *
|
|
reduce_radical_double(int h, struct atom *COEF)
|
|
{
|
|
int i;
|
|
double a, b, c;
|
|
struct atom *p1;
|
|
|
|
c = COEF->u.d;
|
|
|
|
for (i = h; i < tos; i++) {
|
|
|
|
p1 = stack[i];
|
|
|
|
if (isradical(p1)) {
|
|
|
|
push(cadr(p1)); // base
|
|
a = pop_double();
|
|
|
|
push(caddr(p1)); // exponent
|
|
b = pop_double();
|
|
|
|
c = c * pow(a, b); // a > 0 by isradical above
|
|
|
|
slice(i, 1); // remove factor
|
|
|
|
i--; // use same index again
|
|
}
|
|
}
|
|
|
|
push_double(c);
|
|
COEF = pop();
|
|
|
|
return COEF;
|
|
}
|
|
|
|
struct atom *
|
|
reduce_radical_rational(int h, struct atom *COEF)
|
|
{
|
|
int i, k;
|
|
struct atom *p1, *p2, *NUMER, *DENOM, *BASE, *EXPO;
|
|
|
|
if (isplusone(COEF) || isminusone(COEF))
|
|
return COEF; // COEF has no factors, no cancellation is possible
|
|
|
|
push(COEF);
|
|
absfunc();
|
|
p1 = pop();
|
|
|
|
push(p1);
|
|
numerator();
|
|
NUMER = pop();
|
|
|
|
push(p1);
|
|
denominator();
|
|
DENOM = pop();
|
|
|
|
k = 0;
|
|
|
|
for (i = h; i < tos; i++) {
|
|
p1 = stack[i];
|
|
if (!isradical(p1))
|
|
continue;
|
|
BASE = cadr(p1);
|
|
EXPO = caddr(p1);
|
|
if (isnegativenumber(EXPO)) {
|
|
mod_integers(NUMER, BASE);
|
|
p2 = pop();
|
|
if (iszero(p2)) {
|
|
push(NUMER);
|
|
push(BASE);
|
|
divide();
|
|
NUMER = pop();
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push_integer(1);
|
|
push(EXPO);
|
|
add();
|
|
list(3);
|
|
stack[i] = pop();
|
|
k++;
|
|
}
|
|
} else {
|
|
mod_integers(DENOM, BASE);
|
|
p2 = pop();
|
|
if (iszero(p2)) {
|
|
push(DENOM);
|
|
push(BASE);
|
|
divide();
|
|
DENOM = pop();
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push_integer(-1);
|
|
push(EXPO);
|
|
add();
|
|
list(3);
|
|
stack[i] = pop();
|
|
k++;
|
|
}
|
|
}
|
|
}
|
|
|
|
if (k) {
|
|
push(NUMER);
|
|
push(DENOM);
|
|
divide();
|
|
if (isnegativenumber(COEF))
|
|
negate();
|
|
COEF = pop();
|
|
}
|
|
|
|
return COEF;
|
|
}
|
|
|
|
void
|
|
multiply_expand(void)
|
|
{
|
|
expanding++;
|
|
multiply();
|
|
expanding--;
|
|
}
|
|
|
|
void
|
|
multiply_noexpand(void)
|
|
{
|
|
int t;
|
|
t = expanding;
|
|
expanding = 0;
|
|
multiply();
|
|
expanding = t;
|
|
}
|
|
|
|
void
|
|
negate(void)
|
|
{
|
|
push_integer(-1);
|
|
multiply();
|
|
}
|
|
|
|
void
|
|
reciprocate(void)
|
|
{
|
|
push_integer(-1);
|
|
power();
|
|
}
|
|
|
|
void
|
|
divide(void)
|
|
{
|
|
reciprocate();
|
|
multiply();
|
|
}
|
|
void
|
|
eval_nil(struct atom *p1)
|
|
{
|
|
(void) p1; // silence compiler
|
|
push_symbol(NIL);
|
|
}
|
|
void
|
|
eval_noexpand(struct atom *p1)
|
|
{
|
|
int t;
|
|
|
|
t = expanding;
|
|
expanding = 0;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
|
|
expanding = t;
|
|
}
|
|
void
|
|
eval_not(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalp();
|
|
p1 = pop();
|
|
if (iszero(p1))
|
|
push_integer(1);
|
|
else
|
|
push_integer(0);
|
|
}
|
|
#define DELTA 1e-6
|
|
#define EPSILON 1e-9
|
|
|
|
void
|
|
eval_nroots(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
|
|
p1 = cddr(p1);
|
|
|
|
if (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
} else
|
|
push_symbol(X_LOWER);
|
|
|
|
nroots();
|
|
}
|
|
|
|
void
|
|
nroots(void)
|
|
{
|
|
int h, i, n;
|
|
struct atom *A, *P, *X, *RE, *IM;
|
|
double ar, ai, d, xr, xi, yr, yi;
|
|
static double *cr, *ci;
|
|
|
|
X = pop();
|
|
P = pop();
|
|
|
|
h = tos;
|
|
|
|
coeffs(P, X); // put coeffs on stack
|
|
|
|
n = tos - h; // number of coeffs on stack
|
|
|
|
if (cr)
|
|
free(cr);
|
|
if (ci)
|
|
free(ci);
|
|
|
|
cr = alloc_mem(n * sizeof (double));
|
|
ci = alloc_mem(n * sizeof (double));
|
|
|
|
// convert coeffs to floating point
|
|
|
|
for (i = 0; i < n; i++) {
|
|
|
|
push(stack[h + i]);
|
|
real();
|
|
floatfunc();
|
|
RE = pop();
|
|
|
|
push(stack[h + i]);
|
|
imag();
|
|
floatfunc();
|
|
IM = pop();
|
|
|
|
if (!isdouble(RE) || !isdouble(IM))
|
|
stopf("nroots: coeffs");
|
|
|
|
cr[i] = RE->u.d;
|
|
ci[i] = IM->u.d;
|
|
}
|
|
|
|
tos = h; // pop all
|
|
|
|
// divide p(x) by leading coeff
|
|
|
|
xr = cr[n - 1];
|
|
xi = ci[n - 1];
|
|
|
|
d = xr * xr + xi * xi;
|
|
|
|
for (i = 0; i < n - 1; i++) {
|
|
yr = (cr[i] * xr + ci[i] * xi) / d;
|
|
yi = (ci[i] * xr - cr[i] * xi) / d;
|
|
cr[i] = yr;
|
|
ci[i] = yi;
|
|
}
|
|
|
|
cr[n - 1] = 1.0;
|
|
ci[n - 1] = 0.0;
|
|
|
|
// find roots
|
|
|
|
while (n > 1) {
|
|
|
|
nfindroot(cr, ci, n, &ar, &ai);
|
|
|
|
if (fabs(ar) < DELTA * fabs(ai))
|
|
ar = 0.0;
|
|
|
|
if (fabs(ai) < DELTA * fabs(ar))
|
|
ai = 0.0;
|
|
|
|
// push root
|
|
|
|
push_double(ar);
|
|
push_double(ai);
|
|
push(imaginaryunit);
|
|
multiply();
|
|
add();
|
|
|
|
// divide p(x) by x - a
|
|
|
|
nreduce(cr, ci, n, ar, ai);
|
|
|
|
// note: leading coeff of p(x) is still 1
|
|
|
|
n--;
|
|
}
|
|
|
|
n = tos - h; // number of roots on stack
|
|
|
|
if (n == 0) {
|
|
push_symbol(NIL); // no roots
|
|
return;
|
|
}
|
|
|
|
if (n == 1)
|
|
return; // one root
|
|
|
|
sort(n);
|
|
|
|
A = alloc_vector(n);
|
|
|
|
for (i = 0; i < n; i++)
|
|
A->u.tensor->elem[i] = stack[h + i];
|
|
|
|
tos = h; // pop all
|
|
|
|
push(A);
|
|
}
|
|
|
|
void
|
|
nfindroot(double cr[], double ci[], int n, double *par, double *pai)
|
|
{
|
|
int i, j;
|
|
double d;
|
|
double ar, br, dfr, dxr, far, fbr, xr, yr;
|
|
double ai, bi, dfi, dxi, fai, fbi, xi, yi;
|
|
|
|
// if const term is zero then root is zero
|
|
|
|
// note: use exact zero, not "close to zero"
|
|
|
|
// term will be exactly zero from coeffs(), no need for arbitrary cutoff
|
|
|
|
if (cr[0] == 0.0 && ci[0] == 0.0) {
|
|
*par = 0.0;
|
|
*pai = 0.0;
|
|
return;
|
|
}
|
|
|
|
// secant method
|
|
|
|
for (i = 0; i < 100; i++) {
|
|
|
|
ar = urandom();
|
|
ai = urandom();
|
|
|
|
fata(cr, ci, n, ar, ai, &far, &fai);
|
|
|
|
br = ar;
|
|
bi = ai;
|
|
|
|
fbr = far;
|
|
fbi = fai;
|
|
|
|
ar = urandom();
|
|
ai = urandom();
|
|
|
|
for (j = 0; j < 1000; j++) {
|
|
|
|
fata(cr, ci, n, ar, ai, &far, &fai);
|
|
|
|
if (zabs(far, fai) < EPSILON) {
|
|
*par = ar;
|
|
*pai = ai;
|
|
return;
|
|
}
|
|
|
|
if (zabs(far, fai) < zabs(fbr, fbi)) {
|
|
|
|
xr = ar;
|
|
xi = ai;
|
|
|
|
ar = br;
|
|
ai = bi;
|
|
|
|
br = xr;
|
|
bi = xi;
|
|
|
|
xr = far;
|
|
xi = fai;
|
|
|
|
far = fbr;
|
|
fai = fbi;
|
|
|
|
fbr = xr;
|
|
fbi = xi;
|
|
}
|
|
|
|
// dx = b - a
|
|
|
|
dxr = br - ar;
|
|
dxi = bi - ai;
|
|
|
|
// df = fb - fa
|
|
|
|
dfr = fbr - far;
|
|
dfi = fbi - fai;
|
|
|
|
// y = dx / df
|
|
|
|
d = dfr * dfr + dfi * dfi;
|
|
|
|
if (d == 0.0)
|
|
break;
|
|
|
|
yr = (dxr * dfr + dxi * dfi) / d;
|
|
yi = (dxi * dfr - dxr * dfi) / d;
|
|
|
|
// a = b - y * fb
|
|
|
|
ar = br - (yr * fbr - yi * fbi);
|
|
ai = bi - (yr * fbi + yi * fbr);
|
|
}
|
|
}
|
|
|
|
stopf("nroots: convergence error");
|
|
}
|
|
|
|
// compute f at a
|
|
|
|
void
|
|
fata(double cr[], double ci[], int n, double ar, double ai, double *far, double *fai)
|
|
{
|
|
int k;
|
|
double xr, xi, yr, yi;
|
|
|
|
yr = cr[n - 1];
|
|
yi = ci[n - 1];
|
|
|
|
for (k = n - 2; k >= 0; k--) {
|
|
|
|
// x = a * y
|
|
|
|
xr = ar * yr - ai * yi;
|
|
xi = ar * yi + ai * yr;
|
|
|
|
// y = x + c
|
|
|
|
yr = xr + cr[k];
|
|
yi = xi + ci[k];
|
|
}
|
|
|
|
*far = yr;
|
|
*fai = yi;
|
|
}
|
|
|
|
// divide by x - a
|
|
|
|
void
|
|
nreduce(double cr[], double ci[], int n, double ar, double ai)
|
|
{
|
|
int k;
|
|
|
|
// divide
|
|
|
|
for (k = n - 1; k > 0; k--) {
|
|
cr[k - 1] += cr[k] * ar - ci[k] * ai;
|
|
ci[k - 1] += ci[k] * ar + cr[k] * ai;
|
|
}
|
|
|
|
if (zabs(cr[0], ci[0]) > DELTA)
|
|
stopf("nroots: residual error"); // not a root
|
|
|
|
// shift
|
|
|
|
for (k = 0; k < n - 1; k++) {
|
|
cr[k] = cr[k + 1];
|
|
ci[k] = ci[k + 1];
|
|
}
|
|
}
|
|
|
|
double
|
|
zabs(double r, double i)
|
|
{
|
|
return sqrt(r * r + i * i);
|
|
}
|
|
|
|
double
|
|
urandom(void)
|
|
{
|
|
return 4.0 * ((double) rand() / (double) RAND_MAX) - 2.0;
|
|
}
|
|
void
|
|
eval_number(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
|
|
p1 = pop();
|
|
|
|
if (isnum(p1))
|
|
push_integer(1);
|
|
else
|
|
push_integer(0);
|
|
}
|
|
void
|
|
eval_numerator(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
numerator();
|
|
}
|
|
|
|
void
|
|
numerator(void)
|
|
{
|
|
numden();
|
|
swap();
|
|
pop(); // discard denominator
|
|
}
|
|
void
|
|
eval_or(struct atom *p1)
|
|
{
|
|
struct atom *p2;
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalp();
|
|
p2 = pop();
|
|
if (!iszero(p2)) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
p1 = cdr(p1);
|
|
}
|
|
push_integer(0);
|
|
}
|
|
void
|
|
eval_outer(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = cddr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
outer();
|
|
p1 = cdr(p1);
|
|
}
|
|
}
|
|
|
|
void
|
|
outer(void)
|
|
{
|
|
int i, j, k, n, ncol, nrow;
|
|
struct atom *p1, *p2, *p3;
|
|
|
|
p2 = pop();
|
|
p1 = pop();
|
|
|
|
if (!istensor(p1) || !istensor(p2)) {
|
|
push(p1);
|
|
push(p2);
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
if (p1->u.tensor->ndim + p2->u.tensor->ndim > MAXDIM)
|
|
stopf("outer: rank exceeds max");
|
|
|
|
// sync diffs
|
|
|
|
nrow = p1->u.tensor->nelem;
|
|
ncol = p2->u.tensor->nelem;
|
|
|
|
p3 = alloc_tensor(nrow * ncol);
|
|
|
|
for (i = 0; i < nrow; i++)
|
|
for (j = 0; j < ncol; j++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
push(p2->u.tensor->elem[j]);
|
|
multiply();
|
|
p3->u.tensor->elem[i * ncol + j] = pop();
|
|
}
|
|
|
|
// dim info
|
|
|
|
p3->u.tensor->ndim = p1->u.tensor->ndim + p2->u.tensor->ndim;
|
|
|
|
k = 0;
|
|
|
|
n = p1->u.tensor->ndim;
|
|
|
|
for (i = 0; i < n; i++)
|
|
p3->u.tensor->dim[k++] = p1->u.tensor->dim[i];
|
|
|
|
n = p2->u.tensor->ndim;
|
|
|
|
for (i = 0; i < n; i++)
|
|
p3->u.tensor->dim[k++] = p2->u.tensor->dim[i];
|
|
|
|
push(p3);
|
|
}
|
|
void
|
|
eval_polar(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
polar();
|
|
}
|
|
|
|
void
|
|
polar(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
polar();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
magfunc();
|
|
push(p1);
|
|
argfunc();
|
|
p2 = pop();
|
|
if (isdouble(p2)) {
|
|
push_double(p2->u.d / M_PI);
|
|
push_symbol(PI);
|
|
push(imaginaryunit);
|
|
multiply_factors(3);
|
|
} else {
|
|
// the result of arg is arctan
|
|
push(p2);
|
|
push(imaginaryunit);
|
|
multiply();
|
|
}
|
|
expfunc();
|
|
multiply();
|
|
}
|
|
void
|
|
eval_power(struct atom *p1)
|
|
{
|
|
int t;
|
|
struct atom *p2;
|
|
|
|
expanding--; // undo expanding++ in evalf
|
|
|
|
// base
|
|
|
|
push(cadr(p1));
|
|
|
|
// exponent
|
|
|
|
push(caddr(p1));
|
|
evalg();
|
|
dupl();
|
|
p2 = pop();
|
|
|
|
// if exponent is negative then evaluate base without expanding
|
|
|
|
swap();
|
|
if (isnegativenumber(p2)) {
|
|
t = expanding;
|
|
expanding = 0;
|
|
evalg();
|
|
expanding = t;
|
|
} else
|
|
evalg();
|
|
swap();
|
|
|
|
power();
|
|
|
|
expanding++;
|
|
}
|
|
|
|
void
|
|
power(void)
|
|
{
|
|
int h, i, n;
|
|
struct atom *p1, *BASE, *EXPO;
|
|
|
|
EXPO = pop();
|
|
BASE = pop();
|
|
|
|
if (istensor(BASE) && istensor(EXPO)) {
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push(EXPO);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
if (istensor(EXPO)) {
|
|
p1 = copy_tensor(EXPO);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(BASE);
|
|
push(p1->u.tensor->elem[i]);
|
|
power();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (istensor(BASE)) {
|
|
p1 = copy_tensor(BASE);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
push(EXPO);
|
|
power();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (BASE == symbol(EXP1) && isdouble(EXPO)) {
|
|
push_double(M_E);
|
|
BASE = pop();
|
|
}
|
|
|
|
if (BASE == symbol(PI) && isdouble(EXPO)) {
|
|
push_double(M_PI);
|
|
BASE = pop();
|
|
}
|
|
|
|
if (isnum(BASE) && isnum(EXPO)) {
|
|
power_numbers(BASE, EXPO);
|
|
return;
|
|
}
|
|
|
|
// expr^0
|
|
|
|
if (iszero(EXPO)) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
// 0^expr
|
|
|
|
if (iszero(BASE)) {
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push(EXPO);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
// 1^expr
|
|
|
|
if (isplusone(BASE)) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
// expr^1
|
|
|
|
if (isplusone(EXPO)) {
|
|
push(BASE);
|
|
return;
|
|
}
|
|
|
|
// BASE is an integer?
|
|
|
|
if (isinteger(BASE)) {
|
|
// raise each factor in BASE to power EXPO
|
|
// EXPO is not numerical, that case was handled by power_numbers() above
|
|
h = tos;
|
|
push(BASE);
|
|
factor_factor();
|
|
n = tos - h;
|
|
for (i = 0; i < n; i++) {
|
|
p1 = stack[h + i];
|
|
if (car(p1) == symbol(POWER)) {
|
|
push_symbol(POWER);
|
|
push(cadr(p1)); // base
|
|
push(caddr(p1)); // expo
|
|
push(EXPO);
|
|
multiply();
|
|
list(3);
|
|
} else {
|
|
push_symbol(POWER);
|
|
push(p1);
|
|
push(EXPO);
|
|
list(3);
|
|
}
|
|
stack[h + i] = pop();
|
|
}
|
|
if (n > 1) {
|
|
sort_factors(n);
|
|
list(n);
|
|
push_symbol(MULTIPLY);
|
|
swap();
|
|
cons(); // prepend MULTIPLY to list
|
|
}
|
|
return;
|
|
}
|
|
|
|
// BASE is a numerical fraction?
|
|
|
|
if (isfraction(BASE)) {
|
|
// power numerator, power denominator
|
|
// EXPO is not numerical, that case was handled by power_numbers() above
|
|
push(BASE);
|
|
numerator();
|
|
push(EXPO);
|
|
power();
|
|
push(BASE);
|
|
denominator();
|
|
push(EXPO);
|
|
negate();
|
|
power();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// BASE = e ?
|
|
|
|
if (BASE == symbol(EXP1)) {
|
|
power_natural_number(EXPO);
|
|
return;
|
|
}
|
|
|
|
// (a + b) ^ c
|
|
|
|
if (car(BASE) == symbol(ADD)) {
|
|
power_sum(BASE, EXPO);
|
|
return;
|
|
}
|
|
|
|
// (a b) ^ c --> (a ^ c) (b ^ c)
|
|
|
|
if (car(BASE) == symbol(MULTIPLY)) {
|
|
h = tos;
|
|
p1 = cdr(BASE);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
push(EXPO);
|
|
power();
|
|
p1 = cdr(p1);
|
|
}
|
|
multiply_factors(tos - h);
|
|
return;
|
|
}
|
|
|
|
// (a ^ b) ^ c --> a ^ (b c)
|
|
|
|
if (car(BASE) == symbol(POWER)) {
|
|
push(cadr(BASE));
|
|
push(caddr(BASE));
|
|
push(EXPO);
|
|
multiply_expand(); // always expand products of exponents
|
|
power();
|
|
return;
|
|
}
|
|
|
|
// none of the above
|
|
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push(EXPO);
|
|
list(3);
|
|
}
|
|
|
|
// BASE and EXPO are rational or double
|
|
|
|
void
|
|
power_numbers(struct atom *BASE, struct atom *EXPO)
|
|
{
|
|
int h, i, j, n;
|
|
uint32_t *a, *b;
|
|
struct atom *p1, *p2;
|
|
|
|
// n^0
|
|
|
|
if (iszero(EXPO)) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
// 0^n
|
|
|
|
if (iszero(BASE)) {
|
|
if (isnegativenumber(EXPO)) {
|
|
if (shuntflag)
|
|
errorflag = 1;
|
|
else
|
|
stopf("divide by zero");
|
|
}
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
// 1^n
|
|
|
|
if (isplusone(BASE)) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
// n^1
|
|
|
|
if (isplusone(EXPO)) {
|
|
push(BASE);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(BASE) || isdouble(EXPO)) {
|
|
power_double(BASE, EXPO);
|
|
return;
|
|
}
|
|
|
|
// integer exponent?
|
|
|
|
if (isinteger(EXPO)) {
|
|
a = mpow(BASE->u.q.a, EXPO->u.q.a);
|
|
b = mpow(BASE->u.q.b, EXPO->u.q.a);
|
|
if (isnegativenumber(BASE) && (EXPO->u.q.a[0] & 1))
|
|
if (isnegativenumber(EXPO))
|
|
push_bignum(MMINUS, b, a); // reciprocate
|
|
else
|
|
push_bignum(MMINUS, a, b);
|
|
else
|
|
if (isnegativenumber(EXPO))
|
|
push_bignum(MPLUS, b, a); // reciprocate
|
|
else
|
|
push_bignum(MPLUS, a, b);
|
|
return;
|
|
}
|
|
|
|
// exponent is a root
|
|
|
|
h = tos;
|
|
|
|
// put factors on stack
|
|
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push(EXPO);
|
|
list(3);
|
|
|
|
factor_factor();
|
|
|
|
// normalize factors
|
|
|
|
n = tos - h; // fix n now, stack can grow
|
|
|
|
for (i = 0; i < n; i++) {
|
|
p1 = stack[h + i];
|
|
if (car(p1) == symbol(POWER)) {
|
|
BASE = cadr(p1);
|
|
EXPO = caddr(p1);
|
|
power_numbers_factor(BASE, EXPO);
|
|
stack[h + i] = pop(); // fill hole
|
|
}
|
|
}
|
|
|
|
// combine numbers (leaves radicals on stack)
|
|
|
|
p1 = one;
|
|
|
|
for (i = h; i < tos; i++) {
|
|
p2 = stack[i];
|
|
if (isnum(p2)) {
|
|
push(p1);
|
|
push(p2);
|
|
multiply();
|
|
p1 = pop();
|
|
for (j = i + 1; j < tos; j++)
|
|
stack[j - 1] = stack[j];
|
|
tos--;
|
|
i--;
|
|
}
|
|
}
|
|
|
|
// finalize
|
|
|
|
n = tos - h;
|
|
|
|
if (n == 0 || !isplusone(p1)) {
|
|
push(p1);
|
|
n++;
|
|
}
|
|
|
|
if (n == 1)
|
|
return;
|
|
|
|
sort_factors(n);
|
|
list(n);
|
|
push_symbol(MULTIPLY);
|
|
swap();
|
|
cons(); // prepend MULTIPLY to list
|
|
}
|
|
|
|
// BASE is an integer
|
|
|
|
void
|
|
power_numbers_factor(struct atom *BASE, struct atom *EXPO)
|
|
{
|
|
uint32_t *a, *b, *n, *q, *r;
|
|
struct atom *p0;
|
|
|
|
if (isminusone(BASE)) {
|
|
power_minusone(EXPO);
|
|
p0 = pop();
|
|
if (car(p0) == symbol(MULTIPLY)) {
|
|
p0 = cdr(p0);
|
|
while (iscons(p0)) {
|
|
push(car(p0));
|
|
p0 = cdr(p0);
|
|
}
|
|
} else
|
|
push(p0);
|
|
return;
|
|
}
|
|
|
|
if (isinteger(EXPO)) {
|
|
a = mpow(BASE->u.q.a, EXPO->u.q.a);
|
|
b = mint(1);
|
|
if (isnegativenumber(EXPO))
|
|
push_bignum(MPLUS, b, a); // reciprocate
|
|
else
|
|
push_bignum(MPLUS, a, b);
|
|
return;
|
|
}
|
|
|
|
// EXPO.a r
|
|
// ------ == q + ------
|
|
// EXPO.b EXPO.b
|
|
|
|
q = mdiv(EXPO->u.q.a, EXPO->u.q.b);
|
|
r = mmod(EXPO->u.q.a, EXPO->u.q.b);
|
|
|
|
// process q
|
|
|
|
if (!MZERO(q)) {
|
|
a = mpow(BASE->u.q.a, q);
|
|
b = mint(1);
|
|
if (isnegativenumber(EXPO))
|
|
push_bignum(MPLUS, b, a); // reciprocate
|
|
else
|
|
push_bignum(MPLUS, a, b);
|
|
}
|
|
|
|
mfree(q);
|
|
|
|
// process r
|
|
|
|
if (MLENGTH(BASE->u.q.a) == 1 && BASE->u.q.a[0] <= 0x7fffffff) {
|
|
// BASE is less than 2^31, hence BASE is a prime number, no root
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push_bignum(EXPO->sign, r, mcopy(EXPO->u.q.b)); // r used here, r is not leaked
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
// BASE was too big to factor, try finding root
|
|
|
|
n = mroot(BASE->u.q.a, EXPO->u.q.b);
|
|
|
|
if (n == NULL) {
|
|
// no root
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push_bignum(EXPO->sign, r, mcopy(EXPO->u.q.b)); // r used here, r is not leaked
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
// raise n to rth power
|
|
|
|
a = mpow(n, r);
|
|
b = mint(1);
|
|
|
|
mfree(n);
|
|
mfree(r);
|
|
|
|
if (isnegativenumber(EXPO))
|
|
push_bignum(MPLUS, b, a); // reciprocate
|
|
else
|
|
push_bignum(MPLUS, a, b);
|
|
}
|
|
|
|
void
|
|
power_double(struct atom *BASE, struct atom *EXPO)
|
|
{
|
|
double base, d, expo;
|
|
|
|
push(BASE);
|
|
base = pop_double();
|
|
|
|
push(EXPO);
|
|
expo = pop_double();
|
|
|
|
if (base > 0.0 || expo == floor(expo)) {
|
|
d = pow(base, expo);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
// BASE is negative and EXPO is fractional
|
|
|
|
power_minusone(EXPO);
|
|
|
|
if (base == -1.0)
|
|
return;
|
|
|
|
d = pow(-base, expo);
|
|
push_double(d);
|
|
|
|
multiply();
|
|
}
|
|
|
|
// power -1 to EXPO where EXPO is RATIONAL or DOUBLE
|
|
|
|
void
|
|
power_minusone(struct atom *EXPO)
|
|
{
|
|
// optimization for i
|
|
|
|
if (isequalq(EXPO, 1, 2)) {
|
|
push(imaginaryunit);
|
|
return;
|
|
}
|
|
|
|
// root is an odd number?
|
|
|
|
if (isrational(EXPO) && EXPO->u.q.b[0] & 1) {
|
|
if (EXPO->u.q.a[0] & 1)
|
|
push_integer(-1);
|
|
else
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
if (isrational(EXPO)) {
|
|
normalize_clock_rational(EXPO);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(EXPO)) {
|
|
normalize_clock_double(EXPO);
|
|
rect();
|
|
return;
|
|
}
|
|
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push(EXPO);
|
|
list(3);
|
|
}
|
|
|
|
void
|
|
normalize_clock_rational(struct atom *EXPO)
|
|
{
|
|
int n;
|
|
struct atom *R;
|
|
|
|
// R = EXPO mod 2
|
|
|
|
push(EXPO);
|
|
push_integer(2);
|
|
modfunc();
|
|
R = pop();
|
|
|
|
// convert negative rotation to positive
|
|
|
|
if (R->sign == MMINUS) {
|
|
push(R);
|
|
push_integer(2);
|
|
add();
|
|
R = pop();
|
|
}
|
|
|
|
push(R);
|
|
push_integer(2);
|
|
multiply();
|
|
floorfunc();
|
|
n = pop_integer(); // number of 90 degree turns
|
|
|
|
push(R);
|
|
push_integer(n);
|
|
push_rational(-1, 2);
|
|
multiply();
|
|
add();
|
|
R = pop(); // remainder
|
|
|
|
switch (n) {
|
|
|
|
case 0:
|
|
if (iszero(R))
|
|
push_integer(1);
|
|
else {
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push(R);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 1:
|
|
if (iszero(R))
|
|
push(imaginaryunit);
|
|
else {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push(R);
|
|
push_rational(-1, 2);
|
|
add();
|
|
list(3);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 2:
|
|
if (iszero(R))
|
|
push_integer(-1);
|
|
else {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push(R);
|
|
list(3);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 3:
|
|
if (iszero(R)) {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push(imaginaryunit);
|
|
list(3);
|
|
} else {
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push(R);
|
|
push_rational(-1, 2);
|
|
add();
|
|
list(3);
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
|
|
void
|
|
normalize_clock_double(struct atom *EXPO)
|
|
{
|
|
double expo, n, r;
|
|
|
|
expo = EXPO->u.d;
|
|
|
|
// expo = expo mod 2
|
|
|
|
expo = fmod(expo, 2.0);
|
|
|
|
// convert negative rotation to positive
|
|
|
|
if (expo < 0.0)
|
|
expo += 2.0;
|
|
|
|
n = floor(2.0 * expo); // number of 90 degree turns
|
|
|
|
r = expo - n / 2.0; // remainder
|
|
|
|
switch ((int) n) {
|
|
|
|
case 0:
|
|
if (r == 0.0)
|
|
push_integer(1);
|
|
else {
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push_double(r);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 1:
|
|
if (r == 0.0)
|
|
push(imaginaryunit);
|
|
else {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push_double(r - 0.5);
|
|
list(3);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 2:
|
|
if (r == 0.0)
|
|
push_integer(-1);
|
|
else {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push_double(r);
|
|
list(3);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 3:
|
|
if (r == 0.0) {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push(imaginaryunit);
|
|
list(3);
|
|
} else {
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push_double(r - 0.5);
|
|
list(3);
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
|
|
void
|
|
power_natural_number(struct atom *EXPO)
|
|
{
|
|
double x, y;
|
|
|
|
// exp(x + i y) = exp(x) (cos(y) + i sin(y))
|
|
|
|
if (isdoublez(EXPO)) {
|
|
if (car(EXPO) == symbol(ADD)) {
|
|
x = cadr(EXPO)->u.d;
|
|
y = cadaddr(EXPO)->u.d;
|
|
} else {
|
|
x = 0.0;
|
|
y = cadr(EXPO)->u.d;
|
|
}
|
|
push_double(exp(x));
|
|
push_double(y);
|
|
cosfunc();
|
|
push(imaginaryunit);
|
|
push_double(y);
|
|
sinfunc();
|
|
multiply();
|
|
add();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// e^log(expr) = expr
|
|
|
|
if (car(EXPO) == symbol(LOG)) {
|
|
push(cadr(EXPO));
|
|
return;
|
|
}
|
|
|
|
if (isdenormalpolar(EXPO)) {
|
|
normalize_polar(EXPO);
|
|
return;
|
|
}
|
|
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push(EXPO);
|
|
list(3);
|
|
}
|
|
|
|
void
|
|
normalize_polar(struct atom *EXPO)
|
|
{
|
|
int h;
|
|
struct atom *p1;
|
|
if (car(EXPO) == symbol(ADD)) {
|
|
h = tos;
|
|
p1 = cdr(EXPO);
|
|
while (iscons(p1)) {
|
|
EXPO = car(p1);
|
|
if (isdenormalpolarterm(EXPO))
|
|
normalize_polar_term(EXPO);
|
|
else {
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push(EXPO);
|
|
list(3);
|
|
}
|
|
p1 = cdr(p1);
|
|
}
|
|
multiply_factors(tos - h);
|
|
} else
|
|
normalize_polar_term(EXPO);
|
|
}
|
|
|
|
void
|
|
normalize_polar_term(struct atom *EXPO)
|
|
{
|
|
struct atom *R;
|
|
|
|
// exp(i pi) = -1
|
|
|
|
if (lengthf(EXPO) == 3) {
|
|
push_integer(-1);
|
|
return;
|
|
}
|
|
|
|
R = cadr(EXPO); // R = coeff of term
|
|
|
|
if (isrational(R))
|
|
normalize_polar_term_rational(R);
|
|
else
|
|
normalize_polar_term_double(R);
|
|
}
|
|
|
|
void
|
|
normalize_polar_term_rational(struct atom *R)
|
|
{
|
|
int n;
|
|
|
|
// R = R mod 2
|
|
|
|
push(R);
|
|
push_integer(2);
|
|
modfunc();
|
|
R = pop();
|
|
|
|
// convert negative rotation to positive
|
|
|
|
if (R->sign == MMINUS) {
|
|
push(R);
|
|
push_integer(2);
|
|
add();
|
|
R = pop();
|
|
}
|
|
|
|
push(R);
|
|
push_integer(2);
|
|
multiply();
|
|
floorfunc();
|
|
n = pop_integer(); // number of 90 degree turns
|
|
|
|
push(R);
|
|
push_integer(n);
|
|
push_rational(-1, 2);
|
|
multiply();
|
|
add();
|
|
R = pop(); // remainder
|
|
|
|
switch (n % 4) {
|
|
|
|
case 0:
|
|
if (iszero(R))
|
|
push_integer(1);
|
|
else {
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push_symbol(MULTIPLY);
|
|
push(R);
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
list(4);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 1:
|
|
if (iszero(R))
|
|
push(imaginaryunit);
|
|
else {
|
|
push_symbol(MULTIPLY);
|
|
push(imaginaryunit);
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push_symbol(MULTIPLY);
|
|
push(R);
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
list(4);
|
|
list(3);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 2:
|
|
if (iszero(R))
|
|
push_integer(-1);
|
|
else {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push_symbol(MULTIPLY);
|
|
push(R);
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
list(4);
|
|
list(3);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 3:
|
|
if (iszero(R)) {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push(imaginaryunit);
|
|
list(3);
|
|
} else {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push(imaginaryunit);
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push_symbol(MULTIPLY);
|
|
push(R);
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
list(4);
|
|
list(3);
|
|
list(4);
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
|
|
void
|
|
normalize_polar_term_double(struct atom *R)
|
|
{
|
|
int n;
|
|
double coeff, r;
|
|
|
|
coeff = R->u.d;
|
|
|
|
// coeff = coeff mod 2
|
|
|
|
coeff = fmod(coeff, 2.0);
|
|
|
|
// convert negative rotation to positive
|
|
|
|
if (coeff < 0.0)
|
|
coeff += 2.0;
|
|
|
|
n = (int) floor(2.0 * coeff); // number of 90 degree turns
|
|
|
|
r = coeff - n / 2.0; // remainder
|
|
|
|
switch (n % 4) {
|
|
|
|
case 0:
|
|
if (r == 0.0)
|
|
push_integer(1);
|
|
else {
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push_symbol(MULTIPLY);
|
|
push_double(r);
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
list(4);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 1:
|
|
if (r == 0.0)
|
|
push(imaginaryunit);
|
|
else {
|
|
push_symbol(MULTIPLY);
|
|
push(imaginaryunit);
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push_symbol(MULTIPLY);
|
|
push_double(r);
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
list(4);
|
|
list(3);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 2:
|
|
if (r == 0.0)
|
|
push_integer(-1);
|
|
else {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push_symbol(MULTIPLY);
|
|
push_double(r);
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
list(4);
|
|
list(3);
|
|
list(3);
|
|
}
|
|
break;
|
|
|
|
case 3:
|
|
if (r == 0.0) {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push(imaginaryunit);
|
|
list(3);
|
|
} else {
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push(imaginaryunit);
|
|
push_symbol(POWER);
|
|
push_symbol(EXP1);
|
|
push_symbol(MULTIPLY);
|
|
push_double(r);
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
list(4);
|
|
list(3);
|
|
list(4);
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
|
|
// BASE is a sum of terms
|
|
|
|
void
|
|
power_sum(struct atom *BASE, struct atom *EXPO)
|
|
{
|
|
int h, i, n;
|
|
struct atom *p1, *p2;
|
|
|
|
if (iscomplexnumber(BASE) && isnum(EXPO)) {
|
|
power_complex_number(BASE, EXPO);
|
|
return;
|
|
}
|
|
|
|
if (expanding == 0 || !issmallinteger(EXPO) || isnegativenumber(EXPO)) {
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push(EXPO);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
push(EXPO);
|
|
n = pop_integer();
|
|
|
|
// square the sum first (prevents infinite loop through multiply)
|
|
|
|
h = tos;
|
|
|
|
p1 = cdr(BASE);
|
|
|
|
while (iscons(p1)) {
|
|
p2 = cdr(BASE);
|
|
while (iscons(p2)) {
|
|
push(car(p1));
|
|
push(car(p2));
|
|
multiply();
|
|
p2 = cdr(p2);
|
|
}
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
add_terms(tos - h);
|
|
|
|
// continue up to power n
|
|
|
|
for (i = 2; i < n; i++) {
|
|
push(BASE);
|
|
multiply();
|
|
}
|
|
}
|
|
|
|
// BASE is rectangular complex numerical, EXPO is numerical
|
|
|
|
void
|
|
power_complex_number(struct atom *BASE, struct atom *EXPO)
|
|
{
|
|
int n;
|
|
struct atom *X, *Y;
|
|
|
|
// prefixform(2+3*i) = (add 2 (multiply 3 (power -1 1/2)))
|
|
|
|
// prefixform(1+i) = (add 1 (power -1 1/2))
|
|
|
|
// prefixform(3*i) = (multiply 3 (power -1 1/2))
|
|
|
|
// prefixform(i) = (power -1 1/2)
|
|
|
|
if (car(BASE) == symbol(ADD)) {
|
|
X = cadr(BASE);
|
|
if (caaddr(BASE) == symbol(MULTIPLY))
|
|
Y = cadaddr(BASE);
|
|
else
|
|
Y = one;
|
|
} else if (car(BASE) == symbol(MULTIPLY)) {
|
|
X = zero;
|
|
Y = cadr(BASE);
|
|
} else {
|
|
X = zero;
|
|
Y = one;
|
|
}
|
|
|
|
if (isdouble(X) || isdouble(Y) || isdouble(EXPO)) {
|
|
power_complex_double(X, Y, EXPO);
|
|
return;
|
|
}
|
|
|
|
if (!isinteger(EXPO)) {
|
|
power_complex_rational(X, Y, EXPO);
|
|
return;
|
|
}
|
|
|
|
if (!issmallinteger(EXPO)) {
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push(EXPO);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
push(EXPO);
|
|
n = pop_integer();
|
|
|
|
if (n > 0)
|
|
power_complex_plus(X, Y, n);
|
|
else if (n < 0)
|
|
power_complex_minus(X, Y, -n);
|
|
else
|
|
push_integer(1);
|
|
}
|
|
|
|
void
|
|
power_complex_plus(struct atom *X, struct atom *Y, int n)
|
|
{
|
|
int i;
|
|
struct atom *PX, *PY;
|
|
|
|
PX = X;
|
|
PY = Y;
|
|
|
|
for (i = 1; i < n; i++) {
|
|
|
|
push(PX);
|
|
push(X);
|
|
multiply();
|
|
push(PY);
|
|
push(Y);
|
|
multiply();
|
|
subtract();
|
|
|
|
push(PX);
|
|
push(Y);
|
|
multiply();
|
|
push(PY);
|
|
push(X);
|
|
multiply();
|
|
add();
|
|
|
|
PY = pop();
|
|
PX = pop();
|
|
}
|
|
|
|
// X + i*Y
|
|
|
|
push(PX);
|
|
push(imaginaryunit);
|
|
push(PY);
|
|
multiply();
|
|
add();
|
|
}
|
|
|
|
//
|
|
// / \ n
|
|
// -n | X - iY |
|
|
// (X + iY) = | -------- |
|
|
// | 2 2 |
|
|
// \ X + Y /
|
|
|
|
// X and Y are rational numbers
|
|
|
|
void
|
|
power_complex_minus(struct atom *X, struct atom *Y, int n)
|
|
{
|
|
int i;
|
|
struct atom *PX, *PY, *R;
|
|
|
|
// R = X^2 + Y^2
|
|
|
|
push(X);
|
|
push(X);
|
|
multiply();
|
|
push(Y);
|
|
push(Y);
|
|
multiply();
|
|
add();
|
|
R = pop();
|
|
|
|
// X = X / R
|
|
|
|
push(X);
|
|
push(R);
|
|
divide();
|
|
X = pop();
|
|
|
|
// Y = -Y / R
|
|
|
|
push(Y);
|
|
negate();
|
|
push(R);
|
|
divide();
|
|
Y = pop();
|
|
|
|
PX = X;
|
|
PY = Y;
|
|
|
|
for (i = 1; i < n; i++) {
|
|
|
|
push(PX);
|
|
push(X);
|
|
multiply();
|
|
push(PY);
|
|
push(Y);
|
|
multiply();
|
|
subtract();
|
|
|
|
push(PX);
|
|
push(Y);
|
|
multiply();
|
|
push(PY);
|
|
push(X);
|
|
multiply();
|
|
add();
|
|
|
|
PY = pop();
|
|
PX = pop();
|
|
}
|
|
|
|
// X + i*Y
|
|
|
|
push(PX);
|
|
push(imaginaryunit);
|
|
push(PY);
|
|
multiply();
|
|
add();
|
|
}
|
|
|
|
void
|
|
power_complex_double(struct atom *X, struct atom *Y, struct atom *EXPO)
|
|
{
|
|
double expo, r, theta, x, y;
|
|
|
|
push(EXPO);
|
|
expo = pop_double();
|
|
|
|
push(X);
|
|
x = pop_double();
|
|
|
|
push(Y);
|
|
y = pop_double();
|
|
|
|
r = hypot(x, y);
|
|
theta = atan2(y, x);
|
|
|
|
r = pow(r, expo);
|
|
theta = expo * theta;
|
|
|
|
x = r * cos(theta);
|
|
y = r * sin(theta);
|
|
|
|
push_double(x);
|
|
push_double(y);
|
|
push(imaginaryunit);
|
|
multiply();
|
|
add();
|
|
}
|
|
|
|
// X and Y are rational, EXPO is rational and not an integer
|
|
|
|
void
|
|
power_complex_rational(struct atom *X, struct atom *Y, struct atom *EXPO)
|
|
{
|
|
// calculate sqrt(X^2 + Y^2) ^ (1/2 * EXPO)
|
|
|
|
push(X);
|
|
push(X);
|
|
multiply();
|
|
push(Y);
|
|
push(Y);
|
|
multiply();
|
|
add();
|
|
push_rational(1, 2);
|
|
push(EXPO);
|
|
multiply();
|
|
power();
|
|
|
|
// calculate (-1) ^ (EXPO * arctan(Y, X) / pi)
|
|
|
|
push(Y);
|
|
push(X);
|
|
arctan();
|
|
push_symbol(PI);
|
|
divide();
|
|
push(EXPO);
|
|
multiply();
|
|
EXPO = pop();
|
|
power_minusone(EXPO);
|
|
|
|
// result = sqrt(X^2 + Y^2) ^ (1/2 * EXPO) * (-1) ^ (EXPO * arctan(Y, X) / pi)
|
|
|
|
multiply();
|
|
}
|
|
void
|
|
eval_prefixform(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = pop();
|
|
|
|
outbuf_init();
|
|
prefixform(p1);
|
|
|
|
push_string(outbuf);
|
|
}
|
|
|
|
// for debugging
|
|
|
|
void
|
|
print_prefixform(struct atom *p)
|
|
{
|
|
outbuf_init();
|
|
prefixform(p);
|
|
outbuf_puts("\n");
|
|
printbuf(outbuf, BLACK);
|
|
}
|
|
|
|
void
|
|
prefixform(struct atom *p)
|
|
{
|
|
char *s;
|
|
switch (p->atomtype) {
|
|
case CONS:
|
|
outbuf_puts("(");
|
|
prefixform(car(p));
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
outbuf_puts(" ");
|
|
prefixform(car(p));
|
|
p = cdr(p);
|
|
}
|
|
if (p != symbol(NIL)) {
|
|
outbuf_puts(" . ");
|
|
prefixform(p);
|
|
}
|
|
outbuf_puts(")");
|
|
break;
|
|
case STR:
|
|
outbuf_puts("\"");
|
|
outbuf_puts(p->u.str);
|
|
outbuf_puts("\"");
|
|
break;
|
|
case RATIONAL:
|
|
if (p->sign == MMINUS)
|
|
outbuf_puts("-");
|
|
s = mstr(p->u.q.a);
|
|
outbuf_puts(s);
|
|
s = mstr(p->u.q.b);
|
|
if (strcmp(s, "1") == 0)
|
|
break;
|
|
outbuf_puts("/");
|
|
outbuf_puts(s);
|
|
break;
|
|
case DOUBLE:
|
|
snprintf(strbuf, STRBUFLEN, "%g", p->u.d);
|
|
outbuf_puts(strbuf);
|
|
if (!strchr(strbuf, '.') && !strchr(strbuf, 'e'))
|
|
outbuf_puts(".0");
|
|
break;
|
|
case KSYM:
|
|
case USYM:
|
|
outbuf_puts(printname(p));
|
|
break;
|
|
case TENSOR:
|
|
outbuf_puts("(tensor)");
|
|
break;
|
|
default:
|
|
outbuf_puts("(?)");
|
|
break;
|
|
}
|
|
}
|
|
void
|
|
eval_print(struct atom *p1)
|
|
{
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
push(car(p1));
|
|
evalf();
|
|
print_result();
|
|
p1 = cdr(p1);
|
|
}
|
|
push_symbol(NIL);
|
|
}
|
|
|
|
void
|
|
print_result(void)
|
|
{
|
|
struct atom *p1, *p2;
|
|
|
|
p2 = pop(); // result
|
|
p1 = pop(); // input
|
|
|
|
if (p2 == symbol(NIL))
|
|
return;
|
|
|
|
if (annotate_result(p1, p2)) {
|
|
push_symbol(SETQ);
|
|
push(p1);
|
|
push(p2);
|
|
list(3);
|
|
p2 = pop();
|
|
}
|
|
|
|
p1 = get_binding(symbol(TTY));
|
|
|
|
if (p1 == symbol(TTY) || iszero(p1)) {
|
|
push(p2);
|
|
display();
|
|
} else
|
|
print_infixform(p2);
|
|
}
|
|
|
|
// returns 1 if result should be annotated
|
|
|
|
int
|
|
annotate_result(struct atom *p1, struct atom *p2)
|
|
{
|
|
if (!isusersymbol(p1))
|
|
return 0;
|
|
|
|
if (p1 == p2)
|
|
return 0; // A = A
|
|
|
|
if (p1 == symbol(I_LOWER) && isimaginaryunit(p2))
|
|
return 0;
|
|
|
|
if (p1 == symbol(J_LOWER) && isimaginaryunit(p2))
|
|
return 0;
|
|
|
|
return 1;
|
|
}
|
|
void
|
|
eval_product(struct atom *p1)
|
|
{
|
|
int h, i, j, k, n;
|
|
struct atom *p2, *p3;
|
|
|
|
// product of tensor elements?
|
|
|
|
if (lengthf(p1) == 2) {
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = pop();
|
|
if (!istensor(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++)
|
|
push(p1->u.tensor->elem[i]);
|
|
multiply_factors(n);
|
|
return;
|
|
}
|
|
|
|
p2 = cadr(p1);
|
|
if (!isusersymbol(p2))
|
|
stopf("product: index symbol err");
|
|
|
|
push(caddr(p1));
|
|
evalf();
|
|
p3 = pop();
|
|
if (!issmallinteger(p3))
|
|
stopf("product: index range err");
|
|
push(p3);
|
|
j = pop_integer();
|
|
|
|
push(cadddr(p1));
|
|
evalf();
|
|
p3 = pop();
|
|
if (!issmallinteger(p3))
|
|
stopf("product: index range err");
|
|
push(p3);
|
|
k = pop_integer();
|
|
|
|
p1 = caddddr(p1);
|
|
|
|
save_symbol(p2);
|
|
|
|
h = tos;
|
|
|
|
for (;;) {
|
|
push_integer(j);
|
|
p3 = pop();
|
|
set_symbol(p2, p3, symbol(NIL));
|
|
push(p1);
|
|
evalg();
|
|
if (j == k)
|
|
break;
|
|
if (j < k)
|
|
j++;
|
|
else
|
|
j--;
|
|
if (tos - h == 1000)
|
|
multiply_factors(1000); // to prevent stack overflow
|
|
}
|
|
|
|
multiply_factors(tos - h);
|
|
|
|
p1 = pop();
|
|
restore_symbol();
|
|
push(p1);
|
|
}
|
|
void
|
|
eval_quote(struct atom *p1)
|
|
{
|
|
push(cadr(p1)); // not evaluated
|
|
}
|
|
void
|
|
eval_rand(struct atom *p1)
|
|
{
|
|
double d;
|
|
d = (double) rand() / ((double) RAND_MAX + 1);
|
|
push_double(d);
|
|
}
|
|
void
|
|
eval_rank(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = pop();
|
|
if (istensor(p1))
|
|
push_integer(p1->u.tensor->ndim);
|
|
else
|
|
push_integer(0);
|
|
}
|
|
void
|
|
eval_rationalize(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
rationalize();
|
|
}
|
|
|
|
void
|
|
rationalize(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
rationalize();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
numden();
|
|
swap();
|
|
reciprocate();
|
|
multiply_noexpand();
|
|
}
|
|
void
|
|
eval_real(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
real();
|
|
}
|
|
|
|
void
|
|
real(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
real();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
rect();
|
|
p1 = pop();
|
|
push(p1);
|
|
push(p1);
|
|
conjfunc();
|
|
add();
|
|
push_rational(1, 2);
|
|
multiply();
|
|
}
|
|
void
|
|
eval_rect(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
rect();
|
|
}
|
|
|
|
void
|
|
rect(void)
|
|
{
|
|
int h, i, n;
|
|
struct atom *p1, *p2, *BASE, *EXPO;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
rect();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(ADD)) {
|
|
p1 = cdr(p1);
|
|
h = tos;
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
rect();
|
|
p1 = cdr(p1);
|
|
}
|
|
add_terms(tos - h);
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
p1 = cdr(p1);
|
|
h = tos;
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
rect();
|
|
p1 = cdr(p1);
|
|
}
|
|
multiply_factors(tos - h);
|
|
return;
|
|
}
|
|
|
|
if (car(p1) != symbol(POWER)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
BASE = cadr(p1);
|
|
EXPO = caddr(p1);
|
|
|
|
// handle sum in exponent
|
|
|
|
if (car(EXPO) == symbol(ADD)) {
|
|
p1 = cdr(EXPO);
|
|
h = tos;
|
|
while (iscons(p1)) {
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push(car(p1));
|
|
list(3);
|
|
rect();
|
|
p1 = cdr(p1);
|
|
}
|
|
multiply_factors(tos - h);
|
|
return;
|
|
}
|
|
|
|
// return mag(p1) * cos(arg(p1)) + i sin(arg(p1)))
|
|
|
|
push(p1);
|
|
magfunc();
|
|
|
|
push(p1);
|
|
argfunc();
|
|
p2 = pop();
|
|
|
|
push(p2);
|
|
cosfunc();
|
|
|
|
push(imaginaryunit);
|
|
push(p2);
|
|
sinfunc();
|
|
multiply();
|
|
|
|
add();
|
|
|
|
multiply();
|
|
}
|
|
void
|
|
eval_roots(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
|
|
p1 = cddr(p1);
|
|
|
|
if (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
} else
|
|
push_symbol(X_LOWER);
|
|
|
|
roots();
|
|
}
|
|
|
|
void
|
|
roots(void)
|
|
{
|
|
int h, i, j, k, n;
|
|
struct atom *A, *P, *X;
|
|
|
|
X = pop();
|
|
P = pop();
|
|
|
|
h = tos;
|
|
|
|
coeffs(P, X); // put coeffs on stack
|
|
|
|
k = tos;
|
|
|
|
n = k - h; // number of coeffs on stack
|
|
|
|
// check coeffs
|
|
|
|
for (i = 0; i < n; i++)
|
|
if (!isrational(stack[h + i]))
|
|
stopf("roots: coeffs");
|
|
|
|
// find roots
|
|
|
|
while (n > 1) {
|
|
|
|
if (findroot(h, n) == 0)
|
|
break; // no root found
|
|
|
|
// A is the root
|
|
|
|
A = stack[tos - 1];
|
|
|
|
// divide p(x) by X - A
|
|
|
|
reduce(h, n, A);
|
|
|
|
n--;
|
|
}
|
|
|
|
n = tos - k; // number of roots on stack
|
|
|
|
if (n == 0) {
|
|
tos = h; // pop all
|
|
push_symbol(NIL); // no roots
|
|
return;
|
|
}
|
|
|
|
sort(n); // sort roots
|
|
|
|
// eliminate repeated roots
|
|
|
|
for (i = 0; i < n - 1; i++)
|
|
if (equal(stack[k + i], stack[k + i + 1])) {
|
|
for (j = i + 1; j < n - 1; j++)
|
|
stack[k + j] = stack[k + j + 1];
|
|
i--;
|
|
n--;
|
|
}
|
|
|
|
if (n == 1) {
|
|
A = stack[k];
|
|
tos = h; // pop all
|
|
push(A); // one root
|
|
return;
|
|
}
|
|
|
|
A = alloc_vector(n);
|
|
|
|
for (i = 0; i < n; i++)
|
|
A->u.tensor->elem[i] = stack[k + i];
|
|
|
|
tos = h; // pop all
|
|
|
|
push(A);
|
|
}
|
|
|
|
int
|
|
findroot(int h, int n)
|
|
{
|
|
int i, j, m, p, q, r;
|
|
struct atom *A, *C, *PA;
|
|
|
|
// check constant term
|
|
|
|
if (iszero(stack[h])) {
|
|
push_integer(0); // root is zero
|
|
return 1;
|
|
}
|
|
|
|
// eliminate denominators
|
|
|
|
for (i = 0; i < n; i++) {
|
|
C = stack[h + i];
|
|
if (isinteger(C))
|
|
continue;
|
|
push(C);
|
|
denominator();
|
|
C = pop();
|
|
for (j = 0; j < n; j++) {
|
|
push(stack[h + j]);
|
|
push(C);
|
|
multiply();
|
|
stack[h + j] = pop();
|
|
}
|
|
}
|
|
|
|
p = tos;
|
|
|
|
push(stack[h]);
|
|
m = pop_integer();
|
|
divisors(m); // divisors of constant term
|
|
|
|
q = tos;
|
|
|
|
push(stack[h + n - 1]);
|
|
m = pop_integer();
|
|
divisors(m); // divisors of leading coeff
|
|
|
|
r = tos;
|
|
|
|
for (i = p; i < q; i++) {
|
|
for (j = q; j < r; j++) {
|
|
|
|
// try positive A
|
|
|
|
push(stack[i]);
|
|
push(stack[j]);
|
|
divide();
|
|
A = pop();
|
|
|
|
horner(h, n, A);
|
|
|
|
PA = pop(); // polynomial evaluated at A
|
|
|
|
if (iszero(PA)) {
|
|
tos = p; // pop all
|
|
push(A);
|
|
return 1; // root on stack
|
|
}
|
|
|
|
// try negative A
|
|
|
|
push(A);
|
|
negate();
|
|
A = pop();
|
|
|
|
horner(h, n, A);
|
|
|
|
PA = pop(); // polynomial evaluated at A
|
|
|
|
if (iszero(PA)) {
|
|
tos = p; // pop all
|
|
push(A);
|
|
return 1; // root on stack
|
|
}
|
|
}
|
|
}
|
|
|
|
tos = p; // pop all
|
|
|
|
return 0; // no root
|
|
}
|
|
|
|
// evaluate p(x) at x = A using horner's rule
|
|
|
|
void
|
|
horner(int h, int n, struct atom *A)
|
|
{
|
|
int i;
|
|
|
|
push(stack[h + n - 1]);
|
|
|
|
for (i = n - 2; i >= 0; i--) {
|
|
push(A);
|
|
multiply();
|
|
push(stack[h + i]);
|
|
add();
|
|
}
|
|
}
|
|
|
|
// push all divisors of n
|
|
|
|
void
|
|
divisors(int n)
|
|
{
|
|
int h, i, k;
|
|
|
|
h = tos;
|
|
|
|
factor_int(n);
|
|
|
|
k = tos;
|
|
|
|
// contruct divisors by recursive descent
|
|
|
|
push_integer(1);
|
|
|
|
divisors_nib(h, k);
|
|
|
|
// move
|
|
|
|
n = tos - k;
|
|
|
|
for (i = 0; i < n; i++)
|
|
stack[h + i] = stack[k + i];
|
|
|
|
tos = h + n; // pop all
|
|
}
|
|
|
|
// Generate all divisors for a factored number
|
|
//
|
|
// Input: Factor pairs on stack (base, expo)
|
|
//
|
|
// h first pair
|
|
//
|
|
// k just past last pair
|
|
//
|
|
// Output: Divisors on stack
|
|
//
|
|
// For example, the number 12 (= 2^2 3^1) has 6 divisors:
|
|
//
|
|
// 1, 2, 3, 4, 6, 12
|
|
|
|
void
|
|
divisors_nib(int h, int k)
|
|
{
|
|
int i, n;
|
|
struct atom *ACCUM, *BASE, *EXPO;
|
|
|
|
if (h == k)
|
|
return;
|
|
|
|
ACCUM = pop();
|
|
|
|
BASE = stack[h + 0];
|
|
EXPO = stack[h + 1];
|
|
|
|
push(EXPO);
|
|
n = pop_integer();
|
|
|
|
for (i = 0; i <= n; i++) {
|
|
push(ACCUM);
|
|
push(BASE);
|
|
push_integer(i);
|
|
power();
|
|
multiply();
|
|
divisors_nib(h + 2, k);
|
|
}
|
|
}
|
|
|
|
// divide by X - A
|
|
|
|
void
|
|
reduce(int h, int n, struct atom *A)
|
|
{
|
|
int i;
|
|
|
|
for (i = n - 1; i > 0; i--) {
|
|
push(A);
|
|
push(stack[h + i]);
|
|
multiply();
|
|
push(stack[h + i - 1]);
|
|
add();
|
|
stack[h + i - 1] = pop();
|
|
}
|
|
|
|
if (!iszero(stack[h]))
|
|
stopf("roots: residual error"); // not a root
|
|
|
|
// move
|
|
|
|
for (i = 0; i < n - 1; i++)
|
|
stack[h + i] = stack[h + i + 1];
|
|
}
|
|
|
|
// push coefficients of polynomial P(X) on stack
|
|
|
|
void
|
|
coeffs(struct atom *P, struct atom *X)
|
|
{
|
|
struct atom *C;
|
|
|
|
for (;;) {
|
|
|
|
push(P);
|
|
push(X);
|
|
push_integer(0);
|
|
subst();
|
|
evalf();
|
|
C = pop();
|
|
|
|
push(C);
|
|
|
|
push(P);
|
|
push(C);
|
|
subtract();
|
|
P = pop();
|
|
|
|
if (iszero(P))
|
|
break;
|
|
|
|
push(P);
|
|
push(X);
|
|
divide();
|
|
P = pop();
|
|
}
|
|
}
|
|
#define NUMQBITS PSI->u.tensor->nelem
|
|
#define KET0 PSI->u.tensor->elem[i ^ n]
|
|
#define KET1 PSI->u.tensor->elem[i]
|
|
|
|
#define POWEROF2(x) (((x) & ((x) - 1)) == 0)
|
|
|
|
void
|
|
eval_rotate(struct atom *p1)
|
|
{
|
|
int m, n;
|
|
uint32_t c;
|
|
struct atom *PSI, *OPCODE, *PHASE;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
PSI = pop();
|
|
|
|
if (!istensor(PSI) || PSI->u.tensor->ndim > 1 || PSI->u.tensor->nelem > 32768 || !POWEROF2(PSI->u.tensor->nelem))
|
|
stopf("rotate error 1 first argument is not a vector or dimension error");
|
|
|
|
c = 0;
|
|
|
|
p1 = cddr(p1);
|
|
|
|
while (iscons(p1)) {
|
|
|
|
if (!iscons(cdr(p1)))
|
|
stopf("rotate error 2 unexpected end of argument list");
|
|
|
|
OPCODE = car(p1);
|
|
push(cadr(p1));
|
|
evalf();
|
|
n = pop_integer();
|
|
|
|
if (n > 14 || (1 << n) >= PSI->u.tensor->nelem)
|
|
stopf("rotate error 3 qubit number format or range");
|
|
|
|
p1 = cddr(p1);
|
|
|
|
if (OPCODE == symbol(C_UPPER)) {
|
|
c |= 1 << n;
|
|
continue;
|
|
}
|
|
|
|
if (OPCODE == symbol(H_UPPER)) {
|
|
rotate_h(PSI, c, n);
|
|
c = 0;
|
|
continue;
|
|
}
|
|
|
|
if (OPCODE == symbol(P_UPPER)) {
|
|
if (!iscons(p1))
|
|
stopf("rotate error 2 unexpected end of argument list");
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
evalf();
|
|
push(imaginaryunit);
|
|
multiply();
|
|
expfunc();
|
|
PHASE = pop();
|
|
rotate_p(PSI, PHASE, c, n);
|
|
c = 0;
|
|
continue;
|
|
}
|
|
|
|
if (OPCODE == symbol(Q_UPPER)) {
|
|
rotate_q(PSI, n);
|
|
c = 0;
|
|
continue;
|
|
}
|
|
|
|
if (OPCODE == symbol(V_UPPER)) {
|
|
rotate_v(PSI, n);
|
|
c = 0;
|
|
continue;
|
|
}
|
|
|
|
if (OPCODE == symbol(W_UPPER)) {
|
|
m = n;
|
|
if (!iscons(p1))
|
|
stopf("rotate error 2 unexpected end of argument list");
|
|
push(car(p1));
|
|
p1 = cdr(p1);
|
|
evalf();
|
|
n = pop_integer();
|
|
if (n > 14 || (1 << n) >= PSI->u.tensor->nelem)
|
|
stopf("rotate error 3 qubit number format or range");
|
|
rotate_w(PSI, c, m, n);
|
|
c = 0;
|
|
continue;
|
|
}
|
|
|
|
if (OPCODE == symbol(X_UPPER)) {
|
|
rotate_x(PSI, c, n);
|
|
c = 0;
|
|
continue;
|
|
}
|
|
|
|
if (OPCODE == symbol(Y_UPPER)) {
|
|
rotate_y(PSI, c, n);
|
|
c = 0;
|
|
continue;
|
|
}
|
|
|
|
if (OPCODE == symbol(Z_UPPER)) {
|
|
rotate_z(PSI, c, n);
|
|
c = 0;
|
|
continue;
|
|
}
|
|
|
|
stopf("rotate error 4 unknown rotation code");
|
|
}
|
|
|
|
push(PSI);
|
|
}
|
|
|
|
// hadamard
|
|
|
|
void
|
|
rotate_h(struct atom *PSI, uint32_t c, int n)
|
|
{
|
|
int i;
|
|
n = 1 << n;
|
|
for (i = 0; i < NUMQBITS; i++) {
|
|
if ((i & c) != c)
|
|
continue;
|
|
if (i & n) {
|
|
push(KET0);
|
|
push(KET1);
|
|
add();
|
|
push_rational(1, 2);
|
|
sqrtfunc();
|
|
multiply();
|
|
push(KET0);
|
|
push(KET1);
|
|
subtract();
|
|
push_rational(1, 2);
|
|
sqrtfunc();
|
|
multiply();
|
|
KET1 = pop();
|
|
KET0 = pop();
|
|
}
|
|
}
|
|
}
|
|
|
|
// phase
|
|
|
|
void
|
|
rotate_p(struct atom *PSI, struct atom *PHASE, uint32_t c, int n)
|
|
{
|
|
int i;
|
|
n = 1 << n;
|
|
for (i = 0; i < NUMQBITS; i++) {
|
|
if ((i & c) != c)
|
|
continue;
|
|
if (i & n) {
|
|
push(KET1);
|
|
push(PHASE);
|
|
multiply();
|
|
KET1 = pop();
|
|
}
|
|
}
|
|
}
|
|
|
|
// swap
|
|
|
|
void
|
|
rotate_w(struct atom *PSI, uint32_t c, int m, int n)
|
|
{
|
|
int i;
|
|
m = 1 << m;
|
|
n = 1 << n;
|
|
for (i = 0; i < NUMQBITS; i++) {
|
|
if ((i & c) != c)
|
|
continue;
|
|
if ((i & m) && !(i & n)) {
|
|
push(PSI->u.tensor->elem[i]);
|
|
push(PSI->u.tensor->elem[i ^ m ^ n]);
|
|
PSI->u.tensor->elem[i] = pop();
|
|
PSI->u.tensor->elem[i ^ m ^ n] = pop();
|
|
}
|
|
}
|
|
}
|
|
|
|
void
|
|
rotate_x(struct atom *PSI, uint32_t c, int n)
|
|
{
|
|
int i;
|
|
n = 1 << n;
|
|
for (i = 0; i < NUMQBITS; i++) {
|
|
if ((i & c) != c)
|
|
continue;
|
|
if (i & n) {
|
|
push(KET0);
|
|
push(KET1);
|
|
KET0 = pop();
|
|
KET1 = pop();
|
|
}
|
|
}
|
|
}
|
|
|
|
void
|
|
rotate_y(struct atom *PSI, uint32_t c, int n)
|
|
{
|
|
int i;
|
|
n = 1 << n;
|
|
for (i = 0; i < NUMQBITS; i++) {
|
|
if ((i & c) != c)
|
|
continue;
|
|
if (i & n) {
|
|
push(imaginaryunit);
|
|
push(KET0);
|
|
multiply();
|
|
push(imaginaryunit);
|
|
negate();
|
|
push(KET1);
|
|
multiply();
|
|
KET0 = pop();
|
|
KET1 = pop();
|
|
}
|
|
}
|
|
}
|
|
|
|
void
|
|
rotate_z(struct atom *PSI, uint32_t c, int n)
|
|
{
|
|
int i;
|
|
n = 1 << n;
|
|
for (i = 0; i < NUMQBITS; i++) {
|
|
if ((i & c) != c)
|
|
continue;
|
|
if (i & n) {
|
|
push(KET1);
|
|
negate();
|
|
KET1 = pop();
|
|
}
|
|
}
|
|
}
|
|
|
|
// quantum fourier transform
|
|
|
|
void
|
|
rotate_q(struct atom *PSI, int n)
|
|
{
|
|
int i, j;
|
|
struct atom *PHASE;
|
|
for (i = n; i >= 0; i--) {
|
|
rotate_h(PSI, 0, i);
|
|
for (j = 0; j < i; j++) {
|
|
push_rational(1, 2);
|
|
push_integer(i - j);
|
|
power();
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
evalf(); // in case PI is numerical
|
|
multiply_factors(3);
|
|
expfunc();
|
|
PHASE = pop();
|
|
rotate_p(PSI, PHASE, 1 << j, i);
|
|
}
|
|
}
|
|
for (i = 0; i < (n + 1) / 2; i++)
|
|
rotate_w(PSI, 0, i, n - i);
|
|
}
|
|
|
|
// inverse qft
|
|
|
|
void
|
|
rotate_v(struct atom *PSI, int n)
|
|
{
|
|
int i, j;
|
|
struct atom *PHASE;
|
|
for (i = 0; i < (n + 1) / 2; i++)
|
|
rotate_w(PSI, 0, i, n - i);
|
|
for (i = 0; i <= n; i++) {
|
|
for (j = i - 1; j >= 0; j--) {
|
|
push_rational(1, 2);
|
|
push_integer(i - j);
|
|
power();
|
|
push(imaginaryunit);
|
|
push_symbol(PI);
|
|
evalf(); // in case PI is numerical
|
|
multiply_factors(3);
|
|
negate();
|
|
expfunc();
|
|
PHASE = pop();
|
|
rotate_p(PSI, PHASE, 1 << j, i);
|
|
}
|
|
rotate_h(PSI, 0, i);
|
|
}
|
|
}
|
|
void
|
|
eval_run(struct atom *p1)
|
|
{
|
|
char *buf;
|
|
struct atom *p2;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = pop();
|
|
if (!isstr(p1))
|
|
stopf("run: file name expected");
|
|
|
|
p2 = alloc_str();
|
|
buf = read_file(p1->u.str);
|
|
if (buf == NULL)
|
|
stopf("run: cannot read file");
|
|
p2->u.str = buf;
|
|
|
|
push(p2); // make visible to garbage collector
|
|
run_buf(buf);
|
|
pop(); // buf is freed on next gc
|
|
|
|
push_symbol(NIL); // return value
|
|
}
|
|
|
|
char *
|
|
read_file(char *filename)
|
|
{
|
|
int fd, n;
|
|
char *buf;
|
|
off_t t;
|
|
|
|
fd = open(filename, O_RDONLY);
|
|
|
|
if (fd < 0)
|
|
return NULL;
|
|
|
|
t = lseek(fd, 0, SEEK_END);
|
|
|
|
if (t < 0 || t > 0x1000000) { // 16 MB max
|
|
close(fd);
|
|
return NULL;
|
|
}
|
|
|
|
if (lseek(fd, 0, SEEK_SET)) {
|
|
close(fd);
|
|
return NULL;
|
|
}
|
|
|
|
n = (int) t;
|
|
|
|
buf = malloc(n + 1);
|
|
|
|
if (buf == NULL) {
|
|
close(fd);
|
|
return NULL;
|
|
}
|
|
|
|
if (read(fd, buf, n) != n) {
|
|
free(buf);
|
|
close(fd);
|
|
return NULL;
|
|
}
|
|
|
|
close(fd);
|
|
|
|
buf[n] = '\0';
|
|
|
|
return buf;
|
|
}
|
|
void
|
|
eval_setq(struct atom *p1)
|
|
{
|
|
struct atom *p2;
|
|
|
|
push_symbol(NIL); // return value
|
|
|
|
if (caadr(p1) == symbol(INDEX)) {
|
|
setq_indexed(p1);
|
|
return;
|
|
}
|
|
|
|
if (iscons(cadr(p1))) {
|
|
setq_usrfunc(p1);
|
|
return;
|
|
}
|
|
|
|
if (!isusersymbol(cadr(p1)))
|
|
stopf("user symbol expected");
|
|
|
|
push(caddr(p1));
|
|
evalg();
|
|
p2 = pop();
|
|
|
|
set_symbol(cadr(p1), p2, symbol(NIL));
|
|
}
|
|
|
|
// Example: a[1] = b
|
|
//
|
|
// p1----->cons--->cons------------------->cons
|
|
// | | |
|
|
// setq cons--->cons--->cons b
|
|
// | | |
|
|
// index a 1
|
|
//
|
|
// caadr(p1) = index
|
|
// cadadr(p1) = a
|
|
// caddr(p1) = b
|
|
|
|
void
|
|
setq_indexed(struct atom *p1)
|
|
{
|
|
int h;
|
|
struct atom *S, *LVAL, *RVAL;
|
|
|
|
S = cadadr(p1);
|
|
|
|
if (!isusersymbol(S))
|
|
stopf("user symbol expected");
|
|
|
|
push(S);
|
|
evalg();
|
|
|
|
push(caddr(p1));
|
|
evalg();
|
|
|
|
RVAL = pop();
|
|
LVAL = pop();
|
|
|
|
// eval indices
|
|
|
|
p1 = cddadr(p1);
|
|
|
|
h = tos;
|
|
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
set_component(LVAL, RVAL, h);
|
|
|
|
set_symbol(S, LVAL, symbol(NIL));
|
|
}
|
|
|
|
void
|
|
set_component(struct atom *LVAL, struct atom *RVAL, int h)
|
|
{
|
|
int i, k, m, n, t;
|
|
|
|
if (!istensor(LVAL))
|
|
stopf("index error");
|
|
|
|
// n is the number of indices
|
|
|
|
n = tos - h;
|
|
|
|
if (n < 1 || n > LVAL->u.tensor->ndim)
|
|
stopf("index error");
|
|
|
|
// k is the combined index
|
|
|
|
k = 0;
|
|
|
|
for (i = 0; i < n; i++) {
|
|
push(stack[h + i]);
|
|
t = pop_integer();
|
|
if (t < 1 || t > LVAL->u.tensor->dim[i])
|
|
stopf("index error");
|
|
k = k * LVAL->u.tensor->dim[i] + t - 1;
|
|
}
|
|
|
|
tos = h; // pop all
|
|
|
|
if (istensor(RVAL)) {
|
|
m = RVAL->u.tensor->ndim;
|
|
if (n + m != LVAL->u.tensor->ndim)
|
|
stopf("index error");
|
|
for (i = 0; i < m; i++)
|
|
if (LVAL->u.tensor->dim[n + i] != RVAL->u.tensor->dim[i])
|
|
stopf("index error");
|
|
m = RVAL->u.tensor->nelem;
|
|
for (i = 0; i < m; i++)
|
|
LVAL->u.tensor->elem[m * k + i] = RVAL->u.tensor->elem[i];
|
|
} else {
|
|
if (n != LVAL->u.tensor->ndim)
|
|
stopf("index error");
|
|
LVAL->u.tensor->elem[k] = RVAL;
|
|
}
|
|
}
|
|
|
|
// Example:
|
|
//
|
|
// f(x,y)=x^y
|
|
//
|
|
// For this definition, p1 points to the following structure.
|
|
//
|
|
// p1
|
|
// |
|
|
// ___v__ ______ ______
|
|
// |CONS |->|CONS |--------------------->|CONS |
|
|
// |______| |______| |______|
|
|
// | | |
|
|
// ___v__ ___v__ ______ ______ ___v__ ______ ______
|
|
// |SETQ | |CONS |->|CONS |->|CONS | |CONS |->|CONS |->|CONS |
|
|
// |______| |______| |______| |______| |______| |______| |______|
|
|
// | | | | | |
|
|
// ___v__ ___v__ ___v__ ___v__ ___v__ ___v__
|
|
// |SYM f | |SYM x | |SYM y | |POWER | |SYM x | |SYM y |
|
|
// |______| |______| |______| |______| |______| |______|
|
|
//
|
|
// We have
|
|
//
|
|
// caadr(p1) points to f
|
|
// cdadr(p1) points to the list (x y)
|
|
// caddr(p1) points to (power x y)
|
|
|
|
void
|
|
setq_usrfunc(struct atom *p1)
|
|
{
|
|
struct atom *F, *A, *B, *C;
|
|
|
|
F = caadr(p1);
|
|
A = cdadr(p1);
|
|
B = caddr(p1);
|
|
|
|
if (!isusersymbol(F))
|
|
stopf("user symbol expected");
|
|
|
|
if (lengthf(A) > 9)
|
|
stopf("more than 9 arguments");
|
|
|
|
push(B);
|
|
convert_body(A);
|
|
C = pop();
|
|
|
|
set_symbol(F, B, C);
|
|
}
|
|
|
|
void
|
|
convert_body(struct atom *A)
|
|
{
|
|
if (!iscons(A))
|
|
return;
|
|
|
|
push(car(A));
|
|
push_symbol(ARG1);
|
|
subst();
|
|
|
|
A = cdr(A);
|
|
if (!iscons(A))
|
|
return;
|
|
|
|
push(car(A));
|
|
push_symbol(ARG2);
|
|
subst();
|
|
|
|
A = cdr(A);
|
|
if (!iscons(A))
|
|
return;
|
|
|
|
push(car(A));
|
|
push_symbol(ARG3);
|
|
subst();
|
|
|
|
A = cdr(A);
|
|
if (!iscons(A))
|
|
return;
|
|
|
|
push(car(A));
|
|
push_symbol(ARG4);
|
|
subst();
|
|
|
|
A = cdr(A);
|
|
if (!iscons(A))
|
|
return;
|
|
|
|
push(car(A));
|
|
push_symbol(ARG5);
|
|
subst();
|
|
|
|
A = cdr(A);
|
|
|
|
if (!iscons(A))
|
|
return;
|
|
|
|
push(car(A));
|
|
push_symbol(ARG6);
|
|
subst();
|
|
|
|
A = cdr(A);
|
|
if (!iscons(A))
|
|
return;
|
|
|
|
push(car(A));
|
|
push_symbol(ARG7);
|
|
subst();
|
|
|
|
A = cdr(A);
|
|
if (!iscons(A))
|
|
return;
|
|
|
|
push(car(A));
|
|
push_symbol(ARG8);
|
|
subst();
|
|
|
|
A = cdr(A);
|
|
if (!iscons(A))
|
|
return;
|
|
|
|
push(car(A));
|
|
push_symbol(ARG9);
|
|
subst();
|
|
}
|
|
// first author: github.com/phbillet
|
|
|
|
void
|
|
eval_sgn(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
sgnfunc();
|
|
}
|
|
|
|
void
|
|
sgnfunc(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
sgnfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
p2 = p1;
|
|
|
|
if (!isnum(p2)) {
|
|
push(p2);
|
|
floatfunc();
|
|
p2 = pop();
|
|
}
|
|
|
|
if (!isnum(p2)) {
|
|
push_symbol(SGN);
|
|
push(p1);
|
|
list(2);
|
|
return;
|
|
}
|
|
|
|
if (iszero(p2)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
if (isnegativenumber(p2))
|
|
push_integer(-1);
|
|
else
|
|
push_integer(1);
|
|
}
|
|
void
|
|
eval_simplify(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
simplify();
|
|
}
|
|
|
|
void
|
|
simplify(void)
|
|
{
|
|
int i, n;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
simplify();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
simplify_trig(); // do this first otherwise compton-demo runs out of memory
|
|
simplify_nib();
|
|
}
|
|
|
|
void
|
|
simplify_nib(void)
|
|
{
|
|
int h;
|
|
struct atom *p1, *p2, *p3, *NUM, *DEN, *R;
|
|
|
|
p1 = pop();
|
|
|
|
if (!iscons(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
rect();
|
|
p2 = pop();
|
|
push(p1);
|
|
polar();
|
|
p3 = pop();
|
|
if (simpler(p3, p2))
|
|
p2 = p3;
|
|
if (simpler(p2, p1))
|
|
p1 = p2;
|
|
|
|
if (!iscons(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
expform();
|
|
rect();
|
|
p2 = pop();
|
|
if (simpler(p2, p1))
|
|
p1 = p2;
|
|
|
|
if (!iscons(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
// depth first
|
|
|
|
h = tos;
|
|
push(car(p1)); // function name
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
simplify_nib();
|
|
p1 = cdr(p1);
|
|
}
|
|
list(tos - h);
|
|
evalf(); // normalize
|
|
p1 = pop();
|
|
|
|
if (!iscons(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
numden();
|
|
NUM = pop();
|
|
DEN = pop();
|
|
|
|
// NUM / DEN = A / (B / C) = A C / B
|
|
|
|
// for example, 1 / (x + y^2 / x) -> x / (x^2 + y^2)
|
|
|
|
push(DEN);
|
|
numden();
|
|
DEN = pop();
|
|
push(NUM);
|
|
multiply();
|
|
NUM = pop();
|
|
|
|
// search for R such that NUM = R DEN
|
|
|
|
if (car(NUM) == symbol(ADD) && car(DEN) == symbol(ADD)) {
|
|
|
|
p2 = cdr(DEN);
|
|
|
|
while (iscons(p2)) {
|
|
|
|
// provisional ratio
|
|
|
|
push(cadr(NUM)); // 1st term of numerator
|
|
push(car(p2));
|
|
divide();
|
|
R = pop();
|
|
|
|
// check
|
|
|
|
push(NUM);
|
|
push(R);
|
|
push(DEN);
|
|
multiply();
|
|
subtract();
|
|
p3 = pop();
|
|
|
|
if (iszero(p3)) {
|
|
push(R);
|
|
return;
|
|
}
|
|
|
|
p2 = cdr(p2);
|
|
}
|
|
}
|
|
|
|
push(NUM);
|
|
push(DEN);
|
|
divide();
|
|
p2 = pop();
|
|
if (simpler(p2, p1)) {
|
|
push(p2);
|
|
return;
|
|
}
|
|
|
|
push(DEN);
|
|
push(NUM);
|
|
divide();
|
|
rationalize();
|
|
reciprocate();
|
|
p2 = pop();
|
|
if (simpler(p2, p1)) {
|
|
push(p2);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
}
|
|
|
|
// try exponential form
|
|
|
|
void
|
|
simplify_trig(void)
|
|
{
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
if (!iscons(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
expform();
|
|
numden();
|
|
swap();
|
|
divide();
|
|
p2 = pop();
|
|
|
|
if (simpler(p2, p1))
|
|
push(p2);
|
|
else
|
|
push(p1);
|
|
}
|
|
|
|
int
|
|
simpler(struct atom *p1, struct atom *p2)
|
|
{
|
|
int d1, d2;
|
|
|
|
d1 = diameter(p1);
|
|
d2 = diameter(p2);
|
|
|
|
if (d1 == d2) {
|
|
d1 = mass(p1);
|
|
d2 = mass(p2);
|
|
}
|
|
|
|
return d1 < d2;
|
|
}
|
|
|
|
// for example, 1 / (x + y^2 / x) has diameter of 2
|
|
|
|
int
|
|
diameter(struct atom *p)
|
|
{
|
|
int max = 0, n;
|
|
|
|
if (car(p) == symbol(POWER) && isnegativenumber(caddr(p)))
|
|
return 1 + diameter(cadr(p));
|
|
|
|
while (iscons(p)) {
|
|
n = diameter(car(p));
|
|
if (n > max)
|
|
max = n;
|
|
p = cdr(p);
|
|
}
|
|
|
|
return max;
|
|
}
|
|
|
|
int
|
|
mass(struct atom *p)
|
|
{
|
|
int n = 1;
|
|
while (iscons(p)) {
|
|
n += mass(car(p));
|
|
p = cdr(p);
|
|
}
|
|
return n;
|
|
}
|
|
void
|
|
eval_sin(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
sinfunc();
|
|
}
|
|
|
|
void
|
|
sinfunc(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1, *p2, *X, *Y;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
sinfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
d = sin(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
// sin(z) = -i/2 exp(i z) + i/2 exp(-i z)
|
|
|
|
if (isdoublez(p1)) {
|
|
push_double(-0.5);
|
|
push(imaginaryunit);
|
|
multiply();
|
|
push(imaginaryunit);
|
|
push(p1);
|
|
multiply();
|
|
expfunc();
|
|
push(imaginaryunit);
|
|
negate();
|
|
push(p1);
|
|
multiply();
|
|
expfunc();
|
|
subtract();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// sin(-x) = -sin(x)
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push(p1);
|
|
negate();
|
|
sinfunc();
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(ADD)) {
|
|
sinfunc_sum(p1);
|
|
return;
|
|
}
|
|
|
|
// sin(arctan(y,x)) = y (x^2 + y^2)^(-1/2)
|
|
|
|
if (car(p1) == symbol(ARCTAN)) {
|
|
X = caddr(p1);
|
|
Y = cadr(p1);
|
|
push(Y);
|
|
push(X);
|
|
push(X);
|
|
multiply();
|
|
push(Y);
|
|
push(Y);
|
|
multiply();
|
|
add();
|
|
push_rational(-1, 2);
|
|
power();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
// sin(arccos(x)) = sqrt(1 - x^2)
|
|
|
|
if (car(p1) == symbol(ARCCOS)) {
|
|
push_integer(1);
|
|
push(cadr(p1));
|
|
push_integer(2);
|
|
power();
|
|
subtract();
|
|
push_rational(1, 2);
|
|
power();
|
|
return;
|
|
}
|
|
|
|
// n pi ?
|
|
|
|
push(p1);
|
|
push_symbol(PI);
|
|
divide();
|
|
p2 = pop();
|
|
|
|
if (!isnum(p2)) {
|
|
push_symbol(SIN);
|
|
push(p1);
|
|
list(2);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p2)) {
|
|
push(p2);
|
|
d = pop_double();
|
|
d = sin(d * M_PI);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
push(p2); // nonnegative by sin(-x) = -sin(x) above
|
|
push_integer(180);
|
|
multiply();
|
|
p2 = pop();
|
|
|
|
if (!isinteger(p2)) {
|
|
push_symbol(SIN);
|
|
push(p1);
|
|
list(2);
|
|
return;
|
|
}
|
|
|
|
push(p2);
|
|
push_integer(360);
|
|
modfunc();
|
|
n = pop_integer();
|
|
|
|
switch (n) {
|
|
case 0:
|
|
case 180:
|
|
push_integer(0);
|
|
break;
|
|
case 30:
|
|
case 150:
|
|
push_rational(1, 2);
|
|
break;
|
|
case 210:
|
|
case 330:
|
|
push_rational(-1, 2);
|
|
break;
|
|
case 45:
|
|
case 135:
|
|
push_rational(1, 2);
|
|
push_integer(2);
|
|
push_rational(1, 2);
|
|
power();
|
|
multiply();
|
|
break;
|
|
case 225:
|
|
case 315:
|
|
push_rational(-1, 2);
|
|
push_integer(2);
|
|
push_rational(1, 2);
|
|
power();
|
|
multiply();
|
|
break;
|
|
case 60:
|
|
case 120:
|
|
push_rational(1, 2);
|
|
push_integer(3);
|
|
push_rational(1, 2);
|
|
power();
|
|
multiply();
|
|
break;
|
|
case 240:
|
|
case 300:
|
|
push_rational(-1, 2);
|
|
push_integer(3);
|
|
push_rational(1, 2);
|
|
power();
|
|
multiply();
|
|
break;
|
|
case 90:
|
|
push_integer(1);
|
|
break;
|
|
case 270:
|
|
push_integer(-1);
|
|
break;
|
|
default:
|
|
push_symbol(SIN);
|
|
push(p1);
|
|
list(2);
|
|
break;
|
|
}
|
|
}
|
|
|
|
// sin(x + n/2 pi) = sin(x) cos(n/2 pi) + cos(x) sin(n/2 pi)
|
|
|
|
void
|
|
sinfunc_sum(struct atom *p1)
|
|
{
|
|
struct atom *p2, *p3;
|
|
p2 = cdr(p1);
|
|
while (iscons(p2)) {
|
|
push_integer(2);
|
|
push(car(p2));
|
|
multiply();
|
|
push_symbol(PI);
|
|
divide();
|
|
p3 = pop();
|
|
if (isinteger(p3)) {
|
|
push(p1);
|
|
push(car(p2));
|
|
subtract();
|
|
p3 = pop();
|
|
push(p3);
|
|
sinfunc();
|
|
push(car(p2));
|
|
cosfunc();
|
|
multiply();
|
|
push(p3);
|
|
cosfunc();
|
|
push(car(p2));
|
|
sinfunc();
|
|
multiply();
|
|
add();
|
|
return;
|
|
}
|
|
p2 = cdr(p2);
|
|
}
|
|
push_symbol(SIN);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_sinh(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
sinhfunc();
|
|
}
|
|
|
|
void
|
|
sinhfunc(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
sinhfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
d = sinh(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
// sinh(z) = 1/2 exp(z) - 1/2 exp(-z)
|
|
|
|
if (isdoublez(p1)) {
|
|
push_rational(1, 2);
|
|
push(p1);
|
|
expfunc();
|
|
push(p1);
|
|
negate();
|
|
expfunc();
|
|
subtract();
|
|
multiply();
|
|
return;
|
|
}
|
|
|
|
if (iszero(p1)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
// sinh(-x) -> -sinh(x)
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push(p1);
|
|
negate();
|
|
sinhfunc();
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(ARCSINH)) {
|
|
push(cadr(p1));
|
|
return;
|
|
}
|
|
|
|
push_symbol(SINH);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_sqrt(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
sqrtfunc();
|
|
}
|
|
|
|
void
|
|
sqrtfunc(void)
|
|
{
|
|
push_rational(1, 2);
|
|
power();
|
|
}
|
|
void
|
|
eval_status(struct atom *p1)
|
|
{
|
|
(void) p1; // silence compiler
|
|
|
|
outbuf_init();
|
|
|
|
snprintf(strbuf, STRBUFLEN, "block_count %d (%d%%)\n", block_count, 100 * block_count / MAXBLOCKS);
|
|
outbuf_puts(strbuf);
|
|
|
|
snprintf(strbuf, STRBUFLEN, "free_count %d\n", free_count);
|
|
outbuf_puts(strbuf);
|
|
|
|
snprintf(strbuf, STRBUFLEN, "gc_count %d\n", gc_count);
|
|
outbuf_puts(strbuf);
|
|
|
|
snprintf(strbuf, STRBUFLEN, "bignum_count %d\n", bignum_count);
|
|
outbuf_puts(strbuf);
|
|
|
|
snprintf(strbuf, STRBUFLEN, "ksym_count %d\n", ksym_count);
|
|
outbuf_puts(strbuf);
|
|
|
|
snprintf(strbuf, STRBUFLEN, "usym_count %d\n", usym_count);
|
|
outbuf_puts(strbuf);
|
|
|
|
snprintf(strbuf, STRBUFLEN, "string_count %d\n", string_count);
|
|
outbuf_puts(strbuf);
|
|
|
|
snprintf(strbuf, STRBUFLEN, "tensor_count %d\n", tensor_count);
|
|
outbuf_puts(strbuf);
|
|
|
|
snprintf(strbuf, STRBUFLEN, "max_eval_level %d\n", max_eval_level);
|
|
outbuf_puts(strbuf);
|
|
|
|
snprintf(strbuf, STRBUFLEN, "max_tos %d (%d%%)\n", max_tos, 100 * max_tos / STACKSIZE);
|
|
outbuf_puts(strbuf);
|
|
|
|
printbuf(outbuf, BLACK);
|
|
|
|
push_symbol(NIL);
|
|
}
|
|
void
|
|
eval_stop(struct atom *p1)
|
|
{
|
|
(void) p1; // silence compiler
|
|
stopf("stop function");
|
|
}
|
|
void
|
|
eval_sum(struct atom *p1)
|
|
{
|
|
int h, i, j, k, n;
|
|
struct atom *p2, *p3;
|
|
|
|
// sum over tensor elements?
|
|
|
|
if (lengthf(p1) == 2) {
|
|
push(cadr(p1));
|
|
evalf();
|
|
p1 = pop();
|
|
if (!istensor(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++)
|
|
push(p1->u.tensor->elem[i]);
|
|
add_terms(n);
|
|
return;
|
|
}
|
|
|
|
p2 = cadr(p1);
|
|
if (!isusersymbol(p2))
|
|
stopf("sum: index symbol err");
|
|
|
|
push(caddr(p1));
|
|
evalf();
|
|
p3 = pop();
|
|
if (!issmallinteger(p3))
|
|
stopf("sum: index range err");
|
|
push(p3);
|
|
j = pop_integer();
|
|
|
|
push(cadddr(p1));
|
|
evalf();
|
|
p3 = pop();
|
|
if (!issmallinteger(p3))
|
|
stopf("sum: index range err");
|
|
push(p3);
|
|
k = pop_integer();
|
|
|
|
p1 = caddddr(p1);
|
|
|
|
save_symbol(p2);
|
|
|
|
h = tos;
|
|
|
|
for (;;) {
|
|
push_integer(j);
|
|
p3 = pop();
|
|
set_symbol(p2, p3, symbol(NIL));
|
|
push(p1);
|
|
evalg();
|
|
if (j == k)
|
|
break;
|
|
if (j < k)
|
|
j++;
|
|
else
|
|
j--;
|
|
if (tos - h == 1000)
|
|
add_terms(1000); // to prevent stack overflow
|
|
}
|
|
|
|
add_terms(tos - h);
|
|
|
|
p1 = pop();
|
|
restore_symbol();
|
|
push(p1);
|
|
}
|
|
void
|
|
eval_tan(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
tanfunc();
|
|
}
|
|
|
|
void
|
|
tanfunc(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
tanfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
d = tan(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
if (isdoublez(p1)) {
|
|
push(p1);
|
|
sinfunc();
|
|
push(p1);
|
|
cosfunc();
|
|
divide();
|
|
return;
|
|
}
|
|
|
|
// tan(-x) = -tan(x)
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push(p1);
|
|
negate();
|
|
tanfunc();
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(ADD)) {
|
|
tanfunc_sum(p1);
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(ARCTAN)) {
|
|
push(cadr(p1));
|
|
push(caddr(p1));
|
|
divide();
|
|
return;
|
|
}
|
|
|
|
// n pi ?
|
|
|
|
push(p1);
|
|
push_symbol(PI);
|
|
divide();
|
|
p2 = pop();
|
|
|
|
if (!isnum(p2)) {
|
|
push_symbol(TAN);
|
|
push(p1);
|
|
list(2);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p2)) {
|
|
push(p2);
|
|
d = pop_double();
|
|
d = tan(d * M_PI);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
push(p2); // nonnegative by tan(-x) = -tan(x) above
|
|
push_integer(180);
|
|
multiply();
|
|
p2 = pop();
|
|
|
|
if (!isinteger(p2)) {
|
|
push_symbol(TAN);
|
|
push(p1);
|
|
list(2);
|
|
return;
|
|
}
|
|
|
|
push(p2);
|
|
push_integer(360);
|
|
modfunc();
|
|
n = pop_integer();
|
|
|
|
switch (n) {
|
|
case 0:
|
|
case 180:
|
|
push_integer(0);
|
|
break;
|
|
case 30:
|
|
case 210:
|
|
push_rational(1, 3);
|
|
push_integer(3);
|
|
push_rational(1, 2);
|
|
power();
|
|
multiply();
|
|
break;
|
|
case 150:
|
|
case 330:
|
|
push_rational(-1, 3);
|
|
push_integer(3);
|
|
push_rational(1, 2);
|
|
power();
|
|
multiply();
|
|
break;
|
|
case 45:
|
|
case 225:
|
|
push_integer(1);
|
|
break;
|
|
case 135:
|
|
case 315:
|
|
push_integer(-1);
|
|
break;
|
|
case 60:
|
|
case 240:
|
|
push_integer(3);
|
|
push_rational(1, 2);
|
|
power();
|
|
break;
|
|
case 120:
|
|
case 300:
|
|
push_integer(3);
|
|
push_rational(1, 2);
|
|
power();
|
|
negate();
|
|
break;
|
|
default:
|
|
push_symbol(TAN);
|
|
push(p1);
|
|
list(2);
|
|
break;
|
|
}
|
|
}
|
|
|
|
// tan(x + n pi) = tan(x)
|
|
|
|
void
|
|
tanfunc_sum(struct atom *p1)
|
|
{
|
|
struct atom *p2, *p3;
|
|
p2 = cdr(p1);
|
|
while (iscons(p2)) {
|
|
push(car(p2));
|
|
push_symbol(PI);
|
|
divide();
|
|
p3 = pop();
|
|
if (isinteger(p3)) {
|
|
push(p1);
|
|
push(car(p2));
|
|
subtract();
|
|
tanfunc();
|
|
return;
|
|
}
|
|
p2 = cdr(p2);
|
|
}
|
|
push_symbol(TAN);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_tanh(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
tanhfunc();
|
|
}
|
|
|
|
void
|
|
tanhfunc(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
tanhfunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p1)) {
|
|
push(p1);
|
|
d = pop_double();
|
|
d = tanh(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
if (isdoublez(p1)) {
|
|
push(p1);
|
|
sinhfunc();
|
|
push(p1);
|
|
coshfunc();
|
|
divide();
|
|
return;
|
|
}
|
|
|
|
if (iszero(p1)) {
|
|
push_integer(0);
|
|
return;
|
|
}
|
|
|
|
// tanh(-x) = -tanh(x)
|
|
|
|
if (isnegativeterm(p1)) {
|
|
push(p1);
|
|
negate();
|
|
tanhfunc();
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(ARCTANH)) {
|
|
push(cadr(p1));
|
|
return;
|
|
}
|
|
|
|
push_symbol(TANH);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_taylor(struct atom *p1)
|
|
{
|
|
int h, i, n;
|
|
struct atom *F, *X, *A, *C;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
F = pop();
|
|
|
|
push(caddr(p1));
|
|
evalf();
|
|
X = pop();
|
|
|
|
push(cadddr(p1));
|
|
evalf();
|
|
n = pop_integer();
|
|
|
|
p1 = cddddr(p1);
|
|
|
|
if (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
} else
|
|
push_integer(0); // default expansion point
|
|
|
|
A = pop();
|
|
|
|
h = tos;
|
|
|
|
push(F); // f(a)
|
|
push(X);
|
|
push(A);
|
|
subst();
|
|
evalf();
|
|
|
|
push_integer(1);
|
|
C = pop();
|
|
|
|
for (i = 1; i <= n; i++) {
|
|
|
|
push(F); // f = f'
|
|
push(X);
|
|
derivative();
|
|
F = pop();
|
|
|
|
if (findf(F, symbol(DERIVATIVE)))
|
|
stopf("taylor: derivative err");
|
|
|
|
if (iszero(F))
|
|
break;
|
|
|
|
push(C); // c = c * (x - a)
|
|
push(X);
|
|
push(A);
|
|
subtract();
|
|
multiply();
|
|
C = pop();
|
|
|
|
push(F); // f(a)
|
|
push(X);
|
|
push(A);
|
|
subst();
|
|
evalf();
|
|
|
|
push(C);
|
|
multiply();
|
|
push_integer(i);
|
|
factorial();
|
|
divide();
|
|
}
|
|
|
|
add_terms(tos - h);
|
|
}
|
|
void
|
|
eval_tensor(struct atom *p1)
|
|
{
|
|
int i;
|
|
|
|
p1 = copy_tensor(p1);
|
|
|
|
for (i = 0; i < p1->u.tensor->nelem; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
evalf();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
|
|
push(p1);
|
|
|
|
promote_tensor();
|
|
}
|
|
|
|
// tensors with elements that are also tensors get promoted to a higher rank
|
|
|
|
void
|
|
promote_tensor(void)
|
|
{
|
|
int i, j, k, ndim1, ndim2, nelem1, nelem2;
|
|
struct atom *p1, *p2, *p3;
|
|
|
|
p1 = pop();
|
|
|
|
if (!istensor(p1)) {
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
ndim1 = p1->u.tensor->ndim;
|
|
nelem1 = p1->u.tensor->nelem;
|
|
|
|
// check
|
|
|
|
p2 = p1->u.tensor->elem[0];
|
|
|
|
for (i = 1; i < nelem1; i++) {
|
|
p3 = p1->u.tensor->elem[i];
|
|
if (!compatible_dimensions(p2, p3))
|
|
stopf("tensor dimensions");
|
|
}
|
|
|
|
if (!istensor(p2)) {
|
|
push(p1);
|
|
return; // all elements are scalars
|
|
}
|
|
|
|
ndim2 = p2->u.tensor->ndim;
|
|
nelem2 = p2->u.tensor->nelem;
|
|
|
|
if (ndim1 + ndim2 > MAXDIM)
|
|
stopf("rank exceeds max");
|
|
|
|
// alloc
|
|
|
|
p3 = alloc_tensor(nelem1 * nelem2);
|
|
|
|
// merge dimensions
|
|
|
|
k = 0;
|
|
|
|
for (i = 0; i < ndim1; i++)
|
|
p3->u.tensor->dim[k++] = p1->u.tensor->dim[i];
|
|
|
|
for (i = 0; i < ndim2; i++)
|
|
p3->u.tensor->dim[k++] = p2->u.tensor->dim[i];
|
|
|
|
p3->u.tensor->ndim = ndim1 + ndim2;
|
|
|
|
// merge elements
|
|
|
|
k = 0;
|
|
|
|
for (i = 0; i < nelem1; i++) {
|
|
p2 = p1->u.tensor->elem[i];
|
|
for (j = 0; j < nelem2; j++)
|
|
p3->u.tensor->elem[k++] = p2->u.tensor->elem[j];
|
|
}
|
|
|
|
push(p3);
|
|
}
|
|
|
|
int
|
|
compatible_dimensions(struct atom *p, struct atom *q)
|
|
{
|
|
int i, n;
|
|
|
|
if (!istensor(p) && !istensor(q))
|
|
return 1; // both p and q are scalars
|
|
|
|
if (!istensor(p) || !istensor(q))
|
|
return 0; // scalar and tensor
|
|
|
|
n = p->u.tensor->ndim;
|
|
|
|
if (n != q->u.tensor->ndim)
|
|
return 0;
|
|
|
|
for (i = 0; i < n; i++)
|
|
if (p->u.tensor->dim[i] != q->u.tensor->dim[i])
|
|
return 0;
|
|
|
|
return 1;
|
|
}
|
|
|
|
struct atom *
|
|
copy_tensor(struct atom *p1)
|
|
{
|
|
int i;
|
|
struct atom *p2;
|
|
|
|
p2 = alloc_tensor(p1->u.tensor->nelem);
|
|
|
|
p2->u.tensor->ndim = p1->u.tensor->ndim;
|
|
|
|
for (i = 0; i < p1->u.tensor->ndim; i++)
|
|
p2->u.tensor->dim[i] = p1->u.tensor->dim[i];
|
|
|
|
for (i = 0; i < p1->u.tensor->nelem; i++)
|
|
p2->u.tensor->elem[i] = p1->u.tensor->elem[i];
|
|
|
|
return p2;
|
|
}
|
|
void
|
|
eval_test(struct atom *p1)
|
|
{
|
|
struct atom *p2;
|
|
p1 = cdr(p1);
|
|
while (iscons(p1)) {
|
|
if (!iscons(cdr(p1))) {
|
|
push(car(p1)); // default case
|
|
evalf();
|
|
return;
|
|
}
|
|
push(car(p1));
|
|
evalp();
|
|
p2 = pop();
|
|
if (!iszero(p2)) {
|
|
push(cadr(p1));
|
|
evalf();
|
|
return;
|
|
}
|
|
p1 = cddr(p1);
|
|
}
|
|
push_symbol(NIL);
|
|
}
|
|
|
|
void
|
|
eval_testeq(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
push(caddr(p1));
|
|
evalf();
|
|
subtract();
|
|
simplify();
|
|
p1 = pop();
|
|
if (iszero(p1))
|
|
push_integer(1);
|
|
else
|
|
push_integer(0);
|
|
}
|
|
|
|
void
|
|
eval_testge(struct atom *p1)
|
|
{
|
|
if (cmp_args(p1) >= 0)
|
|
push_integer(1);
|
|
else
|
|
push_integer(0);
|
|
}
|
|
|
|
void
|
|
eval_testgt(struct atom *p1)
|
|
{
|
|
if (cmp_args(p1) > 0)
|
|
push_integer(1);
|
|
else
|
|
push_integer(0);
|
|
}
|
|
|
|
void
|
|
eval_testle(struct atom *p1)
|
|
{
|
|
if (cmp_args(p1) <= 0)
|
|
push_integer(1);
|
|
else
|
|
push_integer(0);
|
|
}
|
|
|
|
void
|
|
eval_testlt(struct atom *p1)
|
|
{
|
|
if (cmp_args(p1) < 0)
|
|
push_integer(1);
|
|
else
|
|
push_integer(0);
|
|
}
|
|
|
|
int
|
|
cmp_args(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
push(caddr(p1));
|
|
evalf();
|
|
subtract();
|
|
floatfunc();
|
|
p1 = pop();
|
|
if (iszero(p1))
|
|
return 0;
|
|
if (!isnum(p1))
|
|
stopf("arithmetic comparison: not a number");
|
|
if (isnegativenumber(p1))
|
|
return -1;
|
|
else
|
|
return 1;
|
|
}
|
|
void
|
|
eval_tgamma(struct atom *p1)
|
|
{
|
|
push(cadr(p1));
|
|
evalf();
|
|
tgammafunc();
|
|
}
|
|
|
|
void
|
|
tgammafunc(void)
|
|
{
|
|
int i, n;
|
|
double d;
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
if (istensor(p1)) {
|
|
p1 = copy_tensor(p1);
|
|
n = p1->u.tensor->nelem;
|
|
for (i = 0; i < n; i++) {
|
|
push(p1->u.tensor->elem[i]);
|
|
tgammafunc();
|
|
p1->u.tensor->elem[i] = pop();
|
|
}
|
|
push(p1);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
floatfunc();
|
|
p2 = pop();
|
|
|
|
if (isnum(p2)) {
|
|
push(p2);
|
|
d = pop_double();
|
|
d = tgamma(d);
|
|
push_double(d);
|
|
return;
|
|
}
|
|
|
|
push_symbol(TGAMMA);
|
|
push(p1);
|
|
list(2);
|
|
}
|
|
void
|
|
eval_transpose(struct atom *p1)
|
|
{
|
|
int m, n;
|
|
struct atom *p2;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
p2 = pop();
|
|
push(p2);
|
|
|
|
if (!istensor(p2) || p2->u.tensor->ndim < 2)
|
|
return;
|
|
|
|
p1 = cddr(p1);
|
|
|
|
if (!iscons(p1)) {
|
|
transpose(1, 2);
|
|
return;
|
|
}
|
|
|
|
while (iscons(p1)) {
|
|
|
|
push(car(p1));
|
|
evalf();
|
|
n = pop_integer();
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
m = pop_integer();
|
|
|
|
transpose(n, m);
|
|
|
|
p1 = cddr(p1);
|
|
}
|
|
}
|
|
|
|
void
|
|
transpose(int n, int m)
|
|
{
|
|
int i, j, k, ndim, nelem;
|
|
int index[MAXDIM];
|
|
struct atom *p1, *p2;
|
|
|
|
p1 = pop();
|
|
|
|
ndim = p1->u.tensor->ndim;
|
|
nelem = p1->u.tensor->nelem;
|
|
|
|
if (n < 1 || n > ndim || m < 1 || m > ndim)
|
|
stopf("transpose: index error");
|
|
|
|
n--; // make zero based
|
|
m--;
|
|
|
|
p2 = copy_tensor(p1);
|
|
|
|
// interchange indices n and m
|
|
|
|
p2->u.tensor->dim[n] = p1->u.tensor->dim[m];
|
|
p2->u.tensor->dim[m] = p1->u.tensor->dim[n];
|
|
|
|
for (i = 0; i < ndim; i++)
|
|
index[i] = 0;
|
|
|
|
for (i = 0; i < nelem; i++) {
|
|
|
|
k = 0;
|
|
|
|
for (j = 0; j < ndim; j++) {
|
|
if (j == n)
|
|
k = k * p1->u.tensor->dim[m] + index[m];
|
|
else if (j == m)
|
|
k = k * p1->u.tensor->dim[n] + index[n];
|
|
else
|
|
k = k * p1->u.tensor->dim[j] + index[j];
|
|
}
|
|
|
|
p2->u.tensor->elem[k] = p1->u.tensor->elem[i];
|
|
|
|
// increment index
|
|
|
|
for (j = ndim - 1; j >= 0; j--) {
|
|
if (++index[j] < p1->u.tensor->dim[j])
|
|
break;
|
|
index[j] = 0;
|
|
}
|
|
}
|
|
|
|
push(p2);
|
|
}
|
|
void
|
|
eval_unit(struct atom *p1)
|
|
{
|
|
int i, j, n;
|
|
|
|
push(cadr(p1));
|
|
evalf();
|
|
|
|
n = pop_integer();
|
|
|
|
if (n < 1)
|
|
stopf("unit: index err");
|
|
|
|
if (n == 1) {
|
|
push_integer(1);
|
|
return;
|
|
}
|
|
|
|
p1 = alloc_matrix(n, n);
|
|
|
|
for (i = 0; i < n; i++)
|
|
for (j = 0; j < n; j++)
|
|
if (i == j)
|
|
p1->u.tensor->elem[n * i + j] = one;
|
|
else
|
|
p1->u.tensor->elem[n * i + j] = zero;
|
|
|
|
push(p1);
|
|
}
|
|
void
|
|
eval_user_function(struct atom *p1)
|
|
{
|
|
int h, i;
|
|
struct atom *FUNC_NAME, *FUNC_ARGS, *FUNC_DEFN;
|
|
|
|
FUNC_NAME = car(p1);
|
|
FUNC_ARGS = cdr(p1);
|
|
|
|
FUNC_DEFN = get_usrfunc(FUNC_NAME);
|
|
|
|
// undefined function?
|
|
|
|
if (FUNC_DEFN == symbol(NIL)) {
|
|
if (FUNC_NAME == symbol(D_LOWER)) {
|
|
expanding++;
|
|
eval_derivative(p1);
|
|
expanding--;
|
|
return;
|
|
}
|
|
h = tos;
|
|
push(FUNC_NAME);
|
|
while (iscons(FUNC_ARGS)) {
|
|
push(car(FUNC_ARGS));
|
|
evalg();
|
|
FUNC_ARGS = cdr(FUNC_ARGS);
|
|
}
|
|
list(tos - h);
|
|
return;
|
|
}
|
|
|
|
save_symbol(symbol(ARG1));
|
|
save_symbol(symbol(ARG2));
|
|
save_symbol(symbol(ARG3));
|
|
save_symbol(symbol(ARG4));
|
|
save_symbol(symbol(ARG5));
|
|
save_symbol(symbol(ARG6));
|
|
save_symbol(symbol(ARG7));
|
|
save_symbol(symbol(ARG8));
|
|
save_symbol(symbol(ARG9));
|
|
|
|
push(FUNC_DEFN); // make visible to garbage collector
|
|
|
|
// eval all args before changing bindings
|
|
|
|
for (i = 0; i < 9; i++) {
|
|
push(car(FUNC_ARGS));
|
|
evalg();
|
|
FUNC_ARGS = cdr(FUNC_ARGS);
|
|
}
|
|
|
|
set_symbol(symbol(ARG9), pop(), symbol(NIL));
|
|
set_symbol(symbol(ARG8), pop(), symbol(NIL));
|
|
set_symbol(symbol(ARG7), pop(), symbol(NIL));
|
|
set_symbol(symbol(ARG6), pop(), symbol(NIL));
|
|
set_symbol(symbol(ARG5), pop(), symbol(NIL));
|
|
set_symbol(symbol(ARG4), pop(), symbol(NIL));
|
|
set_symbol(symbol(ARG3), pop(), symbol(NIL));
|
|
set_symbol(symbol(ARG2), pop(), symbol(NIL));
|
|
set_symbol(symbol(ARG1), pop(), symbol(NIL));
|
|
|
|
evalg(); // eval FUNC_DEFN
|
|
|
|
p1 = pop();
|
|
restore_symbol();
|
|
restore_symbol();
|
|
restore_symbol();
|
|
restore_symbol();
|
|
restore_symbol();
|
|
restore_symbol();
|
|
restore_symbol();
|
|
restore_symbol();
|
|
restore_symbol();
|
|
push(p1);
|
|
}
|
|
void
|
|
eval_user_symbol(struct atom *p1)
|
|
{
|
|
struct atom *p2;
|
|
p2 = get_binding(p1);
|
|
if (p1 == p2)
|
|
push(p1); // symbol evaluates to itself
|
|
else {
|
|
push(p2); // evaluate symbol binding
|
|
evalg();
|
|
}
|
|
}
|
|
void
|
|
eval_zero(struct atom *p1)
|
|
{
|
|
int h, i, m, n;
|
|
|
|
p1 = cdr(p1);
|
|
h = tos;
|
|
m = 1;
|
|
|
|
while (iscons(p1)) {
|
|
push(car(p1));
|
|
evalf();
|
|
dupl();
|
|
n = pop_integer();
|
|
if (n < 2)
|
|
stopf("zero: dim err");
|
|
m *= n;
|
|
p1 = cdr(p1);
|
|
}
|
|
|
|
n = tos - h;
|
|
|
|
if (n == 0) {
|
|
push_integer(0); // scalar zero
|
|
return;
|
|
}
|
|
|
|
if (n > MAXDIM)
|
|
stopf("zero: rank err");
|
|
|
|
p1 = alloc_tensor(m);
|
|
|
|
for (i = 0; i < m; i++)
|
|
p1->u.tensor->elem[i] = zero;
|
|
|
|
// dim info
|
|
|
|
p1->u.tensor->ndim = n;
|
|
|
|
for (i = 0; i < n; i++)
|
|
p1->u.tensor->dim[n - i - 1] = pop_integer();
|
|
|
|
push(p1);
|
|
}
|
|
// factors N or N^M where N and M are rational numbers, returns factors on stack
|
|
|
|
void
|
|
factor_factor(void)
|
|
{
|
|
uint32_t *numer, *denom;
|
|
struct atom *INPUT, *BASE, *EXPO;
|
|
|
|
INPUT = pop();
|
|
|
|
if (car(INPUT) == symbol(POWER)) {
|
|
|
|
BASE = cadr(INPUT);
|
|
EXPO = caddr(INPUT);
|
|
|
|
if (!isrational(BASE) || !isrational(EXPO)) {
|
|
push(INPUT); // cannot factor
|
|
return;
|
|
}
|
|
|
|
if (isminusone(BASE)) {
|
|
push(INPUT); // -1 to the M
|
|
return;
|
|
}
|
|
|
|
if (isnegativenumber(BASE)) {
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push(EXPO);
|
|
list(3); // leave on stack
|
|
}
|
|
|
|
numer = BASE->u.q.a;
|
|
denom = BASE->u.q.b;
|
|
|
|
if (!MEQUAL(numer, 1))
|
|
factor_bignum(numer, EXPO);
|
|
|
|
if (!MEQUAL(denom, 1)) {
|
|
// flip sign of exponent
|
|
push(EXPO);
|
|
negate();
|
|
EXPO = pop();
|
|
factor_bignum(denom, EXPO);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
if (!isrational(INPUT) || iszero(INPUT) || isplusone(INPUT) || isminusone(INPUT)) {
|
|
push(INPUT);
|
|
return;
|
|
}
|
|
|
|
if (isnegativenumber(INPUT))
|
|
push_integer(-1);
|
|
|
|
numer = INPUT->u.q.a;
|
|
denom = INPUT->u.q.b;
|
|
|
|
if (!MEQUAL(numer, 1))
|
|
factor_bignum(numer, one);
|
|
|
|
if (!MEQUAL(denom, 1))
|
|
factor_bignum(denom, minusone);
|
|
}
|
|
|
|
// factor N, raise each factor to the power M
|
|
|
|
void
|
|
factor_bignum(uint32_t *N, struct atom *M)
|
|
{
|
|
int h, i, n;
|
|
struct atom *BASE, *EXPO;
|
|
|
|
// greater than 31 bits?
|
|
|
|
if (MLENGTH(N) > 1 || N[0] > 0x7fffffff) {
|
|
push_bignum(MPLUS, mcopy(N), mint(1));
|
|
if (isplusone(M))
|
|
return;
|
|
push_symbol(POWER);
|
|
swap();
|
|
push(M);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
h = tos;
|
|
|
|
n = N[0];
|
|
|
|
factor_int(n);
|
|
|
|
n = (tos - h) / 2; // number of factors on stack
|
|
|
|
for (i = 0; i < n; i++) {
|
|
|
|
BASE = stack[h + 2 * i + 0];
|
|
EXPO = stack[h + 2 * i + 1];
|
|
|
|
push(EXPO);
|
|
push(M);
|
|
multiply();
|
|
EXPO = pop();
|
|
|
|
if (isplusone(EXPO)) {
|
|
stack[h + i] = BASE;
|
|
continue;
|
|
}
|
|
|
|
push_symbol(POWER);
|
|
push(BASE);
|
|
push(EXPO);
|
|
list(3);
|
|
stack[h + i] = pop();
|
|
}
|
|
|
|
tos = h + n; // pop all
|
|
}
|
|
|
|
#define NPRIME 4792
|
|
|
|
int primetab[NPRIME] = {
|
|
2,3,5,7,11,13,17,19,
|
|
23,29,31,37,41,43,47,53,
|
|
59,61,67,71,73,79,83,89,
|
|
97,101,103,107,109,113,127,131,
|
|
137,139,149,151,157,163,167,173,
|
|
179,181,191,193,197,199,211,223,
|
|
227,229,233,239,241,251,257,263,
|
|
269,271,277,281,283,293,307,311,
|
|
313,317,331,337,347,349,353,359,
|
|
367,373,379,383,389,397,401,409,
|
|
419,421,431,433,439,443,449,457,
|
|
461,463,467,479,487,491,499,503,
|
|
509,521,523,541,547,557,563,569,
|
|
571,577,587,593,599,601,607,613,
|
|
617,619,631,641,643,647,653,659,
|
|
661,673,677,683,691,701,709,719,
|
|
727,733,739,743,751,757,761,769,
|
|
773,787,797,809,811,821,823,827,
|
|
829,839,853,857,859,863,877,881,
|
|
883,887,907,911,919,929,937,941,
|
|
947,953,967,971,977,983,991,997,
|
|
1009,1013,1019,1021,1031,1033,1039,1049,
|
|
1051,1061,1063,1069,1087,1091,1093,1097,
|
|
1103,1109,1117,1123,1129,1151,1153,1163,
|
|
1171,1181,1187,1193,1201,1213,1217,1223,
|
|
1229,1231,1237,1249,1259,1277,1279,1283,
|
|
1289,1291,1297,1301,1303,1307,1319,1321,
|
|
1327,1361,1367,1373,1381,1399,1409,1423,
|
|
1427,1429,1433,1439,1447,1451,1453,1459,
|
|
1471,1481,1483,1487,1489,1493,1499,1511,
|
|
1523,1531,1543,1549,1553,1559,1567,1571,
|
|
1579,1583,1597,1601,1607,1609,1613,1619,
|
|
1621,1627,1637,1657,1663,1667,1669,1693,
|
|
1697,1699,1709,1721,1723,1733,1741,1747,
|
|
1753,1759,1777,1783,1787,1789,1801,1811,
|
|
1823,1831,1847,1861,1867,1871,1873,1877,
|
|
1879,1889,1901,1907,1913,1931,1933,1949,
|
|
1951,1973,1979,1987,1993,1997,1999,2003,
|
|
2011,2017,2027,2029,2039,2053,2063,2069,
|
|
2081,2083,2087,2089,2099,2111,2113,2129,
|
|
2131,2137,2141,2143,2153,2161,2179,2203,
|
|
2207,2213,2221,2237,2239,2243,2251,2267,
|
|
2269,2273,2281,2287,2293,2297,2309,2311,
|
|
2333,2339,2341,2347,2351,2357,2371,2377,
|
|
2381,2383,2389,2393,2399,2411,2417,2423,
|
|
2437,2441,2447,2459,2467,2473,2477,2503,
|
|
2521,2531,2539,2543,2549,2551,2557,2579,
|
|
2591,2593,2609,2617,2621,2633,2647,2657,
|
|
2659,2663,2671,2677,2683,2687,2689,2693,
|
|
2699,2707,2711,2713,2719,2729,2731,2741,
|
|
2749,2753,2767,2777,2789,2791,2797,2801,
|
|
2803,2819,2833,2837,2843,2851,2857,2861,
|
|
2879,2887,2897,2903,2909,2917,2927,2939,
|
|
2953,2957,2963,2969,2971,2999,3001,3011,
|
|
3019,3023,3037,3041,3049,3061,3067,3079,
|
|
3083,3089,3109,3119,3121,3137,3163,3167,
|
|
3169,3181,3187,3191,3203,3209,3217,3221,
|
|
3229,3251,3253,3257,3259,3271,3299,3301,
|
|
3307,3313,3319,3323,3329,3331,3343,3347,
|
|
3359,3361,3371,3373,3389,3391,3407,3413,
|
|
3433,3449,3457,3461,3463,3467,3469,3491,
|
|
3499,3511,3517,3527,3529,3533,3539,3541,
|
|
3547,3557,3559,3571,3581,3583,3593,3607,
|
|
3613,3617,3623,3631,3637,3643,3659,3671,
|
|
3673,3677,3691,3697,3701,3709,3719,3727,
|
|
3733,3739,3761,3767,3769,3779,3793,3797,
|
|
3803,3821,3823,3833,3847,3851,3853,3863,
|
|
3877,3881,3889,3907,3911,3917,3919,3923,
|
|
3929,3931,3943,3947,3967,3989,4001,4003,
|
|
4007,4013,4019,4021,4027,4049,4051,4057,
|
|
4073,4079,4091,4093,4099,4111,4127,4129,
|
|
4133,4139,4153,4157,4159,4177,4201,4211,
|
|
4217,4219,4229,4231,4241,4243,4253,4259,
|
|
4261,4271,4273,4283,4289,4297,4327,4337,
|
|
4339,4349,4357,4363,4373,4391,4397,4409,
|
|
4421,4423,4441,4447,4451,4457,4463,4481,
|
|
4483,4493,4507,4513,4517,4519,4523,4547,
|
|
4549,4561,4567,4583,4591,4597,4603,4621,
|
|
4637,4639,4643,4649,4651,4657,4663,4673,
|
|
4679,4691,4703,4721,4723,4729,4733,4751,
|
|
4759,4783,4787,4789,4793,4799,4801,4813,
|
|
4817,4831,4861,4871,4877,4889,4903,4909,
|
|
4919,4931,4933,4937,4943,4951,4957,4967,
|
|
4969,4973,4987,4993,4999,5003,5009,5011,
|
|
5021,5023,5039,5051,5059,5077,5081,5087,
|
|
5099,5101,5107,5113,5119,5147,5153,5167,
|
|
5171,5179,5189,5197,5209,5227,5231,5233,
|
|
5237,5261,5273,5279,5281,5297,5303,5309,
|
|
5323,5333,5347,5351,5381,5387,5393,5399,
|
|
5407,5413,5417,5419,5431,5437,5441,5443,
|
|
5449,5471,5477,5479,5483,5501,5503,5507,
|
|
5519,5521,5527,5531,5557,5563,5569,5573,
|
|
5581,5591,5623,5639,5641,5647,5651,5653,
|
|
5657,5659,5669,5683,5689,5693,5701,5711,
|
|
5717,5737,5741,5743,5749,5779,5783,5791,
|
|
5801,5807,5813,5821,5827,5839,5843,5849,
|
|
5851,5857,5861,5867,5869,5879,5881,5897,
|
|
5903,5923,5927,5939,5953,5981,5987,6007,
|
|
6011,6029,6037,6043,6047,6053,6067,6073,
|
|
6079,6089,6091,6101,6113,6121,6131,6133,
|
|
6143,6151,6163,6173,6197,6199,6203,6211,
|
|
6217,6221,6229,6247,6257,6263,6269,6271,
|
|
6277,6287,6299,6301,6311,6317,6323,6329,
|
|
6337,6343,6353,6359,6361,6367,6373,6379,
|
|
6389,6397,6421,6427,6449,6451,6469,6473,
|
|
6481,6491,6521,6529,6547,6551,6553,6563,
|
|
6569,6571,6577,6581,6599,6607,6619,6637,
|
|
6653,6659,6661,6673,6679,6689,6691,6701,
|
|
6703,6709,6719,6733,6737,6761,6763,6779,
|
|
6781,6791,6793,6803,6823,6827,6829,6833,
|
|
6841,6857,6863,6869,6871,6883,6899,6907,
|
|
6911,6917,6947,6949,6959,6961,6967,6971,
|
|
6977,6983,6991,6997,7001,7013,7019,7027,
|
|
7039,7043,7057,7069,7079,7103,7109,7121,
|
|
7127,7129,7151,7159,7177,7187,7193,7207,
|
|
7211,7213,7219,7229,7237,7243,7247,7253,
|
|
7283,7297,7307,7309,7321,7331,7333,7349,
|
|
7351,7369,7393,7411,7417,7433,7451,7457,
|
|
7459,7477,7481,7487,7489,7499,7507,7517,
|
|
7523,7529,7537,7541,7547,7549,7559,7561,
|
|
7573,7577,7583,7589,7591,7603,7607,7621,
|
|
7639,7643,7649,7669,7673,7681,7687,7691,
|
|
7699,7703,7717,7723,7727,7741,7753,7757,
|
|
7759,7789,7793,7817,7823,7829,7841,7853,
|
|
7867,7873,7877,7879,7883,7901,7907,7919,
|
|
7927,7933,7937,7949,7951,7963,7993,8009,
|
|
8011,8017,8039,8053,8059,8069,8081,8087,
|
|
8089,8093,8101,8111,8117,8123,8147,8161,
|
|
8167,8171,8179,8191,8209,8219,8221,8231,
|
|
8233,8237,8243,8263,8269,8273,8287,8291,
|
|
8293,8297,8311,8317,8329,8353,8363,8369,
|
|
8377,8387,8389,8419,8423,8429,8431,8443,
|
|
8447,8461,8467,8501,8513,8521,8527,8537,
|
|
8539,8543,8563,8573,8581,8597,8599,8609,
|
|
8623,8627,8629,8641,8647,8663,8669,8677,
|
|
8681,8689,8693,8699,8707,8713,8719,8731,
|
|
8737,8741,8747,8753,8761,8779,8783,8803,
|
|
8807,8819,8821,8831,8837,8839,8849,8861,
|
|
8863,8867,8887,8893,8923,8929,8933,8941,
|
|
8951,8963,8969,8971,8999,9001,9007,9011,
|
|
9013,9029,9041,9043,9049,9059,9067,9091,
|
|
9103,9109,9127,9133,9137,9151,9157,9161,
|
|
9173,9181,9187,9199,9203,9209,9221,9227,
|
|
9239,9241,9257,9277,9281,9283,9293,9311,
|
|
9319,9323,9337,9341,9343,9349,9371,9377,
|
|
9391,9397,9403,9413,9419,9421,9431,9433,
|
|
9437,9439,9461,9463,9467,9473,9479,9491,
|
|
9497,9511,9521,9533,9539,9547,9551,9587,
|
|
9601,9613,9619,9623,9629,9631,9643,9649,
|
|
9661,9677,9679,9689,9697,9719,9721,9733,
|
|
9739,9743,9749,9767,9769,9781,9787,9791,
|
|
9803,9811,9817,9829,9833,9839,9851,9857,
|
|
9859,9871,9883,9887,9901,9907,9923,9929,
|
|
9931,9941,9949,9967,9973,10007,10009,10037,
|
|
10039,10061,10067,10069,10079,10091,10093,10099,
|
|
10103,10111,10133,10139,10141,10151,10159,10163,
|
|
10169,10177,10181,10193,10211,10223,10243,10247,
|
|
10253,10259,10267,10271,10273,10289,10301,10303,
|
|
10313,10321,10331,10333,10337,10343,10357,10369,
|
|
10391,10399,10427,10429,10433,10453,10457,10459,
|
|
10463,10477,10487,10499,10501,10513,10529,10531,
|
|
10559,10567,10589,10597,10601,10607,10613,10627,
|
|
10631,10639,10651,10657,10663,10667,10687,10691,
|
|
10709,10711,10723,10729,10733,10739,10753,10771,
|
|
10781,10789,10799,10831,10837,10847,10853,10859,
|
|
10861,10867,10883,10889,10891,10903,10909,10937,
|
|
10939,10949,10957,10973,10979,10987,10993,11003,
|
|
11027,11047,11057,11059,11069,11071,11083,11087,
|
|
11093,11113,11117,11119,11131,11149,11159,11161,
|
|
11171,11173,11177,11197,11213,11239,11243,11251,
|
|
11257,11261,11273,11279,11287,11299,11311,11317,
|
|
11321,11329,11351,11353,11369,11383,11393,11399,
|
|
11411,11423,11437,11443,11447,11467,11471,11483,
|
|
11489,11491,11497,11503,11519,11527,11549,11551,
|
|
11579,11587,11593,11597,11617,11621,11633,11657,
|
|
11677,11681,11689,11699,11701,11717,11719,11731,
|
|
11743,11777,11779,11783,11789,11801,11807,11813,
|
|
11821,11827,11831,11833,11839,11863,11867,11887,
|
|
11897,11903,11909,11923,11927,11933,11939,11941,
|
|
11953,11959,11969,11971,11981,11987,12007,12011,
|
|
12037,12041,12043,12049,12071,12073,12097,12101,
|
|
12107,12109,12113,12119,12143,12149,12157,12161,
|
|
12163,12197,12203,12211,12227,12239,12241,12251,
|
|
12253,12263,12269,12277,12281,12289,12301,12323,
|
|
12329,12343,12347,12373,12377,12379,12391,12401,
|
|
12409,12413,12421,12433,12437,12451,12457,12473,
|
|
12479,12487,12491,12497,12503,12511,12517,12527,
|
|
12539,12541,12547,12553,12569,12577,12583,12589,
|
|
12601,12611,12613,12619,12637,12641,12647,12653,
|
|
12659,12671,12689,12697,12703,12713,12721,12739,
|
|
12743,12757,12763,12781,12791,12799,12809,12821,
|
|
12823,12829,12841,12853,12889,12893,12899,12907,
|
|
12911,12917,12919,12923,12941,12953,12959,12967,
|
|
12973,12979,12983,13001,13003,13007,13009,13033,
|
|
13037,13043,13049,13063,13093,13099,13103,13109,
|
|
13121,13127,13147,13151,13159,13163,13171,13177,
|
|
13183,13187,13217,13219,13229,13241,13249,13259,
|
|
13267,13291,13297,13309,13313,13327,13331,13337,
|
|
13339,13367,13381,13397,13399,13411,13417,13421,
|
|
13441,13451,13457,13463,13469,13477,13487,13499,
|
|
13513,13523,13537,13553,13567,13577,13591,13597,
|
|
13613,13619,13627,13633,13649,13669,13679,13681,
|
|
13687,13691,13693,13697,13709,13711,13721,13723,
|
|
13729,13751,13757,13759,13763,13781,13789,13799,
|
|
13807,13829,13831,13841,13859,13873,13877,13879,
|
|
13883,13901,13903,13907,13913,13921,13931,13933,
|
|
13963,13967,13997,13999,14009,14011,14029,14033,
|
|
14051,14057,14071,14081,14083,14087,14107,14143,
|
|
14149,14153,14159,14173,14177,14197,14207,14221,
|
|
14243,14249,14251,14281,14293,14303,14321,14323,
|
|
14327,14341,14347,14369,14387,14389,14401,14407,
|
|
14411,14419,14423,14431,14437,14447,14449,14461,
|
|
14479,14489,14503,14519,14533,14537,14543,14549,
|
|
14551,14557,14561,14563,14591,14593,14621,14627,
|
|
14629,14633,14639,14653,14657,14669,14683,14699,
|
|
14713,14717,14723,14731,14737,14741,14747,14753,
|
|
14759,14767,14771,14779,14783,14797,14813,14821,
|
|
14827,14831,14843,14851,14867,14869,14879,14887,
|
|
14891,14897,14923,14929,14939,14947,14951,14957,
|
|
14969,14983,15013,15017,15031,15053,15061,15073,
|
|
15077,15083,15091,15101,15107,15121,15131,15137,
|
|
15139,15149,15161,15173,15187,15193,15199,15217,
|
|
15227,15233,15241,15259,15263,15269,15271,15277,
|
|
15287,15289,15299,15307,15313,15319,15329,15331,
|
|
15349,15359,15361,15373,15377,15383,15391,15401,
|
|
15413,15427,15439,15443,15451,15461,15467,15473,
|
|
15493,15497,15511,15527,15541,15551,15559,15569,
|
|
15581,15583,15601,15607,15619,15629,15641,15643,
|
|
15647,15649,15661,15667,15671,15679,15683,15727,
|
|
15731,15733,15737,15739,15749,15761,15767,15773,
|
|
15787,15791,15797,15803,15809,15817,15823,15859,
|
|
15877,15881,15887,15889,15901,15907,15913,15919,
|
|
15923,15937,15959,15971,15973,15991,16001,16007,
|
|
16033,16057,16061,16063,16067,16069,16073,16087,
|
|
16091,16097,16103,16111,16127,16139,16141,16183,
|
|
16187,16189,16193,16217,16223,16229,16231,16249,
|
|
16253,16267,16273,16301,16319,16333,16339,16349,
|
|
16361,16363,16369,16381,16411,16417,16421,16427,
|
|
16433,16447,16451,16453,16477,16481,16487,16493,
|
|
16519,16529,16547,16553,16561,16567,16573,16603,
|
|
16607,16619,16631,16633,16649,16651,16657,16661,
|
|
16673,16691,16693,16699,16703,16729,16741,16747,
|
|
16759,16763,16787,16811,16823,16829,16831,16843,
|
|
16871,16879,16883,16889,16901,16903,16921,16927,
|
|
16931,16937,16943,16963,16979,16981,16987,16993,
|
|
17011,17021,17027,17029,17033,17041,17047,17053,
|
|
17077,17093,17099,17107,17117,17123,17137,17159,
|
|
17167,17183,17189,17191,17203,17207,17209,17231,
|
|
17239,17257,17291,17293,17299,17317,17321,17327,
|
|
17333,17341,17351,17359,17377,17383,17387,17389,
|
|
17393,17401,17417,17419,17431,17443,17449,17467,
|
|
17471,17477,17483,17489,17491,17497,17509,17519,
|
|
17539,17551,17569,17573,17579,17581,17597,17599,
|
|
17609,17623,17627,17657,17659,17669,17681,17683,
|
|
17707,17713,17729,17737,17747,17749,17761,17783,
|
|
17789,17791,17807,17827,17837,17839,17851,17863,
|
|
17881,17891,17903,17909,17911,17921,17923,17929,
|
|
17939,17957,17959,17971,17977,17981,17987,17989,
|
|
18013,18041,18043,18047,18049,18059,18061,18077,
|
|
18089,18097,18119,18121,18127,18131,18133,18143,
|
|
18149,18169,18181,18191,18199,18211,18217,18223,
|
|
18229,18233,18251,18253,18257,18269,18287,18289,
|
|
18301,18307,18311,18313,18329,18341,18353,18367,
|
|
18371,18379,18397,18401,18413,18427,18433,18439,
|
|
18443,18451,18457,18461,18481,18493,18503,18517,
|
|
18521,18523,18539,18541,18553,18583,18587,18593,
|
|
18617,18637,18661,18671,18679,18691,18701,18713,
|
|
18719,18731,18743,18749,18757,18773,18787,18793,
|
|
18797,18803,18839,18859,18869,18899,18911,18913,
|
|
18917,18919,18947,18959,18973,18979,19001,19009,
|
|
19013,19031,19037,19051,19069,19073,19079,19081,
|
|
19087,19121,19139,19141,19157,19163,19181,19183,
|
|
19207,19211,19213,19219,19231,19237,19249,19259,
|
|
19267,19273,19289,19301,19309,19319,19333,19373,
|
|
19379,19381,19387,19391,19403,19417,19421,19423,
|
|
19427,19429,19433,19441,19447,19457,19463,19469,
|
|
19471,19477,19483,19489,19501,19507,19531,19541,
|
|
19543,19553,19559,19571,19577,19583,19597,19603,
|
|
19609,19661,19681,19687,19697,19699,19709,19717,
|
|
19727,19739,19751,19753,19759,19763,19777,19793,
|
|
19801,19813,19819,19841,19843,19853,19861,19867,
|
|
19889,19891,19913,19919,19927,19937,19949,19961,
|
|
19963,19973,19979,19991,19993,19997,20011,20021,
|
|
20023,20029,20047,20051,20063,20071,20089,20101,
|
|
20107,20113,20117,20123,20129,20143,20147,20149,
|
|
20161,20173,20177,20183,20201,20219,20231,20233,
|
|
20249,20261,20269,20287,20297,20323,20327,20333,
|
|
20341,20347,20353,20357,20359,20369,20389,20393,
|
|
20399,20407,20411,20431,20441,20443,20477,20479,
|
|
20483,20507,20509,20521,20533,20543,20549,20551,
|
|
20563,20593,20599,20611,20627,20639,20641,20663,
|
|
20681,20693,20707,20717,20719,20731,20743,20747,
|
|
20749,20753,20759,20771,20773,20789,20807,20809,
|
|
20849,20857,20873,20879,20887,20897,20899,20903,
|
|
20921,20929,20939,20947,20959,20963,20981,20983,
|
|
21001,21011,21013,21017,21019,21023,21031,21059,
|
|
21061,21067,21089,21101,21107,21121,21139,21143,
|
|
21149,21157,21163,21169,21179,21187,21191,21193,
|
|
21211,21221,21227,21247,21269,21277,21283,21313,
|
|
21317,21319,21323,21341,21347,21377,21379,21383,
|
|
21391,21397,21401,21407,21419,21433,21467,21481,
|
|
21487,21491,21493,21499,21503,21517,21521,21523,
|
|
21529,21557,21559,21563,21569,21577,21587,21589,
|
|
21599,21601,21611,21613,21617,21647,21649,21661,
|
|
21673,21683,21701,21713,21727,21737,21739,21751,
|
|
21757,21767,21773,21787,21799,21803,21817,21821,
|
|
21839,21841,21851,21859,21863,21871,21881,21893,
|
|
21911,21929,21937,21943,21961,21977,21991,21997,
|
|
22003,22013,22027,22031,22037,22039,22051,22063,
|
|
22067,22073,22079,22091,22093,22109,22111,22123,
|
|
22129,22133,22147,22153,22157,22159,22171,22189,
|
|
22193,22229,22247,22259,22271,22273,22277,22279,
|
|
22283,22291,22303,22307,22343,22349,22367,22369,
|
|
22381,22391,22397,22409,22433,22441,22447,22453,
|
|
22469,22481,22483,22501,22511,22531,22541,22543,
|
|
22549,22567,22571,22573,22613,22619,22621,22637,
|
|
22639,22643,22651,22669,22679,22691,22697,22699,
|
|
22709,22717,22721,22727,22739,22741,22751,22769,
|
|
22777,22783,22787,22807,22811,22817,22853,22859,
|
|
22861,22871,22877,22901,22907,22921,22937,22943,
|
|
22961,22963,22973,22993,23003,23011,23017,23021,
|
|
23027,23029,23039,23041,23053,23057,23059,23063,
|
|
23071,23081,23087,23099,23117,23131,23143,23159,
|
|
23167,23173,23189,23197,23201,23203,23209,23227,
|
|
23251,23269,23279,23291,23293,23297,23311,23321,
|
|
23327,23333,23339,23357,23369,23371,23399,23417,
|
|
23431,23447,23459,23473,23497,23509,23531,23537,
|
|
23539,23549,23557,23561,23563,23567,23581,23593,
|
|
23599,23603,23609,23623,23627,23629,23633,23663,
|
|
23669,23671,23677,23687,23689,23719,23741,23743,
|
|
23747,23753,23761,23767,23773,23789,23801,23813,
|
|
23819,23827,23831,23833,23857,23869,23873,23879,
|
|
23887,23893,23899,23909,23911,23917,23929,23957,
|
|
23971,23977,23981,23993,24001,24007,24019,24023,
|
|
24029,24043,24049,24061,24071,24077,24083,24091,
|
|
24097,24103,24107,24109,24113,24121,24133,24137,
|
|
24151,24169,24179,24181,24197,24203,24223,24229,
|
|
24239,24247,24251,24281,24317,24329,24337,24359,
|
|
24371,24373,24379,24391,24407,24413,24419,24421,
|
|
24439,24443,24469,24473,24481,24499,24509,24517,
|
|
24527,24533,24547,24551,24571,24593,24611,24623,
|
|
24631,24659,24671,24677,24683,24691,24697,24709,
|
|
24733,24749,24763,24767,24781,24793,24799,24809,
|
|
24821,24841,24847,24851,24859,24877,24889,24907,
|
|
24917,24919,24923,24943,24953,24967,24971,24977,
|
|
24979,24989,25013,25031,25033,25037,25057,25073,
|
|
25087,25097,25111,25117,25121,25127,25147,25153,
|
|
25163,25169,25171,25183,25189,25219,25229,25237,
|
|
25243,25247,25253,25261,25301,25303,25307,25309,
|
|
25321,25339,25343,25349,25357,25367,25373,25391,
|
|
25409,25411,25423,25439,25447,25453,25457,25463,
|
|
25469,25471,25523,25537,25541,25561,25577,25579,
|
|
25583,25589,25601,25603,25609,25621,25633,25639,
|
|
25643,25657,25667,25673,25679,25693,25703,25717,
|
|
25733,25741,25747,25759,25763,25771,25793,25799,
|
|
25801,25819,25841,25847,25849,25867,25873,25889,
|
|
25903,25913,25919,25931,25933,25939,25943,25951,
|
|
25969,25981,25997,25999,26003,26017,26021,26029,
|
|
26041,26053,26083,26099,26107,26111,26113,26119,
|
|
26141,26153,26161,26171,26177,26183,26189,26203,
|
|
26209,26227,26237,26249,26251,26261,26263,26267,
|
|
26293,26297,26309,26317,26321,26339,26347,26357,
|
|
26371,26387,26393,26399,26407,26417,26423,26431,
|
|
26437,26449,26459,26479,26489,26497,26501,26513,
|
|
26539,26557,26561,26573,26591,26597,26627,26633,
|
|
26641,26647,26669,26681,26683,26687,26693,26699,
|
|
26701,26711,26713,26717,26723,26729,26731,26737,
|
|
26759,26777,26783,26801,26813,26821,26833,26839,
|
|
26849,26861,26863,26879,26881,26891,26893,26903,
|
|
26921,26927,26947,26951,26953,26959,26981,26987,
|
|
26993,27011,27017,27031,27043,27059,27061,27067,
|
|
27073,27077,27091,27103,27107,27109,27127,27143,
|
|
27179,27191,27197,27211,27239,27241,27253,27259,
|
|
27271,27277,27281,27283,27299,27329,27337,27361,
|
|
27367,27397,27407,27409,27427,27431,27437,27449,
|
|
27457,27479,27481,27487,27509,27527,27529,27539,
|
|
27541,27551,27581,27583,27611,27617,27631,27647,
|
|
27653,27673,27689,27691,27697,27701,27733,27737,
|
|
27739,27743,27749,27751,27763,27767,27773,27779,
|
|
27791,27793,27799,27803,27809,27817,27823,27827,
|
|
27847,27851,27883,27893,27901,27917,27919,27941,
|
|
27943,27947,27953,27961,27967,27983,27997,28001,
|
|
28019,28027,28031,28051,28057,28069,28081,28087,
|
|
28097,28099,28109,28111,28123,28151,28163,28181,
|
|
28183,28201,28211,28219,28229,28277,28279,28283,
|
|
28289,28297,28307,28309,28319,28349,28351,28387,
|
|
28393,28403,28409,28411,28429,28433,28439,28447,
|
|
28463,28477,28493,28499,28513,28517,28537,28541,
|
|
28547,28549,28559,28571,28573,28579,28591,28597,
|
|
28603,28607,28619,28621,28627,28631,28643,28649,
|
|
28657,28661,28663,28669,28687,28697,28703,28711,
|
|
28723,28729,28751,28753,28759,28771,28789,28793,
|
|
28807,28813,28817,28837,28843,28859,28867,28871,
|
|
28879,28901,28909,28921,28927,28933,28949,28961,
|
|
28979,29009,29017,29021,29023,29027,29033,29059,
|
|
29063,29077,29101,29123,29129,29131,29137,29147,
|
|
29153,29167,29173,29179,29191,29201,29207,29209,
|
|
29221,29231,29243,29251,29269,29287,29297,29303,
|
|
29311,29327,29333,29339,29347,29363,29383,29387,
|
|
29389,29399,29401,29411,29423,29429,29437,29443,
|
|
29453,29473,29483,29501,29527,29531,29537,29567,
|
|
29569,29573,29581,29587,29599,29611,29629,29633,
|
|
29641,29663,29669,29671,29683,29717,29723,29741,
|
|
29753,29759,29761,29789,29803,29819,29833,29837,
|
|
29851,29863,29867,29873,29879,29881,29917,29921,
|
|
29927,29947,29959,29983,29989,30011,30013,30029,
|
|
30047,30059,30071,30089,30091,30097,30103,30109,
|
|
30113,30119,30133,30137,30139,30161,30169,30181,
|
|
30187,30197,30203,30211,30223,30241,30253,30259,
|
|
30269,30271,30293,30307,30313,30319,30323,30341,
|
|
30347,30367,30389,30391,30403,30427,30431,30449,
|
|
30467,30469,30491,30493,30497,30509,30517,30529,
|
|
30539,30553,30557,30559,30577,30593,30631,30637,
|
|
30643,30649,30661,30671,30677,30689,30697,30703,
|
|
30707,30713,30727,30757,30763,30773,30781,30803,
|
|
30809,30817,30829,30839,30841,30851,30853,30859,
|
|
30869,30871,30881,30893,30911,30931,30937,30941,
|
|
30949,30971,30977,30983,31013,31019,31033,31039,
|
|
31051,31063,31069,31079,31081,31091,31121,31123,
|
|
31139,31147,31151,31153,31159,31177,31181,31183,
|
|
31189,31193,31219,31223,31231,31237,31247,31249,
|
|
31253,31259,31267,31271,31277,31307,31319,31321,
|
|
31327,31333,31337,31357,31379,31387,31391,31393,
|
|
31397,31469,31477,31481,31489,31511,31513,31517,
|
|
31531,31541,31543,31547,31567,31573,31583,31601,
|
|
31607,31627,31643,31649,31657,31663,31667,31687,
|
|
31699,31721,31723,31727,31729,31741,31751,31769,
|
|
31771,31793,31799,31817,31847,31849,31859,31873,
|
|
31883,31891,31907,31957,31963,31973,31981,31991,
|
|
32003,32009,32027,32029,32051,32057,32059,32063,
|
|
32069,32077,32083,32089,32099,32117,32119,32141,
|
|
32143,32159,32173,32183,32189,32191,32203,32213,
|
|
32233,32237,32251,32257,32261,32297,32299,32303,
|
|
32309,32321,32323,32327,32341,32353,32359,32363,
|
|
32369,32371,32377,32381,32401,32411,32413,32423,
|
|
32429,32441,32443,32467,32479,32491,32497,32503,
|
|
32507,32531,32533,32537,32561,32563,32569,32573,
|
|
32579,32587,32603,32609,32611,32621,32633,32647,
|
|
32653,32687,32693,32707,32713,32717,32719,32749,
|
|
32771,32779,32783,32789,32797,32801,32803,32831,
|
|
32833,32839,32843,32869,32887,32909,32911,32917,
|
|
32933,32939,32941,32957,32969,32971,32983,32987,
|
|
32993,32999,33013,33023,33029,33037,33049,33053,
|
|
33071,33073,33083,33091,33107,33113,33119,33149,
|
|
33151,33161,33179,33181,33191,33199,33203,33211,
|
|
33223,33247,33287,33289,33301,33311,33317,33329,
|
|
33331,33343,33347,33349,33353,33359,33377,33391,
|
|
33403,33409,33413,33427,33457,33461,33469,33479,
|
|
33487,33493,33503,33521,33529,33533,33547,33563,
|
|
33569,33577,33581,33587,33589,33599,33601,33613,
|
|
33617,33619,33623,33629,33637,33641,33647,33679,
|
|
33703,33713,33721,33739,33749,33751,33757,33767,
|
|
33769,33773,33791,33797,33809,33811,33827,33829,
|
|
33851,33857,33863,33871,33889,33893,33911,33923,
|
|
33931,33937,33941,33961,33967,33997,34019,34031,
|
|
34033,34039,34057,34061,34123,34127,34129,34141,
|
|
34147,34157,34159,34171,34183,34211,34213,34217,
|
|
34231,34253,34259,34261,34267,34273,34283,34297,
|
|
34301,34303,34313,34319,34327,34337,34351,34361,
|
|
34367,34369,34381,34403,34421,34429,34439,34457,
|
|
34469,34471,34483,34487,34499,34501,34511,34513,
|
|
34519,34537,34543,34549,34583,34589,34591,34603,
|
|
34607,34613,34631,34649,34651,34667,34673,34679,
|
|
34687,34693,34703,34721,34729,34739,34747,34757,
|
|
34759,34763,34781,34807,34819,34841,34843,34847,
|
|
34849,34871,34877,34883,34897,34913,34919,34939,
|
|
34949,34961,34963,34981,35023,35027,35051,35053,
|
|
35059,35069,35081,35083,35089,35099,35107,35111,
|
|
35117,35129,35141,35149,35153,35159,35171,35201,
|
|
35221,35227,35251,35257,35267,35279,35281,35291,
|
|
35311,35317,35323,35327,35339,35353,35363,35381,
|
|
35393,35401,35407,35419,35423,35437,35447,35449,
|
|
35461,35491,35507,35509,35521,35527,35531,35533,
|
|
35537,35543,35569,35573,35591,35593,35597,35603,
|
|
35617,35671,35677,35729,35731,35747,35753,35759,
|
|
35771,35797,35801,35803,35809,35831,35837,35839,
|
|
35851,35863,35869,35879,35897,35899,35911,35923,
|
|
35933,35951,35963,35969,35977,35983,35993,35999,
|
|
36007,36011,36013,36017,36037,36061,36067,36073,
|
|
36083,36097,36107,36109,36131,36137,36151,36161,
|
|
36187,36191,36209,36217,36229,36241,36251,36263,
|
|
36269,36277,36293,36299,36307,36313,36319,36341,
|
|
36343,36353,36373,36383,36389,36433,36451,36457,
|
|
36467,36469,36473,36479,36493,36497,36523,36527,
|
|
36529,36541,36551,36559,36563,36571,36583,36587,
|
|
36599,36607,36629,36637,36643,36653,36671,36677,
|
|
36683,36691,36697,36709,36713,36721,36739,36749,
|
|
36761,36767,36779,36781,36787,36791,36793,36809,
|
|
36821,36833,36847,36857,36871,36877,36887,36899,
|
|
36901,36913,36919,36923,36929,36931,36943,36947,
|
|
36973,36979,36997,37003,37013,37019,37021,37039,
|
|
37049,37057,37061,37087,37097,37117,37123,37139,
|
|
37159,37171,37181,37189,37199,37201,37217,37223,
|
|
37243,37253,37273,37277,37307,37309,37313,37321,
|
|
37337,37339,37357,37361,37363,37369,37379,37397,
|
|
37409,37423,37441,37447,37463,37483,37489,37493,
|
|
37501,37507,37511,37517,37529,37537,37547,37549,
|
|
37561,37567,37571,37573,37579,37589,37591,37607,
|
|
37619,37633,37643,37649,37657,37663,37691,37693,
|
|
37699,37717,37747,37781,37783,37799,37811,37813,
|
|
37831,37847,37853,37861,37871,37879,37889,37897,
|
|
37907,37951,37957,37963,37967,37987,37991,37993,
|
|
37997,38011,38039,38047,38053,38069,38083,38113,
|
|
38119,38149,38153,38167,38177,38183,38189,38197,
|
|
38201,38219,38231,38237,38239,38261,38273,38281,
|
|
38287,38299,38303,38317,38321,38327,38329,38333,
|
|
38351,38371,38377,38393,38431,38447,38449,38453,
|
|
38459,38461,38501,38543,38557,38561,38567,38569,
|
|
38593,38603,38609,38611,38629,38639,38651,38653,
|
|
38669,38671,38677,38693,38699,38707,38711,38713,
|
|
38723,38729,38737,38747,38749,38767,38783,38791,
|
|
38803,38821,38833,38839,38851,38861,38867,38873,
|
|
38891,38903,38917,38921,38923,38933,38953,38959,
|
|
38971,38977,38993,39019,39023,39041,39043,39047,
|
|
39079,39089,39097,39103,39107,39113,39119,39133,
|
|
39139,39157,39161,39163,39181,39191,39199,39209,
|
|
39217,39227,39229,39233,39239,39241,39251,39293,
|
|
39301,39313,39317,39323,39341,39343,39359,39367,
|
|
39371,39373,39383,39397,39409,39419,39439,39443,
|
|
39451,39461,39499,39503,39509,39511,39521,39541,
|
|
39551,39563,39569,39581,39607,39619,39623,39631,
|
|
39659,39667,39671,39679,39703,39709,39719,39727,
|
|
39733,39749,39761,39769,39779,39791,39799,39821,
|
|
39827,39829,39839,39841,39847,39857,39863,39869,
|
|
39877,39883,39887,39901,39929,39937,39953,39971,
|
|
39979,39983,39989,40009,40013,40031,40037,40039,
|
|
40063,40087,40093,40099,40111,40123,40127,40129,
|
|
40151,40153,40163,40169,40177,40189,40193,40213,
|
|
40231,40237,40241,40253,40277,40283,40289,40343,
|
|
40351,40357,40361,40387,40423,40427,40429,40433,
|
|
40459,40471,40483,40487,40493,40499,40507,40519,
|
|
40529,40531,40543,40559,40577,40583,40591,40597,
|
|
40609,40627,40637,40639,40693,40697,40699,40709,
|
|
40739,40751,40759,40763,40771,40787,40801,40813,
|
|
40819,40823,40829,40841,40847,40849,40853,40867,
|
|
40879,40883,40897,40903,40927,40933,40939,40949,
|
|
40961,40973,40993,41011,41017,41023,41039,41047,
|
|
41051,41057,41077,41081,41113,41117,41131,41141,
|
|
41143,41149,41161,41177,41179,41183,41189,41201,
|
|
41203,41213,41221,41227,41231,41233,41243,41257,
|
|
41263,41269,41281,41299,41333,41341,41351,41357,
|
|
41381,41387,41389,41399,41411,41413,41443,41453,
|
|
41467,41479,41491,41507,41513,41519,41521,41539,
|
|
41543,41549,41579,41593,41597,41603,41609,41611,
|
|
41617,41621,41627,41641,41647,41651,41659,41669,
|
|
41681,41687,41719,41729,41737,41759,41761,41771,
|
|
41777,41801,41809,41813,41843,41849,41851,41863,
|
|
41879,41887,41893,41897,41903,41911,41927,41941,
|
|
41947,41953,41957,41959,41969,41981,41983,41999,
|
|
42013,42017,42019,42023,42043,42061,42071,42073,
|
|
42083,42089,42101,42131,42139,42157,42169,42179,
|
|
42181,42187,42193,42197,42209,42221,42223,42227,
|
|
42239,42257,42281,42283,42293,42299,42307,42323,
|
|
42331,42337,42349,42359,42373,42379,42391,42397,
|
|
42403,42407,42409,42433,42437,42443,42451,42457,
|
|
42461,42463,42467,42473,42487,42491,42499,42509,
|
|
42533,42557,42569,42571,42577,42589,42611,42641,
|
|
42643,42649,42667,42677,42683,42689,42697,42701,
|
|
42703,42709,42719,42727,42737,42743,42751,42767,
|
|
42773,42787,42793,42797,42821,42829,42839,42841,
|
|
42853,42859,42863,42899,42901,42923,42929,42937,
|
|
42943,42953,42961,42967,42979,42989,43003,43013,
|
|
43019,43037,43049,43051,43063,43067,43093,43103,
|
|
43117,43133,43151,43159,43177,43189,43201,43207,
|
|
43223,43237,43261,43271,43283,43291,43313,43319,
|
|
43321,43331,43391,43397,43399,43403,43411,43427,
|
|
43441,43451,43457,43481,43487,43499,43517,43541,
|
|
43543,43573,43577,43579,43591,43597,43607,43609,
|
|
43613,43627,43633,43649,43651,43661,43669,43691,
|
|
43711,43717,43721,43753,43759,43777,43781,43783,
|
|
43787,43789,43793,43801,43853,43867,43889,43891,
|
|
43913,43933,43943,43951,43961,43963,43969,43973,
|
|
43987,43991,43997,44017,44021,44027,44029,44041,
|
|
44053,44059,44071,44087,44089,44101,44111,44119,
|
|
44123,44129,44131,44159,44171,44179,44189,44201,
|
|
44203,44207,44221,44249,44257,44263,44267,44269,
|
|
44273,44279,44281,44293,44351,44357,44371,44381,
|
|
44383,44389,44417,44449,44453,44483,44491,44497,
|
|
44501,44507,44519,44531,44533,44537,44543,44549,
|
|
44563,44579,44587,44617,44621,44623,44633,44641,
|
|
44647,44651,44657,44683,44687,44699,44701,44711,
|
|
44729,44741,44753,44771,44773,44777,44789,44797,
|
|
44809,44819,44839,44843,44851,44867,44879,44887,
|
|
44893,44909,44917,44927,44939,44953,44959,44963,
|
|
44971,44983,44987,45007,45013,45053,45061,45077,
|
|
45083,45119,45121,45127,45131,45137,45139,45161,
|
|
45179,45181,45191,45197,45233,45247,45259,45263,
|
|
45281,45289,45293,45307,45317,45319,45329,45337,
|
|
45341,45343,45361,45377,45389,45403,45413,45427,
|
|
45433,45439,45481,45491,45497,45503,45523,45533,
|
|
45541,45553,45557,45569,45587,45589,45599,45613,
|
|
45631,45641,45659,45667,45673,45677,45691,45697,
|
|
45707,45737,45751,45757,45763,45767,45779,45817,
|
|
45821,45823,45827,45833,45841,45853,45863,45869,
|
|
45887,45893,45943,45949,45953,45959,45971,45979,
|
|
45989,46021,46027,46049,46051,46061,46073,46091,
|
|
46093,46099,46103,46133,46141,46147,46153,46171,
|
|
46181,46183,46187,46199,46219,46229,46237,46261,
|
|
46271,46273,46279,46301,46307,46309,46327,46337,
|
|
};
|
|
|
|
// the next prime after 46337 is 46349
|
|
|
|
// 46349 ^ 2 = 2,148,229,801 which is greater than 2^31 - 1 = 2,147,483,648 = 0x7fffffff
|
|
|
|
// hence this table can factor all positive ints
|
|
|
|
void
|
|
factor_int(int n)
|
|
{
|
|
int d, k, m;
|
|
|
|
n = abs(n);
|
|
|
|
if (n < 2)
|
|
return;
|
|
|
|
for (k = 0; k < NPRIME; k++) {
|
|
|
|
d = primetab[k];
|
|
|
|
m = 0;
|
|
|
|
while (n % d == 0) {
|
|
n /= d;
|
|
m++;
|
|
}
|
|
|
|
if (m == 0)
|
|
continue;
|
|
|
|
push_integer(d);
|
|
push_integer(m);
|
|
|
|
if (n == 1)
|
|
return;
|
|
}
|
|
|
|
push_integer(n);
|
|
push_integer(1);
|
|
}
|
|
#define TABLE_HSPACE 3
|
|
#define TABLE_VSPACE 1
|
|
|
|
#define EMIT_SPACE 1
|
|
#define EMIT_CHAR 2
|
|
#define EMIT_LIST 3
|
|
#define EMIT_SUPERSCRIPT 4
|
|
#define EMIT_SUBSCRIPT 5
|
|
#define EMIT_SUBEXPR 6
|
|
#define EMIT_FRACTION 7
|
|
#define EMIT_TABLE 8
|
|
|
|
#define OPCODE(p) ((int) car(p)->u.d)
|
|
#define HEIGHT(p) ((int) cadr(p)->u.d)
|
|
#define DEPTH(p) ((int) caddr(p)->u.d)
|
|
#define WIDTH(p) ((int) cadddr(p)->u.d)
|
|
|
|
#define VAL1(p) ((int) car(p)->u.d)
|
|
#define VAL2(p) ((int) cadr(p)->u.d)
|
|
|
|
#define PLUS_SIGN '+'
|
|
#define MINUS_SIGN 0xe28892
|
|
#define MULTIPLY_SIGN 0xc397
|
|
#define GREATEREQUAL 0xe289a5
|
|
#define LESSEQUAL 0xe289a4
|
|
|
|
#define BDLL 0xe295b4 // BOX DRAW LIGHT LEFT
|
|
#define BDLR 0xe295b6 // BOX DRAW LIGHT RIGHT
|
|
|
|
#define BDLH 0xe29480 // BOX DRAW LIGHT HORIZONTAL
|
|
#define BDLV 0xe29482 // BOX DRAW LIGHT VERTICAL
|
|
|
|
#define BDLDAR 0xe2948c // BOX DRAW LIGHT DOWN AND RIGHT
|
|
#define BDLDAL 0xe29490 // BOX DRAW LIGHT DOWN AND LEFT
|
|
#define BDLUAR 0xe29494 // BOX DRAW LIGHT UP AND RIGHT
|
|
#define BDLUAL 0xe29498 // BOX DRAW LIGHT UP AND LEFT
|
|
|
|
// #define MAX(a,b) ((a) > (b) ? (a) : (b))
|
|
// #define MIN(a,b) ((a) < (b) ? (a) : (b))
|
|
|
|
int fmt_level;
|
|
int fmt_nrow;
|
|
int fmt_ncol;
|
|
uint32_t *fmt_buf;
|
|
int fmt_buf_len;
|
|
|
|
void
|
|
fmt(void)
|
|
{
|
|
int c, d, h, i, j, m, n, w;
|
|
struct atom *p1;
|
|
|
|
fmt_level = 0;
|
|
|
|
p1 = pop();
|
|
|
|
fmt_list(p1);
|
|
|
|
p1 = pop();
|
|
|
|
h = HEIGHT(p1);
|
|
d = DEPTH(p1);
|
|
w = WIDTH(p1);
|
|
|
|
fmt_nrow = h + d;
|
|
fmt_ncol = w;
|
|
|
|
n = fmt_nrow * fmt_ncol * sizeof (uint32_t); // number of bytes
|
|
|
|
m = 1000 * (n / 1000 + 1); // round up
|
|
|
|
if (m > fmt_buf_len) {
|
|
if (fmt_buf)
|
|
free(fmt_buf);
|
|
fmt_buf = alloc_mem(m);
|
|
fmt_buf_len = m;
|
|
}
|
|
|
|
memset(fmt_buf, 0, n);
|
|
|
|
fmt_draw(0, h - 1, p1);
|
|
|
|
outbuf_init();
|
|
|
|
for (i = 0; i < fmt_nrow; i++) {
|
|
for (j = 0; j < fmt_ncol; j++) {
|
|
c = fmt_buf[i * fmt_ncol + j];
|
|
fmt_putw(c);
|
|
}
|
|
fmt_putw('\n');
|
|
}
|
|
|
|
fmt_putw('\n'); // blank line after result
|
|
|
|
printbuf(outbuf, BLACK);
|
|
}
|
|
|
|
void
|
|
fmt_args(struct atom *p)
|
|
{
|
|
int t;
|
|
|
|
p = cdr(p);
|
|
|
|
if (!iscons(p)) {
|
|
fmt_roman_char('(');
|
|
fmt_roman_char(')');
|
|
return;
|
|
}
|
|
|
|
t = tos;
|
|
|
|
fmt_expr(car(p));
|
|
|
|
p = cdr(p);
|
|
|
|
while (iscons(p)) {
|
|
fmt_roman_char(',');
|
|
fmt_expr(car(p));
|
|
p = cdr(p);
|
|
}
|
|
|
|
fmt_update_list(t);
|
|
|
|
fmt_update_subexpr();
|
|
}
|
|
|
|
void
|
|
fmt_base(struct atom *p)
|
|
{
|
|
if (isnegativenumber(p) || isfraction(p) || isdouble(p) || car(p) == symbol(ADD) || car(p) == symbol(MULTIPLY) || car(p) == symbol(POWER))
|
|
fmt_subexpr(p);
|
|
else
|
|
fmt_expr(p);
|
|
}
|
|
|
|
void
|
|
fmt_denominators(struct atom *p)
|
|
{
|
|
int n, t;
|
|
char *s;
|
|
struct atom *q;
|
|
|
|
t = tos;
|
|
n = count_denominators(p);
|
|
p = cdr(p);
|
|
|
|
while (iscons(p)) {
|
|
|
|
q = car(p);
|
|
p = cdr(p);
|
|
|
|
if (!isdenominator(q))
|
|
continue;
|
|
|
|
if (tos > t)
|
|
fmt_space();
|
|
|
|
if (isrational(q)) {
|
|
s = mstr(q->u.q.b);
|
|
fmt_roman_string(s);
|
|
continue;
|
|
}
|
|
|
|
if (isminusone(caddr(q))) {
|
|
q = cadr(q);
|
|
if (car(q) == symbol(ADD) && n == 1)
|
|
fmt_expr(q); // parens not needed
|
|
else
|
|
fmt_factor(q);
|
|
} else {
|
|
fmt_base(cadr(q));
|
|
fmt_numeric_exponent(caddr(q)); // sign is not emitted
|
|
}
|
|
}
|
|
|
|
fmt_update_list(t);
|
|
}
|
|
|
|
void
|
|
fmt_double(struct atom *p)
|
|
{
|
|
int t;
|
|
char *s;
|
|
|
|
snprintf(strbuf, STRBUFLEN, "%g", fabs(p->u.d));
|
|
|
|
s = strbuf;
|
|
|
|
while (*s && *s != 'E' && *s != 'e')
|
|
fmt_roman_char(*s++);
|
|
|
|
if (!*s)
|
|
return;
|
|
|
|
s++;
|
|
|
|
fmt_roman_char(MULTIPLY_SIGN);
|
|
|
|
fmt_roman_string("10");
|
|
|
|
// superscripted exponent
|
|
|
|
fmt_level++;
|
|
|
|
t = tos;
|
|
|
|
// sign of exponent
|
|
|
|
if (*s == '+')
|
|
s++;
|
|
else if (*s == '-') {
|
|
fmt_roman_char(MINUS_SIGN);
|
|
s++;
|
|
}
|
|
|
|
// skip leading zeroes in exponent
|
|
|
|
while (*s == '0')
|
|
s++;
|
|
|
|
fmt_roman_string(s);
|
|
|
|
fmt_update_list(t);
|
|
|
|
fmt_level--;
|
|
|
|
fmt_update_superscript();
|
|
}
|
|
|
|
void
|
|
fmt_exponent(struct atom *p)
|
|
{
|
|
if (isnum(p) && !isnegativenumber(p)) {
|
|
fmt_numeric_exponent(p); // sign is not emitted
|
|
return;
|
|
}
|
|
|
|
fmt_level++;
|
|
fmt_list(p);
|
|
fmt_level--;
|
|
|
|
fmt_update_superscript();
|
|
}
|
|
|
|
void
|
|
fmt_expr(struct atom *p)
|
|
{
|
|
if (isnegativeterm(p) || (car(p) == symbol(ADD) && isnegativeterm(cadr(p))))
|
|
fmt_roman_char(MINUS_SIGN);
|
|
|
|
if (car(p) == symbol(ADD))
|
|
fmt_expr_nib(p);
|
|
else
|
|
fmt_term(p);
|
|
}
|
|
|
|
void
|
|
fmt_expr_nib(struct atom *p)
|
|
{
|
|
p = cdr(p);
|
|
fmt_term(car(p));
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
if (isnegativeterm(car(p)))
|
|
fmt_infix_operator(MINUS_SIGN);
|
|
else
|
|
fmt_infix_operator(PLUS_SIGN);
|
|
fmt_term(car(p));
|
|
p = cdr(p);
|
|
}
|
|
}
|
|
|
|
void
|
|
fmt_factor(struct atom *p)
|
|
{
|
|
if (isrational(p)) {
|
|
fmt_rational(p);
|
|
return;
|
|
}
|
|
|
|
if (isdouble(p)) {
|
|
fmt_double(p);
|
|
return;
|
|
}
|
|
|
|
if (issymbol(p)) {
|
|
fmt_symbol(p);
|
|
return;
|
|
}
|
|
|
|
if (isstr(p)) {
|
|
fmt_string(p);
|
|
return;
|
|
}
|
|
|
|
if (istensor(p)) {
|
|
fmt_tensor(p);
|
|
return;
|
|
}
|
|
|
|
if (iscons(p)) {
|
|
if (car(p) == symbol(POWER))
|
|
fmt_power(p);
|
|
else if (car(p) == symbol(ADD) || car(p) == symbol(MULTIPLY))
|
|
fmt_subexpr(p);
|
|
else
|
|
fmt_function(p);
|
|
return;
|
|
}
|
|
}
|
|
|
|
void
|
|
fmt_frac(struct atom *p)
|
|
{
|
|
fmt_numerators(p);
|
|
fmt_denominators(p);
|
|
fmt_update_fraction();
|
|
}
|
|
|
|
void
|
|
fmt_function(struct atom *p)
|
|
{
|
|
// d(f(x),x)
|
|
|
|
if (car(p) == symbol(DERIVATIVE)) {
|
|
fmt_roman_char('d');
|
|
fmt_args(p);
|
|
return;
|
|
}
|
|
|
|
// n!
|
|
|
|
if (car(p) == symbol(FACTORIAL)) {
|
|
p = cadr(p);
|
|
if (isposint(p) || issymbol(p))
|
|
fmt_expr(p);
|
|
else
|
|
fmt_subexpr(p);
|
|
fmt_roman_char('!');
|
|
return;
|
|
}
|
|
|
|
// A[1,2]
|
|
|
|
if (car(p) == symbol(INDEX)) {
|
|
p = cdr(p);
|
|
if (issymbol(car(p)))
|
|
fmt_symbol(car(p));
|
|
else
|
|
fmt_subexpr(car(p));
|
|
fmt_indices(p);
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(SETQ) || car(p) == symbol(TESTEQ)) {
|
|
fmt_expr(cadr(p));
|
|
fmt_infix_operator('=');
|
|
fmt_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(TESTGE)) {
|
|
fmt_expr(cadr(p));
|
|
fmt_infix_operator(GREATEREQUAL);
|
|
fmt_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(TESTGT)) {
|
|
fmt_expr(cadr(p));
|
|
fmt_infix_operator('>');
|
|
fmt_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(TESTLE)) {
|
|
fmt_expr(cadr(p));
|
|
fmt_infix_operator(LESSEQUAL);
|
|
fmt_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
if (car(p) == symbol(TESTLT)) {
|
|
fmt_expr(cadr(p));
|
|
fmt_infix_operator('<');
|
|
fmt_expr(caddr(p));
|
|
return;
|
|
}
|
|
|
|
// default
|
|
|
|
if (issymbol(car(p)))
|
|
fmt_symbol(car(p));
|
|
else
|
|
fmt_subexpr(car(p));
|
|
|
|
fmt_args(p);
|
|
}
|
|
|
|
void
|
|
fmt_indices(struct atom *p)
|
|
{
|
|
fmt_roman_char('[');
|
|
|
|
p = cdr(p);
|
|
|
|
if (iscons(p)) {
|
|
fmt_expr(car(p));
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
fmt_roman_char(',');
|
|
fmt_expr(car(p));
|
|
p = cdr(p);
|
|
}
|
|
}
|
|
|
|
fmt_roman_char(']');
|
|
}
|
|
|
|
void
|
|
fmt_infix_operator(int c)
|
|
{
|
|
fmt_space();
|
|
fmt_roman_char(c);
|
|
fmt_space();
|
|
}
|
|
|
|
void
|
|
fmt_list(struct atom *p)
|
|
{
|
|
int t = tos;
|
|
fmt_expr(p);
|
|
fmt_update_list(t);
|
|
}
|
|
|
|
void
|
|
fmt_matrix(struct atom *p, int d, int k)
|
|
{
|
|
int i, j, m, n, span;
|
|
|
|
if (d == p->u.tensor->ndim) {
|
|
fmt_list(p->u.tensor->elem[k]);
|
|
return;
|
|
}
|
|
|
|
// compute element span
|
|
|
|
span = 1;
|
|
|
|
for (i = d + 2; i < p->u.tensor->ndim; i++)
|
|
span *= p->u.tensor->dim[i];
|
|
|
|
n = p->u.tensor->dim[d]; // number of rows
|
|
m = p->u.tensor->dim[d + 1]; // number of columns
|
|
|
|
for (i = 0; i < n; i++)
|
|
for (j = 0; j < m; j++)
|
|
fmt_matrix(p, d + 2, k + (i * m + j) * span);
|
|
|
|
fmt_update_table(n, m);
|
|
}
|
|
|
|
void
|
|
fmt_numerators(struct atom *p)
|
|
{
|
|
int n, t;
|
|
char *s;
|
|
struct atom *q;
|
|
|
|
t = tos;
|
|
n = count_numerators(p);
|
|
p = cdr(p);
|
|
|
|
while (iscons(p)) {
|
|
|
|
q = car(p);
|
|
p = cdr(p);
|
|
|
|
if (!isnumerator(q))
|
|
continue;
|
|
|
|
if (tos > t)
|
|
fmt_space();
|
|
|
|
if (isrational(q)) {
|
|
s = mstr(q->u.q.a);
|
|
fmt_roman_string(s);
|
|
continue;
|
|
}
|
|
|
|
if (car(q) == symbol(ADD) && n == 1)
|
|
fmt_expr(q); // parens not needed
|
|
else
|
|
fmt_factor(q);
|
|
}
|
|
|
|
if (t == tos)
|
|
fmt_roman_char('1'); // no numerators
|
|
|
|
fmt_update_list(t);
|
|
}
|
|
|
|
// p is rational or double, sign is not emitted
|
|
|
|
void
|
|
fmt_numeric_exponent(struct atom *p)
|
|
{
|
|
int t;
|
|
char *s;
|
|
|
|
fmt_level++;
|
|
|
|
t = tos;
|
|
|
|
if (isrational(p)) {
|
|
s = mstr(p->u.q.a);
|
|
fmt_roman_string(s);
|
|
if (!MEQUAL(p->u.q.b, 1)) {
|
|
fmt_roman_char('/');
|
|
s = mstr(p->u.q.b);
|
|
fmt_roman_string(s);
|
|
}
|
|
} else
|
|
fmt_double(p);
|
|
|
|
fmt_update_list(t);
|
|
|
|
fmt_level--;
|
|
|
|
fmt_update_superscript();
|
|
}
|
|
|
|
void
|
|
fmt_power(struct atom *p)
|
|
{
|
|
if (cadr(p) == symbol(EXP1)) {
|
|
fmt_roman_string("exp");
|
|
fmt_args(cdr(p));
|
|
return;
|
|
}
|
|
|
|
if (isimaginaryunit(p)) {
|
|
if (isimaginaryunit(get_binding(symbol(J_LOWER)))) {
|
|
fmt_roman_char('j');
|
|
return;
|
|
}
|
|
if (isimaginaryunit(get_binding(symbol(I_LOWER)))) {
|
|
fmt_roman_char('i');
|
|
return;
|
|
}
|
|
}
|
|
|
|
if (isnegativenumber(caddr(p))) {
|
|
fmt_reciprocal(p);
|
|
return;
|
|
}
|
|
|
|
fmt_base(cadr(p));
|
|
fmt_exponent(caddr(p));
|
|
}
|
|
|
|
void
|
|
fmt_rational(struct atom *p)
|
|
{
|
|
int t;
|
|
char *s;
|
|
|
|
if (MEQUAL(p->u.q.b, 1)) {
|
|
s = mstr(p->u.q.a);
|
|
fmt_roman_string(s);
|
|
return;
|
|
}
|
|
|
|
fmt_level++;
|
|
|
|
t = tos;
|
|
s = mstr(p->u.q.a);
|
|
fmt_roman_string(s);
|
|
fmt_update_list(t);
|
|
|
|
t = tos;
|
|
s = mstr(p->u.q.b);
|
|
fmt_roman_string(s);
|
|
fmt_update_list(t);
|
|
|
|
fmt_level--;
|
|
|
|
fmt_update_fraction();
|
|
}
|
|
|
|
// p = y^x where x is a negative number
|
|
|
|
void
|
|
fmt_reciprocal(struct atom *p)
|
|
{
|
|
int t;
|
|
|
|
fmt_roman_char('1'); // numerator
|
|
|
|
t = tos;
|
|
|
|
if (isminusone(caddr(p)))
|
|
fmt_expr(cadr(p));
|
|
else {
|
|
fmt_base(cadr(p));
|
|
fmt_numeric_exponent(caddr(p)); // sign is not emitted
|
|
}
|
|
|
|
fmt_update_list(t);
|
|
|
|
fmt_update_fraction();
|
|
}
|
|
|
|
void
|
|
fmt_roman_char(int c)
|
|
{
|
|
int d, h, w;
|
|
|
|
h = 1;
|
|
d = 0;
|
|
w = 1;
|
|
|
|
push_double(EMIT_CHAR);
|
|
push_double(h);
|
|
push_double(d);
|
|
push_double(w);
|
|
push_double(c);
|
|
|
|
list(5);
|
|
}
|
|
|
|
void
|
|
fmt_roman_string(char *s)
|
|
{
|
|
while (*s)
|
|
fmt_roman_char(*s++);
|
|
}
|
|
|
|
void
|
|
fmt_space(void)
|
|
{
|
|
push_double(EMIT_SPACE);
|
|
push_double(0);
|
|
push_double(0);
|
|
push_double(1);
|
|
|
|
list(4);
|
|
}
|
|
|
|
void
|
|
fmt_string(struct atom *p)
|
|
{
|
|
fmt_roman_string(p->u.str);
|
|
}
|
|
|
|
void
|
|
fmt_subexpr(struct atom *p)
|
|
{
|
|
fmt_list(p);
|
|
fmt_update_subexpr();
|
|
}
|
|
|
|
void
|
|
fmt_symbol(struct atom *p)
|
|
{
|
|
int k, t;
|
|
char *s;
|
|
|
|
if (p == symbol(EXP1)) {
|
|
fmt_roman_string("exp(1)");
|
|
return;
|
|
}
|
|
|
|
s = printname(p);
|
|
|
|
if (iskeyword(p) || p == symbol(LAST) || p == symbol(TRACE) || p == symbol(TTY)) {
|
|
fmt_roman_string(s);
|
|
return;
|
|
}
|
|
|
|
k = fmt_symbol_fragment(s, 0);
|
|
|
|
if (s[k] == '\0')
|
|
return;
|
|
|
|
// emit subscript
|
|
|
|
fmt_level++;
|
|
|
|
t = tos;
|
|
|
|
while (s[k] != '\0')
|
|
k = fmt_symbol_fragment(s, k);
|
|
|
|
fmt_update_list(t);
|
|
|
|
fmt_level--;
|
|
|
|
fmt_update_subscript();
|
|
}
|
|
|
|
#define NUM_SYMBOL_NAMES 49
|
|
|
|
char *symbol_name_tab[NUM_SYMBOL_NAMES] = {
|
|
|
|
"Alpha",
|
|
"Beta",
|
|
"Gamma",
|
|
"Delta",
|
|
"Epsilon",
|
|
"Zeta",
|
|
"Eta",
|
|
"Theta",
|
|
"Iota",
|
|
"Kappa",
|
|
"Lambda",
|
|
"Mu",
|
|
"Nu",
|
|
"Xi",
|
|
"Omicron",
|
|
"Pi",
|
|
"Rho",
|
|
"Sigma",
|
|
"Tau",
|
|
"Upsilon",
|
|
"Phi",
|
|
"Chi",
|
|
"Psi",
|
|
"Omega",
|
|
|
|
"alpha",
|
|
"beta",
|
|
"gamma",
|
|
"delta",
|
|
"epsilon",
|
|
"zeta",
|
|
"eta",
|
|
"theta",
|
|
"iota",
|
|
"kappa",
|
|
"lambda",
|
|
"mu",
|
|
"nu",
|
|
"xi",
|
|
"omicron",
|
|
"pi",
|
|
"rho",
|
|
"sigma",
|
|
"tau",
|
|
"upsilon",
|
|
"phi",
|
|
"chi",
|
|
"psi",
|
|
"omega",
|
|
|
|
"hbar",
|
|
};
|
|
|
|
int symbol_unicode_tab[NUM_SYMBOL_NAMES] = {
|
|
|
|
0xce91, // Alpha
|
|
0xce92, // Beta
|
|
0xce93, // Gamma
|
|
0xce94, // Delta
|
|
0xce95, // Epsilon
|
|
0xce96, // Zeta
|
|
0xce97, // Eta
|
|
0xce98, // Theta
|
|
0xce99, // Iota
|
|
0xce9a, // Kappa
|
|
0xce9b, // Lambda
|
|
0xce9c, // Mu
|
|
0xce9d, // Nu
|
|
0xce9e, // Xi
|
|
0xce9f, // Omicron
|
|
0xcea0, // Pi
|
|
0xcea1, // Rho
|
|
0xcea3, // Sigma
|
|
0xcea4, // Tau
|
|
0xcea5, // Upsilon
|
|
0xcea6, // Phi
|
|
0xcea7, // Chi
|
|
0xcea8, // Psi
|
|
0xcea9, // Omega
|
|
|
|
0xceb1, // alpha
|
|
0xceb2, // beta
|
|
0xceb3, // gamma
|
|
0xceb4, // delta
|
|
0xceb5, // epsilon
|
|
0xceb6, // zeta
|
|
0xceb7, // eta
|
|
0xceb8, // theta
|
|
0xceb9, // iota
|
|
0xceba, // kappa
|
|
0xcebb, // lambda
|
|
0xcebc, // mu
|
|
0xcebd, // nu
|
|
0xcebe, // xi
|
|
0xcebf, // omicron
|
|
0xcf80, // pi
|
|
0xcf81, // rho
|
|
0xcf83, // sigma
|
|
0xcf84, // tau
|
|
0xcf85, // upsilon
|
|
0xcf86, // phi
|
|
0xcf87, // chi
|
|
0xcf88, // psi
|
|
0xcf89, // omega
|
|
|
|
0xc4a7, // hbar
|
|
};
|
|
|
|
int
|
|
fmt_symbol_fragment(char *s, int k)
|
|
{
|
|
int c, i, n;
|
|
char *t;
|
|
|
|
for (i = 0; i < NUM_SYMBOL_NAMES; i++) {
|
|
t = symbol_name_tab[i];
|
|
n = (int) strlen(t);
|
|
if (strncmp(s + k, t, n) == 0)
|
|
break;
|
|
}
|
|
|
|
if (i == NUM_SYMBOL_NAMES) {
|
|
fmt_roman_char(s[k]);
|
|
return k + 1;
|
|
}
|
|
|
|
c = symbol_unicode_tab[i];
|
|
|
|
fmt_roman_char(c);
|
|
|
|
return k + n;
|
|
}
|
|
|
|
void
|
|
fmt_table(int x, int y, struct atom *p)
|
|
{
|
|
int cx, dx, i, j, m, n;
|
|
int column_width, elem_width, row_depth, row_height;
|
|
struct atom *d, *h, *w, *table;
|
|
|
|
n = VAL1(p);
|
|
m = VAL2(p);
|
|
|
|
p = cddr(p);
|
|
|
|
table = car(p);
|
|
h = cadr(p);
|
|
d = caddr(p);
|
|
|
|
for (i = 0; i < n; i++) { // for each row
|
|
|
|
row_height = VAL1(h);
|
|
row_depth = VAL1(d);
|
|
|
|
y += row_height;
|
|
|
|
dx = 0;
|
|
|
|
w = cadddr(p);
|
|
|
|
for (j = 0; j < m; j++) { // for each column
|
|
column_width = VAL1(w);
|
|
elem_width = WIDTH(car(table));
|
|
cx = x + dx + (column_width - elem_width) / 2; // center horizontal
|
|
fmt_draw(cx, y, car(table));
|
|
dx += column_width + TABLE_HSPACE;
|
|
table = cdr(table);
|
|
w = cdr(w);
|
|
}
|
|
|
|
y += row_depth + TABLE_VSPACE;
|
|
|
|
h = cdr(h);
|
|
d = cdr(d);
|
|
}
|
|
}
|
|
|
|
void
|
|
fmt_tensor(struct atom *p)
|
|
{
|
|
if (p->u.tensor->ndim % 2 == 1)
|
|
fmt_vector(p); // odd rank
|
|
else
|
|
fmt_matrix(p, 0, 0); // even rank
|
|
}
|
|
|
|
void
|
|
fmt_term(struct atom *p)
|
|
{
|
|
if (car(p) == symbol(MULTIPLY))
|
|
fmt_term_nib(p);
|
|
else
|
|
fmt_factor(p);
|
|
}
|
|
|
|
void
|
|
fmt_term_nib(struct atom *p)
|
|
{
|
|
if (find_denominator(p)) {
|
|
fmt_frac(p);
|
|
return;
|
|
}
|
|
|
|
// no denominators
|
|
|
|
p = cdr(p);
|
|
|
|
if (isminusone(car(p)))
|
|
p = cdr(p); // sign already emitted
|
|
|
|
fmt_factor(car(p));
|
|
|
|
p = cdr(p);
|
|
|
|
while (iscons(p)) {
|
|
fmt_space();
|
|
fmt_factor(car(p));
|
|
p = cdr(p);
|
|
}
|
|
}
|
|
|
|
void
|
|
fmt_update_fraction(void)
|
|
{
|
|
int d, h, w;
|
|
struct atom *p1, *p2;
|
|
|
|
p2 = pop(); // denominator
|
|
p1 = pop(); // numerator
|
|
|
|
h = HEIGHT(p1) + DEPTH(p1);
|
|
d = HEIGHT(p2) + DEPTH(p2);
|
|
w = MAX(WIDTH(p1), WIDTH(p2));
|
|
|
|
h += 1;
|
|
w += 2;
|
|
|
|
push_double(EMIT_FRACTION);
|
|
push_double(h);
|
|
push_double(d);
|
|
push_double(w);
|
|
push(p1);
|
|
push(p2);
|
|
|
|
list(6);
|
|
}
|
|
|
|
void
|
|
fmt_update_list(int t)
|
|
{
|
|
int d, h, i, w;
|
|
struct atom *p1;
|
|
|
|
if (tos - t == 1)
|
|
return;
|
|
|
|
h = 0;
|
|
d = 0;
|
|
w = 0;
|
|
|
|
for (i = t; i < tos; i++) {
|
|
p1 = stack[i];
|
|
h = MAX(h, HEIGHT(p1));
|
|
d = MAX(d, DEPTH(p1));
|
|
w += WIDTH(p1);
|
|
}
|
|
|
|
list(tos - t);
|
|
p1 = pop();
|
|
|
|
push_double(EMIT_LIST);
|
|
push_double(h);
|
|
push_double(d);
|
|
push_double(w);
|
|
push(p1);
|
|
|
|
list(5);
|
|
}
|
|
|
|
void
|
|
fmt_update_subexpr(void)
|
|
{
|
|
int d, h, w;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
h = HEIGHT(p1);
|
|
d = DEPTH(p1);
|
|
w = WIDTH(p1);
|
|
|
|
// delimiters have vertical symmetry (h - m == d + m, m = 1/2)
|
|
|
|
if (h > 1 || d > 0) {
|
|
h = MAX(h, d + 1) + 1; // plus extra
|
|
d = h - 1; // by symmetry
|
|
}
|
|
|
|
w += 2;
|
|
|
|
push_double(EMIT_SUBEXPR);
|
|
push_double(h);
|
|
push_double(d);
|
|
push_double(w);
|
|
push(p1);
|
|
|
|
list(5);
|
|
}
|
|
|
|
void
|
|
fmt_update_subscript(void)
|
|
{
|
|
int d, dx, dy, h, w;
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
h = HEIGHT(p1);
|
|
d = DEPTH(p1);
|
|
w = WIDTH(p1);
|
|
|
|
dx = 0;
|
|
dy = 1;
|
|
|
|
push_double(EMIT_SUBSCRIPT);
|
|
push_double(h);
|
|
push_double(d + dy);
|
|
push_double(w);
|
|
push_double(dx);
|
|
push_double(dy);
|
|
push(p1);
|
|
|
|
list(7);
|
|
}
|
|
|
|
void
|
|
fmt_update_superscript(void)
|
|
{
|
|
int d, dx, dy, h, w, y;
|
|
struct atom *p1, *p2;
|
|
|
|
p2 = pop(); // exponent
|
|
p1 = pop(); // base
|
|
|
|
h = HEIGHT(p2);
|
|
d = DEPTH(p2);
|
|
w = WIDTH(p2);
|
|
|
|
// y is distance from baseline to bottom of superscript
|
|
|
|
y = HEIGHT(p1) - d - 1;
|
|
|
|
y = MAX(y, 1);
|
|
|
|
dx = 0;
|
|
dy = -(y + d);
|
|
|
|
h = y + h + d;
|
|
d = 0;
|
|
|
|
if (OPCODE(p1) == EMIT_SUBSCRIPT) {
|
|
dx = -WIDTH(p1);
|
|
w = MAX(0, w - WIDTH(p1));
|
|
}
|
|
|
|
push(p1); // base
|
|
|
|
push_double(EMIT_SUPERSCRIPT);
|
|
push_double(h);
|
|
push_double(d);
|
|
push_double(w);
|
|
push_double(dx);
|
|
push_double(dy);
|
|
push(p2);
|
|
|
|
list(7);
|
|
}
|
|
|
|
void
|
|
fmt_update_table(int n, int m)
|
|
{
|
|
int i, j, t;
|
|
int d, h, w;
|
|
int total_height, total_width;
|
|
struct atom *p1, *p2, *p3, *p4;
|
|
|
|
total_height = 0;
|
|
total_width = 0;
|
|
|
|
t = tos - n * m;
|
|
|
|
// height of each row
|
|
|
|
for (i = 0; i < n; i++) { // for each row
|
|
h = 0;
|
|
for (j = 0; j < m; j++) { // for each column
|
|
p1 = stack[t + i * m + j];
|
|
h = MAX(h, HEIGHT(p1));
|
|
}
|
|
push_double(h);
|
|
total_height += h;
|
|
}
|
|
|
|
list(n);
|
|
p2 = pop();
|
|
|
|
// depth of each row
|
|
|
|
for (i = 0; i < n; i++) { // for each row
|
|
d = 0;
|
|
for (j = 0; j < m; j++) { // for each column
|
|
p1 = stack[t + i * m + j];
|
|
d = MAX(d, DEPTH(p1));
|
|
}
|
|
push_double(d);
|
|
total_height += d;
|
|
}
|
|
|
|
list(n);
|
|
p3 = pop();
|
|
|
|
// width of each column
|
|
|
|
for (j = 0; j < m; j++) { // for each column
|
|
w = 0;
|
|
for (i = 0; i < n; i++) { // for each row
|
|
p1 = stack[t + i * m + j];
|
|
w = MAX(w, WIDTH(p1));
|
|
}
|
|
push_double(w);
|
|
total_width += w;
|
|
}
|
|
|
|
list(m);
|
|
p4 = pop();
|
|
|
|
// h, d, w for entire table centered vertical
|
|
|
|
total_height += (n - 1) * TABLE_VSPACE + 2; // +2 for delimiters
|
|
total_width += (m - 1) * TABLE_HSPACE + 4; // +4 for delimiters
|
|
|
|
h = total_height / 2 + 1;
|
|
d = total_height - h;
|
|
w = total_width;
|
|
|
|
list(n * m);
|
|
p1 = pop();
|
|
|
|
push_double(EMIT_TABLE);
|
|
push_double(h);
|
|
push_double(d);
|
|
push_double(w);
|
|
push_double(n);
|
|
push_double(m);
|
|
push(p1);
|
|
push(p2);
|
|
push(p3);
|
|
push(p4);
|
|
|
|
list(10);
|
|
}
|
|
|
|
void
|
|
fmt_vector(struct atom *p)
|
|
{
|
|
int i, n, span;
|
|
|
|
// compute element span
|
|
|
|
span = 1;
|
|
|
|
n = p->u.tensor->ndim;
|
|
|
|
for (i = 1; i < n; i++)
|
|
span *= p->u.tensor->dim[i];
|
|
|
|
n = p->u.tensor->dim[0]; // number of rows
|
|
|
|
for (i = 0; i < n; i++)
|
|
fmt_matrix(p, 1, i * span);
|
|
|
|
fmt_update_table(n, 1); // n rows, 1 column
|
|
}
|
|
|
|
void
|
|
fmt_draw(int x, int y, struct atom *p)
|
|
{
|
|
int d, dx, dy, h, i, k, w;
|
|
|
|
k = OPCODE(p);
|
|
h = HEIGHT(p);
|
|
d = DEPTH(p);
|
|
w = WIDTH(p);
|
|
|
|
p = cddddr(p);
|
|
|
|
switch (k) {
|
|
|
|
case EMIT_SPACE:
|
|
break;
|
|
|
|
case EMIT_CHAR:
|
|
fmt_draw_char(x, y, VAL1(p));
|
|
break;
|
|
|
|
case EMIT_LIST:
|
|
p = car(p);
|
|
while (iscons(p)) {
|
|
fmt_draw(x, y, car(p));
|
|
x += WIDTH(car(p));
|
|
p = cdr(p);
|
|
}
|
|
break;
|
|
|
|
case EMIT_SUPERSCRIPT:
|
|
case EMIT_SUBSCRIPT:
|
|
dx = VAL1(p);
|
|
dy = VAL2(p);
|
|
p = caddr(p);
|
|
fmt_draw(x + dx, y + dy, p);
|
|
break;
|
|
|
|
case EMIT_SUBEXPR:
|
|
fmt_draw_delims(x, y, h, d, w);
|
|
fmt_draw(x + 1, y, car(p));
|
|
break;
|
|
|
|
case EMIT_FRACTION:
|
|
|
|
// horizontal line
|
|
|
|
fmt_draw_char(x, y, BDLR);
|
|
|
|
for (i = 1; i < w - 1; i++)
|
|
fmt_draw_char(x + i, y, BDLH);
|
|
|
|
fmt_draw_char(x + w - 1, y, BDLL);
|
|
|
|
// numerator
|
|
|
|
dx = (w - WIDTH(car(p))) / 2;
|
|
dy = -h + HEIGHT(car(p));
|
|
fmt_draw(x + dx, y + dy, car(p));
|
|
|
|
// denominator
|
|
|
|
p = cdr(p);
|
|
dx = (w - WIDTH(car(p))) / 2;
|
|
dy = d - DEPTH(car(p));
|
|
fmt_draw(x + dx, y + dy, car(p));
|
|
|
|
break;
|
|
|
|
case EMIT_TABLE:
|
|
fmt_draw_delims(x, y, h, d, w);
|
|
fmt_draw_table(x + 2, y - h + 1, p);
|
|
break;
|
|
}
|
|
}
|
|
|
|
void
|
|
fmt_draw_char(int x, int y, int c)
|
|
{
|
|
if (x >= 0 && x < fmt_ncol && y >= 0 && y < fmt_nrow)
|
|
fmt_buf[y * fmt_ncol + x] = c;
|
|
}
|
|
|
|
void
|
|
fmt_draw_delims(int x, int y, int h, int d, int w)
|
|
{
|
|
if (h > 1 || d > 0) {
|
|
fmt_draw_ldelim(x, y, h, d);
|
|
fmt_draw_rdelim(x + w - 1, y, h, d);
|
|
} else {
|
|
fmt_draw_char(x, y, '(');
|
|
fmt_draw_char(x + w - 1, y, ')');
|
|
}
|
|
}
|
|
|
|
void
|
|
fmt_draw_ldelim(int x, int y, int h, int d)
|
|
{
|
|
int i;
|
|
|
|
fmt_draw_char(x, y - h + 1, BDLDAR);
|
|
|
|
for (i = 1; i < h + d - 1; i++)
|
|
fmt_draw_char(x, y - h + 1 + i, BDLV);
|
|
|
|
fmt_draw_char(x, y + d, BDLUAR);
|
|
}
|
|
|
|
void
|
|
fmt_draw_rdelim(int x, int y, int h, int d)
|
|
{
|
|
int i;
|
|
|
|
fmt_draw_char(x, y - h + 1, BDLDAL);
|
|
|
|
for (i = 1; i < h + d - 1; i++)
|
|
fmt_draw_char(x, y - h + 1 + i, BDLV);
|
|
|
|
fmt_draw_char(x, y + d, BDLUAL);
|
|
}
|
|
|
|
void
|
|
fmt_draw_table(int x, int y, struct atom *p)
|
|
{
|
|
int cx, dx, i, j, m, n;
|
|
int column_width, elem_width, row_depth, row_height;
|
|
struct atom *d, *h, *w, *table;
|
|
|
|
n = VAL1(p);
|
|
m = VAL2(p);
|
|
|
|
p = cddr(p);
|
|
|
|
table = car(p);
|
|
h = cadr(p);
|
|
d = caddr(p);
|
|
|
|
for (i = 0; i < n; i++) { // for each row
|
|
|
|
row_height = VAL1(h);
|
|
row_depth = VAL1(d);
|
|
|
|
y += row_height;
|
|
|
|
dx = 0;
|
|
|
|
w = cadddr(p);
|
|
|
|
for (j = 0; j < m; j++) { // for each column
|
|
|
|
column_width = VAL1(w);
|
|
elem_width = WIDTH(car(table));
|
|
cx = x + dx + (column_width - elem_width) / 2; // center horizontal
|
|
fmt_draw(cx, y, car(table));
|
|
dx += column_width + TABLE_HSPACE;
|
|
table = cdr(table);
|
|
w = cdr(w);
|
|
}
|
|
|
|
y += row_depth + TABLE_VSPACE;
|
|
|
|
h = cdr(h);
|
|
d = cdr(d);
|
|
}
|
|
}
|
|
|
|
void
|
|
fmt_putw(uint32_t w)
|
|
{
|
|
uint8_t buf[4];
|
|
if (w == 0)
|
|
w = ' ';
|
|
buf[0] = w >> 24;
|
|
buf[1] = w >> 16;
|
|
buf[2] = w >> 8;
|
|
buf[3] = w;
|
|
if (buf[1])
|
|
outbuf_putc(buf[1]);
|
|
if (buf[2])
|
|
outbuf_putc(buf[2]);
|
|
outbuf_putc(buf[3]);
|
|
}
|
|
// automatic variables not visible to the garbage collector are reclaimed
|
|
|
|
void
|
|
gc(void)
|
|
{
|
|
int i, j;
|
|
struct atom *p;
|
|
|
|
gc_count++;
|
|
alloc_count = 0;
|
|
|
|
// tag everything
|
|
|
|
for (i = 0; i < block_count; i++)
|
|
for (j = 0; j < BLOCKSIZE; j++)
|
|
mem[i][j].tag = 1;
|
|
|
|
// untag what's used
|
|
|
|
untag(zero);
|
|
untag(one);
|
|
untag(minusone);
|
|
untag(imaginaryunit);
|
|
|
|
for (i = 0; i < tos; i++)
|
|
untag(stack[i]);
|
|
|
|
for (i = 0; i < 27 * BUCKETSIZE; i++) {
|
|
untag(symtab[i]);
|
|
untag(binding[i]);
|
|
untag(usrfunc[i]);
|
|
}
|
|
|
|
// collect everything that's still tagged
|
|
|
|
free_list = NULL;
|
|
free_count = 0;
|
|
|
|
for (i = 0; i < block_count; i++)
|
|
for (j = 0; j < BLOCKSIZE; j++) {
|
|
|
|
p = mem[i] + j;
|
|
|
|
if (p->tag == 0)
|
|
continue;
|
|
|
|
// still tagged so it's unused, put on free list
|
|
|
|
switch (p->atomtype) {
|
|
case KSYM:
|
|
free(p->u.ksym.name);
|
|
ksym_count--;
|
|
break;
|
|
case USYM:
|
|
free(p->u.usym.name);
|
|
usym_count--;
|
|
break;
|
|
case RATIONAL:
|
|
mfree(p->u.q.a);
|
|
mfree(p->u.q.b);
|
|
break;
|
|
case STR:
|
|
if (p->u.str)
|
|
free(p->u.str);
|
|
string_count--;
|
|
break;
|
|
case TENSOR:
|
|
free(p->u.tensor);
|
|
tensor_count--;
|
|
break;
|
|
default:
|
|
break; // FREEATOM, CONS, or DOUBLE
|
|
}
|
|
|
|
p->atomtype = FREEATOM;
|
|
p->u.next = free_list;
|
|
|
|
free_list = p;
|
|
free_count++;
|
|
}
|
|
}
|
|
|
|
void
|
|
untag(struct atom *p)
|
|
{
|
|
int i;
|
|
|
|
if (p == NULL)
|
|
return;
|
|
|
|
while (iscons(p)) {
|
|
if (p->tag == 0)
|
|
return;
|
|
p->tag = 0;
|
|
untag(p->u.cons.car);
|
|
p = p->u.cons.cdr;
|
|
}
|
|
|
|
if (p->tag == 0)
|
|
return;
|
|
|
|
p->tag = 0;
|
|
|
|
if (istensor(p))
|
|
for (i = 0; i < p->u.tensor->nelem; i++)
|
|
untag(p->u.tensor->elem[i]);
|
|
}
|
|
struct atom *mem[MAXBLOCKS]; // an array of pointers
|
|
struct atom *free_list;
|
|
|
|
int tos; // top of stack
|
|
|
|
struct atom *stack[STACKSIZE];
|
|
|
|
struct atom *symtab[27 * BUCKETSIZE];
|
|
struct atom *binding[27 * BUCKETSIZE];
|
|
struct atom *usrfunc[27 * BUCKETSIZE];
|
|
|
|
struct atom *zero;
|
|
struct atom *one;
|
|
struct atom *minusone;
|
|
struct atom *imaginaryunit;
|
|
|
|
int eval_level;
|
|
int gc_level;
|
|
int expanding;
|
|
int drawing;
|
|
int interrupt;
|
|
int shuntflag;
|
|
int errorflag;
|
|
int breakflag;
|
|
jmp_buf jmpbuf;
|
|
char *trace1;
|
|
char *trace2;
|
|
|
|
int alloc_count;
|
|
int block_count;
|
|
int free_count;
|
|
int gc_count;
|
|
int bignum_count;
|
|
int ksym_count;
|
|
int usym_count;
|
|
int string_count;
|
|
int tensor_count;
|
|
int max_eval_level;
|
|
int max_tos;
|
|
|
|
char strbuf[STRBUFLEN];
|
|
|
|
char *outbuf;
|
|
int outbuf_index;
|
|
int outbuf_length;
|
|
// int
|
|
// main(int argc, char *argv[])
|
|
// {
|
|
// int i;
|
|
// for (i = 1; i < argc; i++)
|
|
// run_infile(argv[i]);
|
|
// if (isatty(fileno(stdout)))
|
|
// run_stdin();
|
|
// }
|
|
|
|
void
|
|
run_infile(char *infile)
|
|
{
|
|
char *buf;
|
|
buf = read_file(infile);
|
|
if (buf == NULL) {
|
|
fprintf(stderr, "cannot read %s\n", infile);
|
|
exit(1);
|
|
}
|
|
run(buf);
|
|
free(buf);
|
|
}
|
|
|
|
void
|
|
run_stdin(void)
|
|
{
|
|
static char inbuf[1000];
|
|
for (;;) {
|
|
fputs("? ", stdout);
|
|
fflush(stdout);
|
|
fgets(inbuf, sizeof inbuf, stdin);
|
|
run(inbuf);
|
|
}
|
|
}
|
|
|
|
void
|
|
display(void)
|
|
{
|
|
fmt();
|
|
}
|
|
|
|
void
|
|
printbuf(char *s, int color)
|
|
{
|
|
fputs(s, stdout);
|
|
}
|
|
|
|
void
|
|
eval_draw(struct atom *p1)
|
|
{
|
|
(void) p1; // silence compiler
|
|
push_symbol(NIL);
|
|
}
|
|
|
|
void
|
|
eval_exit(struct atom *p1)
|
|
{
|
|
(void) p1; // silence compiler
|
|
exit(0);
|
|
}
|
|
void
|
|
numden(void)
|
|
{
|
|
struct atom *p0, *p1, *p2;
|
|
|
|
p1 = pop();
|
|
p2 = one;
|
|
|
|
while (numden_find_divisor(p1)) {
|
|
p0 = pop();
|
|
push(p0);
|
|
push(p1);
|
|
numden_cancel_factor();
|
|
p1 = pop();
|
|
push(p0);
|
|
push(p2);
|
|
multiply();
|
|
p2 = pop();
|
|
}
|
|
|
|
push(p2);
|
|
push(p1);
|
|
}
|
|
|
|
// returns 1 with divisor on stack, otherwise returns 0
|
|
|
|
int
|
|
numden_find_divisor(struct atom *p)
|
|
{
|
|
if (car(p) == symbol(ADD)) {
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
if (numden_find_divisor_term(car(p)))
|
|
return 1;
|
|
p = cdr(p);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
return numden_find_divisor_term(p);
|
|
}
|
|
|
|
int
|
|
numden_find_divisor_term(struct atom *p)
|
|
{
|
|
if (car(p) == symbol(MULTIPLY)) {
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
if (numden_find_divisor_factor(car(p)))
|
|
return 1;
|
|
p = cdr(p);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
return numden_find_divisor_factor(p);
|
|
}
|
|
|
|
int
|
|
numden_find_divisor_factor(struct atom *p)
|
|
{
|
|
if (isrational(p) && !isinteger(p)) {
|
|
push_bignum(MPLUS, mcopy(p->u.q.b), mint(1));
|
|
return 1;
|
|
}
|
|
|
|
if (car(p) == symbol(POWER) && isnegativeterm(caddr(p))) {
|
|
if (isminusone(caddr(p)))
|
|
push(cadr(p));
|
|
else {
|
|
push_symbol(POWER);
|
|
push(cadr(p));
|
|
push(caddr(p));
|
|
negate();
|
|
list(3);
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
void
|
|
numden_cancel_factor(void)
|
|
{
|
|
int h;
|
|
struct atom *p1, *p2;
|
|
|
|
p2 = pop(); // numerator
|
|
p1 = pop(); // divisor
|
|
|
|
// multiply term by term to ensure divisor is not distributed
|
|
|
|
if (car(p2) == symbol(ADD)) {
|
|
h = tos;
|
|
p2 = cdr(p2);
|
|
while (iscons(p2)) {
|
|
push(p1);
|
|
push(car(p2));
|
|
multiply();
|
|
p2 = cdr(p2);
|
|
}
|
|
add_terms(tos - h);
|
|
return;
|
|
}
|
|
|
|
push(p1);
|
|
push(p2);
|
|
multiply();
|
|
}
|
|
void
|
|
outbuf_init(void)
|
|
{
|
|
outbuf_index = 0;
|
|
outbuf_puts(""); // init outbuf as empty string
|
|
}
|
|
|
|
void
|
|
outbuf_puts(char *s)
|
|
{
|
|
int len, m;
|
|
|
|
len = (int) strlen(s);
|
|
|
|
// Let outbuf_index + len == 1000
|
|
|
|
// Then m == 2000 hence there is always room for the terminator '\0'
|
|
|
|
m = 1000 * ((outbuf_index + len) / 1000 + 1); // m is a multiple of 1000
|
|
|
|
if (m > outbuf_length) {
|
|
outbuf = realloc(outbuf, m);
|
|
if (outbuf == NULL)
|
|
exit(1);
|
|
outbuf_length = m;
|
|
}
|
|
|
|
strcpy(outbuf + outbuf_index, s);
|
|
outbuf_index += len;
|
|
}
|
|
|
|
void
|
|
outbuf_putc(int c)
|
|
{
|
|
int m;
|
|
|
|
// Let outbuf_index + 1 == 1000
|
|
|
|
// Then m == 2000 hence there is always room for the terminator '\0'
|
|
|
|
m = 1000 * ((outbuf_index + 1) / 1000 + 1); // m is a multiple of 1000
|
|
|
|
if (m > outbuf_length) {
|
|
outbuf = realloc(outbuf, m);
|
|
if (outbuf == NULL)
|
|
exit(1);
|
|
outbuf_length = m;
|
|
}
|
|
|
|
outbuf[outbuf_index++] = c;
|
|
outbuf[outbuf_index] = '\0';
|
|
}
|
|
int
|
|
iszero(struct atom *p)
|
|
{
|
|
int i;
|
|
if (isrational(p))
|
|
return MZERO(p->u.q.a);
|
|
if (isdouble(p))
|
|
return p->u.d == 0.0;
|
|
if (istensor(p)) {
|
|
for (i = 0; i < p->u.tensor->nelem; i++)
|
|
if (!iszero(p->u.tensor->elem[i]))
|
|
return 0;
|
|
return 1;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
isequaln(struct atom *p, int n)
|
|
{
|
|
return isequalq(p, n, 1);
|
|
}
|
|
|
|
int
|
|
isequalq(struct atom *p, int a, int b)
|
|
{
|
|
int sign;
|
|
if (isrational(p)) {
|
|
if (a < 0) {
|
|
sign = MMINUS;
|
|
a = -a;
|
|
} else
|
|
sign = MPLUS;
|
|
return p->sign == sign && MEQUAL(p->u.q.a, a) && MEQUAL(p->u.q.b, b);
|
|
}
|
|
if (isdouble(p))
|
|
return p->u.d == (double) a / b;
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
isplusone(struct atom *p)
|
|
{
|
|
return isequaln(p, 1);
|
|
}
|
|
|
|
int
|
|
isminusone(struct atom *p)
|
|
{
|
|
return isequaln(p, -1);
|
|
}
|
|
|
|
int
|
|
isinteger(struct atom *p)
|
|
{
|
|
return isrational(p) && MEQUAL(p->u.q.b, 1);
|
|
}
|
|
|
|
int
|
|
isfraction(struct atom *p)
|
|
{
|
|
return isrational(p) && !MEQUAL(p->u.q.b, 1);
|
|
}
|
|
|
|
int
|
|
isposint(struct atom *p)
|
|
{
|
|
return isinteger(p) && !isnegativenumber(p);
|
|
}
|
|
|
|
int
|
|
isradicalterm(struct atom *p)
|
|
{
|
|
return car(p) == symbol(MULTIPLY) && isnum(cadr(p)) && isradical(caddr(p));
|
|
}
|
|
|
|
int
|
|
isradical(struct atom *p)
|
|
{
|
|
return car(p) == symbol(POWER) && isposint(cadr(p)) && isfraction(caddr(p));
|
|
}
|
|
|
|
int
|
|
isnegativeterm(struct atom *p)
|
|
{
|
|
return isnegativenumber(p) || (car(p) == symbol(MULTIPLY) && isnegativenumber(cadr(p)));
|
|
}
|
|
|
|
int
|
|
isnegativenumber(struct atom *p)
|
|
{
|
|
if (isrational(p))
|
|
return p->sign == MMINUS;
|
|
else if (isdouble(p))
|
|
return p->u.d < 0.0;
|
|
else
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
isimaginaryterm(struct atom *p)
|
|
{
|
|
if (isimaginaryfactor(p))
|
|
return 1;
|
|
if (car(p) == symbol(MULTIPLY)) {
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
if (isimaginaryfactor(car(p)))
|
|
return 1;
|
|
p = cdr(p);
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
isimaginaryfactor(struct atom *p)
|
|
{
|
|
return car(p) == symbol(POWER) && isminusone(cadr(p));
|
|
}
|
|
|
|
int
|
|
iscomplexnumber(struct atom *p)
|
|
{
|
|
return isimaginarynumber(p) || (lengthf(p) == 3 && car(p) == symbol(ADD) && isnum(cadr(p)) && isimaginarynumber(caddr(p)));
|
|
}
|
|
|
|
int
|
|
isimaginarynumber(struct atom *p)
|
|
{
|
|
return isimaginaryunit(p) || (lengthf(p) == 3 && car(p) == symbol(MULTIPLY) && isnum(cadr(p)) && isimaginaryunit(caddr(p)));
|
|
}
|
|
|
|
int
|
|
isimaginaryunit(struct atom *p)
|
|
{
|
|
return car(p) == symbol(POWER) && isminusone(cadr(p)) && isequalq(caddr(p), 1, 2);
|
|
}
|
|
|
|
int
|
|
isoneoversqrttwo(struct atom *p)
|
|
{
|
|
return car(p) == symbol(POWER) && isequaln(cadr(p), 2) && isequalq(caddr(p), -1, 2);
|
|
}
|
|
|
|
int
|
|
isminusoneoversqrttwo(struct atom *p)
|
|
{
|
|
return lengthf(p) == 3 && car(p) == symbol(MULTIPLY) && isminusone(cadr(p)) && isoneoversqrttwo(caddr(p));
|
|
}
|
|
|
|
// x + y * (-1)^(1/2) where x and y are double?
|
|
|
|
int
|
|
isdoublez(struct atom *p)
|
|
{
|
|
if (car(p) == symbol(ADD)) {
|
|
|
|
if (lengthf(p) != 3)
|
|
return 0;
|
|
|
|
if (!isdouble(cadr(p))) // x
|
|
return 0;
|
|
|
|
p = caddr(p);
|
|
}
|
|
|
|
if (car(p) != symbol(MULTIPLY))
|
|
return 0;
|
|
|
|
if (lengthf(p) != 3)
|
|
return 0;
|
|
|
|
if (!isdouble(cadr(p))) // y
|
|
return 0;
|
|
|
|
p = caddr(p);
|
|
|
|
if (car(p) != symbol(POWER))
|
|
return 0;
|
|
|
|
if (!isminusone(cadr(p)))
|
|
return 0;
|
|
|
|
if (!isequalq(caddr(p), 1, 2))
|
|
return 0;
|
|
|
|
return 1;
|
|
}
|
|
|
|
int
|
|
isdenominator(struct atom *p)
|
|
{
|
|
if (car(p) == symbol(POWER) && isnegativenumber(caddr(p)))
|
|
return 1;
|
|
else if (isrational(p) && !MEQUAL(p->u.q.b, 1))
|
|
return 1;
|
|
else
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
isnumerator(struct atom *p)
|
|
{
|
|
if (car(p) == symbol(POWER) && isnegativenumber(caddr(p)))
|
|
return 0;
|
|
else if (isrational(p) && MEQUAL(p->u.q.a, 1))
|
|
return 0;
|
|
else
|
|
return 1;
|
|
}
|
|
|
|
int
|
|
hasdouble(struct atom *p)
|
|
{
|
|
if (iscons(p)) {
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
if (hasdouble(car(p)))
|
|
return 1;
|
|
p = cdr(p);
|
|
}
|
|
return 0;
|
|
}
|
|
return isdouble(p);
|
|
}
|
|
|
|
int
|
|
isdenormalpolar(struct atom *p)
|
|
{
|
|
if (car(p) == symbol(ADD)) {
|
|
p = cdr(p);
|
|
while (iscons(p)) {
|
|
if (isdenormalpolarterm(car(p)))
|
|
return 1;
|
|
p = cdr(p);
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
return isdenormalpolarterm(p);
|
|
}
|
|
|
|
// returns 1 if term is (coeff * i * pi) and coeff < 0 or coeff >= 1/2
|
|
|
|
int
|
|
isdenormalpolarterm(struct atom *p)
|
|
{
|
|
if (car(p) != symbol(MULTIPLY))
|
|
return 0;
|
|
|
|
if (lengthf(p) == 3 && isimaginaryunit(cadr(p)) && caddr(p) == symbol(PI))
|
|
return 1; // exp(i pi)
|
|
|
|
if (lengthf(p) != 4 || !isnum(cadr(p)) || !isimaginaryunit(caddr(p)) || cadddr(p) != symbol(PI))
|
|
return 0;
|
|
|
|
p = cadr(p); // p = coeff of term
|
|
|
|
if (isnegativenumber(p))
|
|
return 1; // p < 0
|
|
|
|
push(p);
|
|
push_rational(-1, 2);
|
|
add();
|
|
p = pop();
|
|
|
|
if (!isnegativenumber(p))
|
|
return 1; // p >= 1/2
|
|
|
|
return 0;
|
|
}
|
|
|
|
int
|
|
issquarematrix(struct atom *p)
|
|
{
|
|
return istensor(p) && p->u.tensor->ndim == 2 && p->u.tensor->dim[0] == p->u.tensor->dim[1];
|
|
}
|
|
|
|
int
|
|
issmallinteger(struct atom *p)
|
|
{
|
|
if (isinteger(p))
|
|
return MLENGTH(p->u.q.a) == 1 && p->u.q.a[0] <= 0x7fffffff;
|
|
|
|
if (isdouble(p))
|
|
return p->u.d == floor(p->u.d) && fabs(p->u.d) <= 0x7fffffff;
|
|
|
|
return 0;
|
|
}
|
|
|
|
// does f depend on x?
|
|
|
|
int
|
|
dependent(struct atom *f, struct atom *x)
|
|
{
|
|
if (equal(f, x))
|
|
return 1;
|
|
|
|
// a user function with no arguments?
|
|
|
|
if (isusersymbol(car(f)) && lengthf(f) == 1)
|
|
return 1;
|
|
|
|
while (iscons(f)) {
|
|
if (dependent(car(f), x))
|
|
return 1;
|
|
f = cdr(f);
|
|
}
|
|
|
|
return 0;
|
|
}
|
|
|
|
void
|
|
run(char *buf)
|
|
{
|
|
if (setjmp(jmpbuf))
|
|
return;
|
|
|
|
tos = 0;
|
|
interrupt = 0;
|
|
eval_level = 0;
|
|
gc_level = 0;
|
|
expanding = 1;
|
|
drawing = 0;
|
|
shuntflag = 0;
|
|
errorflag = 0;
|
|
breakflag = 0;
|
|
|
|
if (zero == NULL) {
|
|
srand((unsigned) time(NULL));
|
|
init_symbol_table();
|
|
push_bignum(MPLUS, mint(0), mint(1));
|
|
zero = pop();
|
|
push_bignum(MPLUS, mint(1), mint(1));
|
|
one = pop();
|
|
push_bignum(MMINUS, mint(1), mint(1));
|
|
minusone = pop();
|
|
push_symbol(POWER);
|
|
push_integer(-1);
|
|
push_rational(1, 2);
|
|
list(3);
|
|
imaginaryunit = pop();
|
|
run_init_script();
|
|
}
|
|
|
|
run_buf(buf);
|
|
}
|
|
|
|
void
|
|
run_buf(char *buf)
|
|
{
|
|
char *s, *save_trace1, *save_trace2;
|
|
struct atom *p1;
|
|
|
|
save_trace1 = trace1;
|
|
save_trace2 = trace2;
|
|
|
|
s = buf;
|
|
|
|
for (;;) {
|
|
|
|
s = scan_input(s); // also updates trace1 and trace2
|
|
|
|
if (s == NULL)
|
|
break; // end of input
|
|
|
|
dupl();
|
|
evalg();
|
|
|
|
// update last
|
|
|
|
dupl();
|
|
p1 = pop();
|
|
|
|
if (p1 != symbol(NIL))
|
|
set_symbol(symbol(LAST), p1, symbol(NIL));
|
|
|
|
print_result();
|
|
}
|
|
|
|
trace1 = save_trace1;
|
|
trace2 = save_trace2;
|
|
}
|
|
|
|
char *
|
|
scan_input(char *s)
|
|
{
|
|
struct atom *p1;
|
|
trace1 = s;
|
|
s = scan(s);
|
|
trace2 = s;
|
|
p1 = get_binding(symbol(TRACE));
|
|
if (p1 != symbol(TRACE) && !iszero(p1))
|
|
print_trace(BLUE);
|
|
return s;
|
|
}
|
|
|
|
void
|
|
print_trace(int color)
|
|
{
|
|
char c, *s;
|
|
if (trace1 == NULL || trace2 == NULL)
|
|
return;
|
|
outbuf_init();
|
|
c = '\n';
|
|
s = trace1;
|
|
while (*s && s < trace2) {
|
|
c = *s++;
|
|
outbuf_putc(c);
|
|
}
|
|
if (c != '\n')
|
|
outbuf_putc('\n');
|
|
printbuf(outbuf, color);
|
|
}
|
|
|
|
char *init_script =
|
|
"i = sqrt(-1)\n"
|
|
"grad(f) = d(f,(x,y,z))\n"
|
|
"cross(a,b) = (dot(a[2],b[3])-dot(a[3],b[2]),dot(a[3],b[1])-dot(a[1],b[3]),dot(a[1],b[2])-dot(a[2],b[1]))\n"
|
|
"curl(u) = (d(u[3],y)-d(u[2],z),d(u[1],z)-d(u[3],x),d(u[2],x)-d(u[1],y))\n"
|
|
"div(u) = d(u[1],x)+d(u[2],y)+d(u[3],z)\n"
|
|
"laguerre(x,n,m) = (n + m)! sum(k,0,n,(-x)^k / ((n - k)! (m + k)! k!))\n"
|
|
"legendre(f,n,m,x) = eval(1 / (2^n n!) (1 - x^2)^(m/2) d((x^2 - 1)^n,x,n + m),x,f)\n"
|
|
"hermite(x,n) = (-1)^n exp(x^2) d(exp(-x^2),x,n)\n"
|
|
"binomial(n,k) = n! / k! / (n - k)!\n"
|
|
"choose(n,k) = n! / k! / (n - k)!\n"
|
|
;
|
|
|
|
void
|
|
run_init_script(void)
|
|
{
|
|
run_buf(init_script);
|
|
}
|
|
|
|
void
|
|
stopf(char *s)
|
|
{
|
|
print_trace(RED);
|
|
snprintf(strbuf, STRBUFLEN, "Stop: %s\n", s);
|
|
printbuf(strbuf, RED);
|
|
longjmp(jmpbuf, 1);
|
|
}
|
|
// token_str and scan_str are pointers to the input string, for example
|
|
//
|
|
// | g | a | m | m | a | | a | l | p | h | a |
|
|
// ^ ^
|
|
// token_str scan_str
|
|
|
|
#define T_EXCLAM 33
|
|
#define T_QUOTEDBL 34
|
|
#define T_NUMBERSIGN 35
|
|
#define T_PARENLEFT 40
|
|
#define T_PARENRIGHT 41
|
|
#define T_ASTERISK 42
|
|
#define T_PLUS 43
|
|
#define T_COMMA 44
|
|
#define T_HYPHEN 45
|
|
#define T_PERIOD 46
|
|
#define T_SLASH 47
|
|
#define T_LESS 60
|
|
#define T_EQUAL 61
|
|
#define T_GREATER 62
|
|
#define T_BRACKETLEFT 91
|
|
#define T_BRACKETRIGHT 93
|
|
#define T_ASCIICIRCUM 94
|
|
#define T_INTEGER 1001
|
|
#define T_DOUBLE 1002
|
|
#define T_SYMBOL 1003
|
|
#define T_FUNCTION 1004
|
|
#define T_NEWLINE 1006
|
|
#define T_STRING 1007
|
|
#define T_GTEQ 1008
|
|
#define T_LTEQ 1009
|
|
#define T_EQ 1010
|
|
#define T_END 1011
|
|
|
|
int token;
|
|
int scan_mode;
|
|
int scan_level;
|
|
|
|
char *scan_str;
|
|
char *token_str;
|
|
char *token_buf;
|
|
int token_buf_len;
|
|
|
|
char *
|
|
scan(char *s)
|
|
{
|
|
scan_mode = 0;
|
|
return scan_nib(s);
|
|
}
|
|
|
|
char *
|
|
scan1(char *s)
|
|
{
|
|
scan_mode = 1; // mode for table of integrals
|
|
return scan_nib(s);
|
|
}
|
|
|
|
char *
|
|
scan_nib(char *s)
|
|
{
|
|
scan_str = s;
|
|
scan_level = 0;
|
|
get_token_skip_newlines();
|
|
if (token == T_END)
|
|
return NULL;
|
|
scan_stmt();
|
|
if (token != T_NEWLINE && token != T_END)
|
|
scan_error("syntax err"); // unexpected token, for example, 1:2
|
|
return scan_str;
|
|
}
|
|
|
|
void
|
|
scan_stmt(void)
|
|
{
|
|
scan_comparison();
|
|
if (token == '=') {
|
|
get_token_skip_newlines(); // get token after '='
|
|
push_symbol(SETQ);
|
|
swap();
|
|
scan_comparison();
|
|
list(3);
|
|
}
|
|
}
|
|
|
|
void
|
|
scan_comparison(void)
|
|
{
|
|
scan_expression();
|
|
switch (token) {
|
|
case T_EQ:
|
|
push_symbol(TESTEQ); // ==
|
|
break;
|
|
case T_LTEQ:
|
|
push_symbol(TESTLE);
|
|
break;
|
|
case T_GTEQ:
|
|
push_symbol(TESTGE);
|
|
break;
|
|
case '<':
|
|
push_symbol(TESTLT);
|
|
break;
|
|
case '>':
|
|
push_symbol(TESTGT);
|
|
break;
|
|
default:
|
|
return;
|
|
}
|
|
swap();
|
|
get_token_skip_newlines(); // get token after rel op
|
|
scan_expression();
|
|
list(3);
|
|
}
|
|
|
|
void
|
|
scan_expression(void)
|
|
{
|
|
int h = tos, t;
|
|
t = token;
|
|
if (token == '+' || token == '-')
|
|
get_token_skip_newlines();
|
|
scan_term();
|
|
if (t == '-')
|
|
static_negate();
|
|
while (token == '+' || token == '-') {
|
|
t = token;
|
|
get_token_skip_newlines(); // get token after '+' or '-'
|
|
scan_term();
|
|
if (t == '-')
|
|
static_negate();
|
|
}
|
|
if (tos - h > 1) {
|
|
list(tos - h);
|
|
push_symbol(ADD);
|
|
swap();
|
|
cons(); // prepend ADD to list
|
|
}
|
|
}
|
|
|
|
int
|
|
another_factor_pending(void)
|
|
{
|
|
switch (token) {
|
|
case '*':
|
|
case '/':
|
|
case '(':
|
|
case T_SYMBOL:
|
|
case T_FUNCTION:
|
|
case T_INTEGER:
|
|
case T_DOUBLE:
|
|
case T_STRING:
|
|
return 1;
|
|
default:
|
|
break;
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
void
|
|
scan_term(void)
|
|
{
|
|
int h = tos, t;
|
|
|
|
scan_power();
|
|
|
|
while (another_factor_pending()) {
|
|
|
|
t = token;
|
|
|
|
if (token == '*' || token == '/')
|
|
get_token_skip_newlines();
|
|
|
|
scan_power();
|
|
|
|
if (t == '/')
|
|
static_reciprocate();
|
|
}
|
|
|
|
if (tos - h > 1) {
|
|
list(tos - h);
|
|
push_symbol(MULTIPLY);
|
|
swap();
|
|
cons(); // prepend MULTIPLY to list
|
|
}
|
|
}
|
|
|
|
void
|
|
scan_power(void)
|
|
{
|
|
scan_factor();
|
|
if (token == '^') {
|
|
get_token_skip_newlines();
|
|
push_symbol(POWER);
|
|
swap();
|
|
scan_power();
|
|
list(3);
|
|
}
|
|
}
|
|
|
|
void
|
|
scan_factor(void)
|
|
{
|
|
int h = tos;
|
|
|
|
switch (token) {
|
|
|
|
case '(':
|
|
scan_subexpr();
|
|
break;
|
|
|
|
case T_SYMBOL:
|
|
scan_symbol();
|
|
break;
|
|
|
|
case T_FUNCTION:
|
|
scan_function_call();
|
|
break;
|
|
|
|
case T_INTEGER:
|
|
scan_integer();
|
|
get_token();
|
|
break;
|
|
|
|
case T_DOUBLE:
|
|
push_double(atof(token_buf));
|
|
get_token();
|
|
break;
|
|
|
|
case T_STRING:
|
|
scan_string();
|
|
break;
|
|
|
|
default:
|
|
scan_error("syntax err");
|
|
break;
|
|
}
|
|
|
|
// index
|
|
|
|
if (token == '[') {
|
|
scan_level++;
|
|
get_token(); // get token after '['
|
|
push_symbol(INDEX);
|
|
swap();
|
|
scan_expression();
|
|
while (token == ',') {
|
|
get_token(); // get token after ','
|
|
scan_expression();
|
|
}
|
|
if (token != ']')
|
|
scan_error("expected ']'");
|
|
scan_level--;
|
|
get_token(); // get token after ']'
|
|
list(tos - h);
|
|
}
|
|
|
|
while (token == '!') {
|
|
get_token(); // get token after '!'
|
|
push_symbol(FACTORIAL);
|
|
swap();
|
|
list(2);
|
|
}
|
|
}
|
|
|
|
void
|
|
scan_symbol(void)
|
|
{
|
|
if (scan_mode && strlen(token_buf) == 1)
|
|
switch (token_buf[0]) {
|
|
case 'a':
|
|
push_symbol(SA);
|
|
break;
|
|
case 'b':
|
|
push_symbol(SB);
|
|
break;
|
|
case 'x':
|
|
push_symbol(SX);
|
|
break;
|
|
default:
|
|
push(lookup(token_buf));
|
|
break;
|
|
}
|
|
else
|
|
push(lookup(token_buf));
|
|
get_token();
|
|
}
|
|
|
|
void
|
|
scan_string(void)
|
|
{
|
|
push_string(token_buf);
|
|
get_token();
|
|
}
|
|
|
|
void
|
|
scan_function_call(void)
|
|
{
|
|
int h = tos;
|
|
scan_level++;
|
|
push(lookup(token_buf)); // push function name
|
|
get_token(); // get token after function name
|
|
get_token(); // get token after '('
|
|
if (token == ')') {
|
|
scan_level--;
|
|
get_token(); // get token after ')'
|
|
list(1); // function call with no args
|
|
return;
|
|
}
|
|
scan_stmt();
|
|
while (token == ',') {
|
|
get_token(); // get token after ','
|
|
scan_stmt();
|
|
}
|
|
if (token != ')')
|
|
scan_error("expected ')'");
|
|
scan_level--;
|
|
get_token(); // get token after ')'
|
|
list(tos - h);
|
|
}
|
|
|
|
void
|
|
scan_integer(void)
|
|
{
|
|
int sign;
|
|
uint32_t *a;
|
|
switch (*token_buf) {
|
|
case '+':
|
|
sign = MPLUS;
|
|
a = mscan(token_buf + 1);
|
|
break;
|
|
case '-':
|
|
sign = MMINUS;
|
|
a = mscan(token_buf + 1);
|
|
break;
|
|
default:
|
|
sign = MPLUS;
|
|
a = mscan(token_buf);
|
|
break;
|
|
}
|
|
push_bignum(sign, a, mint(1));
|
|
}
|
|
|
|
void
|
|
scan_subexpr(void)
|
|
{
|
|
int h, i, n;
|
|
struct atom *p;
|
|
h = tos;
|
|
scan_level++;
|
|
get_token(); // get token after '('
|
|
scan_stmt();
|
|
while (token == ',') {
|
|
get_token(); // get token after ','
|
|
scan_stmt();
|
|
}
|
|
if (token != ')')
|
|
scan_error("expected ')'");
|
|
scan_level--;
|
|
get_token(); // get token after ')'
|
|
n = tos - h;
|
|
if (n < 2)
|
|
return;
|
|
p = alloc_vector(n);
|
|
for (i = 0; i < n; i++)
|
|
p->u.tensor->elem[i] = stack[h + i];
|
|
tos = h;
|
|
push(p);
|
|
}
|
|
|
|
void
|
|
get_token_skip_newlines(void)
|
|
{
|
|
scan_level++;
|
|
get_token();
|
|
scan_level--;
|
|
}
|
|
|
|
void
|
|
get_token(void)
|
|
{
|
|
get_token_nib();
|
|
if (scan_level)
|
|
while (token == T_NEWLINE)
|
|
get_token_nib();
|
|
}
|
|
|
|
void
|
|
get_token_nib(void)
|
|
{
|
|
// skip spaces
|
|
|
|
while (*scan_str != '\0' && *scan_str != '\n' && *scan_str != '\r' && (*scan_str < 33 || *scan_str > 126))
|
|
scan_str++;
|
|
|
|
token_str = scan_str;
|
|
|
|
// end of input?
|
|
|
|
if (*scan_str == '\0') {
|
|
token = T_END;
|
|
return;
|
|
}
|
|
|
|
// newline?
|
|
|
|
if (*scan_str == '\n' || *scan_str == '\r') {
|
|
scan_str++;
|
|
token = T_NEWLINE;
|
|
return;
|
|
}
|
|
|
|
// comment?
|
|
|
|
if (*scan_str == '#' || (scan_str[0] == '-' && scan_str[1] == '-')) {
|
|
while (*scan_str && *scan_str != '\n' && *scan_str != '\r')
|
|
scan_str++;
|
|
if (*scan_str)
|
|
scan_str++;
|
|
token = T_NEWLINE;
|
|
return;
|
|
}
|
|
|
|
// number?
|
|
|
|
if (isdigit((unsigned char)*scan_str) || *scan_str == '.') {
|
|
while (isdigit((unsigned char)*scan_str))
|
|
scan_str++;
|
|
if (*scan_str == '.') {
|
|
scan_str++;
|
|
while (isdigit((unsigned char)*scan_str))
|
|
scan_str++;
|
|
if (token_str + 1 == scan_str)
|
|
scan_error("expected decimal digit"); // only a decimal point
|
|
token = T_DOUBLE;
|
|
} else
|
|
token = T_INTEGER;
|
|
update_token_buf(token_str, scan_str);
|
|
return;
|
|
}
|
|
|
|
// symbol?
|
|
|
|
if (isalpha((unsigned char)*scan_str)) {
|
|
while (isalnum((unsigned char)*scan_str))
|
|
scan_str++;
|
|
if (*scan_str == '(')
|
|
token = T_FUNCTION;
|
|
else
|
|
token = T_SYMBOL;
|
|
update_token_buf(token_str, scan_str);
|
|
return;
|
|
}
|
|
|
|
// string?
|
|
|
|
if (*scan_str == '"') {
|
|
scan_str++;
|
|
while (*scan_str && *scan_str != '"' && *scan_str != '\n' && *scan_str != '\r')
|
|
scan_str++;
|
|
if (*scan_str != '"')
|
|
scan_error("runaway string");
|
|
scan_str++;
|
|
token = T_STRING;
|
|
update_token_buf(token_str + 1, scan_str - 1); // don't include quote chars
|
|
return;
|
|
}
|
|
|
|
// relational operator?
|
|
|
|
if (*scan_str == '=' && scan_str[1] == '=') {
|
|
scan_str += 2;
|
|
token = T_EQ;
|
|
return;
|
|
}
|
|
|
|
if (*scan_str == '<' && scan_str[1] == '=') {
|
|
scan_str += 2;
|
|
token = T_LTEQ;
|
|
return;
|
|
}
|
|
|
|
if (*scan_str == '>' && scan_str[1] == '=') {
|
|
scan_str += 2;
|
|
token = T_GTEQ;
|
|
return;
|
|
}
|
|
|
|
// single char token
|
|
|
|
token = *scan_str++;
|
|
}
|
|
|
|
void
|
|
update_token_buf(char *a, char *b)
|
|
{
|
|
int m, n;
|
|
|
|
n = (int) (b - a);
|
|
|
|
// Let n == 1000
|
|
|
|
// Then m == 2000 hence there is always room for the terminator '\0'
|
|
|
|
m = 1000 * (n / 1000 + 1); // m is a multiple of 1000
|
|
|
|
if (m > token_buf_len) {
|
|
if (token_buf)
|
|
free(token_buf);
|
|
token_buf = alloc_mem(m);
|
|
token_buf_len = m;
|
|
}
|
|
|
|
strncpy(token_buf, a, n);
|
|
token_buf[n] = '\0';
|
|
}
|
|
|
|
void
|
|
scan_error(char *errmsg)
|
|
{
|
|
trace2 = scan_str;
|
|
stopf(errmsg);
|
|
}
|
|
|
|
void
|
|
static_negate(void)
|
|
{
|
|
struct atom *p1;
|
|
|
|
p1 = pop();
|
|
|
|
if (isnum(p1)) {
|
|
push(p1);
|
|
negate();
|
|
return;
|
|
}
|
|
|
|
if (car(p1) == symbol(MULTIPLY)) {
|
|
push_symbol(MULTIPLY);
|
|
if (isnum(cadr(p1))) {
|
|
push(cadr(p1)); // A
|
|
negate();
|
|
push(cddr(p1)); // B
|
|
} else {
|
|
push_integer(-1); // A
|
|
push(cdr(p1)); // B
|
|
}
|
|
cons(); // prepend A to B
|
|
cons(); // prepend MULTIPLY
|
|
return;
|
|
}
|
|
|
|
push_symbol(MULTIPLY);
|
|
push_integer(-1);
|
|
push(p1);
|
|
list(3);
|
|
}
|
|
|
|
void
|
|
static_reciprocate(void)
|
|
{
|
|
struct atom *p1, *p2;
|
|
|
|
p2 = pop();
|
|
p1 = pop();
|
|
|
|
// save divide by zero error for runtime
|
|
|
|
if (iszero(p2)) {
|
|
push(p1);
|
|
push_symbol(POWER);
|
|
push(p2);
|
|
push_integer(-1);
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
if (isnum(p1) && isnum(p2)) {
|
|
push(p1);
|
|
push(p2);
|
|
divide();
|
|
return;
|
|
}
|
|
|
|
if (!isrational(p1) || !isequaln(p1, 1))
|
|
push(p1); // p1 != 1
|
|
|
|
if (isnum(p2)) {
|
|
push(p2);
|
|
reciprocate();
|
|
return;
|
|
}
|
|
|
|
if (car(p2) == symbol(POWER) && isnum(caddr(p2))) {
|
|
push_symbol(POWER);
|
|
push(cadr(p2));
|
|
push(caddr(p2));
|
|
negate();
|
|
list(3);
|
|
return;
|
|
}
|
|
|
|
push_symbol(POWER);
|
|
push(p2);
|
|
push_integer(-1);
|
|
list(3);
|
|
}
|
|
void
|
|
push(struct atom *p)
|
|
{
|
|
if (tos < 0 || tos >= STACKSIZE)
|
|
stopf("stack error");
|
|
stack[tos++] = p;
|
|
if (tos > max_tos)
|
|
max_tos = tos;
|
|
}
|
|
|
|
struct atom *
|
|
pop(void)
|
|
{
|
|
if (tos < 1 || tos > STACKSIZE)
|
|
stopf("stack error");
|
|
return stack[--tos];
|
|
}
|
|
|
|
void
|
|
save_symbol(struct atom *p)
|
|
{
|
|
push(p);
|
|
push(get_binding(p));
|
|
push(get_usrfunc(p));
|
|
}
|
|
|
|
void
|
|
restore_symbol(void)
|
|
{
|
|
struct atom *p1, *p2, *p3;
|
|
p3 = pop();
|
|
p2 = pop();
|
|
p1 = pop();
|
|
set_symbol(p1, p2, p3);
|
|
}
|
|
|
|
void
|
|
dupl(void)
|
|
{
|
|
struct atom *p1;
|
|
p1 = pop();
|
|
push(p1);
|
|
push(p1);
|
|
}
|
|
|
|
void
|
|
swap(void)
|
|
{
|
|
struct atom *p1, *p2;
|
|
p1 = pop();
|
|
p2 = pop();
|
|
push(p1);
|
|
push(p2);
|
|
}
|
|
|
|
void
|
|
push_integer(int n)
|
|
{
|
|
switch (n) {
|
|
case 0:
|
|
push(zero);
|
|
break;
|
|
case 1:
|
|
push(one);
|
|
break;
|
|
case -1:
|
|
push(minusone);
|
|
break;
|
|
default:
|
|
if (n < 0)
|
|
push_bignum(MMINUS, mint(-n), mint(1));
|
|
else
|
|
push_bignum(MPLUS, mint(n), mint(1));
|
|
break;
|
|
}
|
|
}
|
|
|
|
void
|
|
push_rational(int a, int b)
|
|
{
|
|
if (a < 0)
|
|
push_bignum(MMINUS, mint(-a), mint(b));
|
|
else
|
|
push_bignum(MPLUS, mint(a), mint(b));
|
|
}
|
|
|
|
void
|
|
push_bignum(int sign, uint32_t *a, uint32_t *b)
|
|
{
|
|
struct atom *p;
|
|
|
|
// normalize zero
|
|
|
|
if (MZERO(a)) {
|
|
sign = MPLUS;
|
|
if (!MEQUAL(b, 1)) {
|
|
mfree(b);
|
|
b = mint(1);
|
|
}
|
|
}
|
|
|
|
p = alloc_atom();
|
|
p->atomtype = RATIONAL;
|
|
p->sign = sign;
|
|
p->u.q.a = a;
|
|
p->u.q.b = b;
|
|
|
|
push(p);
|
|
}
|
|
|
|
int
|
|
pop_integer(void)
|
|
{
|
|
int n;
|
|
struct atom *p;
|
|
|
|
p = pop();
|
|
|
|
if (!issmallinteger(p))
|
|
stopf("small integer expected");
|
|
|
|
if (isrational(p)) {
|
|
n = p->u.q.a[0];
|
|
if (isnegativenumber(p))
|
|
n = -n;
|
|
} else
|
|
n = (int) p->u.d;
|
|
|
|
return n;
|
|
}
|
|
|
|
void
|
|
push_double(double d)
|
|
{
|
|
struct atom *p;
|
|
p = alloc_atom();
|
|
p->atomtype = DOUBLE;
|
|
p->u.d = d;
|
|
push(p);
|
|
}
|
|
|
|
double
|
|
pop_double(void)
|
|
{
|
|
double a, b, d;
|
|
struct atom *p;
|
|
|
|
p = pop();
|
|
|
|
if (!isnum(p))
|
|
stopf("number expected");
|
|
|
|
if (isdouble(p))
|
|
d = p->u.d;
|
|
else {
|
|
a = mfloat(p->u.q.a);
|
|
b = mfloat(p->u.q.b);
|
|
d = a / b;
|
|
if (isnegativenumber(p))
|
|
d = -d;
|
|
}
|
|
|
|
return d;
|
|
}
|
|
|
|
void
|
|
push_string(char *s)
|
|
{
|
|
struct atom *p;
|
|
p = alloc_str();
|
|
s = strdup(s);
|
|
if (s == NULL)
|
|
exit(1);
|
|
p->u.str = s;
|
|
push(p);
|
|
}
|
|
|
|
// start from stack + h and remove n items
|
|
|
|
void
|
|
slice(int h, int n)
|
|
{
|
|
int i, m;
|
|
m = tos - h - n;
|
|
if (m < 0)
|
|
stopf("stack slice error");
|
|
for (i = 0; i < m; i++)
|
|
stack[h + i] = stack[h + n + i];
|
|
tos -= n;
|
|
}
|
|
// symbol lookup, create symbol if not found
|
|
|
|
struct atom *
|
|
lookup(char *s)
|
|
{
|
|
int i, k;
|
|
struct atom *p;
|
|
|
|
if (isupper((unsigned char)*s))
|
|
k = BUCKETSIZE * (*s - 'A');
|
|
else if (islower((unsigned char)*s))
|
|
k = BUCKETSIZE * (*s - 'a');
|
|
else
|
|
k = BUCKETSIZE * 26;
|
|
|
|
for (i = 0; i < BUCKETSIZE; i++) {
|
|
p = symtab[k + i];
|
|
if (p == NULL)
|
|
break;
|
|
if (strcmp(s, printname(p)) == 0)
|
|
return p;
|
|
}
|
|
|
|
if (i == BUCKETSIZE)
|
|
stopf("symbol table full");
|
|
|
|
p = alloc_atom();
|
|
s = strdup(s);
|
|
if (s == NULL)
|
|
exit(1);
|
|
p->atomtype = USYM;
|
|
p->u.usym.name = s;
|
|
p->u.usym.index = k + i;
|
|
symtab[k + i] = p;
|
|
usym_count++;
|
|
|
|
return p;
|
|
}
|
|
|
|
char *
|
|
printname(struct atom *p)
|
|
{
|
|
if (iskeyword(p))
|
|
return p->u.ksym.name;
|
|
else if (isusersymbol(p))
|
|
return p->u.usym.name;
|
|
else
|
|
return "?";
|
|
}
|
|
|
|
void
|
|
set_symbol(struct atom *p1, struct atom *p2, struct atom *p3)
|
|
{
|
|
if (!isusersymbol(p1))
|
|
stopf("symbol error");
|
|
binding[p1->u.usym.index] = p2;
|
|
usrfunc[p1->u.usym.index] = p3;
|
|
}
|
|
|
|
struct atom *
|
|
get_binding(struct atom *p1)
|
|
{
|
|
struct atom *p2;
|
|
if (!isusersymbol(p1))
|
|
stopf("symbol error");
|
|
p2 = binding[p1->u.usym.index];
|
|
if (p2 == NULL || p2 == symbol(NIL))
|
|
p2 = p1; // symbol binds to itself
|
|
return p2;
|
|
}
|
|
|
|
struct atom *
|
|
get_usrfunc(struct atom *p)
|
|
{
|
|
if (!isusersymbol(p))
|
|
stopf("symbol error");
|
|
p = usrfunc[p->u.usym.index];
|
|
if (p == NULL)
|
|
p = symbol(NIL);
|
|
return p;
|
|
}
|
|
|
|
struct se {
|
|
char *str;
|
|
int index;
|
|
void (*func)(struct atom *);
|
|
} stab[] = {
|
|
|
|
{ "abs", ABS, eval_abs },
|
|
{ "adj", ADJ, eval_adj },
|
|
{ "and", AND, eval_and },
|
|
{ "arccos", ARCCOS, eval_arccos },
|
|
{ "arccosh", ARCCOSH, eval_arccosh },
|
|
{ "arcsin", ARCSIN, eval_arcsin },
|
|
{ "arcsinh", ARCSINH, eval_arcsinh },
|
|
{ "arctan", ARCTAN, eval_arctan },
|
|
{ "arctanh", ARCTANH, eval_arctanh },
|
|
{ "arg", ARG, eval_arg },
|
|
|
|
{ "binding", BINDING, eval_binding },
|
|
{ "break", BREAK, eval_break },
|
|
|
|
{ "C", C_UPPER, NULL },
|
|
{ "c", C_LOWER, NULL },
|
|
{ "ceiling", CEILING, eval_ceiling },
|
|
{ "check", CHECK, eval_check },
|
|
{ "circexp", CIRCEXP, eval_expform },
|
|
{ "clear", CLEAR, eval_clear },
|
|
{ "clock", CLOCK, eval_clock },
|
|
{ "cofactor", COFACTOR, eval_cofactor },
|
|
{ "conj", CONJ, eval_conj },
|
|
{ "contract", CONTRACT, eval_contract },
|
|
{ "cos", COS, eval_cos },
|
|
{ "cosh", COSH, eval_cosh },
|
|
|
|
{ "D", D_UPPER, NULL },
|
|
{ "d", D_LOWER, NULL },
|
|
{ "defint", DEFINT, eval_defint },
|
|
{ "denominator", DENOMINATOR, eval_denominator },
|
|
{ "derivative", DERIVATIVE, eval_derivative },
|
|
{ "det", DET, eval_det },
|
|
{ "dim", DIM, eval_dim },
|
|
{ "do", DO, eval_do },
|
|
{ "dot", DOT, eval_inner },
|
|
{ "draw", DRAW, eval_draw },
|
|
|
|
{ "eigenvec", EIGENVEC, eval_eigenvec },
|
|
{ "erf", ERF, eval_erf },
|
|
{ "erfc", ERFC, eval_erfc },
|
|
{ "eval", EVAL, eval_eval },
|
|
{ "exit", EXIT, eval_exit },
|
|
{ "exp", EXP, eval_exp },
|
|
{ "expcos", EXPCOS, eval_expcos },
|
|
{ "expcosh", EXPCOSH, eval_expcosh },
|
|
{ "expform", EXPFORM, eval_expform },
|
|
{ "expsin", EXPSIN, eval_expsin },
|
|
{ "expsinh", EXPSINH, eval_expsinh },
|
|
{ "exptan", EXPTAN, eval_exptan },
|
|
{ "exptanh", EXPTANH, eval_exptanh },
|
|
|
|
{ "factorial", FACTORIAL, eval_factorial },
|
|
{ "float", FLOATF, eval_float },
|
|
{ "floor", FLOOR, eval_floor },
|
|
{ "for", FOR, eval_for },
|
|
|
|
{ "H", H_UPPER, NULL },
|
|
{ "h", H_LOWER, NULL },
|
|
{ "hadamard", HADAMARD, eval_hadamard },
|
|
|
|
{ "I", I_UPPER, NULL },
|
|
{ "i", I_LOWER, NULL },
|
|
{ "imag", IMAG, eval_imag },
|
|
{ "infixform", INFIXFORM, eval_infixform },
|
|
{ "inner", INNER, eval_inner },
|
|
{ "integral", INTEGRAL, eval_integral },
|
|
{ "inv", INV, eval_inv },
|
|
|
|
{ "J", J_UPPER, NULL },
|
|
{ "j", J_LOWER, NULL },
|
|
|
|
{ "kronecker", KRONECKER, eval_kronecker },
|
|
|
|
{ "last", LAST, NULL },
|
|
{ "lgamma", LGAMMA, eval_lgamma },
|
|
{ "log", LOG, eval_log },
|
|
{ "loop", LOOP, eval_loop },
|
|
|
|
{ "mag", MAG, eval_mag },
|
|
{ "minor", MINOR, eval_minor },
|
|
{ "minormatrix", MINORMATRIX, eval_minormatrix },
|
|
{ "mod", MOD, eval_mod },
|
|
|
|
{ "nil", NIL, eval_nil },
|
|
{ "noexpand", NOEXPAND, eval_noexpand },
|
|
{ "not", NOT, eval_not },
|
|
{ "nroots", NROOTS, eval_nroots },
|
|
{ "number", NUMBER, eval_number },
|
|
{ "numerator", NUMERATOR, eval_numerator },
|
|
|
|
{ "or", OR, eval_or },
|
|
{ "outer", OUTER, eval_outer },
|
|
|
|
{ "p", P_LOWER, NULL },
|
|
{ "P", P_UPPER, NULL },
|
|
{ "pi", PI, NULL },
|
|
{ "polar", POLAR, eval_polar },
|
|
{ "prefixform", PREFIXFORM, eval_prefixform },
|
|
{ "print", PRINT, eval_print },
|
|
{ "product", PRODUCT, eval_product },
|
|
|
|
{ "Q", Q_UPPER, NULL },
|
|
{ "q", Q_LOWER, NULL },
|
|
{ "quote", QUOTE, eval_quote },
|
|
|
|
{ "R", R_UPPER, NULL },
|
|
{ "r", R_LOWER, NULL },
|
|
{ "rand", RAND, eval_rand },
|
|
{ "rank", RANK, eval_rank },
|
|
{ "rationalize", RATIONALIZE, eval_rationalize },
|
|
{ "real", REAL, eval_real },
|
|
{ "rect", RECTF, eval_rect },
|
|
{ "roots", ROOTS, eval_roots },
|
|
{ "rotate", ROTATE, eval_rotate },
|
|
{ "run", RUN, eval_run },
|
|
|
|
{ "S", S_UPPER, NULL },
|
|
{ "s", S_LOWER, NULL },
|
|
{ "sgn", SGN, eval_sgn },
|
|
{ "simplify", SIMPLIFY, eval_simplify },
|
|
{ "sin", SIN, eval_sin },
|
|
{ "sinh", SINH, eval_sinh },
|
|
{ "sqrt", SQRT, eval_sqrt },
|
|
{ "status", STATUS, eval_status },
|
|
{ "stop", STOP, eval_stop },
|
|
{ "sum", SUM, eval_sum },
|
|
|
|
{ "T", T_UPPER, NULL },
|
|
{ "t", T_LOWER, NULL },
|
|
{ "tan", TAN, eval_tan },
|
|
{ "tanh", TANH, eval_tanh },
|
|
{ "taylor", TAYLOR, eval_taylor },
|
|
{ "test", TEST, eval_test },
|
|
{ "testeq", TESTEQ, eval_testeq },
|
|
{ "testge", TESTGE, eval_testge },
|
|
{ "testgt", TESTGT, eval_testgt },
|
|
{ "testle", TESTLE, eval_testle },
|
|
{ "testlt", TESTLT, eval_testlt },
|
|
{ "tgamma", TGAMMA, eval_tgamma },
|
|
{ "trace", TRACE, NULL },
|
|
{ "transpose", TRANSPOSE, eval_transpose },
|
|
{ "tty", TTY, NULL },
|
|
|
|
{ "U", U_UPPER, NULL },
|
|
{ "u", U_LOWER, NULL },
|
|
{ "unit", UNIT, eval_unit },
|
|
|
|
{ "V", V_UPPER, NULL },
|
|
{ "v", V_LOWER, NULL },
|
|
|
|
{ "W", W_UPPER, NULL },
|
|
{ "w", W_LOWER, NULL },
|
|
|
|
{ "X", X_UPPER, NULL },
|
|
{ "x", X_LOWER, NULL },
|
|
|
|
{ "Y", Y_UPPER, NULL },
|
|
{ "y", Y_LOWER, NULL },
|
|
|
|
{ "Z", Z_UPPER, NULL },
|
|
{ "z", Z_LOWER, NULL },
|
|
{ "zero", ZERO, eval_zero },
|
|
|
|
{ "+", ADD, eval_add },
|
|
{ "*", MULTIPLY, eval_multiply },
|
|
{ "^", POWER, eval_power },
|
|
{ "[", INDEX, eval_index },
|
|
{ "=", SETQ, eval_setq },
|
|
{ "$e", EXP1, NULL },
|
|
{ "$a", SA, NULL },
|
|
{ "$b", SB, NULL },
|
|
{ "$x", SX, NULL },
|
|
{ "$arg1", ARG1, NULL },
|
|
{ "$arg2", ARG2, NULL },
|
|
{ "$arg3", ARG3, NULL },
|
|
{ "$arg4", ARG4, NULL },
|
|
{ "$arg5", ARG5, NULL },
|
|
{ "$arg6", ARG6, NULL },
|
|
{ "$arg7", ARG7, NULL },
|
|
{ "$arg8", ARG8, NULL },
|
|
{ "$arg9", ARG9, NULL },
|
|
};
|
|
|
|
void
|
|
init_symbol_table(void)
|
|
{
|
|
int i, n;
|
|
char *s;
|
|
struct atom *p;
|
|
|
|
for (i = 0; i < 27 * BUCKETSIZE; i++) {
|
|
symtab[i] = NULL;
|
|
binding[i] = NULL;
|
|
usrfunc[i] = NULL;
|
|
}
|
|
|
|
n = sizeof stab / sizeof (struct se);
|
|
|
|
for (i = 0; i < n; i++) {
|
|
p = alloc_atom();
|
|
s = strdup(stab[i].str);
|
|
if (s == NULL)
|
|
exit(1);
|
|
if (stab[i].func) {
|
|
p->atomtype = KSYM;
|
|
p->u.ksym.name = s;
|
|
p->u.ksym.func = stab[i].func;
|
|
ksym_count++;
|
|
} else {
|
|
p->atomtype = USYM;
|
|
p->u.usym.name = s;
|
|
p->u.usym.index = stab[i].index;
|
|
usym_count++;
|
|
}
|
|
symtab[stab[i].index] = p;
|
|
}
|
|
}
|
|
|
|
|
|
// This is the function which will be called from Python as cexample.add_ints(a, b).
|
|
static mp_obj_t example_add_ints(mp_obj_t a_obj, mp_obj_t b_obj) {
|
|
// Extract the ints from the micropython input objects.
|
|
int a = mp_obj_get_int(a_obj);
|
|
int b = mp_obj_get_int(b_obj);
|
|
|
|
// Calculate the addition and convert to MicroPython object.
|
|
return mp_obj_new_int(a + b);
|
|
}
|
|
// Define a Python reference to the function above.
|
|
static MP_DEFINE_CONST_FUN_OBJ_2(example_add_ints_obj, example_add_ints);
|
|
|
|
// This structure represents Timer instance objects.
|
|
typedef struct _example_Timer_obj_t {
|
|
// All objects start with the base.
|
|
mp_obj_base_t base;
|
|
// Everything below can be thought of as instance attributes, but they
|
|
// cannot be accessed by MicroPython code directly. In this example we
|
|
// store the time at which the object was created.
|
|
mp_uint_t start_time;
|
|
} example_Timer_obj_t;
|
|
|
|
// This is the Timer.time() method. After creating a Timer object, this
|
|
// can be called to get the time elapsed since creating the Timer.
|
|
static mp_obj_t example_Timer_time(mp_obj_t self_in) {
|
|
// The first argument is self. It is cast to the *example_Timer_obj_t
|
|
// type so we can read its attributes.
|
|
example_Timer_obj_t *self = MP_OBJ_TO_PTR(self_in);
|
|
|
|
// Get the elapsed time and return it as a MicroPython integer.
|
|
mp_uint_t elapsed = mp_hal_ticks_ms() - self->start_time;
|
|
return mp_obj_new_int_from_uint(elapsed);
|
|
}
|
|
static MP_DEFINE_CONST_FUN_OBJ_1(example_Timer_time_obj, example_Timer_time);
|
|
|
|
// This represents Timer.__new__ and Timer.__init__, which is called when
|
|
// the user instantiates a Timer object.
|
|
static mp_obj_t example_Timer_make_new(const mp_obj_type_t *type, size_t n_args, size_t n_kw, const mp_obj_t *args) {
|
|
// Allocates the new object and sets the type.
|
|
example_Timer_obj_t *self = mp_obj_malloc(example_Timer_obj_t, type);
|
|
|
|
// Initializes the time for this Timer instance.
|
|
self->start_time = mp_hal_ticks_ms();
|
|
|
|
// The make_new function always returns self.
|
|
return MP_OBJ_FROM_PTR(self);
|
|
}
|
|
|
|
// This collects all methods and other static class attributes of the Timer.
|
|
// The table structure is similar to the module table, as detailed below.
|
|
static const mp_rom_map_elem_t example_Timer_locals_dict_table[] = {
|
|
{ MP_ROM_QSTR(MP_QSTR_time), MP_ROM_PTR(&example_Timer_time_obj) },
|
|
};
|
|
static MP_DEFINE_CONST_DICT(example_Timer_locals_dict, example_Timer_locals_dict_table);
|
|
|
|
// This defines the type(Timer) object.
|
|
MP_DEFINE_CONST_OBJ_TYPE(
|
|
example_type_Timer,
|
|
MP_QSTR_Timer,
|
|
MP_TYPE_FLAG_NONE,
|
|
make_new, example_Timer_make_new,
|
|
locals_dict, &example_Timer_locals_dict
|
|
);
|
|
|
|
// What follows is a *separate* class definition that demonstrates more
|
|
// advanced techniques to implement other Python-like features, such as:
|
|
//
|
|
// - A custom representation for __repr__ and __str__.
|
|
// - Custom attribute handling to create a read/write "property".
|
|
//
|
|
// It reuses some of the elements of the basic Timer class. This is allowed
|
|
// because they both use example_Timer_obj_t as the instance structure.
|
|
|
|
// Handles AdvancedTimer.__repr__, AdvancedTimer.__str__.
|
|
static void example_AdvancedTimer_print(const mp_print_t *print, mp_obj_t self_in, mp_print_kind_t kind) {
|
|
|
|
// Get the elapsed time. In this case, it's also a demonstration of calling
|
|
// the equivalent of self.time() in the C API. This is not usually very
|
|
// efficient, but it can sometimes be useful.
|
|
mp_uint_t elapsed = mp_obj_get_int(example_Timer_time(self_in));
|
|
|
|
// We'll make all representations print at least the class name.
|
|
mp_printf(print, "%q()", (qstr)MP_QSTR_AdvancedTimer);
|
|
|
|
// Decide what else to print based on print kind.
|
|
if (kind == PRINT_STR) {
|
|
// For __str__, let's attempt to make it more readable.
|
|
mp_printf(print, " # created %d seconds ago", (int)(elapsed / 1000));
|
|
}
|
|
}
|
|
|
|
// Handles AdvancedTimer.seconds for reading and writing.
|
|
static void example_AdvancedTimer_attribute_handler(mp_obj_t self_in, qstr attr, mp_obj_t *dest) {
|
|
|
|
// In this example, we only want to handle the .seconds attribute in a
|
|
// special way.
|
|
if (attr != MP_QSTR_seconds) {
|
|
// Attribute not found, continue lookup in locals dict. This way,
|
|
// methods like .time() will be handled normally.
|
|
dest[1] = MP_OBJ_SENTINEL;
|
|
return;
|
|
}
|
|
|
|
// Get reference to AdvancedTimer instance.
|
|
example_Timer_obj_t *self = MP_OBJ_TO_PTR(self_in);
|
|
|
|
// Check if this is a read operation.
|
|
if (dest[0] == MP_OBJ_NULL) {
|
|
// It's read, so "return" elapsed seconds by storing it in dest[0].
|
|
mp_uint_t elapsed = mp_hal_ticks_ms() - self->start_time;
|
|
dest[0] = mp_obj_new_int_from_uint(elapsed / 1000);
|
|
return;
|
|
}
|
|
// Check if this is a delete or store operation.
|
|
else if (dest[0] == MP_OBJ_SENTINEL) {
|
|
// It's delete or store. Now check which one.
|
|
if (dest[1] == MP_OBJ_NULL) {
|
|
// It's delete. But in this example we don't want to allow it
|
|
// so we just return.
|
|
return;
|
|
} else {
|
|
// It's write. First, get the value that the user is trying to set.
|
|
mp_uint_t desired_ms = mp_obj_get_int(dest[1]) * 1000;
|
|
// Use it to update the start time. This way, the next read will
|
|
// report the updated time.
|
|
self->start_time = mp_hal_ticks_ms() - desired_ms;
|
|
|
|
// Indicate successful store.
|
|
dest[0] = MP_OBJ_NULL;
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
|
|
// This defines the type(AdvancedTimer) object.
|
|
MP_DEFINE_CONST_OBJ_TYPE(
|
|
example_type_AdvancedTimer,
|
|
MP_QSTR_AdvancedTimer,
|
|
MP_TYPE_FLAG_NONE,
|
|
attr, example_AdvancedTimer_attribute_handler,
|
|
print, example_AdvancedTimer_print,
|
|
make_new, example_Timer_make_new,
|
|
locals_dict, &example_Timer_locals_dict
|
|
);
|
|
|
|
// Define all attributes of the module.
|
|
// Table entries are key/value pairs of the attribute name (a string)
|
|
// and the MicroPython object reference.
|
|
// All identifiers and strings are written as MP_QSTR_xxx and will be
|
|
// optimized to word-sized integers by the build system (interned strings).
|
|
static const mp_rom_map_elem_t example_module_globals_table[] = {
|
|
{ MP_ROM_QSTR(MP_QSTR___name__), MP_ROM_QSTR(MP_QSTR_cexample) },
|
|
{ MP_ROM_QSTR(MP_QSTR_add_ints), MP_ROM_PTR(&example_add_ints_obj) },
|
|
{ MP_ROM_QSTR(MP_QSTR_Timer), MP_ROM_PTR(&example_type_Timer) },
|
|
{ MP_ROM_QSTR(MP_QSTR_AdvancedTimer), MP_ROM_PTR(&example_type_AdvancedTimer) },
|
|
};
|
|
static MP_DEFINE_CONST_DICT(example_module_globals, example_module_globals_table);
|
|
|
|
// Define module object.
|
|
const mp_obj_module_t example_user_cmodule = {
|
|
.base = { &mp_type_module },
|
|
.globals = (mp_obj_dict_t *)&example_module_globals,
|
|
};
|
|
|
|
// Register the module to make it available in Python.
|
|
MP_REGISTER_MODULE(MP_QSTR_cexample, example_user_cmodule); |