diff --git a/extmod/machine_spi.c b/extmod/machine_spi.c index 5be30e947..88dc79832 100644 --- a/extmod/machine_spi.c +++ b/extmod/machine_spi.c @@ -36,7 +36,8 @@ /******************************************************************************/ // MicroPython bindings for generic machine.SPI -static mp_obj_t machine_spi_init(size_t n_args, const mp_obj_t *args, mp_map_t *kw_args) { +static mp_obj_t machine_spi_init(size_t n_args, const mp_obj_t *args, mp_map_t *kw_args) +{ mp_obj_base_t *s = (mp_obj_base_t *)MP_OBJ_TO_PTR(args[0]); mp_machine_spi_p_t *spi_p = (mp_machine_spi_p_t *)MP_OBJ_TYPE_GET_SLOT(s->type, protocol); spi_p->init(s, n_args - 1, args + 1, kw_args); @@ -44,23 +45,50 @@ static mp_obj_t machine_spi_init(size_t n_args, const mp_obj_t *args, mp_map_t * } static MP_DEFINE_CONST_FUN_OBJ_KW(machine_spi_init_obj, 1, machine_spi_init); -static mp_obj_t machine_spi_deinit(mp_obj_t self) { +static mp_obj_t machine_spi_deinit(mp_obj_t self) +{ mp_obj_base_t *s = (mp_obj_base_t *)MP_OBJ_TO_PTR(self); mp_machine_spi_p_t *spi_p = (mp_machine_spi_p_t *)MP_OBJ_TYPE_GET_SLOT(s->type, protocol); - if (spi_p->deinit != NULL) { + if (spi_p->deinit != NULL) + { spi_p->deinit(s); } return mp_const_none; } static MP_DEFINE_CONST_FUN_OBJ_1(machine_spi_deinit_obj, machine_spi_deinit); -static void mp_machine_spi_transfer(mp_obj_t self, size_t len, const void *src, void *dest) { +static void mp_machine_spi_transfer(mp_obj_t self, size_t len, const void *src, void *dest) +{ mp_obj_base_t *s = (mp_obj_base_t *)MP_OBJ_TO_PTR(self); mp_machine_spi_p_t *spi_p = (mp_machine_spi_p_t *)MP_OBJ_TYPE_GET_SLOT(s->type, protocol); spi_p->transfer(s, len, src, dest); } -static mp_obj_t mp_machine_spi_read(size_t n_args, const mp_obj_t *args) { +static mp_obj_t mp_machine_spi_wait_done(size_t n_args, const mp_obj_t *args) +{ + mp_obj_base_t *s = (mp_obj_base_t *)MP_OBJ_TO_PTR(args[0]); + mp_machine_spi_p_t *spi_p = (mp_machine_spi_p_t *)MP_OBJ_TYPE_GET_SLOT(s->type, protocol); + if (spi_p->wait_done != NULL) + { + spi_p->wait_done(s); + } + return mp_const_none; +} +MP_DEFINE_CONST_FUN_OBJ_VAR_BETWEEN(mp_machine_spi_wait_done_obj, 1, 2, mp_machine_spi_wait_done); + +static mp_obj_t mp_machine_spi_set_tx_irq(size_t n_args, const mp_obj_t *args, mp_map_t *kw_args){ + mp_obj_base_t *s = (mp_obj_base_t *)MP_OBJ_TO_PTR(args[0]); + mp_machine_spi_p_t *spi_p = (mp_machine_spi_p_t *)MP_OBJ_TYPE_GET_SLOT(s->type, protocol); + if (spi_p->set_tx_isr != NULL) + { + spi_p->set_tx_isr(s, n_args - 1, args + 1, kw_args); + } + return mp_const_none; +} +static MP_DEFINE_CONST_FUN_OBJ_KW(machine_spi_set_tx_irq_obj, 1, mp_machine_spi_set_tx_irq); + +static mp_obj_t mp_machine_spi_read(size_t n_args, const mp_obj_t *args) +{ vstr_t vstr; vstr_init_len(&vstr, mp_obj_get_int(args[1])); memset(vstr.buf, n_args == 3 ? mp_obj_get_int(args[2]) : 0, vstr.len); @@ -69,7 +97,8 @@ static mp_obj_t mp_machine_spi_read(size_t n_args, const mp_obj_t *args) { } MP_DEFINE_CONST_FUN_OBJ_VAR_BETWEEN(mp_machine_spi_read_obj, 2, 3, mp_machine_spi_read); -static mp_obj_t mp_machine_spi_readinto(size_t n_args, const mp_obj_t *args) { +static mp_obj_t mp_machine_spi_readinto(size_t n_args, const mp_obj_t *args) +{ mp_buffer_info_t bufinfo; mp_get_buffer_raise(args[1], &bufinfo, MP_BUFFER_WRITE); memset(bufinfo.buf, n_args == 3 ? mp_obj_get_int(args[2]) : 0, bufinfo.len); @@ -78,7 +107,8 @@ static mp_obj_t mp_machine_spi_readinto(size_t n_args, const mp_obj_t *args) { } MP_DEFINE_CONST_FUN_OBJ_VAR_BETWEEN(mp_machine_spi_readinto_obj, 2, 3, mp_machine_spi_readinto); -static mp_obj_t mp_machine_spi_write(mp_obj_t self, mp_obj_t wr_buf) { +static mp_obj_t mp_machine_spi_write(mp_obj_t self, mp_obj_t wr_buf) +{ mp_buffer_info_t src; mp_get_buffer_raise(wr_buf, &src, MP_BUFFER_READ); mp_machine_spi_transfer(self, src.len, (const uint8_t *)src.buf, NULL); @@ -86,12 +116,14 @@ static mp_obj_t mp_machine_spi_write(mp_obj_t self, mp_obj_t wr_buf) { } MP_DEFINE_CONST_FUN_OBJ_2(mp_machine_spi_write_obj, mp_machine_spi_write); -static mp_obj_t mp_machine_spi_write_readinto(mp_obj_t self, mp_obj_t wr_buf, mp_obj_t rd_buf) { +static mp_obj_t mp_machine_spi_write_readinto(mp_obj_t self, mp_obj_t wr_buf, mp_obj_t rd_buf) +{ mp_buffer_info_t src; mp_get_buffer_raise(wr_buf, &src, MP_BUFFER_READ); mp_buffer_info_t dest; mp_get_buffer_raise(rd_buf, &dest, MP_BUFFER_WRITE); - if (src.len != dest.len) { + if (src.len != dest.len) + { mp_raise_ValueError(MP_ERROR_TEXT("buffers must be the same length")); } mp_machine_spi_transfer(self, src.len, src.buf, dest.buf); @@ -100,15 +132,17 @@ static mp_obj_t mp_machine_spi_write_readinto(mp_obj_t self, mp_obj_t wr_buf, mp MP_DEFINE_CONST_FUN_OBJ_3(mp_machine_spi_write_readinto_obj, mp_machine_spi_write_readinto); static const mp_rom_map_elem_t machine_spi_locals_dict_table[] = { - { MP_ROM_QSTR(MP_QSTR_init), MP_ROM_PTR(&machine_spi_init_obj) }, - { MP_ROM_QSTR(MP_QSTR_deinit), MP_ROM_PTR(&machine_spi_deinit_obj) }, - { MP_ROM_QSTR(MP_QSTR_read), MP_ROM_PTR(&mp_machine_spi_read_obj) }, - { MP_ROM_QSTR(MP_QSTR_readinto), MP_ROM_PTR(&mp_machine_spi_readinto_obj) }, - { MP_ROM_QSTR(MP_QSTR_write), MP_ROM_PTR(&mp_machine_spi_write_obj) }, - { MP_ROM_QSTR(MP_QSTR_write_readinto), MP_ROM_PTR(&mp_machine_spi_write_readinto_obj) }, + {MP_ROM_QSTR(MP_QSTR_init), MP_ROM_PTR(&machine_spi_init_obj)}, + {MP_ROM_QSTR(MP_QSTR_deinit), MP_ROM_PTR(&machine_spi_deinit_obj)}, + {MP_ROM_QSTR(MP_QSTR_read), MP_ROM_PTR(&mp_machine_spi_read_obj)}, + {MP_ROM_QSTR(MP_QSTR_readinto), MP_ROM_PTR(&mp_machine_spi_readinto_obj)}, + {MP_ROM_QSTR(MP_QSTR_write), MP_ROM_PTR(&mp_machine_spi_write_obj)}, + {MP_ROM_QSTR(MP_QSTR_write_readinto), MP_ROM_PTR(&mp_machine_spi_write_readinto_obj)}, + {MP_ROM_QSTR(MP_QSTR_wait_done), MP_ROM_PTR(&mp_machine_spi_wait_done_obj)}, + {MP_ROM_QSTR(MP_QSTR_set_tx_irq), MP_ROM_PTR(&machine_spi_set_tx_irq_obj)}, - { MP_ROM_QSTR(MP_QSTR_MSB), MP_ROM_INT(MICROPY_PY_MACHINE_SPI_MSB) }, - { MP_ROM_QSTR(MP_QSTR_LSB), MP_ROM_INT(MICROPY_PY_MACHINE_SPI_LSB) }, + {MP_ROM_QSTR(MP_QSTR_MSB), MP_ROM_INT(MICROPY_PY_MACHINE_SPI_MSB)}, + {MP_ROM_QSTR(MP_QSTR_LSB), MP_ROM_INT(MICROPY_PY_MACHINE_SPI_LSB)}, }; MP_DEFINE_CONST_DICT(mp_machine_spi_locals_dict, machine_spi_locals_dict_table); @@ -119,52 +153,71 @@ MP_DEFINE_CONST_DICT(mp_machine_spi_locals_dict, machine_spi_locals_dict_table); #if MICROPY_PY_MACHINE_SOFTSPI -static uint32_t baudrate_from_delay_half(uint32_t delay_half) { - #ifdef MICROPY_HW_SOFTSPI_MIN_DELAY - if (delay_half == MICROPY_HW_SOFTSPI_MIN_DELAY) { +static uint32_t baudrate_from_delay_half(uint32_t delay_half) +{ +#ifdef MICROPY_HW_SOFTSPI_MIN_DELAY + if (delay_half == MICROPY_HW_SOFTSPI_MIN_DELAY) + { return MICROPY_HW_SOFTSPI_MAX_BAUDRATE; - } else - #endif + } + else +#endif { return 500000 / delay_half; } } -static uint32_t baudrate_to_delay_half(uint32_t baudrate) { - #ifdef MICROPY_HW_SOFTSPI_MIN_DELAY - if (baudrate >= MICROPY_HW_SOFTSPI_MAX_BAUDRATE) { +static uint32_t baudrate_to_delay_half(uint32_t baudrate) +{ +#ifdef MICROPY_HW_SOFTSPI_MIN_DELAY + if (baudrate >= MICROPY_HW_SOFTSPI_MAX_BAUDRATE) + { return MICROPY_HW_SOFTSPI_MIN_DELAY; - } else - #endif + } + else +#endif { uint32_t delay_half = 500000 / baudrate; // round delay_half up so that: actual_baudrate <= requested_baudrate - if (500000 % baudrate != 0) { + if (500000 % baudrate != 0) + { delay_half += 1; } return delay_half; } } -static void mp_machine_soft_spi_print(const mp_print_t *print, mp_obj_t self_in, mp_print_kind_t kind) { +static void mp_machine_soft_spi_print(const mp_print_t *print, mp_obj_t self_in, mp_print_kind_t kind) +{ mp_machine_soft_spi_obj_t *self = MP_OBJ_TO_PTR(self_in); mp_printf(print, "SoftSPI(baudrate=%u, polarity=%u, phase=%u, firstbit=%u," - " sck=" MP_HAL_PIN_FMT ", mosi=" MP_HAL_PIN_FMT ", miso=" MP_HAL_PIN_FMT ")", - baudrate_from_delay_half(self->spi.delay_half), self->spi.polarity, self->spi.phase, self->spi.firstbit, - mp_hal_pin_name(self->spi.sck), mp_hal_pin_name(self->spi.mosi), mp_hal_pin_name(self->spi.miso)); + " sck=" MP_HAL_PIN_FMT ", mosi=" MP_HAL_PIN_FMT ", miso=" MP_HAL_PIN_FMT ")", + baudrate_from_delay_half(self->spi.delay_half), self->spi.polarity, self->spi.phase, self->spi.firstbit, + mp_hal_pin_name(self->spi.sck), mp_hal_pin_name(self->spi.mosi), mp_hal_pin_name(self->spi.miso)); } -static mp_obj_t mp_machine_soft_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n_kw, const mp_obj_t *all_args) { - enum { ARG_baudrate, ARG_polarity, ARG_phase, ARG_bits, ARG_firstbit, ARG_sck, ARG_mosi, ARG_miso }; +static mp_obj_t mp_machine_soft_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n_kw, const mp_obj_t *all_args) +{ + enum + { + ARG_baudrate, + ARG_polarity, + ARG_phase, + ARG_bits, + ARG_firstbit, + ARG_sck, + ARG_mosi, + ARG_miso + }; static const mp_arg_t allowed_args[] = { - { MP_QSTR_baudrate, MP_ARG_INT, {.u_int = 500000} }, - { MP_QSTR_polarity, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = 0} }, - { MP_QSTR_phase, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = 0} }, - { MP_QSTR_bits, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = 8} }, - { MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = MICROPY_PY_MACHINE_SPI_MSB} }, - { MP_QSTR_sck, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL} }, - { MP_QSTR_mosi, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL} }, - { MP_QSTR_miso, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL} }, + {MP_QSTR_baudrate, MP_ARG_INT, {.u_int = 500000}}, + {MP_QSTR_polarity, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = 0}}, + {MP_QSTR_phase, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = 0}}, + {MP_QSTR_bits, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = 8}}, + {MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = MICROPY_PY_MACHINE_SPI_MSB}}, + {MP_QSTR_sck, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL}}, + {MP_QSTR_mosi, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL}}, + {MP_QSTR_miso, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL}}, }; mp_arg_val_t args[MP_ARRAY_SIZE(allowed_args)]; mp_arg_parse_all_kw_array(n_args, n_kw, all_args, MP_ARRAY_SIZE(allowed_args), allowed_args, args); @@ -176,13 +229,13 @@ static mp_obj_t mp_machine_soft_spi_make_new(const mp_obj_type_t *type, size_t n self->spi.delay_half = baudrate_to_delay_half(args[ARG_baudrate].u_int); self->spi.polarity = args[ARG_polarity].u_int; self->spi.phase = args[ARG_phase].u_int; - if (args[ARG_bits].u_int != 8) { + if (args[ARG_bits].u_int != 8) + { mp_raise_ValueError(MP_ERROR_TEXT("bits must be 8")); } self->spi.firstbit = args[ARG_firstbit].u_int; - if (args[ARG_sck].u_obj == MP_OBJ_NULL - || args[ARG_mosi].u_obj == MP_OBJ_NULL - || args[ARG_miso].u_obj == MP_OBJ_NULL) { + if (args[ARG_sck].u_obj == MP_OBJ_NULL || args[ARG_mosi].u_obj == MP_OBJ_NULL || args[ARG_miso].u_obj == MP_OBJ_NULL) + { mp_raise_ValueError(MP_ERROR_TEXT("must specify all of sck/mosi/miso")); } self->spi.sck = mp_hal_get_pin_obj(args[ARG_sck].u_obj); @@ -195,41 +248,58 @@ static mp_obj_t mp_machine_soft_spi_make_new(const mp_obj_type_t *type, size_t n return MP_OBJ_FROM_PTR(self); } -static void mp_machine_soft_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj_t *pos_args, mp_map_t *kw_args) { +static void mp_machine_soft_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj_t *pos_args, mp_map_t *kw_args) +{ mp_machine_soft_spi_obj_t *self = (mp_machine_soft_spi_obj_t *)self_in; - enum { ARG_baudrate, ARG_polarity, ARG_phase, ARG_firstbit, ARG_sck, ARG_mosi, ARG_miso }; + enum + { + ARG_baudrate, + ARG_polarity, + ARG_phase, + ARG_firstbit, + ARG_sck, + ARG_mosi, + ARG_miso + }; static const mp_arg_t allowed_args[] = { - { MP_QSTR_baudrate, MP_ARG_INT, {.u_int = -1} }, - { MP_QSTR_polarity, MP_ARG_INT, {.u_int = -1} }, - { MP_QSTR_phase, MP_ARG_INT, {.u_int = -1} }, - { MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, - { MP_QSTR_sck, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL} }, - { MP_QSTR_mosi, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL} }, - { MP_QSTR_miso, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL} }, + {MP_QSTR_baudrate, MP_ARG_INT, {.u_int = -1}}, + {MP_QSTR_polarity, MP_ARG_INT, {.u_int = -1}}, + {MP_QSTR_phase, MP_ARG_INT, {.u_int = -1}}, + {MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, + {MP_QSTR_sck, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL}}, + {MP_QSTR_mosi, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL}}, + {MP_QSTR_miso, MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_obj = MP_OBJ_NULL}}, }; mp_arg_val_t args[MP_ARRAY_SIZE(allowed_args)]; mp_arg_parse_all(n_args, pos_args, kw_args, MP_ARRAY_SIZE(allowed_args), allowed_args, args); - if (args[ARG_baudrate].u_int != -1) { + if (args[ARG_baudrate].u_int != -1) + { self->spi.delay_half = baudrate_to_delay_half(args[ARG_baudrate].u_int); } - if (args[ARG_polarity].u_int != -1) { + if (args[ARG_polarity].u_int != -1) + { self->spi.polarity = args[ARG_polarity].u_int; } - if (args[ARG_phase].u_int != -1) { + if (args[ARG_phase].u_int != -1) + { self->spi.phase = args[ARG_phase].u_int; } - if (args[ARG_firstbit].u_int != -1) { + if (args[ARG_firstbit].u_int != -1) + { self->spi.firstbit = args[ARG_firstbit].u_int; } - if (args[ARG_sck].u_obj != MP_OBJ_NULL) { + if (args[ARG_sck].u_obj != MP_OBJ_NULL) + { self->spi.sck = mp_hal_get_pin_obj(args[ARG_sck].u_obj); } - if (args[ARG_mosi].u_obj != MP_OBJ_NULL) { + if (args[ARG_mosi].u_obj != MP_OBJ_NULL) + { self->spi.mosi = mp_hal_get_pin_obj(args[ARG_mosi].u_obj); } - if (args[ARG_miso].u_obj != MP_OBJ_NULL) { + if (args[ARG_miso].u_obj != MP_OBJ_NULL) + { self->spi.miso = mp_hal_get_pin_obj(args[ARG_miso].u_obj); } @@ -237,7 +307,8 @@ static void mp_machine_soft_spi_init(mp_obj_base_t *self_in, size_t n_args, cons mp_soft_spi_ioctl(&self->spi, MP_SPI_IOCTL_INIT); } -static void mp_machine_soft_spi_transfer(mp_obj_base_t *self_in, size_t len, const uint8_t *src, uint8_t *dest) { +static void mp_machine_soft_spi_transfer(mp_obj_base_t *self_in, size_t len, const uint8_t *src, uint8_t *dest) +{ mp_machine_soft_spi_obj_t *self = (mp_machine_soft_spi_obj_t *)self_in; mp_soft_spi_transfer(&self->spi, len, src, dest); } @@ -255,7 +326,6 @@ MP_DEFINE_CONST_OBJ_TYPE( make_new, mp_machine_soft_spi_make_new, print, mp_machine_soft_spi_print, protocol, &mp_machine_soft_spi_p, - locals_dict, &mp_machine_spi_locals_dict - ); + locals_dict, &mp_machine_spi_locals_dict); #endif // MICROPY_PY_MACHINE_SOFTSPI diff --git a/extmod/modmachine.h b/extmod/modmachine.h index 7c16ed302..4e8177b00 100644 --- a/extmod/modmachine.h +++ b/extmod/modmachine.h @@ -89,29 +89,35 @@ #endif // Temporary support for legacy construction of SoftI2C via I2C type. -#define MP_MACHINE_I2C_CHECK_FOR_LEGACY_SOFTI2C_CONSTRUCTION(n_args, n_kw, all_args) \ - do { \ - if (n_args == 0 || all_args[0] == MP_OBJ_NEW_SMALL_INT(-1)) { \ - mp_print_str(MICROPY_ERROR_PRINTER, "Warning: I2C(-1, ...) is deprecated, use SoftI2C(...) instead\n"); \ - if (n_args != 0) { \ - --n_args; \ - ++all_args; \ - } \ +#define MP_MACHINE_I2C_CHECK_FOR_LEGACY_SOFTI2C_CONSTRUCTION(n_args, n_kw, all_args) \ + do \ + { \ + if (n_args == 0 || all_args[0] == MP_OBJ_NEW_SMALL_INT(-1)) \ + { \ + mp_print_str(MICROPY_ERROR_PRINTER, "Warning: I2C(-1, ...) is deprecated, use SoftI2C(...) instead\n"); \ + if (n_args != 0) \ + { \ + --n_args; \ + ++all_args; \ + } \ return MP_OBJ_TYPE_GET_SLOT(&mp_machine_soft_i2c_type, make_new)(&mp_machine_soft_i2c_type, n_args, n_kw, all_args); \ - } \ + } \ } while (0) // Temporary support for legacy construction of SoftSPI via SPI type. -#define MP_MACHINE_SPI_CHECK_FOR_LEGACY_SOFTSPI_CONSTRUCTION(n_args, n_kw, all_args) \ - do { \ - if (n_args == 0 || all_args[0] == MP_OBJ_NEW_SMALL_INT(-1)) { \ - mp_print_str(MICROPY_ERROR_PRINTER, "Warning: SPI(-1, ...) is deprecated, use SoftSPI(...) instead\n"); \ - if (n_args != 0) { \ - --n_args; \ - ++all_args; \ - } \ +#define MP_MACHINE_SPI_CHECK_FOR_LEGACY_SOFTSPI_CONSTRUCTION(n_args, n_kw, all_args) \ + do \ + { \ + if (n_args == 0 || all_args[0] == MP_OBJ_NEW_SMALL_INT(-1)) \ + { \ + mp_print_str(MICROPY_ERROR_PRINTER, "Warning: SPI(-1, ...) is deprecated, use SoftSPI(...) instead\n"); \ + if (n_args != 0) \ + { \ + --n_args; \ + ++all_args; \ + } \ return MP_OBJ_TYPE_GET_SLOT(&mp_machine_soft_spi_type, make_new)(&mp_machine_soft_spi_type, n_args, n_kw, all_args); \ - } \ + } \ } while (0) #if MICROPY_PY_MACHINE_I2C || MICROPY_PY_MACHINE_SOFTI2C @@ -134,14 +140,16 @@ typedef struct _machine_pwm_obj_t machine_pwm_obj_t; typedef struct _machine_uart_obj_t machine_uart_obj_t; typedef struct _machine_wdt_obj_t machine_wdt_obj_t; -typedef struct _machine_mem_obj_t { +typedef struct _machine_mem_obj_t +{ mp_obj_base_t base; unsigned elem_size; // in bytes } machine_mem_obj_t; #if MICROPY_PY_MACHINE_I2C || MICROPY_PY_MACHINE_SOFTI2C -typedef struct _mp_machine_i2c_buf_t { +typedef struct _mp_machine_i2c_buf_t +{ size_t len; uint8_t *buf; } mp_machine_i2c_buf_t; @@ -151,10 +159,11 @@ typedef struct _mp_machine_i2c_buf_t { // - start/stop/read/write can be NULL, meaning operation is not supported // - transfer must be non-NULL // - transfer_single only needs to be set if transfer=mp_machine_i2c_transfer_adaptor -typedef struct _mp_machine_i2c_p_t { - #if MICROPY_PY_MACHINE_I2C_TRANSFER_WRITE1 +typedef struct _mp_machine_i2c_p_t +{ +#if MICROPY_PY_MACHINE_I2C_TRANSFER_WRITE1 bool transfer_supports_write1; - #endif +#endif void (*init)(mp_obj_base_t *obj, size_t n_args, const mp_obj_t *pos_args, mp_map_t *kw_args); int (*start)(mp_obj_base_t *obj); int (*stop)(mp_obj_base_t *obj); @@ -165,7 +174,8 @@ typedef struct _mp_machine_i2c_p_t { } mp_machine_i2c_p_t; // SoftI2C object. -typedef struct _mp_machine_soft_i2c_obj_t { +typedef struct _mp_machine_soft_i2c_obj_t +{ mp_obj_base_t base; uint32_t us_delay; uint32_t us_timeout; @@ -178,14 +188,18 @@ typedef struct _mp_machine_soft_i2c_obj_t { #if MICROPY_PY_MACHINE_SPI || MICROPY_PY_MACHINE_SOFTSPI // SPI protocol. -typedef struct _mp_machine_spi_p_t { +typedef struct _mp_machine_spi_p_t +{ void (*init)(mp_obj_base_t *obj, size_t n_args, const mp_obj_t *pos_args, mp_map_t *kw_args); void (*deinit)(mp_obj_base_t *obj); // can be NULL void (*transfer)(mp_obj_base_t *obj, size_t len, const uint8_t *src, uint8_t *dest); + void (*wait_done)(mp_obj_base_t *obj); // can be NULL + void (*set_tx_isr)(mp_obj_base_t *obj, size_t n_args, const mp_obj_t *pos_args, mp_map_t *kw_args); // can be NULL } mp_machine_spi_p_t; // SoftSPI object. -typedef struct _mp_machine_soft_spi_obj_t { +typedef struct _mp_machine_soft_spi_obj_t +{ mp_obj_base_t base; mp_soft_spi_obj_t spi; } mp_machine_soft_spi_obj_t; diff --git a/make_and_flash_rp2.sh b/make_and_flash_rp2.sh new file mode 100755 index 000000000..85c2141fa --- /dev/null +++ b/make_and_flash_rp2.sh @@ -0,0 +1,17 @@ + +rm -rf ./ports/rp2/build-RPI_PICO/* + +make -j -C ports/rp2 BOARD=RPI_PICO USER_C_MODULES=../../user_modules/user.cmake +exit status=$? +# 检查编译是否成功 +if [ $? -eq 0 ]; then + echo "编译成功，开始烧录固件..." + sudo mount /dev/sde1 /mnt/usb + sudo cp ./ports/rp2/build-RPI_PICO/firmware.uf2 /mnt/usb/ + sudo umount /mnt/usb + echo "Firmware flashed to RPI_PICO" + echo "You can now safely eject the RPI_PICO from your computer." +else + echo "编译失败，已取消烧录操作" + exit 1 +fi \ No newline at end of file diff --git a/ports/rp2/boards/RPI_PICO/mpconfigboard.h b/ports/rp2/boards/RPI_PICO/mpconfigboard.h index 7f34cffce..43d167b88 100644 --- a/ports/rp2/boards/RPI_PICO/mpconfigboard.h +++ b/ports/rp2/boards/RPI_PICO/mpconfigboard.h @@ -2,4 +2,4 @@ #define MICROPY_HW_BOARD_NAME "Raspberry Pi Pico" // Modified from MPY origin to reduce flash storage to accommodate larger program flash requirement // of lvgl and its bindings. Developers should review this setting when adding additional features -#define MICROPY_HW_FLASH_STORAGE_BYTES (1024 * 1024) +#define MICROPY_HW_FLASH_STORAGE_BYTES (512 * 1024) diff --git a/ports/rp2/machine_spi.c b/ports/rp2/machine_spi.c index abf0a70bd..82fc2cc53 100644 --- a/ports/rp2/machine_spi.c +++ b/ports/rp2/machine_spi.c @@ -25,8 +25,10 @@ */ #include "py/runtime.h" +#include "py/gc.h" #include "py/mphal.h" #include "py/mperrno.h" +#include "shared/runtime/mpirq.h" #include "extmod/modmachine.h" #include "hardware/spi.h" @@ -101,6 +103,10 @@ typedef struct _machine_spi_obj_t { uint8_t mosi; uint8_t miso; uint32_t baudrate; + int chan_tx; + int chan_rx; + // 这里只为屏幕设置了tx中断，用来控制cs引脚和lv.disp_flush_ready() + mp_irq_obj_t *tx_isr_obj; } machine_spi_obj_t; static machine_spi_obj_t machine_spi_obj[] = { @@ -109,12 +115,20 @@ static machine_spi_obj_t machine_spi_obj[] = { DEFAULT_SPI_POLARITY, DEFAULT_SPI_PHASE, DEFAULT_SPI_BITS, DEFAULT_SPI_FIRSTBIT, MICROPY_HW_SPI0_SCK, MICROPY_HW_SPI0_MOSI, MICROPY_HW_SPI0_MISO, 0, + // DMA channels, -1 means not claimed + -1, + -1, + NULL }, { {&machine_spi_type}, spi1, 1, DEFAULT_SPI_POLARITY, DEFAULT_SPI_PHASE, DEFAULT_SPI_BITS, DEFAULT_SPI_FIRSTBIT, MICROPY_HW_SPI1_SCK, MICROPY_HW_SPI1_MOSI, MICROPY_HW_SPI1_MISO, 0, + // DMA channels, -1 means not claimed + -1, + -1, + NULL }, }; @@ -166,6 +180,8 @@ mp_obj_t machine_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n mp_raise_ValueError(MP_ERROR_TEXT("bad MOSI pin")); } self->mosi = mosi; + if (self->chan_tx < 0) + self->chan_tx = dma_claim_unused_channel(true); } if (args[ARG_miso].u_obj != mp_const_none) { int miso = mp_hal_get_pin_obj(args[ARG_miso].u_obj); @@ -173,6 +189,8 @@ mp_obj_t machine_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n mp_raise_ValueError(MP_ERROR_TEXT("bad MISO pin")); } self->miso = miso; + if (self->chan_rx < 0) + self->chan_rx = dma_claim_unused_channel(true); } // Initialise the SPI peripheral if any arguments given, or it was not initialised previously. @@ -233,73 +251,206 @@ static void machine_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj } if (args[ARG_firstbit].u_int != -1) { self->firstbit = args[ARG_firstbit].u_int; - if (self->firstbit == SPI_LSB_FIRST) { + if (self->firstbit == SPI_LSB_FIRST) + { mp_raise_NotImplementedError(MP_ERROR_TEXT("LSB")); } } + if (self->miso > 0 && self->chan_rx < 0) { + self->chan_rx = dma_claim_unused_channel(true); + } + if (self->mosi > 0 && self->chan_tx < 0) { + self->chan_tx = dma_claim_unused_channel(true); + } if (set_format) { spi_set_format(self->spi_inst, self->bits, self->polarity, self->phase, self->firstbit); } } +static void machine_spi0_tx_irq_handler(void) +{ + // currently only used for spi0 + // mp_printf(&mp_plat_print, "program running isr spi0 tx irq %d\n", __LINE__); + machine_spi_obj_t *self = &machine_spi_obj[0]; + spi_hw_t *spi_hw = spi_get_hw(self->spi_inst); + // clear the interrupt flag + spi_hw->imsc &= ~(1 << 3); + // 检查是否是发送FIFO中断（已屏蔽的中断） + // if (spi_hw->mis & (1 << 3)) { // TXMIS=1 + // 确认发送真正完成：发送FIFO为空且SPI不忙 + // mp_raise_msg_varg(&mp_type_AssertionError, MP_ERROR_TEXT("IRQ triggered")); + if ((spi_hw->sr & (1 << 0)) && !(spi_hw->sr & (1 << 4)) && dma_channel_is_busy(self->chan_tx) == false) { + if (self->tx_isr_obj != NULL && self->tx_isr_obj->handler != mp_const_none) + { + // mp_printf(&mp_plat_print, "program running isr spi0 tx irq %d\n", __LINE__); + if(self->tx_isr_obj->ishard){ + // mp_sched_lock(); + // gc_lock(); + mp_call_function_1(self->tx_isr_obj->handler, self->tx_isr_obj->parent); + // gc_unlock(); + // mp_sched_unlock(); + } else { + mp_irq_handler(self->tx_isr_obj); + } + } + } + // } +} + + +static void machine_spi1_tx_irq_handler(void) +{ + // currently not used + machine_spi_obj_t *self = &machine_spi_obj[1]; + spi_hw_t *spi_hw = spi_get_hw(self->spi_inst); + // clear the interrupt flag + spi_hw->imsc &= ~(1 << 3); + if (spi_hw->mis & (1 << 3)) { // TXMIS=1 + // 确认发送真正完成：发送FIFO为空且SPI不忙 + if ((spi_hw->sr & (1 << 0)) && !(spi_hw->sr & (1 << 4))) { + if (self->tx_isr_obj != NULL && self->tx_isr_obj->handler != mp_const_none) + { + mp_irq_handler(self->tx_isr_obj); + } + } + } +} + + +static void machine_spi_set_tx_isr(mp_obj_base_t *self_in, size_t n_args, const mp_obj_t *pos_args, mp_map_t *kw_args) +{ + machine_spi_obj_t *self = (machine_spi_obj_t *)self_in; + if (self->tx_isr_obj == NULL) { + self->tx_isr_obj = m_new_obj(mp_irq_obj_t); + // MP_STATE_PORT(rp2_uart_irq_obj)[self->uart_id] = self->mp_irq_obj; + } + enum + { + ARG_tx_isr, + ARG_hard + }; + static const mp_arg_t allowed_args[] = { + {MP_QSTR_tx_isr, MP_ARG_REQUIRED | MP_ARG_OBJ, {.u_obj = mp_const_none}}, + { MP_QSTR_hard, MP_ARG_BOOL, {.u_bool = false} }, + }; + mp_arg_val_t args[MP_ARRAY_SIZE(allowed_args)]; + mp_arg_parse_all(n_args, pos_args, kw_args, MP_ARRAY_SIZE(allowed_args), allowed_args, args); + + if (n_args < 1) { + mp_raise_ValueError(MP_ERROR_TEXT("missing tx_isr")); + } + mp_obj_t handler = args[ARG_tx_isr].u_obj; + if (handler == mp_const_none || !mp_obj_is_callable(handler)) { + mp_raise_ValueError(MP_ERROR_TEXT("handler must be callable")); + } + if (self->tx_isr_obj == NULL) { + // disable previous irq + } + irq_set_enabled(self->spi_id == 0 ? SPI0_IRQ : SPI1_IRQ, false); + self->tx_isr_obj->handler = handler; + // self->tx_isr_obj->base.type = &mp_type_irq; + // self->tx_isr_obj->methods = &mp_irq_methods; + self->tx_isr_obj->ishard = args[ARG_hard].u_bool; + self->tx_isr_obj->parent = MP_OBJ_FROM_PTR(self); + + + irq_set_exclusive_handler(self->spi_id == 0 ? SPI0_IRQ : SPI1_IRQ, self->spi_id == 0 ? machine_spi0_tx_irq_handler : machine_spi1_tx_irq_handler); + spi_hw_t *spi_hw = spi_get_hw(self->spi_inst); + spi_hw->imsc |= (1 << 3); + irq_set_enabled(self->spi_id == 0 ? SPI0_IRQ : SPI1_IRQ, true); + +} + +static void machine_spi_wait_done(mp_obj_base_t *self_in) +{ + machine_spi_obj_t *self = (machine_spi_obj_t *)self_in; + int chan_tx = self->chan_tx; + int chan_rx = self->chan_rx; + if (chan_rx >= 0) + dma_channel_wait_for_finish_blocking(chan_rx); + if (chan_tx >= 0) + dma_channel_wait_for_finish_blocking(chan_tx); + spi_hw_t *spi_hw = spi_get_hw(self->spi_inst); + while (!((spi_hw->sr & (1 << 0)) && !(spi_hw->sr & (1 << 4)))) { + // wait for TX FIFO to be empty and SPI not busy + } +} + static void machine_spi_transfer(mp_obj_base_t *self_in, size_t len, const uint8_t *src, uint8_t *dest) { machine_spi_obj_t *self = (machine_spi_obj_t *)self_in; - // Use DMA for large transfers if channels are available - const size_t dma_min_size_threshold = 32; - int chan_tx = -1; - int chan_rx = -1; - if (len >= dma_min_size_threshold) { - // Use two DMA channels to service the two FIFOs - chan_tx = dma_claim_unused_channel(false); - chan_rx = dma_claim_unused_channel(false); - } - bool use_dma = chan_rx >= 0 && chan_tx >= 0; - // note src is guaranteed to be non-NULL bool write_only = dest == NULL; + const size_t dma_min_size_threshold = 8; + if (len <= dma_min_size_threshold){ + // Use software for small transfers + if (write_only) { + spi_write_blocking(self->spi_inst, src, len); + } else { + spi_write_read_blocking(self->spi_inst, src, dest, len); + } + return; + } + // Use DMA for large transfers if channels are available + int chan_tx = self->chan_tx; + int chan_rx = self->chan_rx; + if (chan_rx < 0 && chan_tx < 0) + { + mp_raise_msg_varg(&mp_type_RuntimeError, MP_ERROR_TEXT("Error when using DMA, chan rx: %d, chan tx: %d"), chan_rx, chan_tx); + return; + } + // if (chan_rx >= 0) + // dma_channel_wait_for_finish_blocking(chan_rx); + // if (chan_tx >= 0) + // dma_channel_wait_for_finish_blocking(chan_tx); + machine_spi_wait_done(self_in); + // bool use_dma = chan_rx >= 0 && chan_tx >= 0; + // note src is guaranteed to be non-NULL - if (use_dma) { - uint8_t dev_null; - dma_channel_config c = dma_channel_get_default_config(chan_tx); + uint8_t dev_null; + dma_channel_config c; + if (chan_tx >= 0) + { + c = dma_channel_get_default_config(chan_tx); channel_config_set_transfer_data_size(&c, DMA_SIZE_8); channel_config_set_dreq(&c, spi_get_index(self->spi_inst) ? DREQ_SPI1_TX : DREQ_SPI0_TX); dma_channel_configure(chan_tx, &c, - &spi_get_hw(self->spi_inst)->dr, - src, - len, - false); - + &spi_get_hw(self->spi_inst)->dr, + src, + len, + true); + } + if (chan_rx >= 0) + { c = dma_channel_get_default_config(chan_rx); channel_config_set_transfer_data_size(&c, DMA_SIZE_8); channel_config_set_dreq(&c, spi_get_index(self->spi_inst) ? DREQ_SPI1_RX : DREQ_SPI0_RX); channel_config_set_read_increment(&c, false); channel_config_set_write_increment(&c, !write_only); dma_channel_configure(chan_rx, &c, - write_only ? &dev_null : dest, - &spi_get_hw(self->spi_inst)->dr, - len, - false); - - dma_start_channel_mask((1u << chan_rx) | (1u << chan_tx)); - dma_channel_wait_for_finish_blocking(chan_rx); - dma_channel_wait_for_finish_blocking(chan_tx); + write_only ? &dev_null : dest, + &spi_get_hw(self->spi_inst)->dr, + len, + true); } + // dma_channel_wait_for_finish_blocking(chan_rx); + // dma_channel_wait_for_finish_blocking(chan_tx); + // If we have claimed only one channel successfully, we should release immediately - if (chan_rx >= 0) { - dma_channel_unclaim(chan_rx); - } - if (chan_tx >= 0) { - dma_channel_unclaim(chan_tx); - } + // if (chan_rx >= 0) { + // dma_channel_unclaim(chan_rx); + // } + // if (chan_tx >= 0) { + // dma_channel_unclaim(chan_tx); + // } - if (!use_dma) { - // Use software for small transfers, or if couldn't claim two DMA channels - if (write_only) { - spi_write_blocking(self->spi_inst, src, len); - } else { - spi_write_read_blocking(self->spi_inst, src, dest, len); - } - } + // if (!use_dma) { + // // Use software for small transfers, or if couldn't claim two DMA channels + // if (write_only) { + // spi_write_blocking(self->spi_inst, src, len); + // } else { + // spi_write_read_blocking(self->spi_inst, src, dest, len); + // } + // } } // Buffer protocol implementation for SPI. @@ -317,6 +468,8 @@ static mp_int_t machine_spi_get_buffer(mp_obj_t o_in, mp_buffer_info_t *bufinfo, static const mp_machine_spi_p_t machine_spi_p = { .init = machine_spi_init, .transfer = machine_spi_transfer, + .wait_done = machine_spi_wait_done, + .set_tx_isr = machine_spi_set_tx_isr, }; MP_DEFINE_CONST_OBJ_TYPE( @@ -334,11 +487,11 @@ mp_obj_base_t *mp_hal_get_spi_obj(mp_obj_t o) { if (mp_obj_is_type(o, &machine_spi_type)) { return MP_OBJ_TO_PTR(o); } - #if MICROPY_PY_MACHINE_SOFTSPI +#if MICROPY_PY_MACHINE_SOFTSPI else if (mp_obj_is_type(o, &mp_machine_soft_spi_type)) { return MP_OBJ_TO_PTR(o); } - #endif +#endif else { mp_raise_TypeError(MP_ERROR_TEXT("expecting an SPI object")); } diff --git a/user_modules/eigenmath/eheap.c b/user_modules/eigenmath/eheap.c new file mode 100644 index 000000000..d61564b13 --- /dev/null +++ b/user_modules/eigenmath/eheap.c @@ -0,0 +1,341 @@ +/*======================================================================== + * eheap.c – Improved standalone heap manager + * 32-bit, aligned, safe operations + *======================================================================*/ + + #include "eheap.h" + #include + #include + #include + #include "py/runtime.h" + + #ifndef EHEAP_ALIGN + #define EHEAP_ALIGN 4 /* default byte alignment (power of two) */ + #endif + + #define ALIGN_MASK (EHEAP_ALIGN - 1) + #define ALIGN_UP(x) (((x) + ALIGN_MASK) & ~ALIGN_MASK) + + /*-------------------------------------------------- block header layout */ + typedef struct block_link { + struct block_link *next; + size_t size; /* MSB=1 => allocated, lower bits => block size */ + } block_t; + + #define USED_MASK ((size_t)1 << (sizeof(size_t)*8 - 1)) + #define IS_USED(b) (((b)->size) & USED_MASK) + #define MARK_USED(b) ((b)->size |= USED_MASK) + #define MARK_FREE(b) ((b)->size &= ~USED_MASK) + #define BLOCK_SIZE(b) ((b)->size & ~USED_MASK) + + #define HDR_SIZE ALIGN_UP(sizeof(block_t)) + #define MIN_SPLIT (HDR_SIZE * 2) + + /*-------------------------------------------------- heap globals */ + static uint8_t *heap_base = NULL; + static uint8_t *heap_end = NULL; + static size_t heap_total = 0; + + static block_t start_node; /* dummy head */ + static block_t end_marker; /* tail sentinel storage */ + static block_t *end_node = &end_marker; + + static size_t free_bytes = 0; + static size_t min_free = 0; + static bool initialized = false; + + /*-------------------------------------------------------------------*/ + static bool is_valid_block(block_t *blk) { + uint8_t *ptr = (uint8_t*)blk; + if (ptr < heap_base || ptr >= heap_end) return false; + return (((uintptr_t)ptr - (uintptr_t)heap_base) & ALIGN_MASK) == 0; + } + +/* Insert and coalesce a free block (address-ordered), with overflow guards */ +static void insert_free(block_t *blk) { + if (!is_valid_block(blk) || IS_USED(blk)) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("insert_free: invalid or used block")); + return; + } + size_t blk_sz = BLOCK_SIZE(blk); + /* guard pointer addition overflow */ + if (blk_sz > (size_t)(heap_end - (uint8_t*)blk)) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("insert_free: block size overflow")); + return; + } + uint8_t *blk_end = (uint8_t*)blk + blk_sz; + + block_t *prev = &start_node; + /* find insertion point */ + while (prev->next < blk && prev->next != end_node) { + prev = prev->next; + if (!is_valid_block(prev)) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("insert_free: corrupted free list")); + return; + } + } + + /* forward merge */ + if (prev->next != end_node) { + block_t *fwd = prev->next; + if (!IS_USED(fwd) && + (uint8_t*)fwd == blk_end) { + /* fuse sizes */ + size_t total = blk_sz + BLOCK_SIZE(fwd); + if (total < blk_sz) { /* overflow? */ + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("insert_free: combine overflow")); + return; + } + blk->size = total; + blk->next = fwd->next; + blk_sz = total; /* update for potential backward merge */ + } else { + blk->next = fwd; + } + } else { + blk->next = end_node; + } + + /* backward merge */ + if (prev != &start_node && !IS_USED(prev)) { + uint8_t *prev_end = (uint8_t*)prev + BLOCK_SIZE(prev); + if (prev_end == (uint8_t*)blk) { + size_t total = BLOCK_SIZE(prev) + blk_sz; + if (total < BLOCK_SIZE(prev)) { /* overflow? */ + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("insert_free: combine overflow")); + return; + } + prev->size = total; + prev->next = blk->next; + return; + } + } + prev->next = blk; +} + + static void heap_init_once(void) { + if (initialized) return; + + /* single free block covers [heap_base .. heap_end) excluding end_node */ + block_t *first = (block_t*)heap_base; + first->size = (heap_total - HDR_SIZE); + MARK_FREE(first); + first->next = end_node; + + start_node.next = first; + start_node.size = 0; + + /* initialize end marker */ + end_node->next = NULL; + end_node->size = 0; + MARK_USED(end_node); + + free_bytes = BLOCK_SIZE(first); + min_free = free_bytes; + initialized = true; + } + + void eheap_init(void *buf, size_t bytes) { + if (!buf || bytes <= HDR_SIZE*2 + ALIGN_MASK) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("eheap_init: invalid region")); + return; + } + + /* align base upward */ + uintptr_t start = ALIGN_UP((uintptr_t)buf); + size_t loss = start - (uintptr_t)buf; + bytes = (bytes > loss) ? bytes - loss : 0; + bytes = (bytes / EHEAP_ALIGN) * EHEAP_ALIGN; + if (bytes <= HDR_SIZE*2) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("eheap_init: too small after align")); + return; + } + + heap_base = (uint8_t*)start; + heap_total = bytes; + + /* reserve tail for end_node */ + size_t res = ALIGN_UP(sizeof(block_t)); + heap_total -= res; + end_node = (block_t*)(heap_base + heap_total); + + heap_end = heap_base + heap_total; + + initialized = false; + heap_init_once(); + } + + void* e_malloc(size_t size) { + if (size == 0 || !initialized) return NULL; + + /* check overflow */ + if (size > SIZE_MAX - HDR_SIZE) return NULL; + size_t needed = ALIGN_UP(size + HDR_SIZE); + + block_t *prev = &start_node; + block_t *cur = start_node.next; + + while (cur != end_node) { + if (!is_valid_block(cur)) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("e_malloc: corrupted heap")); + return NULL; + } + if (!IS_USED(cur) && BLOCK_SIZE(cur) >= needed) { + size_t remain = BLOCK_SIZE(cur) - needed; + if (remain >= MIN_SPLIT) { + /* split */ + block_t *split = (block_t*)((uint8_t*)cur + needed); + split->size = remain; + MARK_FREE(split); + split->next = cur->next; + + cur->size = needed; + prev->next = split; + } else { + /* use entire */ + prev->next = cur->next; + needed = BLOCK_SIZE(cur); + } + MARK_USED(cur); + + free_bytes -= needed; + if (free_bytes < min_free) min_free = free_bytes; + return (uint8_t*)cur + HDR_SIZE; + } + prev = cur; + cur = cur->next; + } + return NULL; + } + + void e_free(void *ptr) { + if (!ptr || !initialized) return; + + uint8_t *p = (uint8_t*)ptr; + if (p < heap_base + HDR_SIZE || p >= heap_end) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("e_free: invalid ptr")); + return; + } + if (((uintptr_t)p - HDR_SIZE) & ALIGN_MASK) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("e_free: unaligned ptr")); + return; + } + + block_t *blk = (block_t*)(p - HDR_SIZE); + if (!IS_USED(blk)) { + //mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("e_free: double free")); + return; + } + + size_t sz = BLOCK_SIZE(blk); + if (sz == 0 || (uint8_t*)blk + sz > heap_end) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("e_free: bad size")); + return; + } + + MARK_FREE(blk); + free_bytes += sz; + insert_free(blk); + } + + void* e_realloc(void *ptr, size_t new_size) { + if (!ptr) return e_malloc(new_size); + if (new_size == 0) { e_free(ptr); return NULL; } + if (!initialized) return NULL; + + uint8_t *p = (uint8_t*)ptr; + if (p < heap_base + HDR_SIZE || p >= heap_end) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("e_realloc: invalid ptr")); + return NULL; + } + + block_t *blk = (block_t*)(p - HDR_SIZE); + if (!IS_USED(blk)) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("e_realloc: block not used")); + return NULL; + } + + size_t curr = BLOCK_SIZE(blk) - HDR_SIZE; + if (new_size <= curr) return ptr; + + /* try expand into next free block */ + uint8_t *next_addr = (uint8_t*)blk + BLOCK_SIZE(blk); + if (next_addr + HDR_SIZE <= heap_end) { + block_t *next = (block_t*)next_addr; + if (is_valid_block(next) && !IS_USED(next)) { + size_t combined = BLOCK_SIZE(blk) + BLOCK_SIZE(next); + size_t need = ALIGN_UP(new_size + HDR_SIZE); + if (combined >= need) { + /* remove next from free list */ + block_t *prev = &start_node; + while (prev->next != next && prev->next != end_node) { + prev = prev->next; + } + if (prev->next == next) { + prev->next = next->next; + /* compute new free_bytes: remove next size */ + free_bytes -= BLOCK_SIZE(next); + + /* update blk size */ + blk->size = (blk->size & USED_MASK) | need; + size_t leftover = combined - need; + if (leftover >= MIN_SPLIT) { + block_t *split = (block_t*)((uint8_t*)blk + need); + split->size = leftover; + MARK_FREE(split); + insert_free(split); + } else { + /* absorb all */ + blk->size = (blk->size & USED_MASK) | combined; + } + if (free_bytes < min_free) min_free = free_bytes; + return ptr; + } + } + } + } + + /* fallback: alloc-copy-free */ + void *nptr = e_malloc(new_size); + if (nptr) { + memcpy(nptr, ptr, curr); + e_free(ptr); + } + return nptr; + } + + size_t e_heap_free(void) { return free_bytes; } + size_t e_heap_min_free(void) { return min_free; } + + + int e_heap_fragmentation(void) { + if (!initialized || free_bytes == 0) return 0; + size_t largest = 0; + for (block_t *b = start_node.next; b != end_node; b = b->next) { + if (!IS_USED(b) && BLOCK_SIZE(b) > largest) { + largest = BLOCK_SIZE(b); + } + } + if (largest == 0) return 100; + return (int)(100 - (largest * 100) / free_bytes); + } + + bool e_heap_validate(void) { + if (!initialized) return false; + size_t counted = 0; + for (block_t *b = start_node.next; b != end_node; b = b->next) { + if (!is_valid_block(b)) return false; + if ((uint8_t*)b + BLOCK_SIZE(b) > heap_end) return false; + if (!IS_USED(b)) { + counted += BLOCK_SIZE(b); + /* ensure no adjacent free blocks */ + block_t *n = b->next; + if (n != end_node && !IS_USED(n) && + (uint8_t*)b + BLOCK_SIZE(b) == (uint8_t*)n) { + return false; + } + } + } + return (counted == free_bytes); + } + \ No newline at end of file diff --git a/user_modules/eigenmath/eheap.h b/user_modules/eigenmath/eheap.h new file mode 100644 index 000000000..09545cd38 --- /dev/null +++ b/user_modules/eigenmath/eheap.h @@ -0,0 +1,33 @@ +/*======================================================================== + * eheap.h – Minimal standalone heap manager (Freertos heap_4 style) + * --------------------------------------------------------------------- + * API: + * void eheap_init(void *buffer, size_t size); + * void* e_malloc(size_t bytes); + * void e_free(void *ptr); + * void* e_realloc(void *ptr, size_t new_size); + * size_t e_heap_free(void); + * size_t e_heap_min_free(void); + *======================================================================*/ + + #ifndef EHEAP_H + #define EHEAP_H + + #include + + #ifdef __cplusplus + extern "C" { + #endif + + void eheap_init(void *buffer, size_t size); + void* e_malloc(size_t size); + void e_free(void *ptr); + void* e_realloc(void *ptr, size_t new_size); + size_t e_heap_free(void); + size_t e_heap_min_free(void); + int e_heap_fragmentation(void); + #ifdef __cplusplus + } + #endif + + #endif /* EHEAP_H */ \ No newline at end of file diff --git a/user_modules/eigenmath/eigenmath.c b/user_modules/eigenmath/eigenmath.c new file mode 100644 index 000000000..80c6c593b --- /dev/null +++ b/user_modules/eigenmath/eigenmath.c @@ -0,0 +1,18471 @@ +/* +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 +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "eigenmath.h" +#include "eheap.h" +#include "py/obj.h" +//#include "py/mpconfig.h" +#include "py/misc.h" +#include "py/runtime.h" +#include "py/objstr.h" +#include "eigenmath.h" +//#define STACKSIZE 100000 // evaluation stack +//#define BLOCKSIZE 10000 +//#define MAXBLOCKS 2000 +//#define BUCKETSIZE 100 +//#define STRBUFLEN 1000 +//#define MAXDIM 24 + + +uint32_t STACKSIZE ; +uint32_t MAXATOMS ; // 10,240 atoms + + +// 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 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 LOG (11 * BUCKETSIZE + 1) + +#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 RANK (17 * BUCKETSIZE + 2) +#define RATIONALIZE (17 * BUCKETSIZE + 3) +#define REAL (17 * BUCKETSIZE + 4) +#define RECTF (17 * BUCKETSIZE + 5) +#define ROOTS (17 * BUCKETSIZE + 6) +#define ROTATE (17 * BUCKETSIZE + 7) +#define RUN (17 * BUCKETSIZE + 8) + +#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 TRACE (19 * BUCKETSIZE + 11) +#define TRANSPOSE (19 * BUCKETSIZE + 12) +#define TTY (19 * BUCKETSIZE + 13) + +#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__); +#define Trace mp_printf(&mp_plat_print,"[TRACE]%s:%d\n",__func__,__LINE__); + +bool noprint = false; + + +extern struct atom *mem; // an array of pointers +extern struct atom *free_list; +extern int tos; // top of stack +extern struct atom **stack; +extern struct atom **symtab; +extern struct atom **binding; +extern struct atom **usrfunc; +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 nonstop; +extern int interrupt; +extern jmp_buf jmpbuf0; +extern jmp_buf jmpbuf1; +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; + + +void init_block(struct atom *mem); +struct atom * alloc_atom(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 evalg(void); +void evalf(void); +void evalf_nib(struct atom *p1); +void evalp(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_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 dd(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 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_nib(struct atom *F, struct atom *X); +void integral_lookup(int h, struct atom *F); +int integral_classify(struct atom *p); +int integral_search(int h, struct atom *F, const char * const *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 eval_inv(struct atom *p1); +void inv(void); +void eval_kronecker(struct atom *p1); +void kronecker(void); +void eval_log(struct atom *p1); +void logfunc(void); +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_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 sgn(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_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 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); +//int main(int argc, char *argv[]); +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); +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); +void exitf(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); + +void eigenmath_init(uint8_t *pHeap,size_t heapSize){ + eheap_init((void *)pHeap, heapSize); + uint32_t sizeOfpAtom = sizeof(struct atom *); + uint32_t sizeOfAtom = sizeof(struct atom); + //init atom pool + MAXATOMS=((heapSize/sizeOfAtom)*4)/10; + STACKSIZE=MAXATOMS/12; + //mp_printf(&mp_plat_print,"heapsize=%d,mem size = %d\n", heapSize,(uint32_t)(sizeof (struct atom) * MAXATOMS)); + mem = e_malloc(sizeof (struct atom) * MAXATOMS); + if (mem == NULL) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("Failed to initialize mem")); + return; + } + init_block(mem); + stack = (struct atom **)e_malloc(STACKSIZE * sizeOfpAtom); + symtab = (struct atom **)e_malloc((27 * BUCKETSIZE) * sizeOfpAtom); + binding = (struct atom **)e_malloc((27 * BUCKETSIZE) * sizeOfpAtom); + usrfunc = (struct atom **)e_malloc((27 * BUCKETSIZE) * sizeOfpAtom); + zero = NULL; + if (stack == NULL || symtab == NULL || binding == NULL || usrfunc == NULL) { + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("Failed to initialize fixed ram area")); + return; + } +} + + + +void init_block(struct atom *mem){ + //struct atom *p; + //p=mem; + for (int j = 0; j u.next; + + free_count--; + alloc_count++; + + return p; +} + +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 = e_malloc(n); + if (p == NULL) + stopf("alloc mem failed out of memory"); + 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((const char *)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) + e_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) +{ + e_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 > MAXATOMS / 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"); + + if (eval_level == 200) + stopf("circular 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_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(); + + 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"); + + // 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(DERIVATIVE)) { + dd(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; + } + + if (car(F) == symbol(INTEGRAL) && caddr(F) == X) { + push(cadr(F)); + 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 derivative +// +// example: d(d(f(x,y),y),x) +// +// p1 = d(f(x,y),y) +// +// p2 = x +// +// cadr(p1) = f(x,y) +// +// caddr(p1) = y + +void +dd(struct atom *p1, struct atom *p2) +{ + struct atom *p3; + + // d(f(x,y),x) + + push(cadr(p1)); + push(p2); + derivative(); + + p3 = pop(); + + if (car(p3) == symbol(DERIVATIVE)) { + + // sort dx terms + + push_symbol(DERIVATIVE); + push_symbol(DERIVATIVE); + push(cadr(p3)); + + if (lessp(caddr(p3), caddr(p1))) { + push(caddr(p3)); + list(3); + push(caddr(p1)); + } else { + push(caddr(p1)); + list(3); + push(caddr(p3)); + } + + list(3); + + } else { + push(p3); + push(caddr(p1)); + derivative(); + } +} + +// 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 +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) + e_free(D); + if (Q) + e_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; +} +void +eval_erf(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + erffunc(); +} + +void +erffunc(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]); + erffunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = erf(d); + push_double(d); + return; + } + + if (iszero(p1)) { + push_integer(0); + return; + } + + if (isnegativeterm(p1)) { + push_symbol(ERF); + push(p1); + negate(); + list(2); + negate(); + return; + } + + push_symbol(ERF); + push(p1); + list(2); +} +void +eval_erfc(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + erfcfunc(); +} + +void +erfcfunc(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]); + erfcfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = erfc(d); + push_double(d); + return; + } + + if (iszero(p1)) { + push_integer(1); + return; + } + + push_symbol(ERFC); + push(p1); + list(2); +} +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; + 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); + + for (;;) { + push_integer(j); + p3 = pop(); + set_symbol(p2, p3, symbol(NIL)); + p3 = p1; + while (iscons(p3)) { + push(car(p3)); + evalg(); + pop(); // discard return value + p3 = cdr(p3); + } + if (j == k) + break; + if (j < k) + j++; + else + j--; + } + + restore_symbol(); + + push_symbol(NIL); // return value +} +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]) + 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"); + outbuf_puts("\0"); + if (noprint == false){ + 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); +} +const char * const 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) + +const char * const 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", +}; + +const char * const 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", +}; + +const char * const 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", +}; + +const char * const 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_nib(F, X); + multiply(); // multiply by const part + return; + } + + integral_nib(F, X); +} + +void +integral_nib(struct atom *F, struct atom *X) +{ + int h; + struct atom *p; + + save_symbol(symbol(SA)); + save_symbol(symbol(SB)); + save_symbol(symbol(SX)); + + set_symbol(symbol(SX), X, symbol(NIL)); + + // put constants in F(X) on the stack + + h = tos; + + push_integer(1); // 1 is a candidate for a or b + + push(F); + push(X); + decomp(); // push const coeffs + + integral_lookup(h, F); + + p = pop(); + restore_symbol(); + restore_symbol(); + restore_symbol(); + push(p); +} + +void +integral_lookup(int h, struct atom *F) +{ + int t; + + 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; + } + + stopf("integral: no solution found"); +} + +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, const char * const *table, int n) +{ + int i; + struct atom *C, *I; + + for (i = 0; i < n; i += 3) { + + scan1((char *)table[i + 0]); // integrand + I = pop(); + + scan1((char *)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((char *)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 (!findf(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 (findf(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 (!findf(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 (findf(car(p1), X)) { + push(car(p1)); + push(X); + decomp(); + } + p1 = cdr(p1); + } + + // combine constant factors + + h = tos; + p1 = cdr(F); + while (iscons(p1)) { + if (!findf(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 (!findf(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 (findf(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 +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_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_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=NULL; + struct atom *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) + e_free(cr); + if (ci) + e_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)) + 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"); + outbuf_puts("\0"); + if (noprint == false){ + 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_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) { + e_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(); +} +void +eval_sgn(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + sgn(); +} + +void +sgn(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]); + sgn(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (!isnum(p1)) { + push_symbol(SGN); + push(p1); + list(2); + return; + } + + if (iszero(p1)) { + push_integer(0); + return; + } + + if (isnegativenumber(p1)) + 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, "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 (%ld%%)\n", max_tos, (int32_t)(100 * max_tos / STACKSIZE)); + outbuf_puts(strbuf); + if (noprint == false){ + 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("compare err"); + if (isnegativenumber(p1)) + return -1; + else + return 1; +} +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(); // p1 is on frame stack, not reclaimed + 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 + +const 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 = (int)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 0x2D // '-' 0xe28892 +#define MULTIPLY_SIGN 0x2A // '*' 0xc397 +#define GREATEREQUAL 0xF2 // IBM code page 437 0xe289a5 +#define LESSEQUAL 0xF3// IBM code page 437 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 BDLL 0xC4 /* ╴→ ─ */ +#define BDLR 0xC4 /* ╶→ ─ */ + +/* */ +#define BDLH 0xC4 /* ─ */ +#define BDLV 0xB3 /* │ */ + +/* */ +#define BDLDAR 0xDA /* ┌ */ +#define BDLDAL 0xBF /* ┐ */ +#define BDLUAR 0xC0 /* └ */ +#define BDLUAL 0xD9 /* ┘ */ + +//#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) + e_free(fmt_buf); + fmt_buf = alloc_mem(m); + if (!fmt_buf) { + stopf("fmt: out of memory allocating %d bytes"); + } + 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 + //fmt_putw('\0'); + if (noprint==false){ + 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 + +const char * const 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", +}; + +const int symbol_unicode_tab[NUM_SYMBOL_NAMES] = { + + 0x41, // Alpha 0xce91 + 0x42, // Beta 0xce92 + 0xE2, // Gamma 0xce93 + 0x7F, // Delta0xce94 + 0x45, // Epsilon0xce95 + 0x5A, // Zeta0xce96 + 0x48, // Eta0xce97 + 0xE9, // Theta0xce98 + 0x49, // Iota0xce99 + 0x4B, // Kappa0xce9a + 0xce9b, // Lambda + 0x4D, // Mu0xce9c + 0x4E, // Nu0xce9d + 0xce9e, // Xi + 0x4F, // Omicron0xce9f + 0xE3, // Pi0xcea0 + 0x50, // Rho0xcea1 + 0xE4, // Sigma 0xcea3 + 0x54, // Tau0xcea4 + 0x59, // Upsilon0xcea5 + 0xE8, // Phi0xcea6 + 0x58, // Chi0xcea7 + 0xcea8, // Psi0xcea8 + 0xEA, // Omega0xcea9 + + 0xE0, // alpha0xceb1 + 0xE1, // beta0xceb2 + 0x72, // gamma0xceb3 + 0xEB, // delta0xceb4 + 0xEE, // epsilon0xceb5 + 0x7A, // zeta0xceb6 + 0x6E, // eta0xceb7 + 0xE9, // theta0xceb8 + 0x69, // iota0xceb9 + 0x6B, // kappa0xceba + 0xcebb, // lambda + 0xE6, // mu0xcebc + 0x76, // nu0xcebd + 0xcebe, // xi + 0x6F, // omicron0xcebf + 0xE3, // pi0xcf80 + 0x70, // rho0xcf81 + 0xE5, // sigma0xcf83 + 0xE7, // tau0xcf84 + 0x75, // upsilon0xcf85 + 0xED, // phi0xcf86 + 0x78, // chi0xcf87 + 0xcf88, // psi + 0x77, // omega0xcf89 + + 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 = (char *)symbol_name_tab[i]; + n = (int) strlen((const char *)t); + if (strncmp(s + k, t, n) == 0){ + break; + } + } + + if (i == NUM_SYMBOL_NAMES) { + fmt_roman_char(s[k]); + return k + 1; + } + + c = (int)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; + struct atom *p; + + gc_count++; + alloc_count = 0; + + // tag everything + + for (i = 0; i < MAXATOMS;i++){ + mem[i].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 < MAXATOMS;i++){ + + p = &mem[i]; + if (p->tag == 0){ + continue; + } + // still tagged so it's unused, put on free list + switch (p->atomtype) { + case KSYM: + e_free(p->u.ksym.name); + ksym_count--; + break; + case USYM: + e_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) + e_free(p->u.str); + string_count--; + break; + case TENSOR: + e_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; // an array of pointers +struct atom *free_list; + +int tos; // top of stack + +struct atom **stack; + +struct atom **symtab; +struct atom **binding; +struct atom **usrfunc; + +struct atom *zero; +struct atom *one; +struct atom *minusone; +struct atom *imaginaryunit; + +int eval_level; +int gc_level; +int expanding; +int drawing; +int nonstop; +int interrupt; +jmp_buf jmpbuf0; +jmp_buf jmpbuf1; +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); + mp_printf(&mp_plat_print, "cannot read %s\n", infile); + //exit(1); + stopf("cannot read file"); + } + run(buf); + e_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); + + switch (color) { + case 0: + mp_printf(&mp_plat_print, "\x1b[37;40m%s\x1b[0m", s);//black + break; + case 1: + mp_printf(&mp_plat_print, "\x1b[37;44m%s\x1b[0m", s); // blue + break; + case 2: + mp_printf(&mp_plat_print, "\x1b[37;41m%s\x1b[0m", s); // red + break; + } + + +} + +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); + longjmp(jmpbuf0, 1); +} +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((const char *)s); + + // Make sure there is enough room for new string + '\0' terminator + m = 1000 * ((outbuf_index + len + 1) / 1000 + 1); // +1 for '\0' + + if (m > outbuf_length) { + outbuf = e_realloc(outbuf, m); + if (outbuf == NULL) { + stopf("outbuf_puts: realloc failed"); + } + outbuf_length = m; + } + + // Copy the string + memcpy(outbuf + outbuf_index, s, len); + outbuf_index += len; + + // Always null-terminate + outbuf[outbuf_index] = '\0'; +} + + + +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 = e_realloc(outbuf, m); + if (outbuf == NULL){ + //exit(1); + stopf("outbuf_putc: realloc failed"); + } + 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; +} +void +run(char *buf) +{ + if (setjmp(jmpbuf0)){ + return; + } + tos = 0; + interrupt = 0; + eval_level = 0; + gc_level = 0; + expanding = 1; + drawing = 0; + nonstop = 0; + + if (zero == 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'); + } + if (noprint == false){ + printbuf(outbuf, color); + } + +} + +const char *init_script = +"tty = 1\n" +"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((char *)init_script); +} + +void +stopf(char *s) +{ + if (nonstop){ + longjmp(jmpbuf1, 1); + } + print_trace(RED); + snprintf(strbuf, STRBUFLEN, "Stop: %s\n", s); + if (noprint == false){ + printbuf(strbuf, RED); + }else{ + //todo:push into outbuf + outbuf_puts(strbuf); + } + + longjmp(jmpbuf0, 1); +} + +void +exitf(char *s) +{ + nonstop = 0; + stopf(s); +} +// 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((const char *)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((int)*scan_str) || *scan_str == '.') { + while (isdigit((int)*scan_str)){ + scan_str++; + } + if (*scan_str == '.') { + scan_str++; + while (isdigit((int)*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((int)*scan_str)) { + while (isalnum((int)*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){ + e_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){ + exitf("stack error, circular definition?"); + } + stack[tos++] = p; + if (tos > max_tos){ + max_tos = tos; + } +} + +struct atom * +pop(void) +{ + if (tos < 1 || tos > STACKSIZE){ + exitf("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); + char *ns = e_malloc(strlen((const char *)s) + 1); + if (ns == NULL){ + stopf("push_string memory alloc error"); + } + memcpy(ns, s, strlen((const char *)s) + 1); + p->u.str = ns; + 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((int)*s)){ + k = BUCKETSIZE * (*s - 'A'); + }else if (islower((int)*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); + char *ns = e_malloc(strlen((const char *)s) + 1); + if (ns == NULL){ + stopf("lookup memory alloc error"); + } + memcpy(ns, s, strlen((const char *)s) + 1); + //if (s == NULL) + // exit(1); + p->atomtype = USYM; + p->u.usym.name = ns; + 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; +} + +typedef struct{ + const char *str; + int index; + void (*func)(struct atom *); +} se; +const se 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 }, + + { "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 }, + { "log", LOG, eval_log }, + + { "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 }, + { "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 }, + { "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 }, + { "$1", ARG1, NULL }, + { "$2", ARG2, NULL }, + { "$3", ARG3, NULL }, + { "$4", ARG4, NULL }, + { "$5", ARG5, NULL }, + { "$6", ARG6, NULL }, + { "$7", ARG7, NULL }, + { "$8", ARG8, NULL }, + { "$9", 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 (se); + + for (i = 0; i < n; i++) { + p = alloc_atom(); + s = e_malloc(strlen((const char *)(stab[i].str)) + 1); + if (s == NULL){ + stopf("symbol table init error"); + } + + memcpy(s, stab[i].str, strlen((const char *)(stab[i].str)) + 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; + } +} diff --git a/user_modules/eigenmath/eigenmath.h b/user_modules/eigenmath/eigenmath.h new file mode 100644 index 000000000..63e6b1698 --- /dev/null +++ b/user_modules/eigenmath/eigenmath.h @@ -0,0 +1,35 @@ + +#ifndef EIGENMATH_H +#define EIGENMATH_H + +#include + +#ifdef __cplusplus +extern "C" { +#endif + + +#define STRBUFLEN 1000 +#define BUCKETSIZE 100 +#define MAXDIM 24 + +//extern struct atom *mem ; +//extern struct atom **stack ; // +//extern struct atom **symtab ; // symbol table +//extern struct atom **binding ; +//extern struct atom **usrfunc ; +//extern char *strbuf ; + +//extern uint32_t STACKSIZE ; // evaluation stack +//extern uint32_t MAXATOMS ; // 10,240 atoms + +extern bool noprint; +extern char *outbuf; +extern int outbuf_index; +extern void eigenmath_init(uint8_t *pHeap,size_t heapSize); +extern void run(char *buf); +#ifdef __cplusplus +} +#endif + +#endif /* EHEAP_H */ \ No newline at end of file diff --git a/user_modules/eigenmath/eigenmath_mpy.c b/user_modules/eigenmath/eigenmath_mpy.c new file mode 100644 index 000000000..9d75426ec --- /dev/null +++ b/user_modules/eigenmath/eigenmath_mpy.c @@ -0,0 +1,281 @@ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "py/obj.h" +//#include "py/mpconfig.h" +#include "py/misc.h" +#include "py/runtime.h" +#include "py/objstr.h" +#include "shared/readline/readline.h" +#include "py/binary.h" +#include "py/gc.h" +#include "py/stream.h" +#include "eigenmath.h" +#include "eheap.h" +//-DPICO_STACK_SIZE=0x4000 ?? + +typedef struct _mp_obj_eigenmath_t { + mp_obj_base_t base; + size_t heapSize; + uint8_t *pHeap; +} mp_obj_eigenmath_t; + +static void eigenmath_print(const mp_print_t *print, mp_obj_t self_in, mp_print_kind_t kind) { + mp_printf(print, ""); +} + +static mp_obj_t eigenmath_make_new(const mp_obj_type_t *type, + size_t n_args, size_t n_kw, + const mp_obj_t *args) { + + mp_arg_check_num(n_args, n_kw, 1, 1, false); + mp_obj_eigenmath_t *self = mp_obj_malloc(mp_obj_eigenmath_t, type); + self->base.type = type; + self->heapSize = mp_obj_get_int(args[0]); // 350 * 1024; // 350KB + //mp_printf(&mp_plat_print,"heapSize = %d\n", self->heapSize); + + self->pHeap = (uint8_t *)m_malloc(self->heapSize); + + //mp_printf(&mp_plat_print,"ptemp = %x\n", (uint32_t)(ptemp)); + //mp_printf(&mp_plat_print,"self->pHeap = %x\n", (uint32_t)(self->pHeap)); + if (self->pHeap == NULL){ + mp_raise_msg(&mp_type_MemoryError, MP_ERROR_TEXT("Failed to initialize heap")); + return MP_OBJ_NULL; + } + + + eigenmath_init(self->pHeap,self->heapSize); + + return MP_OBJ_FROM_PTR(self); +} + +static mp_obj_t eigenmath_run(size_t n_args, const mp_obj_t *args) { + //mp_obj_eigenmath_t *self = MP_OBJ_TO_PTR(self_in);mp_obj_t input_str_obj + size_t len; + if (n_args >= 3){ + mp_obj_t arg = args[2]; + if (mp_obj_is_bool(arg) || mp_obj_is_int(arg)) { + noprint = mp_obj_is_true(arg); + } else { + mp_raise_TypeError(MP_ERROR_TEXT("expected a bool")); + } + } else { + noprint = false; + } + + if (!mp_obj_is_str(args[1])) { + mp_raise_TypeError(MP_ERROR_TEXT("expected a string as input")); + } + const char *buf = mp_obj_str_get_data(args[1], &len); + + //GET_STR_DATA_LEN(input_str_obj, str, str_len); + run((char *)buf); + + if (noprint == true){ + return mp_obj_new_bytearray_by_ref(outbuf_index-1, outbuf); + // return memoryview + //return mp_obj_new_memoryview(BYTEARRAY_TYPECODE, outbuf); + + }else{ + return mp_const_none; + } + + +} +static MP_DEFINE_CONST_FUN_OBJ_VAR_BETWEEN(eigenmath_run_obj,2,3, eigenmath_run); + + + + +static mp_obj_t eigenmath_call(mp_obj_t self_in, size_t n_args, size_t n_kw, const mp_obj_t *args) { + //mp_obj_eigenmath_t *self = MP_OBJ_TO_PTR(self_in); + noprint = false; + if (n_args != 1 || n_kw != 0) { + mp_raise_TypeError(MP_ERROR_TEXT("Expected 1 positional argument")); + } + + const char *cmd = mp_obj_str_get_str(args[0]); + run((char *)cmd); // + return mp_const_none; +} + +static mp_obj_t eigenmath_cmd(mp_obj_t self_in) { + //mp_obj_eigenmath_t *self = MP_OBJ_TO_PTR(self_in); + vstr_t* vstr_inbuf = vstr_new(1); + for (;;) { + vstr_clear(vstr_inbuf); + int res = readline(vstr_inbuf,"eigenmath> "); + mp_printf(&mp_plat_print, "Eigenmath run:\n"); + mp_printf(&mp_plat_print, "res=%d\n", res); + mp_printf(&mp_plat_print, "%s\n", vstr_inbuf->buf); + run(vstr_inbuf->buf); + } + return mp_const_none; + +} +static MP_DEFINE_CONST_FUN_OBJ_1(eigenmath_cmd_obj, eigenmath_cmd); + + + +static mp_obj_t eigenmath_runfile(size_t n_args, const mp_obj_t *args ) {//mp_obj_t input_file_obj + + if (n_args >= 3){ + mp_obj_t arg = args[2]; + if (mp_obj_is_bool(arg) || mp_obj_is_int(arg)) { + noprint = mp_obj_is_true(arg); + } else { + mp_raise_TypeError(MP_ERROR_TEXT("expected a bool")); + } + } else { + noprint = false; + } + + + const mp_stream_p_t *stream_p = mp_get_stream_raise(args[1], MP_STREAM_OP_READ | MP_STREAM_OP_IOCTL); + if (stream_p == NULL) { + mp_raise_TypeError(MP_ERROR_TEXT("expected a file-like object")); + } + int error = 0; + + // get file size + struct mp_stream_seek_t seek = { + .offset = 0, + .whence = MP_SEEK_END, + }; + mp_obj_t input_file_obj = args[1]; + if (stream_p->ioctl(input_file_obj, MP_STREAM_SEEK, (uintptr_t)&seek, &error) == MP_STREAM_ERROR) { + mp_raise_OSError(error); + } + mp_off_t size = seek.offset; + + // move to front + seek.offset = 0; + seek.whence = MP_SEEK_SET; + if (stream_p->ioctl(input_file_obj, MP_STREAM_SEEK, (uintptr_t)&seek, &error) == MP_STREAM_ERROR) { + mp_raise_OSError(error); + } + + // get buffer + char *buf = m_new(char, size + 1); + + // read file + mp_uint_t out_sz = stream_p->read(input_file_obj, buf, size, &error); + if (error != 0 || out_sz != size) { + m_del(char, buf, size + 1); + mp_raise_OSError(error); + } + + // add end + buf[out_sz] = '\0'; + + // run + run(buf); + + // release buffer + m_del(char, buf, size + 1); + + if (noprint == true){ + return mp_obj_new_bytearray_by_ref(outbuf_index-1, outbuf); + // return memoryview + //return mp_obj_new_memoryview(BYTEARRAY_TYPECODE, bytearray); + + }else{ + return mp_const_none; + } +} +static MP_DEFINE_CONST_FUN_OBJ_VAR_BETWEEN(eigenmath_runfile_obj, 2,3,eigenmath_runfile); + + + + + +extern int free_count; +extern int MAXATOMS; +static mp_obj_t eigenmath_status(mp_obj_t self_in) { + //mp_obj_eigenmath_t *self = MP_OBJ_TO_PTR(self_in); + int fragmentation = e_heap_fragmentation(); + size_t free_bytes = e_heap_free(); + size_t min_free = e_heap_min_free(); + int num_atoms = free_count; + mp_printf(&mp_plat_print,"Heap fragmentation: %d%%\n", fragmentation); + mp_printf(&mp_plat_print,"Free bytes in Heap: %d\n", (int)free_bytes); + mp_printf(&mp_plat_print,"Minimum free bytes in Heap: %d\n", (int)min_free); + mp_printf(&mp_plat_print,"Number of free atoms: %d of %d\n", num_atoms,MAXATOMS); + return mp_const_none; + +} +static MP_DEFINE_CONST_FUN_OBJ_1(eigenmath_status_obj, eigenmath_status); + + + +extern struct atom *zero; +static mp_obj_t eigenmath_del(mp_obj_t self_in) { + mp_obj_eigenmath_t *self = MP_OBJ_TO_PTR(self_in); + m_free(&self->pHeap); // deinitialize the hea + zero = NULL; + return mp_const_none; +} +static MP_DEFINE_CONST_FUN_OBJ_1(eigenmath_del_obj, eigenmath_del); + +extern struct atom *zero; +static mp_obj_t eigenmath_reset(mp_obj_t self_in) { + mp_obj_eigenmath_t *self = MP_OBJ_TO_PTR(self_in); + eigenmath_init(self->pHeap,self->heapSize); + zero = NULL;//triger the symbol table initialization + return mp_const_none; +} +static MP_DEFINE_CONST_FUN_OBJ_1(eigenmath_reset_obj, eigenmath_reset); + +mp_obj_t eigenmath_attr(mp_obj_t self_in, qstr attr, mp_obj_t *dest) { + if (dest[0] == MP_OBJ_NULL && attr == MP_QSTR___del__) { + dest[0] = MP_OBJ_FROM_PTR(&eigenmath_del_obj); + dest[1] = self_in; + }else{ + // For any other attribute, indicate that lookup should continue in the locals dict + dest[1] = MP_OBJ_SENTINEL; + return MP_OBJ_NULL; + } + + return MP_OBJ_NULL; +} +static const mp_rom_map_elem_t eigenmath_locals_dict_table[] = { + { MP_ROM_QSTR(MP_QSTR_run), MP_ROM_PTR(&eigenmath_run_obj) }, + { MP_ROM_QSTR(MP_QSTR_runfile), MP_ROM_PTR(&eigenmath_runfile_obj) }, + { MP_ROM_QSTR(MP_QSTR_cmd), MP_ROM_PTR(&eigenmath_cmd_obj) }, + { MP_ROM_QSTR(MP_QSTR_reset), MP_ROM_PTR(&eigenmath_reset_obj) }, + { MP_ROM_QSTR(MP_QSTR_status), MP_ROM_PTR(&eigenmath_status_obj) }, +}; +static MP_DEFINE_CONST_DICT(eigenmath_locals_dict, eigenmath_locals_dict_table); + + +MP_DEFINE_CONST_OBJ_TYPE( + eigenmath_type, + MP_QSTR_EigenMath, + MP_TYPE_FLAG_NONE, + make_new, eigenmath_make_new, + call,eigenmath_call, // call handler for the run method + attr, eigenmath_attr, // attr handler before locals_dict + locals_dict, &eigenmath_locals_dict, + print, eigenmath_print +); + +static const mp_rom_map_elem_t eigenmath_module_globals_table[] = { + { MP_ROM_QSTR(MP_QSTR___name__), MP_ROM_QSTR(MP_QSTR_eigenmath) }, + { MP_ROM_QSTR(MP_QSTR_EigenMath), MP_ROM_PTR(&eigenmath_type) }, + }; + static MP_DEFINE_CONST_DICT(mp_module_eigenmath_globals, eigenmath_module_globals_table); + + const mp_obj_module_t eigenmath_user_cmodule = { + .base = { &mp_type_module }, + .globals = (mp_obj_dict_t*)&mp_module_eigenmath_globals, + }; + + MP_REGISTER_MODULE(MP_QSTR_eigenmath, eigenmath_user_cmodule); \ No newline at end of file diff --git a/user_modules/eigenmath/micropython.cmake b/user_modules/eigenmath/micropython.cmake new file mode 100644 index 000000000..b6819f75c --- /dev/null +++ b/user_modules/eigenmath/micropython.cmake @@ -0,0 +1,19 @@ +# Create an INTERFACE library for our C module. +add_library(usermod_eigenmath INTERFACE) + +# Add our source files to the lib +target_sources(usermod_eigenmath INTERFACE + ${CMAKE_CURRENT_LIST_DIR}/eigenmath.c + ${CMAKE_CURRENT_LIST_DIR}/eheap.c + ${CMAKE_CURRENT_LIST_DIR}/eigenmath_mpy.c +) + +# Add the current directory as an include directory. +target_include_directories(usermod_eigenmath INTERFACE + ${CMAKE_CURRENT_LIST_DIR} +) +set(PICO_STACK_SIZE 0x4000 CACHE STRING "App stack size" FORCE) + +# Link our INTERFACE library to the usermod target. +target_link_libraries(usermod INTERFACE usermod_eigenmath) + diff --git a/user_modules/eigenmath/micropython.mk b/user_modules/eigenmath/micropython.mk new file mode 100644 index 000000000..dc5f9c5e9 --- /dev/null +++ b/user_modules/eigenmath/micropython.mk @@ -0,0 +1,10 @@ +PICOCALCDISPLAY_MOD_DIR := $(USERMOD_DIR) + +# Add all C files to SRC_USERMOD. +SRC_USERMOD += $(PICOCALCDISPLAY_MOD_DIR)/eigenmath.c\ + $(PICOCALCDISPLAY_MOD_DIR)/eigenmath_mpy.h\ + $(PICOCALCDISPLAY_MOD_DIR)/eheap.c\ + +# We can add our module folder to include paths if needed +# This is not actually needed in this example. +CFLAGS_USERMOD += -I$(PICOCALCDISPLAY_MOD_DIR) diff --git a/user_modules/user.cmake b/user_modules/user.cmake new file mode 100644 index 000000000..71eaf18bd --- /dev/null +++ b/user_modules/user.cmake @@ -0,0 +1,2 @@ +include(${CMAKE_CURRENT_LIST_DIR}/eigenmath/micropython.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/lv_binding_micropython/bindings.cmake) \ No newline at end of file