From 54b2eb0defd0313216700404e2f2b9e293b77d38 Mon Sep 17 00:00:00 2001 From: feng-arch Date: Fri, 19 Sep 2025 10:15:16 +0800 Subject: [PATCH 1/6] =?UTF-8?q?[feat]:=20rp2040=E8=8A=AF=E7=89=87,=20?= =?UTF-8?q?=E5=9C=A8machine=5Fspi=E4=B8=AD=E6=B7=BB=E5=8A=A0DMA=E6=94=AF?= =?UTF-8?q?=E6=8C=81,=E6=B3=A8=E6=84=8F=EF=BC=9ASPI.write=E5=87=BD?= =?UTF-8?q?=E6=95=B0=E4=BC=9A=E7=9B=B4=E6=8E=A5=E8=BF=94=E5=9B=9E=EF=BC=8C?= =?UTF-8?q?=E8=BF=99=E6=84=8F=E5=91=B3=E7=9D=80=E4=BD=A0=E4=B8=8D=E8=83=BD?= =?UTF-8?q?=E5=9C=A8=E8=B0=83=E7=94=A8SPI.write=E5=90=8E=E7=AB=8B=E5=8D=B3?= =?UTF-8?q?=E5=8F=98=E6=9B=B4CS=E5=BC=95=E8=84=9A=E7=9A=84=E7=8A=B6?= =?UTF-8?q?=E6=80=81?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- extmod/machine_spi.c | 188 +- extmod/modmachine.h | 65 +- make_and_flash_rp2.sh | 14 + ports/rp2/machine_spi.c | 337 +- user_modules/cexample/examplemodule.c | 18780 ++++++++++++++++++++++ user_modules/cexample/micropython.cmake | 15 + user_modules/cexample/micropython.mk | 8 + user_modules/user.cmake | 2 + 8 files changed, 19199 insertions(+), 210 deletions(-) create mode 100755 make_and_flash_rp2.sh create mode 100644 user_modules/cexample/examplemodule.c create mode 100644 user_modules/cexample/micropython.cmake create mode 100644 user_modules/cexample/micropython.mk create mode 100644 user_modules/user.cmake diff --git a/extmod/machine_spi.c b/extmod/machine_spi.c index 5be30e947..04506370f 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,39 @@ 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_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 +86,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 +96,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 +105,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 +121,16 @@ 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_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 +141,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 +217,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 +236,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 +295,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 +314,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..f1f455b41 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,17 @@ 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 } 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..8bff03697 --- /dev/null +++ b/make_and_flash_rp2.sh @@ -0,0 +1,14 @@ +make -j -C ports/rp2 BOARD=RPI_PICO USER_C_MODULES=../../user_modules/lv_binding_micropython/bindings.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/machine_spi.c b/ports/rp2/machine_spi.c index abf0a70bd..3f35cd1a7 100644 --- a/ports/rp2/machine_spi.c +++ b/ports/rp2/machine_spi.c @@ -32,21 +32,21 @@ #include "hardware/spi.h" #include "hardware/dma.h" -#define DEFAULT_SPI_BAUDRATE (1000000) -#define DEFAULT_SPI_POLARITY (0) -#define DEFAULT_SPI_PHASE (0) -#define DEFAULT_SPI_BITS (8) -#define DEFAULT_SPI_FIRSTBIT (SPI_MSB_FIRST) +#define DEFAULT_SPI_BAUDRATE (1000000) +#define DEFAULT_SPI_POLARITY (0) +#define DEFAULT_SPI_PHASE (0) +#define DEFAULT_SPI_BITS (8) +#define DEFAULT_SPI_FIRSTBIT (SPI_MSB_FIRST) #ifdef MICROPY_HW_SPI_NO_DEFAULT_PINS // With no default SPI, need to require the pin args. -#define MICROPY_HW_SPI0_SCK (0) -#define MICROPY_HW_SPI0_MOSI (0) -#define MICROPY_HW_SPI0_MISO (0) -#define MICROPY_HW_SPI1_SCK (0) -#define MICROPY_HW_SPI1_MOSI (0) -#define MICROPY_HW_SPI1_MISO (0) +#define MICROPY_HW_SPI0_SCK (0) +#define MICROPY_HW_SPI0_MOSI (0) +#define MICROPY_HW_SPI0_MISO (0) +#define MICROPY_HW_SPI1_SCK (0) +#define MICROPY_HW_SPI1_MOSI (0) +#define MICROPY_HW_SPI1_MISO (0) #define MICROPY_SPI_PINS_ARG_OPTS MP_ARG_REQUIRED #else @@ -56,40 +56,41 @@ #ifndef MICROPY_HW_SPI0_SCK #if PICO_DEFAULT_SPI == 0 -#define MICROPY_HW_SPI0_SCK (PICO_DEFAULT_SPI_SCK_PIN) -#define MICROPY_HW_SPI0_MOSI (PICO_DEFAULT_SPI_TX_PIN) -#define MICROPY_HW_SPI0_MISO (PICO_DEFAULT_SPI_RX_PIN) +#define MICROPY_HW_SPI0_SCK (PICO_DEFAULT_SPI_SCK_PIN) +#define MICROPY_HW_SPI0_MOSI (PICO_DEFAULT_SPI_TX_PIN) +#define MICROPY_HW_SPI0_MISO (PICO_DEFAULT_SPI_RX_PIN) #else -#define MICROPY_HW_SPI0_SCK (6) -#define MICROPY_HW_SPI0_MOSI (7) -#define MICROPY_HW_SPI0_MISO (4) +#define MICROPY_HW_SPI0_SCK (6) +#define MICROPY_HW_SPI0_MOSI (7) +#define MICROPY_HW_SPI0_MISO (4) #endif #endif #ifndef MICROPY_HW_SPI1_SCK #if PICO_DEFAULT_SPI == 1 -#define MICROPY_HW_SPI1_SCK (PICO_DEFAULT_SPI_SCK_PIN) -#define MICROPY_HW_SPI1_MOSI (PICO_DEFAULT_SPI_TX_PIN) -#define MICROPY_HW_SPI1_MISO (PICO_DEFAULT_SPI_RX_PIN) +#define MICROPY_HW_SPI1_SCK (PICO_DEFAULT_SPI_SCK_PIN) +#define MICROPY_HW_SPI1_MOSI (PICO_DEFAULT_SPI_TX_PIN) +#define MICROPY_HW_SPI1_MISO (PICO_DEFAULT_SPI_RX_PIN) #else -#define MICROPY_HW_SPI1_SCK (10) -#define MICROPY_HW_SPI1_MOSI (11) -#define MICROPY_HW_SPI1_MISO (8) +#define MICROPY_HW_SPI1_SCK (10) +#define MICROPY_HW_SPI1_MOSI (11) +#define MICROPY_HW_SPI1_MISO (8) #endif #endif #endif // SPI0 can be GP{0..7,16..23}, SPI1 can be GP{8..15,24..29}. -#define IS_VALID_PERIPH(spi, pin) ((((pin) & 8) >> 3) == (spi)) +#define IS_VALID_PERIPH(spi, pin) ((((pin) & 8) >> 3) == (spi)) // GP{2,6,10,14,...} -#define IS_VALID_SCK(spi, pin) (((pin) & 3) == 2 && IS_VALID_PERIPH(spi, pin)) +#define IS_VALID_SCK(spi, pin) (((pin) & 3) == 2 && IS_VALID_PERIPH(spi, pin)) // GP{3,7,11,15,...} -#define IS_VALID_MOSI(spi, pin) (((pin) & 3) == 3 && IS_VALID_PERIPH(spi, pin)) +#define IS_VALID_MOSI(spi, pin) (((pin) & 3) == 3 && IS_VALID_PERIPH(spi, pin)) // GP{0,4,8,10,...} -#define IS_VALID_MISO(spi, pin) (((pin) & 3) == 0 && IS_VALID_PERIPH(spi, pin)) +#define IS_VALID_MISO(spi, pin) (((pin) & 3) == 0 && IS_VALID_PERIPH(spi, pin)) -typedef struct _machine_spi_obj_t { +typedef struct _machine_spi_obj_t +{ mp_obj_base_t base; spi_inst_t *const spi_inst; uint8_t spi_id; @@ -101,42 +102,77 @@ typedef struct _machine_spi_obj_t { uint8_t mosi; uint8_t miso; uint32_t baudrate; + int chan_tx; + int chan_rx; } machine_spi_obj_t; static machine_spi_obj_t machine_spi_obj[] = { { - {&machine_spi_type}, spi0, 0, - DEFAULT_SPI_POLARITY, DEFAULT_SPI_PHASE, DEFAULT_SPI_BITS, DEFAULT_SPI_FIRSTBIT, - MICROPY_HW_SPI0_SCK, MICROPY_HW_SPI0_MOSI, MICROPY_HW_SPI0_MISO, + {&machine_spi_type}, + spi0, 0, + 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, }, { - {&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, + {&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, }, }; -static void machine_spi_print(const mp_print_t *print, mp_obj_t self_in, mp_print_kind_t kind) { +static void machine_spi_print(const mp_print_t *print, mp_obj_t self_in, mp_print_kind_t kind) +{ machine_spi_obj_t *self = MP_OBJ_TO_PTR(self_in); mp_printf(print, "SPI(%u, baudrate=%u, polarity=%u, phase=%u, bits=%u, sck=%u, mosi=%u, miso=%u)", - self->spi_id, self->baudrate, self->polarity, self->phase, self->bits, - self->sck, self->mosi, self->miso); + self->spi_id, self->baudrate, self->polarity, self->phase, self->bits, + self->sck, self->mosi, self->miso); } -mp_obj_t machine_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_id, ARG_baudrate, ARG_polarity, ARG_phase, ARG_bits, ARG_firstbit, ARG_sck, ARG_mosi, ARG_miso }; +mp_obj_t machine_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_id, + 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_id, MP_ARG_REQUIRED | MP_ARG_OBJ }, - { MP_QSTR_baudrate, MP_ARG_INT, {.u_int = DEFAULT_SPI_BAUDRATE} }, - { MP_QSTR_polarity, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_POLARITY} }, - { MP_QSTR_phase, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_PHASE} }, - { MP_QSTR_bits, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_BITS} }, - { MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_FIRSTBIT} }, - { MP_QSTR_sck, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE} }, - { MP_QSTR_mosi, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE} }, - { MP_QSTR_miso, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE} }, + {MP_QSTR_id, MP_ARG_REQUIRED | MP_ARG_OBJ}, + {MP_QSTR_baudrate, MP_ARG_INT, {.u_int = DEFAULT_SPI_BAUDRATE}}, + {MP_QSTR_polarity, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_POLARITY}}, + {MP_QSTR_phase, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_PHASE}}, + {MP_QSTR_bits, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_BITS}}, + {MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_FIRSTBIT}}, + {MP_QSTR_sck, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE}}, + {MP_QSTR_mosi, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE}}, + {MP_QSTR_miso, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE}}, }; // Parse the arguments. @@ -145,7 +181,8 @@ mp_obj_t machine_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n // Get the SPI bus id. int spi_id = mp_obj_get_int(args[ARG_id].u_obj); - if (spi_id < 0 || spi_id >= MP_ARRAY_SIZE(machine_spi_obj)) { + if (spi_id < 0 || spi_id >= MP_ARRAY_SIZE(machine_spi_obj)) + { mp_raise_msg_varg(&mp_type_ValueError, MP_ERROR_TEXT("SPI(%d) doesn't exist"), spi_id); } @@ -153,36 +190,48 @@ mp_obj_t machine_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n machine_spi_obj_t *self = (machine_spi_obj_t *)&machine_spi_obj[spi_id]; // Set SCK/MOSI/MISO pins if configured. - if (args[ARG_sck].u_obj != mp_const_none) { + if (args[ARG_sck].u_obj != mp_const_none) + { int sck = mp_hal_get_pin_obj(args[ARG_sck].u_obj); - if (!IS_VALID_SCK(self->spi_id, sck)) { + if (!IS_VALID_SCK(self->spi_id, sck)) + { mp_raise_ValueError(MP_ERROR_TEXT("bad SCK pin")); } self->sck = sck; } - if (args[ARG_mosi].u_obj != mp_const_none) { + if (args[ARG_mosi].u_obj != mp_const_none) + { int mosi = mp_hal_get_pin_obj(args[ARG_mosi].u_obj); - if (!IS_VALID_MOSI(self->spi_id, mosi)) { + if (!IS_VALID_MOSI(self->spi_id, mosi)) + { 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) { + if (args[ARG_miso].u_obj != mp_const_none) + { int miso = mp_hal_get_pin_obj(args[ARG_miso].u_obj); - if (!IS_VALID_MISO(self->spi_id, miso)) { + if (!IS_VALID_MISO(self->spi_id, miso)) + { 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. - if (n_args > 1 || n_kw > 0 || self->baudrate == 0) { + if (n_args > 1 || n_kw > 0 || self->baudrate == 0) + { self->baudrate = args[ARG_baudrate].u_int; self->polarity = args[ARG_polarity].u_int; self->phase = args[ARG_phase].u_int; self->bits = args[ARG_bits].u_int; 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")); } @@ -197,14 +246,22 @@ mp_obj_t machine_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n return MP_OBJ_FROM_PTR(self); } -static void machine_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj_t *pos_args, mp_map_t *kw_args) { - enum { ARG_baudrate, ARG_polarity, ARG_phase, ARG_bits, ARG_firstbit }; +static void machine_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj_t *pos_args, mp_map_t *kw_args) +{ + enum + { + ARG_baudrate, + ARG_polarity, + ARG_phase, + ARG_bits, + ARG_firstbit + }; static const mp_arg_t allowed_args[] = { - { MP_QSTR_baudrate, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, - { MP_QSTR_polarity, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, - { MP_QSTR_phase, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, - { MP_QSTR_bits, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, - { MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, + {MP_QSTR_baudrate, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, + {MP_QSTR_polarity, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, + {MP_QSTR_phase, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, + {MP_QSTR_bits, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, + {MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, }; // Parse the arguments. @@ -213,98 +270,136 @@ static void machine_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj mp_arg_parse_all(n_args, pos_args, kw_args, MP_ARRAY_SIZE(allowed_args), allowed_args, args); // Reconfigure the baudrate if requested. - if (args[ARG_baudrate].u_int != -1) { + if (args[ARG_baudrate].u_int != -1) + { self->baudrate = spi_set_baudrate(self->spi_inst, args[ARG_baudrate].u_int); } // Reconfigure the format if requested. bool set_format = false; - if (args[ARG_polarity].u_int != -1) { + if (args[ARG_polarity].u_int != -1) + { self->polarity = args[ARG_polarity].u_int; set_format = true; } - if (args[ARG_phase].u_int != -1) { + if (args[ARG_phase].u_int != -1) + { self->phase = args[ARG_phase].u_int; set_format = true; } - if (args[ARG_bits].u_int != -1) { + if (args[ARG_bits].u_int != -1) + { self->bits = args[ARG_bits].u_int; set_format = true; } - if (args[ARG_firstbit].u_int != -1) { + 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 (set_format) { + 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_spi_transfer(mp_obj_base_t *self_in, size_t len, const uint8_t *src, uint8_t *dest) { +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); + 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; } - bool use_dma = chan_rx >= 0 && chan_tx >= 0; + if (chan_rx >= 0) + dma_channel_wait_for_finish_blocking(chan_rx); + if (chan_tx >= 0) + dma_channel_wait_for_finish_blocking(chan_tx); + // bool use_dma = chan_rx >= 0 && chan_tx >= 0; // note src is guaranteed to be non-NULL bool write_only = dest == 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. // The buffer represents the SPI data FIFO. -static mp_int_t machine_spi_get_buffer(mp_obj_t o_in, mp_buffer_info_t *bufinfo, mp_uint_t flags) { +static mp_int_t machine_spi_get_buffer(mp_obj_t o_in, mp_buffer_info_t *bufinfo, mp_uint_t flags) +{ machine_spi_obj_t *self = MP_OBJ_TO_PTR(o_in); bufinfo->len = 4; @@ -317,6 +412,7 @@ 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, }; MP_DEFINE_CONST_OBJ_TYPE( @@ -327,19 +423,22 @@ MP_DEFINE_CONST_OBJ_TYPE( print, machine_spi_print, protocol, &machine_spi_p, buffer, machine_spi_get_buffer, - locals_dict, &mp_machine_spi_locals_dict - ); + locals_dict, &mp_machine_spi_locals_dict); -mp_obj_base_t *mp_hal_get_spi_obj(mp_obj_t o) { - if (mp_obj_is_type(o, &machine_spi_type)) { +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 - else if (mp_obj_is_type(o, &mp_machine_soft_spi_type)) { +#if MICROPY_PY_MACHINE_SOFTSPI + else if (mp_obj_is_type(o, &mp_machine_soft_spi_type)) + { return MP_OBJ_TO_PTR(o); } - #endif - else { +#endif + else + { mp_raise_TypeError(MP_ERROR_TEXT("expecting an SPI object")); } } diff --git a/user_modules/cexample/examplemodule.c b/user_modules/cexample/examplemodule.c new file mode 100644 index 000000000..9d8d5e286 --- /dev/null +++ b/user_modules/cexample/examplemodule.c @@ -0,0 +1,18780 @@ +// Include MicroPython API. +#include "py/runtime.h" + +// Used to get the time in the Timer class example. +#include "py/mphal.h" + + +/* +BSD 2-Clause License + +Copyright (c) 2024, George Weigt +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +*/ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#define STACKSIZE 100000 // evaluation stack +#define BLOCKSIZE 10000 +#define MAXBLOCKS 2000 +#define BUCKETSIZE 100 +#define STRBUFLEN 1000 +#define MAXDIM 24 + +// MAXBLOCKS * BLOCKSIZE = 20,000,000 atoms + +// MAXBLOCKS * BLOCKSIZE * sizeof (struct atom) = 480,000,000 bytes + +// Symbolic expressions are built by linking structs of type "atom". +// +// For example, the expression "a b + c" is built like this: +// +// _______ _______ _______ _______ +// |CONS | |CONS | |CONS | |SYM | +// |car cdr|--->|car cdr|----------------------------->|car cdr|--->|"nil" | +// |_|_____| |_|_____| |_|_____| |_______| +// | | | +// | | _v_____ +// | | |SYM | +// | | |"c" | +// | | |_______| +// | | +// _v_____ _v_____ _______ _______ _______ +// |SYM | |CONS | |CONS | |CONS | |SYM | +// |"add" | |car cdr|--->|car cdr|--->|car cdr|--->|"nil" | +// |_______| |_|_____| |_|_____| |_|_____| |_______| +// | | | +// _v_____ _v_____ _v_____ +// |SYM | |SYM | |SYM | +// |"mul" | |"a" | |"b" | +// |_______| |_______| |_______| + +struct atom { + union { + struct { + struct atom *car; + struct atom *cdr; + } cons; + struct { + char *name; + void (*func)(struct atom *); + } ksym; + struct { + char *name; + uint32_t index; + } usym; + struct { + uint32_t *a; // rational number a over b + uint32_t *b; + } q; + double d; + char *str; + struct tensor *tensor; + struct atom *next; + } u; + uint8_t atomtype, tag, sign; +}; + +struct tensor { + int ndim; + int dim[MAXDIM]; + int nelem; + struct atom *elem[1]; +}; + +// atom types + +#define FREEATOM 0 +#define CONS 1 +#define KSYM 2 +#define USYM 3 +#define RATIONAL 4 +#define DOUBLE 5 +#define STR 6 +#define TENSOR 7 + +// symbol table + +#define ABS (0 * BUCKETSIZE + 0) +#define ADJ (0 * BUCKETSIZE + 1) +#define AND (0 * BUCKETSIZE + 2) +#define ARCCOS (0 * BUCKETSIZE + 3) +#define ARCCOSH (0 * BUCKETSIZE + 4) +#define ARCSIN (0 * BUCKETSIZE + 5) +#define ARCSINH (0 * BUCKETSIZE + 6) +#define ARCTAN (0 * BUCKETSIZE + 7) +#define ARCTANH (0 * BUCKETSIZE + 8) +#define ARG (0 * BUCKETSIZE + 9) + +#define BINDING (1 * BUCKETSIZE + 0) +#define BREAK (1 * BUCKETSIZE + 1) + +#define C_UPPER (2 * BUCKETSIZE + 0) +#define C_LOWER (2 * BUCKETSIZE + 1) +#define CEILING (2 * BUCKETSIZE + 2) +#define CHECK (2 * BUCKETSIZE + 3) +#define CIRCEXP (2 * BUCKETSIZE + 4) +#define CLEAR (2 * BUCKETSIZE + 5) +#define CLOCK (2 * BUCKETSIZE + 6) +#define COFACTOR (2 * BUCKETSIZE + 7) +#define CONJ (2 * BUCKETSIZE + 8) +#define CONTRACT (2 * BUCKETSIZE + 9) +#define COS (2 * BUCKETSIZE + 10) +#define COSH (2 * BUCKETSIZE + 11) + +#define D_UPPER (3 * BUCKETSIZE + 0) +#define D_LOWER (3 * BUCKETSIZE + 1) +#define DEFINT (3 * BUCKETSIZE + 2) +#define DENOMINATOR (3 * BUCKETSIZE + 3) +#define DERIVATIVE (3 * BUCKETSIZE + 4) +#define DET (3 * BUCKETSIZE + 5) +#define DIM (3 * BUCKETSIZE + 6) +#define DO (3 * BUCKETSIZE + 7) +#define DOT (3 * BUCKETSIZE + 8) +#define DRAW (3 * BUCKETSIZE + 9) + +#define EIGENVEC (4 * BUCKETSIZE + 0) +#define ERF (4 * BUCKETSIZE + 1) +#define ERFC (4 * BUCKETSIZE + 2) +#define EVAL (4 * BUCKETSIZE + 3) +#define EXIT (4 * BUCKETSIZE + 4) +#define EXP (4 * BUCKETSIZE + 5) +#define EXPCOS (4 * BUCKETSIZE + 6) +#define EXPCOSH (4 * BUCKETSIZE + 7) +#define EXPFORM (4 * BUCKETSIZE + 8) +#define EXPSIN (4 * BUCKETSIZE + 9) +#define EXPSINH (4 * BUCKETSIZE + 10) +#define EXPTAN (4 * BUCKETSIZE + 11) +#define EXPTANH (4 * BUCKETSIZE + 12) + +#define FACTORIAL (5 * BUCKETSIZE + 0) +#define FLOATF (5 * BUCKETSIZE + 1) +#define FLOOR (5 * BUCKETSIZE + 2) +#define FOR (5 * BUCKETSIZE + 3) + +#define H_UPPER (7 * BUCKETSIZE + 0) +#define H_LOWER (7 * BUCKETSIZE + 1) +#define HADAMARD (7 * BUCKETSIZE + 2) + +#define I_UPPER (8 * BUCKETSIZE + 0) +#define I_LOWER (8 * BUCKETSIZE + 1) +#define IMAG (8 * BUCKETSIZE + 2) +#define INFIXFORM (8 * BUCKETSIZE + 3) +#define INNER (8 * BUCKETSIZE + 4) +#define INTEGRAL (8 * BUCKETSIZE + 5) +#define INV (8 * BUCKETSIZE + 6) + +#define J_UPPER (9 * BUCKETSIZE + 0) +#define J_LOWER (9 * BUCKETSIZE + 1) + +#define KRONECKER (10 * BUCKETSIZE + 0) + +#define LAST (11 * BUCKETSIZE + 0) +#define LGAMMA (11 * BUCKETSIZE + 1) +#define LOG (11 * BUCKETSIZE + 2) +#define LOOP (11 * BUCKETSIZE + 3) + +#define MAG (12 * BUCKETSIZE + 0) +#define MINOR (12 * BUCKETSIZE + 1) +#define MINORMATRIX (12 * BUCKETSIZE + 2) +#define MOD (12 * BUCKETSIZE + 3) + +#define NIL (13 * BUCKETSIZE + 0) +#define NOEXPAND (13 * BUCKETSIZE + 1) +#define NOT (13 * BUCKETSIZE + 2) +#define NROOTS (13 * BUCKETSIZE + 3) +#define NUMBER (13 * BUCKETSIZE + 4) +#define NUMERATOR (13 * BUCKETSIZE + 5) + +#define OR (14 * BUCKETSIZE + 0) +#define OUTER (14 * BUCKETSIZE + 1) + +#define P_UPPER (15 * BUCKETSIZE + 0) +#define P_LOWER (15 * BUCKETSIZE + 1) +#define PI (15 * BUCKETSIZE + 2) +#define POLAR (15 * BUCKETSIZE + 3) +#define PREFIXFORM (15 * BUCKETSIZE + 4) +#define PRINT (15 * BUCKETSIZE + 5) +#define PRODUCT (15 * BUCKETSIZE + 6) + +#define Q_UPPER (16 * BUCKETSIZE + 0) +#define Q_LOWER (16 * BUCKETSIZE + 1) +#define QUOTE (16 * BUCKETSIZE + 2) + +#define R_UPPER (17 * BUCKETSIZE + 0) +#define R_LOWER (17 * BUCKETSIZE + 1) +#define RAND (17 * BUCKETSIZE + 2) +#define RANK (17 * BUCKETSIZE + 3) +#define RATIONALIZE (17 * BUCKETSIZE + 4) +#define REAL (17 * BUCKETSIZE + 5) +#define RECTF (17 * BUCKETSIZE + 6) +#define ROOTS (17 * BUCKETSIZE + 7) +#define ROTATE (17 * BUCKETSIZE + 8) +#define RUN (17 * BUCKETSIZE + 9) + +#define S_UPPER (18 * BUCKETSIZE + 0) +#define S_LOWER (18 * BUCKETSIZE + 1) +#define SGN (18 * BUCKETSIZE + 2) +#define SIMPLIFY (18 * BUCKETSIZE + 3) +#define SIN (18 * BUCKETSIZE + 4) +#define SINH (18 * BUCKETSIZE + 5) +#define SQRT (18 * BUCKETSIZE + 6) +#define STATUS (18 * BUCKETSIZE + 7) +#define STOP (18 * BUCKETSIZE + 8) +#define SUM (18 * BUCKETSIZE + 9) + +#define T_UPPER (19 * BUCKETSIZE + 0) +#define T_LOWER (19 * BUCKETSIZE + 1) +#define TAN (19 * BUCKETSIZE + 2) +#define TANH (19 * BUCKETSIZE + 3) +#define TAYLOR (19 * BUCKETSIZE + 4) +#define TEST (19 * BUCKETSIZE + 5) +#define TESTEQ (19 * BUCKETSIZE + 6) +#define TESTGE (19 * BUCKETSIZE + 7) +#define TESTGT (19 * BUCKETSIZE + 8) +#define TESTLE (19 * BUCKETSIZE + 9) +#define TESTLT (19 * BUCKETSIZE + 10) +#define TGAMMA (19 * BUCKETSIZE + 11) +#define TRACE (19 * BUCKETSIZE + 12) +#define TRANSPOSE (19 * BUCKETSIZE + 13) +#define TTY (19 * BUCKETSIZE + 14) + +#define U_UPPER (20 * BUCKETSIZE + 0) +#define U_LOWER (20 * BUCKETSIZE + 1) +#define UNIT (20 * BUCKETSIZE + 2) + +#define V_UPPER (21 * BUCKETSIZE + 0) +#define V_LOWER (21 * BUCKETSIZE + 1) + +#define W_UPPER (22 * BUCKETSIZE + 0) +#define W_LOWER (22 * BUCKETSIZE + 1) + +#define X_UPPER (23 * BUCKETSIZE + 0) +#define X_LOWER (23 * BUCKETSIZE + 1) + +#define Y_UPPER (24 * BUCKETSIZE + 0) +#define Y_LOWER (24 * BUCKETSIZE + 1) + +#define Z_UPPER (25 * BUCKETSIZE + 0) +#define Z_LOWER (25 * BUCKETSIZE + 1) +#define ZERO (25 * BUCKETSIZE + 2) + +#define ADD (26 * BUCKETSIZE + 0) +#define MULTIPLY (26 * BUCKETSIZE + 1) +#define POWER (26 * BUCKETSIZE + 2) +#define INDEX (26 * BUCKETSIZE + 3) +#define SETQ (26 * BUCKETSIZE + 4) +#define EXP1 (26 * BUCKETSIZE + 5) +#define SA (26 * BUCKETSIZE + 6) +#define SB (26 * BUCKETSIZE + 7) +#define SX (26 * BUCKETSIZE + 8) +#define ARG1 (26 * BUCKETSIZE + 9) +#define ARG2 (26 * BUCKETSIZE + 10) +#define ARG3 (26 * BUCKETSIZE + 11) +#define ARG4 (26 * BUCKETSIZE + 12) +#define ARG5 (26 * BUCKETSIZE + 13) +#define ARG6 (26 * BUCKETSIZE + 14) +#define ARG7 (26 * BUCKETSIZE + 15) +#define ARG8 (26 * BUCKETSIZE + 16) +#define ARG9 (26 * BUCKETSIZE + 17) + +#define symbol(x) symtab[x] +#define push_symbol(x) push(symbol(x)) +#define iscons(p) ((p)->atomtype == CONS) +#define isrational(p) ((p)->atomtype == RATIONAL) +#define isdouble(p) ((p)->atomtype == DOUBLE) +#define isnum(p) (isrational(p) || isdouble(p)) +#define isstr(p) ((p)->atomtype == STR) +#define istensor(p) ((p)->atomtype == TENSOR) +#define iskeyword(p) ((p)->atomtype == KSYM) +#define isusersymbol(p) ((p)->atomtype == USYM) +#define issymbol(p) (iskeyword(p) || isusersymbol(p)) +#define equal(p1, p2) (cmp(p1, p2) == 0) +#define lessp(p1, p2) (cmp(p1, p2) < 0) + +#define car(p) (iscons(p) ? (p)->u.cons.car : symbol(NIL)) +#define cdr(p) (iscons(p) ? (p)->u.cons.cdr : symbol(NIL)) +#define caar(p) car(car(p)) +#define cadr(p) car(cdr(p)) +#define cdar(p) cdr(car(p)) +#define cddr(p) cdr(cdr(p)) +#define caadr(p) car(car(cdr(p))) +#define caddr(p) car(cdr(cdr(p))) +#define cadar(p) car(cdr(car(p))) +#define cdadr(p) cdr(car(cdr(p))) +#define cddar(p) cdr(cdr(car(p))) +#define cdddr(p) cdr(cdr(cdr(p))) +#define caaddr(p) car(car(cdr(cdr(p)))) +#define cadadr(p) car(cdr(car(cdr(p)))) +#define caddar(p) car(cdr(cdr(car(p)))) +#define cadddr(p) car(cdr(cdr(cdr(p)))) +#define cdaddr(p) cdr(car(cdr(cdr(p)))) +#define cddadr(p) cdr(cdr(car(cdr(p)))) +#define cddddr(p) cdr(cdr(cdr(cdr(p)))) +#define caddddr(p) car(cdr(cdr(cdr(cdr(p))))) +#define cadaddr(p) car(cdr(car(cdr(cdr(p))))) +#define cddaddr(p) cdr(cdr(car(cdr(cdr(p))))) +#define caddadr(p) car(cdr(cdr(car(cdr(p))))) +#define cdddaddr(p) cdr(cdr(cdr(car(cdr(cdr(p)))))) +#define caddaddr(p) car(cdr(cdr(car(cdr(cdr(p)))))) + +#define MPLUS 0 +#define MMINUS 1 +#define MLENGTH(p) (((int *) (p))[-1]) +#define MZERO(p) (MLENGTH(p) == 1 && (p)[0] == 0) +#define MEQUAL(p, n) (MLENGTH(p) == 1 && (p)[0] == (n)) + +#define BLACK 0 +#define BLUE 1 +#define RED 2 + +#define Trace fprintf(stderr, "%s %d\n", __func__, __LINE__); + +extern struct atom *mem[MAXBLOCKS]; // an array of pointers +extern struct atom *free_list; +extern int tos; // top of stack +extern struct atom *stack[STACKSIZE]; +extern struct atom *symtab[27 * BUCKETSIZE]; +extern struct atom *binding[27 * BUCKETSIZE]; +extern struct atom *usrfunc[27 * BUCKETSIZE]; +extern struct atom *zero; +extern struct atom *one; +extern struct atom *minusone; +extern struct atom *imaginaryunit; +extern int eval_level; +extern int gc_level; +extern int expanding; +extern int drawing; +extern int interrupt; +extern int shuntflag; +extern int breakflag; +extern int errorflag; +extern jmp_buf jmpbuf; +extern char *trace1; +extern char *trace2; +extern int alloc_count; +extern int block_count; +extern int free_count; +extern int gc_count; +extern int bignum_count; +extern int ksym_count; +extern int usym_count; +extern int string_count; +extern int tensor_count; +extern int max_eval_level; +extern int max_tos; +extern int max_tof; +extern char strbuf[]; +extern char *outbuf; +extern int outbuf_index; +extern int outbuf_length; +struct atom * alloc_atom(void); +void alloc_block(void); +struct atom * alloc_vector(int nrow); +struct atom * alloc_matrix(int nrow, int ncol); +struct atom * alloc_tensor(int nelem); +struct atom * alloc_str(void); +void * alloc_mem(int n); +double mfloat(uint32_t *p); +void msetbit(uint32_t *x, uint32_t k); +void mclrbit(uint32_t *x, uint32_t k); +uint32_t * mscan(char *s); +char * mstr(uint32_t *u); +int mdivby1billion(uint32_t *u); +uint32_t * madd(uint32_t *u, uint32_t *v); +uint32_t * msub(uint32_t *u, uint32_t *v); +uint32_t * mmul(uint32_t *u, uint32_t *v); +uint32_t * mdiv(uint32_t *u, uint32_t *v); +uint32_t * mmod(uint32_t *u, uint32_t *v); +uint32_t * mpow(uint32_t *u, uint32_t *v); +void mshr(uint32_t *u); +int mcmp(uint32_t *u, uint32_t *v); +int meq(uint32_t *u, uint32_t *v); +uint32_t * mint(uint32_t n); +uint32_t * mnew(int n); +void mfree(uint32_t *u); +uint32_t * mcopy(uint32_t *u); +void mnorm(uint32_t *u); +uint32_t * mgcd(uint32_t *u, uint32_t *v); +uint32_t * mroot(uint32_t *a, uint32_t *n); +void list(int n); +void cons(void); +int lengthf(struct atom *p); +int findf(struct atom *p, struct atom *q); +void sort(int n); +int sort_func(const void *p1, const void *p2); +int cmp(struct atom *p1, struct atom *p2); +int cmp_numbers(struct atom *p1, struct atom *p2); +int cmp_rationals(struct atom *a, struct atom *b); +int cmp_tensors(struct atom *p1, struct atom *p2); +int find_denominator(struct atom *p); +int count_denominators(struct atom *p); +int count_numerators(struct atom *p); +void subst(void); +void eval_abs(struct atom *p1); +void absfunc(void); +void eval_add(struct atom *p1); +void add(void); +void add_terms(int n); +void flatten_terms(int h); +struct atom * combine_tensors(int h); +void add_tensors(void); +void combine_terms(int h); +int combine_terms_nib(int i); +void sort_terms(int h); +int sort_terms_func(const void *q1, const void *q2); +int cmp_terms(struct atom *p1, struct atom *p2); +void normalize_terms(int h); +void add_numbers(struct atom *p1, struct atom *p2); +void add_rationals(struct atom *p1, struct atom *p2); +void add_integers(struct atom *p1, struct atom *p2); +void subtract(void); +void eval_adj(struct atom *p1); +void adj(void); +void eval_and(struct atom *p1); +void eval_arccos(struct atom *p1); +void arccos(void); +void eval_arccosh(struct atom *p1); +void arccosh(void); +void eval_arcsin(struct atom *p1); +void arcsin(void); +void eval_arcsinh(struct atom *p1); +void arcsinh(void); +void eval_arctan(struct atom *p1); +void arctan(void); +void arctan_numbers(struct atom *X, struct atom *Y); +void eval_arctanh(struct atom *p1); +void arctanh(void); +void eval_arg(struct atom *p1); +void argfunc(void); +void arg_nib(void); +void eval_binding(struct atom *p1); +void eval_break(struct atom *p1); +void eval_ceiling(struct atom *p1); +void ceilingfunc(void); +void eval_check(struct atom *p1); +void eval_clear(struct atom *p1); +void eval_clock(struct atom *p1); +void clockfunc(void); +void eval_cofactor(struct atom *p1); +void eval_conj(struct atom *p1); +void conjfunc(void); +void conjfunc_subst(void); +void eval_contract(struct atom *p1); +void contract(void); +void eval_cos(struct atom *p1); +void cosfunc(void); +void cosfunc_sum(struct atom *p1); +void eval_cosh(struct atom *p1); +void coshfunc(void); +void eval_defint(struct atom *p1); +void eval_denominator(struct atom *p1); +void denominator(void); +void eval_derivative(struct atom *p1); +void derivative(void); +void d_scalar_scalar(struct atom *F, struct atom *X); +void dsum(struct atom *p1, struct atom *p2); +void dproduct(struct atom *p1, struct atom *p2); +void dpower(struct atom *F, struct atom *X); +void dlog(struct atom *p1, struct atom *p2); +void dfunction(struct atom *p1, struct atom *p2); +void dsin(struct atom *p1, struct atom *p2); +void dcos(struct atom *p1, struct atom *p2); +void dtan(struct atom *p1, struct atom *p2); +void darcsin(struct atom *p1, struct atom *p2); +void darccos(struct atom *p1, struct atom *p2); +void darctan(struct atom *p1, struct atom *p2); +void dsinh(struct atom *p1, struct atom *p2); +void dcosh(struct atom *p1, struct atom *p2); +void dtanh(struct atom *p1, struct atom *p2); +void darcsinh(struct atom *p1, struct atom *p2); +void darccosh(struct atom *p1, struct atom *p2); +void darctanh(struct atom *p1, struct atom *p2); +void derf(struct atom *p1, struct atom *p2); +void derfc(struct atom *p1, struct atom *p2); +void d_tensor_tensor(struct atom *p1, struct atom *p2); +void d_scalar_tensor(struct atom *p1, struct atom *p2); +void d_tensor_scalar(struct atom *p1, struct atom *p2); +void derivative_of_derivative(struct atom *F, struct atom *X); +void derivative_of_integral(struct atom *F, struct atom *X); +void eval_det(struct atom *p1); +void det(void); +void eval_dim(struct atom *p1); +void eval_do(struct atom *p1); +void eval_eigenvec(struct atom *p1); +void eigenvec(double *D, double *Q, int n); +int eigenvec_step(double *D, double *Q, int n); +void eigenvec_step_nib(double *D, double *Q, int n, int p, int q); +void eval_erf(struct atom *p1); +void erffunc(void); +void eval_erfc(struct atom *p1); +void erfcfunc(void); +void eval_eval(struct atom *p1); +void asubst(void); +int addcmp(struct atom *p1, struct atom *p2); +int mulcmp(struct atom *p1, struct atom *p2); +int powcmp(struct atom *p1, struct atom *p2); +void eval_exp(struct atom *p1); +void expfunc(void); +void eval_expcos(struct atom *p1); +void expcos(void); +void eval_expcosh(struct atom *p1); +void expcosh(void); +void eval_expform(struct atom *p1); +void expform(void); +void eval_expsin(struct atom *p1); +void expsin(void); +void eval_expsinh(struct atom *p1); +void expsinh(void); +void eval_exptan(struct atom *p1); +void exptan(void); +void eval_exptanh(struct atom *p1); +void exptanh(void); +void eval_factorial(struct atom *p1); +void factorial(void); +void eval_float(struct atom *p1); +void floatfunc(void); +void floatfunc_subst(void); +void eval_floor(struct atom *p1); +void floorfunc(void); +void eval_for(struct atom *p1); +void eval_hadamard(struct atom *p1); +void hadamard(void); +void eval_imag(struct atom *p1); +void imag(void); +void eval_index(struct atom *p1); +void indexfunc(struct atom *T, int h); +void eval_infixform(struct atom *p1); +void print_infixform(struct atom *p); +void infixform_subexpr(struct atom *p); +void infixform_expr(struct atom *p); +void infixform_expr_nib(struct atom *p); +void infixform_term(struct atom *p); +void infixform_term_nib(struct atom *p); +void infixform_numerators(struct atom *p); +void infixform_denominators(struct atom *p); +void infixform_factor(struct atom *p); +void infixform_power(struct atom *p); +void infixform_reciprocal(struct atom *p); +void infixform_factorial(struct atom *p); +void infixform_index(struct atom *p); +void infixform_arglist(struct atom *p); +void infixform_rational(struct atom *p); +void infixform_double(struct atom *p); +void infixform_base(struct atom *p); +void infixform_numeric_base(struct atom *p); +void infixform_numeric_exponent(struct atom *p); +void infixform_tensor(struct atom *p); +void infixform_tensor_nib(struct atom *p, int d, int k); +void eval_inner(struct atom *p1); +void inner(void); +void eval_integral(struct atom *p1); +void integral(void); +void integral_solve(struct atom *F, struct atom *X); +void integral_solve_nib(struct atom *F, struct atom *X); +int integral_classify(struct atom *p); +int integral_search(int h, struct atom *F, char **table, int n); +int integral_search_nib(int h, struct atom *F, struct atom *I, struct atom *C); +void decomp(void); +void decomp_sum(struct atom *F, struct atom *X); +void decomp_product(struct atom *F, struct atom *X); +void partition_term(void); +void integral_of_integral(struct atom *F, struct atom *X); +void integral_of_derivative(struct atom *F, struct atom *X); +void eval_inv(struct atom *p1); +void inv(void); +void eval_kronecker(struct atom *p1); +void kronecker(void); +void eval_lgamma(struct atom *p1); +void lgammafunc(void); +void eval_log(struct atom *p1); +void logfunc(void); +void eval_loop(struct atom *p1); +void eval_mag(struct atom *p1); +void magfunc(void); +void magfunc_nib(void); +void eval_minor(struct atom *p1); +void eval_minormatrix(struct atom *p1); +void minormatrix(int row, int col); +void eval_mod(struct atom *p1); +void modfunc(void); +void mod_rationals(struct atom *p1, struct atom *p2); +void mod_integers(struct atom *p1, struct atom *p2); +void eval_multiply(struct atom *p1); +void multiply(void); +void multiply_factors(int n); +void flatten_factors(int h); +struct atom * multiply_tensor_factors(int h); +void multiply_scalar_factors(int h); +struct atom * combine_numerical_factors(int h, struct atom *COEF); +void combine_factors(int h); +int combine_factors_nib(int i, int j); +void sort_factors_provisional(int h); +int sort_factors_provisional_func(const void *q1, const void *q2); +int cmp_factors_provisional(struct atom *p1, struct atom *p2); +void normalize_power_factors(int h); +void expand_sum_factors(int h); +void sort_factors(int n); +int sort_factors_func(const void *q1, const void *q2); +int cmp_factors(struct atom *p1, struct atom *p2); +int order_factor(struct atom *p); +void multiply_numbers(struct atom *p1, struct atom *p2); +void multiply_rationals(struct atom *p1, struct atom *p2); +struct atom * reduce_radical_factors(int h, struct atom *COEF); +int any_radical_factors(int h); +struct atom * reduce_radical_double(int h, struct atom *COEF); +struct atom * reduce_radical_rational(int h, struct atom *COEF); +void multiply_expand(void); +void multiply_noexpand(void); +void negate(void); +void reciprocate(void); +void divide(void); +void eval_nil(struct atom *p1); +void eval_noexpand(struct atom *p1); +void eval_not(struct atom *p1); +void eval_nroots(struct atom *p1); +void nroots(void); +void nfindroot(double cr[], double ci[], int n, double *par, double *pai); +void fata(double cr[], double ci[], int n, double ar, double ai, double *far, double *fai); +void nreduce(double cr[], double ci[], int n, double ar, double ai); +double zabs(double r, double i); +double urandom(void); +void eval_number(struct atom *p1); +void eval_numerator(struct atom *p1); +void numerator(void); +void eval_or(struct atom *p1); +void eval_outer(struct atom *p1); +void outer(void); +void eval_polar(struct atom *p1); +void polar(void); +void eval_power(struct atom *p1); +void power(void); +void power_numbers(struct atom *BASE, struct atom *EXPO); +void power_numbers_factor(struct atom *BASE, struct atom *EXPO); +void power_double(struct atom *BASE, struct atom *EXPO); +void power_minusone(struct atom *EXPO); +void normalize_clock_rational(struct atom *EXPO); +void normalize_clock_double(struct atom *EXPO); +void power_natural_number(struct atom *EXPO); +void normalize_polar(struct atom *EXPO); +void normalize_polar_term(struct atom *EXPO); +void normalize_polar_term_rational(struct atom *R); +void normalize_polar_term_double(struct atom *R); +void power_sum(struct atom *BASE, struct atom *EXPO); +void power_complex_number(struct atom *BASE, struct atom *EXPO); +void power_complex_plus(struct atom *X, struct atom *Y, int n); +void power_complex_minus(struct atom *X, struct atom *Y, int n); +void power_complex_double(struct atom *X, struct atom *Y, struct atom *EXPO); +void power_complex_rational(struct atom *X, struct atom *Y, struct atom *EXPO); +void eval_prefixform(struct atom *p1); +void print_prefixform(struct atom *p); +void prefixform(struct atom *p); +void eval_print(struct atom *p1); +void print_result(void); +int annotate_result(struct atom *p1, struct atom *p2); +void eval_product(struct atom *p1); +void eval_quote(struct atom *p1); +void eval_rand(struct atom *p1); +void eval_rank(struct atom *p1); +void eval_rationalize(struct atom *p1); +void rationalize(void); +void eval_real(struct atom *p1); +void real(void); +void eval_rect(struct atom *p1); +void rect(void); +void eval_roots(struct atom *p1); +void roots(void); +int findroot(int h, int n); +void horner(int h, int n, struct atom *A); +void divisors(int n); +void divisors_nib(int h, int k); +void reduce(int h, int n, struct atom *A); +void coeffs(struct atom *P, struct atom *X); +void eval_rotate(struct atom *p1); +void rotate_h(struct atom *PSI, uint32_t c, int n); +void rotate_p(struct atom *PSI, struct atom *PHASE, uint32_t c, int n); +void rotate_w(struct atom *PSI, uint32_t c, int m, int n); +void rotate_x(struct atom *PSI, uint32_t c, int n); +void rotate_y(struct atom *PSI, uint32_t c, int n); +void rotate_z(struct atom *PSI, uint32_t c, int n); +void rotate_q(struct atom *PSI, int n); +void rotate_v(struct atom *PSI, int n); +void eval_run(struct atom *p1); +char * read_file(char *filename); +void eval_setq(struct atom *p1); +void setq_indexed(struct atom *p1); +void set_component(struct atom *LVAL, struct atom *RVAL, int h); +void setq_usrfunc(struct atom *p1); +void convert_body(struct atom *A); +void eval_sgn(struct atom *p1); +void sgnfunc(void); +void eval_simplify(struct atom *p1); +void simplify(void); +void simplify_nib(void); +void simplify_trig(void); +int simpler(struct atom *p1, struct atom *p2); +int diameter(struct atom *p); +int mass(struct atom *p); +void eval_sin(struct atom *p1); +void sinfunc(void); +void sinfunc_sum(struct atom *p1); +void eval_sinh(struct atom *p1); +void sinhfunc(void); +void eval_sqrt(struct atom *p1); +void sqrtfunc(void); +void eval_status(struct atom *p1); +void eval_stop(struct atom *p1); +void eval_sum(struct atom *p1); +void eval_tan(struct atom *p1); +void tanfunc(void); +void tanfunc_sum(struct atom *p1); +void eval_tanh(struct atom *p1); +void tanhfunc(void); +void eval_taylor(struct atom *p1); +void eval_tensor(struct atom *p1); +void promote_tensor(void); +int compatible_dimensions(struct atom *p, struct atom *q); +struct atom * copy_tensor(struct atom *p1); +void eval_test(struct atom *p1); +void eval_testeq(struct atom *p1); +void eval_testge(struct atom *p1); +void eval_testgt(struct atom *p1); +void eval_testle(struct atom *p1); +void eval_testlt(struct atom *p1); +int cmp_args(struct atom *p1); +void eval_tgamma(struct atom *p1); +void tgammafunc(void); +void eval_transpose(struct atom *p1); +void transpose(int n, int m); +void eval_unit(struct atom *p1); +void eval_user_function(struct atom *p1); +void eval_user_symbol(struct atom *p1); +void eval_zero(struct atom *p1); +void evalg(void); +void evalf(void); +void evalf_nib(struct atom *p1); +void evalp(void); +void factor_factor(void); +void factor_bignum(uint32_t *N, struct atom *M); +void factor_int(int n); +void fmt(void); +void fmt_args(struct atom *p); +void fmt_base(struct atom *p); +void fmt_denominators(struct atom *p); +void fmt_double(struct atom *p); +void fmt_exponent(struct atom *p); +void fmt_expr(struct atom *p); +void fmt_expr_nib(struct atom *p); +void fmt_factor(struct atom *p); +void fmt_frac(struct atom *p); +void fmt_function(struct atom *p); +void fmt_indices(struct atom *p); +void fmt_infix_operator(int c); +void fmt_list(struct atom *p); +void fmt_matrix(struct atom *p, int d, int k); +void fmt_numerators(struct atom *p); +void fmt_numeric_exponent(struct atom *p); +void fmt_power(struct atom *p); +void fmt_rational(struct atom *p); +void fmt_reciprocal(struct atom *p); +void fmt_roman_char(int c); +void fmt_roman_string(char *s); +void fmt_space(void); +void fmt_string(struct atom *p); +void fmt_subexpr(struct atom *p); +void fmt_symbol(struct atom *p); +int fmt_symbol_fragment(char *s, int k); +void fmt_table(int x, int y, struct atom *p); +void fmt_tensor(struct atom *p); +void fmt_term(struct atom *p); +void fmt_term_nib(struct atom *p); +void fmt_update_fraction(void); +void fmt_update_list(int t); +void fmt_update_subexpr(void); +void fmt_update_subscript(void); +void fmt_update_superscript(void); +void fmt_update_table(int n, int m); +void fmt_vector(struct atom *p); +void fmt_draw(int x, int y, struct atom *p); +void fmt_draw_char(int x, int y, int c); +void fmt_draw_delims(int x, int y, int h, int d, int w); +void fmt_draw_ldelim(int x, int y, int h, int d); +void fmt_draw_rdelim(int x, int y, int h, int d); +void fmt_draw_table(int x, int y, struct atom *p); +void fmt_putw(uint32_t w); +void gc(void); +void untag(struct atom *p); +void run_infile(char *infile); +void run_stdin(void); +void display(void); +void printbuf(char *s, int color); +void eval_draw(struct atom *p1); +void eval_exit(struct atom *p1); +void numden(void); +int numden_find_divisor(struct atom *p); +int numden_find_divisor_term(struct atom *p); +int numden_find_divisor_factor(struct atom *p); +void numden_cancel_factor(void); +void outbuf_init(void); +void outbuf_puts(char *s); +void outbuf_putc(int c); +int iszero(struct atom *p); +int isequaln(struct atom *p, int n); +int isequalq(struct atom *p, int a, int b); +int isplusone(struct atom *p); +int isminusone(struct atom *p); +int isinteger(struct atom *p); +int isfraction(struct atom *p); +int isposint(struct atom *p); +int isradicalterm(struct atom *p); +int isradical(struct atom *p); +int isnegativeterm(struct atom *p); +int isnegativenumber(struct atom *p); +int isimaginaryterm(struct atom *p); +int isimaginaryfactor(struct atom *p); +int iscomplexnumber(struct atom *p); +int isimaginarynumber(struct atom *p); +int isimaginaryunit(struct atom *p); +int isoneoversqrttwo(struct atom *p); +int isminusoneoversqrttwo(struct atom *p); +int isdoublez(struct atom *p); +int isdenominator(struct atom *p); +int isnumerator(struct atom *p); +int hasdouble(struct atom *p); +int isdenormalpolar(struct atom *p); +int isdenormalpolarterm(struct atom *p); +int issquarematrix(struct atom *p); +int issmallinteger(struct atom *p); +int dependent(struct atom *f, struct atom *x); +void run(char *buf); +void run_buf(char *buf); +char * scan_input(char *s); +void print_trace(int color); +void run_init_script(void); +void stopf(char *s); +char * scan(char *s); +char * scan1(char *s); +char * scan_nib(char *s); +void scan_stmt(void); +void scan_comparison(void); +void scan_expression(void); +int another_factor_pending(void); +void scan_term(void); +void scan_power(void); +void scan_factor(void); +void scan_symbol(void); +void scan_string(void); +void scan_function_call(void); +void scan_integer(void); +void scan_subexpr(void); +void get_token_skip_newlines(void); +void get_token(void); +void get_token_nib(void); +void update_token_buf(char *a, char *b); +void scan_error(char *errmsg); +void static_negate(void); +void static_reciprocate(void); +void push(struct atom *p); +struct atom * pop(void); +void save_symbol(struct atom *p); +void restore_symbol(void); +void dupl(void); +void swap(void); +void push_integer(int n); +void push_rational(int a, int b); +void push_bignum(int sign, uint32_t *a, uint32_t *b); +int pop_integer(void); +void push_double(double d); +double pop_double(void); +void push_string(char *s); +void slice(int h, int n); +struct atom * lookup(char *s); +char * printname(struct atom *p); +void set_symbol(struct atom *p1, struct atom *p2, struct atom *p3); +struct atom * get_binding(struct atom *p1); +struct atom * get_usrfunc(struct atom *p); +void init_symbol_table(void); +struct atom * +alloc_atom(void) +{ + struct atom *p; + + if (free_count == 0) + alloc_block(); + + p = free_list; + free_list = p->u.next; + + free_count--; + alloc_count++; + + return p; +} + +void +alloc_block(void) +{ + int i; + struct atom *p; + + if (block_count == MAXBLOCKS) { + tos = 0; + gc(); // prep for next run + stopf("out of memory"); + } + + p = alloc_mem(BLOCKSIZE * sizeof (struct atom)); + + mem[block_count++] = p; + + for (i = 0; i < BLOCKSIZE - 1; i++) { + p[i].atomtype = FREEATOM; + p[i].u.next = p + i + 1; + } + + p[i].atomtype = FREEATOM; + p[i].u.next = NULL; + + free_list = p; + free_count = BLOCKSIZE; +} + +struct atom * +alloc_vector(int nrow) +{ + struct atom *p = alloc_tensor(nrow); + p->u.tensor->ndim = 1; + p->u.tensor->dim[0] = nrow; + return p; +} + +struct atom * +alloc_matrix(int nrow, int ncol) +{ + struct atom *p = alloc_tensor(nrow * ncol); + p->u.tensor->ndim = 2; + p->u.tensor->dim[0] = nrow; + p->u.tensor->dim[1] = ncol; + return p; +} + +struct atom * +alloc_tensor(int nelem) +{ + int i; + struct atom *p; + struct tensor *t; + p = alloc_atom(); + t = alloc_mem(sizeof (struct tensor) + nelem * sizeof (struct atom *)); + p->atomtype = TENSOR; + p->u.tensor = t; + t->nelem = nelem; + for (i = 0; i < nelem; i++) + t->elem[i] = zero; + tensor_count++; + return p; +} + +struct atom * +alloc_str(void) +{ + struct atom *p; + p = alloc_atom(); + p->atomtype = STR; + p->u.str = NULL; + string_count++; + return p; +} + +void * +alloc_mem(int n) +{ + void *p = malloc(n); + if (p == NULL) + exit(1); + return p; +} +double +mfloat(uint32_t *p) +{ + int i, n; + double d; + n = MLENGTH(p); + d = 0.0; + for (i = 0; i < n; i++) + d += scalbn((double) p[i], 32 * i); + return d; +} + +void +msetbit(uint32_t *x, uint32_t k) +{ + x[k / 32] |= 1 << (k % 32); +} + +void +mclrbit(uint32_t *x, uint32_t k) +{ + x[k / 32] &= ~(1 << (k % 32)); +} + +// convert string to bignum (9 decimal digits fits in 32 bits) + +uint32_t * +mscan(char *s) +{ + int i, k, len; + uint32_t *a, *b, *t; + a = mint(0); + len = (int) strlen(s); + if (len == 0) + return a; + k = len % 9; + if (k == 0) + k = 9; + for (i = 0; i < k; i++) + a[0] = 10 * a[0] + s[i] - '0'; + if (k == len) + return a; + b = mint(0); + while (k < len) { + b[0] = 1000000000; // 10^9 + t = mmul(a, b); + mfree(a); + a = t; + b[0] = 0; + for (i = 0; i < 9; i++) + b[0] = 10 * b[0] + s[k++] - '0'; + t = madd(a, b); + mfree(a); + a = t; + } + mfree(b); + return a; +} + +// convert bignum to string (returned value points to static buffer) + +char * +mstr(uint32_t *u) +{ + int i, k, n, r; + static char *buf; + static int len; + + // estimate string length + + // note that 0xffffffff -> 000000004 294967295 + + // hence space for 8 leading zeroes is required + + n = 10 * MLENGTH(u) + 10; + + n = 1000 * (n / 1000 + 1); + + if (n > len) { + if (buf) + free(buf); + buf = alloc_mem(n); + len = n; + } + + u = mcopy(u); + + k = len - 1; + buf[k] = '\0'; // string terminator + + for (;;) { + r = mdivby1billion(u); + for (i = 0; i < 9; i++) { + buf[--k] = r % 10 + '0'; + r /= 10; + } + if (MZERO(u)) + break; + } + + mfree(u); + + // remove leading zeroes + + while (buf[k] == '0' && buf[k + 1]) + k++; + + return buf + k; +} + +// returns remainder, quotient returned in u + +int +mdivby1billion(uint32_t *u) +{ + int i; + uint64_t r = 0; + for (i = MLENGTH(u) - 1; i >= 0; i--) { + r = r << 32 | u[i]; + u[i] = (uint32_t) (r / 1000000000); + r -= (uint64_t) 1000000000 * u[i]; + } + mnorm(u); + return (int) r; +} + +// returns u + v + +uint32_t * +madd(uint32_t *u, uint32_t *v) +{ + int i, nu, nv, nw; + uint64_t t; + uint32_t *w; + nu = MLENGTH(u); + nv = MLENGTH(v); + if (nu > nv) + nw = nu + 1; + else + nw = nv + 1; + w = mnew(nw); + for (i = 0; i < nu; i++) + w[i] = u[i]; + for (i = nu; i < nw; i++) + w[i] = 0; + t = 0; + for (i = 0; i < nv; i++) { + t += (uint64_t) w[i] + v[i]; + w[i] = (uint32_t) t; + t >>= 32; + } + for (i = nv; i < nw; i++) { + t += w[i]; + w[i] = (uint32_t) t; + t >>= 32; + } + mnorm(w); + return w; +} + +// returns u - v + +uint32_t * +msub(uint32_t *u, uint32_t *v) +{ + int i, nu, nv, nw; + uint64_t t; + uint32_t *w; + nu = MLENGTH(u); + nv = MLENGTH(v); + if (nu > nv) + nw = nu; + else + nw = nv; + w = mnew(nw); + for (i = 0; i < nu; i++) + w[i] = u[i]; + for (i = nu; i < nw; i++) + w[i] = 0; + t = 0; + for (i = 0; i < nv; i++) { + t += (uint64_t) w[i] - v[i]; + w[i] = (uint32_t) t; + t = (int64_t) t >> 32; // cast to extend sign + } + for (i = nv; i < nw; i++) { + t += w[i]; + w[i] = (uint32_t) t; + t = (int64_t) t >> 32; // cast to extend sign + } + mnorm(w); + return w; +} + +// returns u * v + +uint32_t * +mmul(uint32_t *u, uint32_t *v) +{ + int i, j, nu, nv, nw; + uint64_t t; + uint32_t *w; + nu = MLENGTH(u); + nv = MLENGTH(v); + nw = nu + nv; + w = mnew(nw); + for (i = 0; i < nw; i++) + w[i] = 0; + for (i = 0; i < nu; i++) { + t = 0; + for (j = 0; j < nv; j++) { + t += (uint64_t) u[i] * v[j] + w[i + j]; + w[i + j] = (uint32_t) t; + t >>= 32; + } + w[i + j] = (uint32_t) t; + } + mnorm(w); + return w; +} + +// returns floor(u / v) + +uint32_t * +mdiv(uint32_t *u, uint32_t *v) +{ + int i, k, nu, nv; + uint32_t *q, qhat, *w; + uint64_t a, b, t; + mnorm(u); + mnorm(v); + if (MLENGTH(v) == 1 && v[0] == 0) + stopf("divide by zero"); // v = 0 + nu = MLENGTH(u); + nv = MLENGTH(v); + k = nu - nv; + if (k < 0) { + q = mnew(1); + q[0] = 0; + return q; // u < v, return zero + } + u = mcopy(u); + q = mnew(k + 1); + w = mnew(nv + 1); + b = v[nv - 1]; + do { + q[k] = 0; + while (nu >= nv + k) { + // estimate 32-bit partial quotient + a = u[nu - 1]; + if (nu > nv + k) + a = a << 32 | u[nu - 2]; + if (a < b) + break; + qhat = (uint32_t) (a / (b + 1)); + if (qhat == 0) + qhat = 1; + // w = qhat * v + t = 0; + for (i = 0; i < nv; i++) { + t += (uint64_t) qhat * v[i]; + w[i] = (uint32_t) t; + t >>= 32; + } + w[nv] = (uint32_t) t; + // u = u - w + t = 0; + for (i = k; i < nu; i++) { + t += (uint64_t) u[i] - w[i - k]; + u[i] = (uint32_t) t; + t = (int64_t) t >> 32; // cast to extend sign + } + if (t) { + // u is negative, restore u + t = 0; + for (i = k; i < nu; i++) { + t += (uint64_t) u[i] + w[i - k]; + u[i] = (uint32_t) t; + t >>= 32; + } + break; + } + q[k] += qhat; + mnorm(u); + nu = MLENGTH(u); + } + } while (--k >= 0); + mnorm(q); + mfree(u); + mfree(w); + return q; +} + +// returns u mod v + +uint32_t * +mmod(uint32_t *u, uint32_t *v) +{ + int i, k, nu, nv; + uint32_t qhat, *w; + uint64_t a, b, t; + mnorm(u); + mnorm(v); + if (MLENGTH(v) == 1 && v[0] == 0) + stopf("divide by zero"); // v = 0 + u = mcopy(u); + nu = MLENGTH(u); + nv = MLENGTH(v); + k = nu - nv; + if (k < 0) + return u; // u < v + w = mnew(nv + 1); + b = v[nv - 1]; + do { + while (nu >= nv + k) { + // estimate 32-bit partial quotient + a = u[nu - 1]; + if (nu > nv + k) + a = a << 32 | u[nu - 2]; + if (a < b) + break; + qhat = (uint32_t) (a / (b + 1)); + if (qhat == 0) + qhat = 1; + // w = qhat * v + t = 0; + for (i = 0; i < nv; i++) { + t += (uint64_t) qhat * v[i]; + w[i] = (uint32_t) t; + t >>= 32; + } + w[nv] = (uint32_t) t; + // u = u - w + t = 0; + for (i = k; i < nu; i++) { + t += (uint64_t) u[i] - w[i - k]; + u[i] = (uint32_t) t; + t = (int64_t) t >> 32; // cast to extend sign + } + if (t) { + // u is negative, restore u + t = 0; + for (i = k; i < nu; i++) { + t += (uint64_t) u[i] + w[i - k]; + u[i] = (uint32_t) t; + t >>= 32; + } + break; + } + mnorm(u); + nu = MLENGTH(u); + } + } while (--k >= 0); + mfree(w); + return u; +} + +// returns u ** v + +uint32_t * +mpow(uint32_t *u, uint32_t *v) +{ + uint32_t *t, *w; + u = mcopy(u); + v = mcopy(v); + // w = 1 + w = mnew(1); + w[0] = 1; + for (;;) { + if (v[0] & 1) { + // w = w * u + t = mmul(w, u); + mfree(w); + w = t; + } + // v = v >> 1 + mshr(v); + // v = 0? + if (MLENGTH(v) == 1 && v[0] == 0) + break; + // u = u * u + t = mmul(u, u); + mfree(u); + u = t; + } + mfree(u); + mfree(v); + return w; +} + +// u = u >> 1 + +void +mshr(uint32_t *u) +{ + int i; + for (i = 0; i < MLENGTH(u) - 1; i++) { + u[i] >>= 1; + if (u[i + 1] & 1) + u[i] |= 0x80000000; + } + u[i] >>= 1; + mnorm(u); +} + +// compare u and v + +int +mcmp(uint32_t *u, uint32_t *v) +{ + int i; + mnorm(u); + mnorm(v); + if (MLENGTH(u) < MLENGTH(v)) + return -1; + if (MLENGTH(u) > MLENGTH(v)) + return 1; + for (i = MLENGTH(u) - 1; i >= 0; i--) { + if (u[i] < v[i]) + return -1; + if (u[i] > v[i]) + return 1; + } + return 0; // u = v +} + +int +meq(uint32_t *u, uint32_t *v) +{ + int i; + if (MLENGTH(u) != MLENGTH(v)) + return 0; + for (i = 0; i < MLENGTH(u); i++) + if (u[i] != v[i]) + return 0; + return 1; +} + +// convert unsigned to bignum + +uint32_t * +mint(uint32_t n) +{ + uint32_t *p; + p = mnew(1); + p[0] = n; + return p; +} + +uint32_t * +mnew(int n) +{ + uint32_t *u; + u = alloc_mem((n + 1) * sizeof (uint32_t)); + bignum_count++; + *u = n; + return u + 1; +} + +void +mfree(uint32_t *u) +{ + free(u - 1); + bignum_count--; +} + +uint32_t * +mcopy(uint32_t *u) +{ + int i; + uint32_t *v; + v = mnew(MLENGTH(u)); + for (i = 0; i < MLENGTH(u); i++) + v[i] = u[i]; + return v; +} + +// remove leading zeroes + +void +mnorm(uint32_t *u) +{ + while (MLENGTH(u) > 1 && u[MLENGTH(u) - 1] == 0) + MLENGTH(u)--; +} + +uint32_t * +mgcd(uint32_t *u, uint32_t *v) +{ + int i, k, n, sign; + uint32_t *t; + + if (MZERO(u)) { + t = mcopy(v); + return t; + } + + if (MZERO(v)) { + t = mcopy(u); + return t; + } + + u = mcopy(u); + v = mcopy(v); + + k = 0; + + while ((u[0] & 1) == 0 && (v[0] & 1) == 0) { + mshr(u); + mshr(v); + k++; + } + + if (u[0] & 1) { + t = mcopy(v); + sign = -1; + } else { + t = mcopy(u); + sign = 1; + } + + while (1) { + + while ((t[0] & 1) == 0) + mshr(t); + + if (sign == 1) { + mfree(u); + u = mcopy(t); + } else { + mfree(v); + v = mcopy(t); + } + + mfree(t); + + if (mcmp(u, v) < 0) { + t = msub(v, u); + sign = -1; + } else { + t = msub(u, v); + sign = 1; + } + + if (MZERO(t)) { + mfree(t); + mfree(v); + n = (k / 32) + 1; + v = mnew(n); + for (i = 0; i < n; i++) + v[i] = 0; + msetbit(v, k); + t = mmul(u, v); + mfree(u); + mfree(v); + return t; + } + } +} + +// returns NULL if not perfect root, otherwise returns a^(1/n) + +uint32_t * +mroot(uint32_t *a, uint32_t *n) +{ + int i, j, k; + uint32_t *b, *c, m; + + if (MLENGTH(n) > 1 || n[0] == 0) + return NULL; + + // k is bit length of a + + k = 32 * (MLENGTH(a) - 1); + + m = a[MLENGTH(a) - 1]; + + while (m) { + m >>= 1; + k++; + } + + if (k == 0) + return mint(0); + + // initial guess of index of ms bit in result + + k = (k - 1) / n[0]; + + j = k / 32 + 1; // k is bit index, not number of bits + + b = mnew(j); + + for (i = 0; i < j; i++) + b[i] = 0; + + while (k >= 0) { + msetbit(b, k); + mnorm(b); + c = mpow(b, n); + switch (mcmp(c, a)) { + case -1: + break; + case 0: + mfree(c); + return b; + case 1: + mclrbit(b, k); + break; + } + mfree(c); + k--; + } + + mfree(b); + + return NULL; +} +// create a list from n things on the stack + +void +list(int n) +{ + int i; + push_symbol(NIL); + for (i = 0; i < n; i++) + cons(); +} + +void +cons(void) +{ + struct atom *p; + p = alloc_atom(); + p->atomtype = CONS; + p->u.cons.cdr = pop(); + p->u.cons.car = pop(); + push(p); +} + +int +lengthf(struct atom *p) +{ + int n = 0; + while (iscons(p)) { + n++; + p = cdr(p); + } + return n; +} + +// returns 1 if expr p contains expr q, otherwise returns 0 + +int +findf(struct atom *p, struct atom *q) +{ + int i; + + if (equal(p, q)) + return 1; + + if (istensor(p)) { + for (i = 0; i < p->u.tensor->nelem; i++) + if (findf(p->u.tensor->elem[i], q)) + return 1; + return 0; + } + + while (iscons(p)) { + if (findf(car(p), q)) + return 1; + p = cdr(p); + } + + return 0; +} + +// sort n things on the stack + +void +sort(int n) +{ + qsort(stack + tos - n, n, sizeof (struct atom *), sort_func); +} + +int +sort_func(const void *p1, const void *p2) +{ + return cmp(*((struct atom **) p1), *((struct atom **) p2)); +} + +int +cmp(struct atom *p1, struct atom *p2) +{ + int t; + + if (p1 == p2) + return 0; + + if (p1 == symbol(NIL)) + return -1; + + if (p2 == symbol(NIL)) + return 1; + + if (isnum(p1) && isnum(p2)) + return cmp_numbers(p1, p2); + + if (isnum(p1)) + return -1; + + if (isnum(p2)) + return 1; + + if (isstr(p1) && isstr(p2)) + return strcmp(p1->u.str, p2->u.str); + + if (isstr(p1)) + return -1; + + if (isstr(p2)) + return 1; + + if (issymbol(p1) && issymbol(p2)) + return strcmp(printname(p1), printname(p2)); + + if (issymbol(p1)) + return -1; + + if (issymbol(p2)) + return 1; + + if (istensor(p1) && istensor(p2)) + return cmp_tensors(p1, p2); + + if (istensor(p1)) + return -1; + + if (istensor(p2)) + return 1; + + while (iscons(p1) && iscons(p2)) { + t = cmp(car(p1), car(p2)); + if (t) + return t; + p1 = cdr(p1); + p2 = cdr(p2); + } + + if (iscons(p2)) + return -1; // lengthf(p1) < lengthf(p2) + + if (iscons(p1)) + return 1; // lengthf(p1) > lengthf(p2) + + return 0; +} + +int +cmp_numbers(struct atom *p1, struct atom *p2) +{ + double d1, d2; + + if (isrational(p1) && isrational(p2)) + return cmp_rationals(p1, p2); + + push(p1); + d1 = pop_double(); + + push(p2); + d2 = pop_double(); + + if (d1 < d2) + return -1; + + if (d1 > d2) + return 1; + + return 0; +} + +int +cmp_rationals(struct atom *a, struct atom *b) +{ + int t; + uint32_t *ab, *ba; + if (a->sign == MMINUS && b->sign == MPLUS) + return -1; + if (a->sign == MPLUS && b->sign == MMINUS) + return 1; + if (isinteger(a) && isinteger(b)) { + if (a->sign == MMINUS) + return mcmp(b->u.q.a, a->u.q.a); + else + return mcmp(a->u.q.a, b->u.q.a); + } + ab = mmul(a->u.q.a, b->u.q.b); + ba = mmul(a->u.q.b, b->u.q.a); + if (a->sign == MMINUS) + t = mcmp(ba, ab); + else + t = mcmp(ab, ba); + mfree(ab); + mfree(ba); + return t; +} + +int +cmp_tensors(struct atom *p1, struct atom *p2) +{ + int i, t; + + t = p1->u.tensor->ndim - p2->u.tensor->ndim; + + if (t) + return t; + + for (i = 0; i < p1->u.tensor->ndim; i++) { + t = p1->u.tensor->dim[i] - p2->u.tensor->dim[i]; + if (t) + return t; + } + + for (i = 0; i < p1->u.tensor->nelem; i++) { + t = cmp(p1->u.tensor->elem[i], p2->u.tensor->elem[i]); + if (t) + return t; + } + + return 0; +} + +int +find_denominator(struct atom *p) +{ + struct atom *q; + p = cdr(p); + while (iscons(p)) { + q = car(p); + if (car(q) == symbol(POWER) && isnegativenumber(caddr(q))) + return 1; + p = cdr(p); + } + return 0; +} + +int +count_denominators(struct atom *p) +{ + int n = 0; + p = cdr(p); + while (iscons(p)) { + if (isdenominator(car(p))) + n++; + p = cdr(p); + } + return n; +} + +int +count_numerators(struct atom *p) +{ + int n = 0; + p = cdr(p); + while (iscons(p)) { + if (isnumerator(car(p))) + n++; + p = cdr(p); + } + return n; +} + +// cannot do any evalf in subst because subst is used by func defn + +void +subst(void) +{ + int h, i, n; + struct atom *p1, *p2, *p3; + + p3 = pop(); // new expr + p2 = pop(); // old expr + p1 = pop(); // expr + + if (p2 == symbol(NIL) || p3 == symbol(NIL)) { + push(p1); + return; + } + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + push(p2); + push(p3); + subst(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (equal(p1, p2)) { + push(p3); + return; + } + + if (!iscons(p1)) { + push(p1); + return; + } + + // depth first + + h = tos; + + while (iscons(p1)) { + push(car(p1)); + push(p2); + push(p3); + subst(); + p1 = cdr(p1); + } + + list(tos - h); +} +// automatic variables not visible to the garbage collector are reclaimed + +void +evalg(void) +{ + if (gc_level == eval_level && alloc_count > MAXBLOCKS * BLOCKSIZE / 10) + gc(); + gc_level++; + evalf(); + gc_level--; +} + +// call evalf instead of evalg to evaluate without garbage collection + +void +evalf(void) +{ + struct atom *p; + eval_level++; + p = pop(); + push(p); // make visible to garbage collector + evalf_nib(p); + p = pop(); + pop(); // remove + push(p); + eval_level--; +} + +void +evalf_nib(struct atom *p1) +{ + if (interrupt) + stopf("interrupt"); + + // this is needed to prevent seg fault (STACKSIZE is greater than process stack) + + if (eval_level > 1000) + stopf("evaluation depth exceeded, possibly due to recursive function or circular symbol definition"); + + if (eval_level > max_eval_level) + max_eval_level = eval_level; + + if (iscons(p1) && iskeyword(car(p1))) { + expanding++; + car(p1)->u.ksym.func(p1); // call through function pointer + expanding--; + return; + } + + if (iscons(p1) && isusersymbol(car(p1))) { + eval_user_function(p1); + return; + } + + if (iskeyword(p1)) { // bare keyword + push(p1); + push_symbol(LAST); // default arg + list(2); + evalg(); + return; + } + + if (isusersymbol(p1)) { + eval_user_symbol(p1); + return; + } + + if (istensor(p1)) { + eval_tensor(p1); + return; + } + + push(p1); // rational, double, or string +} + +// evaluate '=' as '==' + +void +evalp(void) +{ + struct atom *p1; + p1 = pop(); + if (car(p1) == symbol(SETQ)) { + push_symbol(TESTEQ); + push(cadr(p1)); + push(caddr(p1)); + list(3); + p1 = pop(); + } + push(p1); + evalg(); +} +void +eval_abs(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + absfunc(); +} + +void +absfunc(void) +{ + int h; + struct atom *p1, *p2, *p3; + + p1 = pop(); + + if (isnum(p1)) { + push(p1); + if (isnegativenumber(p1)) + negate(); + return; + } + + if (istensor(p1)) { + if (p1->u.tensor->ndim > 1) { + push_symbol(ABS); + push(p1); + list(2); + return; + } + push(p1); + push(p1); + conjfunc(); + inner(); + push_rational(1, 2); + power(); + return; + } + + push(p1); + push(p1); + conjfunc(); + multiply(); + push_rational(1, 2); + power(); + + p2 = pop(); + push(p2); + floatfunc(); + p3 = pop(); + if (isdouble(p3)) { + push(p2); + if (isnegativenumber(p3)) + negate(); + return; + } + + // abs(1/a) evaluates to 1/abs(a) + + if (car(p1) == symbol(POWER) && isnegativeterm(caddr(p1))) { + push(p1); + reciprocate(); + absfunc(); + reciprocate(); + return; + } + + // abs(a*b) evaluates to abs(a)*abs(b) + + if (car(p1) == symbol(MULTIPLY)) { + h = tos; + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + absfunc(); + p1 = cdr(p1); + } + multiply_factors(tos - h); + return; + } + + if (isnegativeterm(p1) || (car(p1) == symbol(ADD) && isnegativeterm(cadr(p1)))) { + push(p1); + negate(); + p1 = pop(); + } + + push_symbol(ABS); + push(p1); + list(2); +} +void +eval_add(struct atom *p1) +{ + int h = tos; + expanding--; // undo expanding++ in evalf + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + evalg(); + p1 = cdr(p1); + } + add_terms(tos - h); + expanding++; +} + +void +add(void) +{ + add_terms(2); +} + +void +add_terms(int n) +{ + int h, i; + struct atom *p, *T; + + if (n < 2) + return; + + h = tos - n; + + flatten_terms(h); + + T = combine_tensors(h); + + combine_terms(h); + normalize_terms(h); + + n = tos - h; + + if (n == 0) { + if (istensor(T)) + push(T); + else + push_integer(0); + return; + } + + if (n > 1) { + list(n); + push_symbol(ADD); + swap(); + cons(); // prepend ADD to list + } + + if (!istensor(T)) + return; + + // add scalar p to every element of T, as is done in R + + p = pop(); + T = copy_tensor(T); + n = T->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(T->u.tensor->elem[i]); + push(p); + add(); + T->u.tensor->elem[i] = pop(); + } + push(T); +} + +void +flatten_terms(int h) +{ + int i, n; + struct atom *p1; + n = tos; + for (i = h; i < n; i++) { + p1 = stack[i]; + if (car(p1) == symbol(ADD)) { + stack[i] = cadr(p1); + p1 = cddr(p1); + while (iscons(p1)) { + push(car(p1)); + p1 = cdr(p1); + } + } + } +} + +struct atom * +combine_tensors(int h) +{ + int i; + struct atom *p1, *T; + T = symbol(NIL); + for (i = h; i < tos; i++) { + p1 = stack[i]; + if (istensor(p1)) { + if (istensor(T)) { + push(T); + push(p1); + add_tensors(); + T = pop(); + } else + T = p1; + slice(i, 1); + i--; // use same index again + } + } + return T; +} + +void +add_tensors(void) +{ + int i, n; + struct atom *p1, *p2; + + p2 = pop(); + p1 = pop(); + + if (!compatible_dimensions(p1, p2)) + stopf("incompatible tensor arithmetic"); + + p1 = copy_tensor(p1); + + n = p1->u.tensor->nelem; + + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + push(p2->u.tensor->elem[i]); + add(); + p1->u.tensor->elem[i] = pop(); + } + + push(p1); +} + +void +combine_terms(int h) +{ + int i; + sort_terms(h); + for (i = h; i < tos; i++) { + if (iszero(stack[i])) { + slice(i, 1); // remove + i--; // use same index again + } else if (i + 1 < tos && combine_terms_nib(i)) { + slice(i + 1, 1); // remove + i--; // use same index again + } + } +} + +int +combine_terms_nib(int i) +{ + int denorm; + struct atom *coeff1, *coeff2, *p1, *p2; + + p1 = stack[i]; + p2 = stack[i + 1]; + + if (isnum(p1) && isnum(p2)) { + add_numbers(p1, p2); + stack[i] = pop(); + return 1; + } + + if (isnum(p1) || isnum(p2)) + return 0; // cannot add number and something else + + coeff1 = one; + coeff2 = one; + + denorm = 0; + + if (car(p1) == symbol(MULTIPLY)) { + p1 = cdr(p1); + denorm = 1; + if (isnum(car(p1))) { + coeff1 = car(p1); + p1 = cdr(p1); + if (cdr(p1) == symbol(NIL)) { + p1 = car(p1); + denorm = 0; + } + } + } + + if (car(p2) == symbol(MULTIPLY)) { + p2 = cdr(p2); + if (isnum(car(p2))) { + coeff2 = car(p2); + p2 = cdr(p2); + if (cdr(p2) == symbol(NIL)) + p2 = car(p2); + } + } + + if (!equal(p1, p2)) + return 0; + + add_numbers(coeff1, coeff2); + + coeff1 = pop(); + + if (iszero(coeff1)) { + stack[i] = coeff1; + return 1; + } + + if (isplusone(coeff1) && !isdouble(coeff1)) { + if (denorm) { + push_symbol(MULTIPLY); + push(p1); // p1 is a list, not an atom + cons(); // prepend MULTIPLY + } else + push(p1); + } else { + if (denorm) { + push_symbol(MULTIPLY); + push(coeff1); + push(p1); // p1 is a list, not an atom + cons(); // prepend coeff1 + cons(); // prepend MULTIPLY + } else { + push_symbol(MULTIPLY); + push(coeff1); + push(p1); + list(3); + } + } + + stack[i] = pop(); + + return 1; +} + +void +sort_terms(int h) +{ + qsort(stack + h, tos - h, sizeof (struct atom *), sort_terms_func); +} + +int +sort_terms_func(const void *q1, const void *q2) +{ + return cmp_terms(*((struct atom **) q1), *((struct atom **) q2)); +} + +int +cmp_terms(struct atom *p1, struct atom *p2) +{ + int a, b, c; + + // 1st level: imaginary terms on the right + + a = isimaginaryterm(p1); + b = isimaginaryterm(p2); + + if (a == 0 && b == 1) + return -1; // ok + + if (a == 1 && b == 0) + return 1; // out of order + + // 2nd level: numericals on the right + + if (isnum(p1) && isnum(p2)) + return 0; // don't care about order, save time, don't compare + + if (isnum(p1)) + return 1; // out of order + + if (isnum(p2)) + return -1; // ok + + // 3rd level: sort by factors + + a = 0; + b = 0; + + if (car(p1) == symbol(MULTIPLY)) { + p1 = cdr(p1); + a = 1; // p1 is a list of factors + if (isnum(car(p1))) { + // skip over coeff + p1 = cdr(p1); + if (cdr(p1) == symbol(NIL)) { + p1 = car(p1); + a = 0; + } + } + } + + if (car(p2) == symbol(MULTIPLY)) { + p2 = cdr(p2); + b = 1; // p2 is a list of factors + if (isnum(car(p2))) { + // skip over coeff + p2 = cdr(p2); + if (cdr(p2) == symbol(NIL)) { + p2 = car(p2); + b = 0; + } + } + } + + if (a == 0 && b == 0) + return cmp_factors(p1, p2); + + if (a == 0 && b == 1) { + c = cmp_factors(p1, car(p2)); + if (c == 0) + c = -1; // lengthf(p1) < lengthf(p2) + return c; + } + + if (a == 1 && b == 0) { + c = cmp_factors(car(p1), p2); + if (c == 0) + c = 1; // lengthf(p1) > lengthf(p2) + return c; + } + + while (iscons(p1) && iscons(p2)) { + c = cmp_factors(car(p1), car(p2)); + if (c) + return c; + p1 = cdr(p1); + p2 = cdr(p2); + } + + if (iscons(p1)) + return 1; // lengthf(p1) > lengthf(p2) + + if (iscons(p2)) + return -1; // lengthf(p1) < lengthf(p2) + + return 0; +} + +// for example, sqrt(1/2) + sqrt(1/2) -> 2 sqrt(1/2) -> sqrt(2) + +void +normalize_terms(int h) +{ + int i, n; + struct atom *p; + n = 0; + for (i = h; i < tos; i++) { + p = stack[i]; + if (isradicalterm(p)) { + push(p); + evalf(); + stack[i] = pop(); + n++; + } + } + if (n) + combine_terms(h); +} + +void +add_numbers(struct atom *p1, struct atom *p2) +{ + double d1, d2; + + if (isrational(p1) && isrational(p2)) { + add_rationals(p1, p2); + return; + } + + push(p1); + d1 = pop_double(); + + push(p2); + d2 = pop_double(); + + push_double(d1 + d2); +} + +void +add_rationals(struct atom *p1, struct atom *p2) +{ + int sign; + uint32_t *a, *ab, *b, *ba, *c; + + if (iszero(p1)) { + push(p2); + return; + } + + if (iszero(p2)) { + push(p1); + return; + } + + if (isinteger(p1) && isinteger(p2)) { + add_integers(p1, p2); + return; + } + + ab = mmul(p1->u.q.a, p2->u.q.b); + ba = mmul(p1->u.q.b, p2->u.q.a); + + if (p1->sign == p2->sign) { + a = madd(ab, ba); + sign = p1->sign; + } else { + switch (mcmp(ab, ba)) { + case 1: + a = msub(ab, ba); + sign = p1->sign; + break; + case 0: + push_integer(0); + mfree(ab); + mfree(ba); + return; + case -1: + a = msub(ba, ab); + sign = p2->sign; + break; + default: + // never gets here, fix compiler warning + return; + } + } + + mfree(ab); + mfree(ba); + + b = mmul(p1->u.q.b, p2->u.q.b); + c = mgcd(a, b); + + push_bignum(sign, mdiv(a, c), mdiv(b, c)); + + mfree(a); + mfree(b); + mfree(c); +} + +void +add_integers(struct atom *p1, struct atom *p2) +{ + int sign = 0; // compiler nag + uint32_t *c = NULL; // compiler nag + if (p1->sign == p2->sign) { + c = madd(p1->u.q.a, p2->u.q.a); + sign = p1->sign; + } else { + switch (mcmp(p1->u.q.a, p2->u.q.a)) { + case 1: + c = msub(p1->u.q.a, p2->u.q.a); + sign = p1->sign; + break; + case 0: + push_integer(0); + return; + case -1: + c = msub(p2->u.q.a, p1->u.q.a); + sign = p2->sign; + break; + default: + stopf("error"); + } + } + push_bignum(sign, c, mint(1)); +} + +void +subtract(void) +{ + negate(); + add(); +} +void +eval_adj(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + adj(); +} + +void +adj(void) +{ + int col, i, j, k, n, row; + struct atom *p1, *p2, *p3; + + p1 = pop(); + + if (!istensor(p1)) { + push_integer(1); // adj of scalar is 1 because adj = det inv + return; + } + + if (!issquarematrix(p1)) + stopf("adj: square matrix expected"); + + n = p1->u.tensor->dim[0]; + + // p2 is the adjunct matrix + + p2 = alloc_matrix(n, n); + + if (n == 2) { + p2->u.tensor->elem[0] = p1->u.tensor->elem[3]; + push(p1->u.tensor->elem[1]); + negate(); + p2->u.tensor->elem[1] = pop(); + push(p1->u.tensor->elem[2]); + negate(); + p2->u.tensor->elem[2] = pop(); + p2->u.tensor->elem[3] = p1->u.tensor->elem[0]; + push(p2); + return; + } + + // p3 is for computing cofactors + + p3 = alloc_matrix(n - 1, n - 1); + + for (row = 0; row < n; row++) { + for (col = 0; col < n; col++) { + k = 0; + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) + if (i != row && j != col) + p3->u.tensor->elem[k++] = p1->u.tensor->elem[n * i + j]; + push(p3); + det(); + if ((row + col) % 2) + negate(); + p2->u.tensor->elem[n * col + row] = pop(); // transpose + } + } + + push(p2); +} +void +eval_and(struct atom *p1) +{ + struct atom *p2; + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + evalp(); + p2 = pop(); + if (iszero(p2)) { + push_integer(0); + return; + } + p1 = cdr(p1); + } + push_integer(1); +} +void +eval_arccos(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + arccos(); +} + +void +arccos(void) +{ + int i, n; + double d; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + arccos(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + if (-1.0 <= d && d <= 1.0) { + d = acos(d); + push_double(d); + return; + } + } + + // arccos(z) = -i log(z + i sqrt(1 - z^2)) + + if (isdouble(p1) || isdoublez(p1)) { + push_double(1.0); + push(p1); + push(p1); + multiply(); + subtract(); + sqrtfunc(); + push(imaginaryunit); + multiply(); + push(p1); + add(); + logfunc(); + push(imaginaryunit); + multiply(); + negate(); + return; + } + + // arccos(1 / sqrt(2)) = 1/4 pi + + if (isoneoversqrttwo(p1)) { + push_rational(1, 4); + push_symbol(PI); + multiply(); + return; + } + + // arccos(-1 / sqrt(2)) = 3/4 pi + + if (isminusoneoversqrttwo(p1)) { + push_rational(3, 4); + push_symbol(PI); + multiply(); + return; + } + + // arccos(0) = 1/2 pi + + if (iszero(p1)) { + push_rational(1, 2); + push_symbol(PI); + multiply(); + return; + } + + // arccos(1/2) = 1/3 pi + + if (isequalq(p1, 1 ,2)) { + push_rational(1, 3); + push_symbol(PI); + multiply(); + return; + } + + // arccos(1) = 0 + + if (isplusone(p1)) { + push_integer(0); + return; + } + + // arccos(-1/2) = 2/3 pi + + if (isequalq(p1, -1, 2)) { + push_rational(2, 3); + push_symbol(PI); + multiply(); + return; + } + + // arccos(-1) = pi + + if (isminusone(p1)) { + push_symbol(PI); + return; + } + + push_symbol(ARCCOS); + push(p1); + list(2); +} +void +eval_arccosh(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + arccosh(); +} + +void +arccosh(void) +{ + int i, n; + double d; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + arccosh(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + if (d >= 1.0) { + d = acosh(d); + push_double(d); + return; + } + } + + // arccosh(z) = log(sqrt(z^2 - 1) + z) + + if (isdouble(p1) || isdoublez(p1)) { + push(p1); + push(p1); + multiply(); + push_double(-1.0); + add(); + sqrtfunc(); + push(p1); + add(); + logfunc(); + return; + } + + if (isplusone(p1)) { + push_integer(0); + return; + } + + if (car(p1) == symbol(COSH)) { + push(cadr(p1)); + return; + } + + push_symbol(ARCCOSH); + push(p1); + list(2); +} +void +eval_arcsin(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + arcsin(); +} + +void +arcsin(void) +{ + int i, n; + double d; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + arcsin(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + if (-1.0 <= d && d <= 1.0) { + d = asin(d); + push_double(d); + return; + } + } + + // arcsin(z) = -i log(i z + sqrt(1 - z^2)) + + if (isdouble(p1) || isdoublez(p1)) { + push(imaginaryunit); + negate(); + push(imaginaryunit); + push(p1); + multiply(); + push_double(1.0); + push(p1); + push(p1); + multiply(); + subtract(); + sqrtfunc(); + add(); + logfunc(); + multiply(); + return; + } + + // arcsin(-x) = -arcsin(x) + + if (isnegativeterm(p1)) { + push(p1); + negate(); + arcsin(); + negate(); + return; + } + + // arcsin(1 / sqrt(2)) = 1/4 pi + + if (isoneoversqrttwo(p1)) { + push_rational(1, 4); + push_symbol(PI); + multiply(); + return; + } + + // arcsin(0) = 0 + + if (iszero(p1)) { + push_integer(0); + return; + } + + // arcsin(1/2) = 1/6 pi + + if (isequalq(p1, 1, 2)) { + push_rational(1, 6); + push_symbol(PI); + multiply(); + return; + } + + // arcsin(1) = 1/2 pi + + if (isplusone(p1)) { + push_rational(1, 2); + push_symbol(PI); + multiply(); + return; + } + + push_symbol(ARCSIN); + push(p1); + list(2); +} +void +eval_arcsinh(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + arcsinh(); +} + +void +arcsinh(void) +{ + int i, n; + double d; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + arcsinh(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = asinh(d); + push_double(d); + return; + } + + // arcsinh(z) = log(sqrt(z^2 + 1) + z) + + if (isdoublez(p1)) { + push(p1); + push(p1); + multiply(); + push_double(1.0); + add(); + sqrtfunc(); + push(p1); + add(); + logfunc(); + return; + } + + if (iszero(p1)) { + push(p1); + return; + } + + // arcsinh(-x) = -arcsinh(x) + + if (isnegativeterm(p1)) { + push(p1); + negate(); + arcsinh(); + negate(); + return; + } + + if (car(p1) == symbol(SINH)) { + push(cadr(p1)); + return; + } + + push_symbol(ARCSINH); + push(p1); + list(2); +} +void +eval_arctan(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + + p1 = cddr(p1); + + if (iscons(p1)) { + push(car(p1)); + evalf(); + } else + push_integer(1); + + arctan(); +} + +void +arctan(void) +{ + int i, n; + struct atom *X, *Y, *Z; + + X = pop(); + Y = pop(); + + if (istensor(Y)) { + Y = copy_tensor(Y); + n = Y->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(Y->u.tensor->elem[i]); + push(X); + arctan(); + Y->u.tensor->elem[i] = pop(); + } + push(Y); + return; + } + + if (isnum(X) && isnum(Y)) { + arctan_numbers(X, Y); + return; + } + + // arctan(z) = -1/2 i log((i - z) / (i + z)) + + if (!iszero(X) && (isdoublez(X) || isdoublez(Y))) { + push(Y); + push(X); + divide(); + Z = pop(); + push_double(-0.5); + push(imaginaryunit); + multiply(); + push(imaginaryunit); + push(Z); + subtract(); + push(imaginaryunit); + push(Z); + add(); + divide(); + logfunc(); + multiply(); + return; + } + + // arctan(-y,x) = -arctan(y,x) + + if (isnegativeterm(Y)) { + push(Y); + negate(); + push(X); + arctan(); + negate(); + return; + } + + if (car(Y) == symbol(TAN) && isplusone(X)) { + push(cadr(Y)); // x of tan(x) + return; + } + + push_symbol(ARCTAN); + push(Y); + push(X); + list(3); +} + +void +arctan_numbers(struct atom *X, struct atom *Y) +{ + double x, y; + struct atom *T; + + if (iszero(X) && iszero(Y)) { + push_integer(0); + return; + } + + if (isdouble(X) || isdouble(Y)) { + push(X); + x = pop_double(); + push(Y); + y = pop_double(); + if (y == 0.0) { + if (x < 0.0) + push_double(-M_PI); + else + push_double(0.0); + } else + push_double(atan2(y, x)); + return; + } + + // X and Y are rational numbers + + if (iszero(Y)) { + if (isnegativenumber(X)) { + push_symbol(PI); + negate(); + } else + push_integer(0); + return; + } + + if (iszero(X)) { + if (isnegativenumber(Y)) + push_rational(-1, 2); + else + push_rational(1, 2); + push_symbol(PI); + multiply(); + return; + } + + // convert fractions to integers + + push(Y); + push(X); + divide(); + absfunc(); + T = pop(); + + push(T); + numerator(); + if (isnegativenumber(Y)) + negate(); + Y = pop(); + + push(T); + denominator(); + if (isnegativenumber(X)) + negate(); + X = pop(); + + // compare numerators and denominators, ignore signs + + if (mcmp(X->u.q.a, Y->u.q.a) != 0 || mcmp(X->u.q.b, Y->u.q.b) != 0) { + // not equal + if (isnegativenumber(Y)) { + push_symbol(ARCTAN); + push(Y); + negate(); + push(X); + list(3); + negate(); + } else { + push_symbol(ARCTAN); + push(Y); + push(X); + list(3); + } + return; + } + + // X = Y modulo sign + + if (isnegativenumber(X)) { + if (isnegativenumber(Y)) + push_rational(-3, 4); + else + push_rational(3, 4); + } else { + if (isnegativenumber(Y)) + push_rational(-1, 4); + else + push_rational(1, 4); + } + + push_symbol(PI); + multiply(); +} +void +eval_arctanh(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + arctanh(); +} + +void +arctanh(void) +{ + int i, n; + double d; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + arctanh(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isplusone(p1) || isminusone(p1)) { + push_symbol(ARCTANH); + push(p1); + list(2); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + if (-1.0 < d && d < 1.0) { + d = atanh(d); + push_double(d); + return; + } + } + + // arctanh(z) = 1/2 log(1 + z) - 1/2 log(1 - z) + + if (isdouble(p1) || isdoublez(p1)) { + push_double(1.0); + push(p1); + add(); + logfunc(); + push_double(1.0); + push(p1); + subtract(); + logfunc(); + subtract(); + push_double(0.5); + multiply(); + return; + } + + if (iszero(p1)) { + push_integer(0); + return; + } + + // arctanh(-x) = -arctanh(x) + + if (isnegativeterm(p1)) { + push(p1); + negate(); + arctanh(); + negate(); + return; + } + + if (car(p1) == symbol(TANH)) { + push(cadr(p1)); + return; + } + + push_symbol(ARCTANH); + push(p1); + list(2); +} +void +eval_arg(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + polar(); // normalize + argfunc(); +} + +// may return a denormalized angle + +void +argfunc(void) +{ + int i, n; + struct atom *p1, *p2, *num, *den; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + argfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + numden(); + num = pop(); + den = pop(); + push(num); + arg_nib(); + push(den); + arg_nib(); + subtract(); + + p2 = pop(); + + if (hasdouble(p1) && findf(p2, symbol(PI))) { + push(p2); + push_symbol(PI); + push_double(M_PI); + subst(); + evalf(); + } else + push(p2); +} + +// This is why Eigenmath returns -pi for the arg of a negative number: +// arg(-i) == arg(-1) + arg(i) == -pi + 1/2 pi == -1/2 pi + +void +arg_nib(void) +{ + int h; + struct atom *p1, *x, *y; + + p1 = pop(); + + if (isrational(p1)) { + if (isnegativenumber(p1)) { + push_symbol(PI); + negate(); // see comment above + } else + push_integer(0); + return; + } + + if (isdouble(p1)) { + if (isnegativenumber(p1)) + push_double(-M_PI); + else + push_double(0.0); + return; + } + + // (-1) ^ expr + + if (car(p1) == symbol(POWER) && isminusone(cadr(p1))) { + push_symbol(PI); + push(caddr(p1)); + multiply(); + return; + } + + // e ^ expr + + if (car(p1) == symbol(POWER) && cadr(p1) == symbol(EXP1)) { + push(caddr(p1)); + imag(); + return; + } + + if (car(p1) == symbol(MULTIPLY)) { + h = tos; + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + arg_nib(); + p1 = cdr(p1); + } + add_terms(tos - h); + return; + } + + if (car(p1) == symbol(ADD)) { + push(p1); + real(); + x = pop(); + push(p1); + imag(); + y = pop(); + if (iszero(y)) { + push_integer(0); + return; + } + if (iszero(x)) { + push_rational(1, 2); + push_symbol(PI); + multiply(); + return; + } + push(y); + push(x); + arctan(); + return; + } + + push_integer(0); // p1 is real +} +void +eval_binding(struct atom *p1) +{ + push(get_binding(cadr(p1))); +} +void +eval_break(struct atom *p1) +{ + breakflag = 1; + push_symbol(NIL); +} +void +eval_ceiling(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + ceilingfunc(); +} + +void +ceilingfunc(void) +{ + int i, n; + uint32_t *a, *b; + double d; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + ceilingfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isinteger(p1)) { + push(p1); + return; + } + + if (isrational(p1)) { + a = mdiv(p1->u.q.a, p1->u.q.b); + b = mint(1); + if (isnegativenumber(p1)) + push_bignum(MMINUS, a, b); + else { + push_bignum(MPLUS, a, b); + push_integer(1); + add(); + } + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = ceil(d); + push_double(d); + return; + } + + push_symbol(CEILING); + push(p1); + list(2); +} +void +eval_check(struct atom *p1) +{ + push(cadr(p1)); + evalp(); + p1 = pop(); + if (iszero(p1)) + stopf("check"); + push_symbol(NIL); // no result is printed +} +void +eval_clear(struct atom *p1) +{ + int i; + + (void) p1; // silence compiler + + save_symbol(symbol(TRACE)); + save_symbol(symbol(TTY)); + + for (i = 0; i < 27 * BUCKETSIZE; i++) { + binding[i] = NULL; + usrfunc[i] = NULL; + } + + run_init_script(); + + restore_symbol(); + restore_symbol(); + + if (gc_level == eval_level) + gc(); + + push_symbol(NIL); // result +} +void +eval_clock(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + clockfunc(); +} + +void +clockfunc(void) +{ + int i, n; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + clockfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + magfunc(); + + push_integer(-1); // base + + push(p1); + argfunc(); + push_symbol(PI); + divide(); + + power(); + + multiply(); +} +void +eval_cofactor(struct atom *p1) +{ + int i, j; + struct atom *p2; + + push(cadr(p1)); + evalf(); + p2 = pop(); + + push(caddr(p1)); + evalf(); + i = pop_integer(); + + push(cadddr(p1)); + evalf(); + j = pop_integer(); + + if (!issquarematrix(p2)) + stopf("cofactor: square matrix expected"); + + if (i < 1 || i > p2->u.tensor->dim[0] || j < 0 || j > p2->u.tensor->dim[1]) + stopf("cofactor: index err"); + + push(p2); + + minormatrix(i, j); + + det(); + + if ((i + j) % 2) + negate(); +} +void +eval_conj(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + conjfunc(); +} + +void +conjfunc(void) +{ + conjfunc_subst(); + evalf(); +} + +void +conjfunc_subst(void) +{ + int h, i, n; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + conjfunc_subst(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + // (-1) ^ expr + + if (car(p1) == symbol(POWER) && isminusone(cadr(p1))) { + push_symbol(POWER); + push_integer(-1); + push(caddr(p1)); + negate(); + list(3); + return; + } + + if (iscons(p1)) { + h = tos; + push(car(p1)); + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + conjfunc_subst(); + p1 = cdr(p1); + } + list(tos - h); + return; + } + + push(p1); +} +void +eval_contract(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + + p1 = cddr(p1); + + if (!iscons(p1)) { + push_integer(1); + push_integer(2); + contract(); + return; + } + + while (iscons(p1)) { + push(car(p1)); + evalf(); + push(cadr(p1)); + evalf(); + contract(); + p1 = cddr(p1); + } +} + +void +contract(void) +{ + int h, i, j, k, m, n, ncol, ndim, nelem, nrow; + int index[MAXDIM]; + struct atom *p1, *p2, *p3; + + p3 = pop(); + p2 = pop(); + p1 = pop(); + + if (!istensor(p1)) { + push(p1); + return; + } + + ndim = p1->u.tensor->ndim; + + push(p2); + n = pop_integer(); + + push(p3); + m = pop_integer(); + + if (n < 1 || n > ndim || m < 1 || m > ndim || n == m) + stopf("contract: index error"); + + n--; // make zero based + m--; + + ncol = p1->u.tensor->dim[n]; + nrow = p1->u.tensor->dim[m]; + + if (ncol != nrow) + stopf("contract: unequal tensor dimensions"); + + // nelem is the number of elements in result + + nelem = p1->u.tensor->nelem / ncol / nrow; + + p2 = alloc_tensor(nelem); + + for (i = 0; i < ndim; i++) + index[i] = 0; + + for (i = 0; i < nelem; i++) { + + for (j = 0; j < ncol; j++) { + index[n] = j; + index[m] = j; + k = index[0]; + for (h = 1; h < ndim; h++) + k = k * p1->u.tensor->dim[h] + index[h]; + push(p1->u.tensor->elem[k]); + } + + add_terms(ncol); + + p2->u.tensor->elem[i] = pop(); + + // increment index + + for (j = ndim - 1; j >= 0; j--) { + if (j == n || j == m) + continue; + if (++index[j] < p1->u.tensor->dim[j]) + break; + index[j] = 0; + } + } + + if (nelem == 1) { + push(p2->u.tensor->elem[0]); + return; + } + + // add dim info + + p2->u.tensor->ndim = ndim - 2; + + k = 0; + + for (i = 0; i < ndim; i++) + if (i != n && i != m) + p2->u.tensor->dim[k++] = p1->u.tensor->dim[i]; + + push(p2); +} +void +eval_cos(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + cosfunc(); +} + +void +cosfunc(void) +{ + int i, n; + double d; + struct atom *p1, *p2, *X, *Y; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + cosfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = cos(d); + push_double(d); + return; + } + + // cos(z) = 1/2 exp(i z) + 1/2 exp(-i z) + + if (isdoublez(p1)) { + push_double(0.5); + push(imaginaryunit); + push(p1); + multiply(); + expfunc(); + push(imaginaryunit); + negate(); + push(p1); + multiply(); + expfunc(); + add(); + multiply(); + return; + } + + // cos(-x) = cos(x) + + if (isnegativeterm(p1)) { + push(p1); + negate(); + cosfunc(); + return; + } + + if (car(p1) == symbol(ADD)) { + cosfunc_sum(p1); + return; + } + + // cos(arctan(y,x)) = x (x^2 + y^2)^(-1/2) + + if (car(p1) == symbol(ARCTAN)) { + X = caddr(p1); + Y = cadr(p1); + push(X); + push(X); + push(X); + multiply(); + push(Y); + push(Y); + multiply(); + add(); + push_rational(-1, 2); + power(); + multiply(); + return; + } + + // cos(arcsin(x)) = sqrt(1 - x^2) + + if (car(p1) == symbol(ARCSIN)) { + push_integer(1); + push(cadr(p1)); + push_integer(2); + power(); + subtract(); + push_rational(1, 2); + power(); + return; + } + + // n pi ? + + push(p1); + push_symbol(PI); + divide(); + p2 = pop(); + + if (!isnum(p2)) { + push_symbol(COS); + push(p1); + list(2); + return; + } + + if (isdouble(p2)) { + push(p2); + d = pop_double(); + d = cos(d * M_PI); + push_double(d); + return; + } + + push(p2); // nonnegative by cos(-x) = cos(x) above + push_integer(180); + multiply(); + p2 = pop(); + + if (!isinteger(p2)) { + push_symbol(COS); + push(p1); + list(2); + return; + } + + push(p2); + push_integer(360); + modfunc(); + n = pop_integer(); + + switch (n) { + case 90: + case 270: + push_integer(0); + break; + case 60: + case 300: + push_rational(1, 2); + break; + case 120: + case 240: + push_rational(-1, 2); + break; + case 45: + case 315: + push_rational(1, 2); + push_integer(2); + push_rational(1, 2); + power(); + multiply(); + break; + case 135: + case 225: + push_rational(-1, 2); + push_integer(2); + push_rational(1, 2); + power(); + multiply(); + break; + case 30: + case 330: + push_rational(1, 2); + push_integer(3); + push_rational(1, 2); + power(); + multiply(); + break; + case 150: + case 210: + push_rational(-1, 2); + push_integer(3); + push_rational(1, 2); + power(); + multiply(); + break; + case 0: + push_integer(1); + break; + case 180: + push_integer(-1); + break; + default: + push_symbol(COS); + push(p1); + list(2); + break; + } +} + +// cos(x + n/2 pi) = cos(x) cos(n/2 pi) - sin(x) sin(n/2 pi) + +void +cosfunc_sum(struct atom *p1) +{ + struct atom *p2, *p3; + p2 = cdr(p1); + while (iscons(p2)) { + push_integer(2); + push(car(p2)); + multiply(); + push_symbol(PI); + divide(); + p3 = pop(); + if (isinteger(p3)) { + push(p1); + push(car(p2)); + subtract(); + p3 = pop(); + push(p3); + cosfunc(); + push(car(p2)); + cosfunc(); + multiply(); + push(p3); + sinfunc(); + push(car(p2)); + sinfunc(); + multiply(); + subtract(); + return; + } + p2 = cdr(p2); + } + push_symbol(COS); + push(p1); + list(2); +} +void +eval_cosh(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + coshfunc(); +} + +void +coshfunc(void) +{ + int i, n; + double d; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + coshfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = cosh(d); + push_double(d); + return; + } + + // cosh(z) = 1/2 exp(z) + 1/2 exp(-z) + + if (isdoublez(p1)) { + push_rational(1, 2); + push(p1); + expfunc(); + push(p1); + negate(); + expfunc(); + add(); + multiply(); + return; + } + + if (iszero(p1)) { + push_integer(1); + return; + } + + // cosh(-x) = cosh(x) + + if (isnegativeterm(p1)) { + push(p1); + negate(); + coshfunc(); + return; + } + + if (car(p1) == symbol(ARCCOSH)) { + push(cadr(p1)); + return; + } + + push_symbol(COSH); + push(p1); + list(2); +} +void +eval_defint(struct atom *p1) +{ + struct atom *F, *X, *A, *B; + + push(cadr(p1)); + evalf(); + F = pop(); + + p1 = cddr(p1); + + while (iscons(p1)) { + + push(car(p1)); + evalf(); + X = pop(); + + push(cadr(p1)); + evalf(); + A = pop(); + + push(caddr(p1)); + evalf(); + B = pop(); + + push(F); + push(X); + integral(); + F = pop(); + + if (findf(F, symbol(INTEGRAL))) + stopf("defint: unsolved integral"); + + push(F); + push(X); + push(B); + subst(); + evalf(); + + push(F); + push(X); + push(A); + subst(); + evalf(); + + subtract(); + F = pop(); + + p1 = cdddr(p1); + } + + push(F); +} +void +eval_denominator(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + denominator(); +} + +void +denominator(void) +{ + numden(); + pop(); // discard numerator +} +void +eval_derivative(struct atom *p1) +{ + int flag, i, n; + struct atom *X, *Y = NULL; // silence compiler + + push(cadr(p1)); + evalf(); + p1 = cddr(p1); + + if (!iscons(p1)) { + push_symbol(X_LOWER); + derivative(); + return; + } + + flag = 0; + + while (iscons(p1) || flag) { + + if (flag) { + X = Y; + flag = 0; + } else { + push(car(p1)); + evalf(); + X = pop(); + p1 = cdr(p1); + } + + if (isnum(X)) { + push(X); + n = pop_integer(); + push_symbol(X_LOWER); + X = pop(); + for (i = 0; i < n; i++) { + push(X); + derivative(); + } + continue; + } + + if (iscons(p1)) { + + push(car(p1)); + evalf(); + Y = pop(); + p1 = cdr(p1); + + if (isnum(Y)) { + push(Y); + n = pop_integer(); + for (i = 0; i < n; i++) { + push(X); + derivative(); + } + continue; + } + + flag = 1; + } + + push(X); + derivative(); + } +} + +void +derivative(void) +{ + struct atom *F, *X; + + X = pop(); + F = pop(); + + if (istensor(F)) { + if (istensor(X)) + d_tensor_tensor(F, X); + else + d_tensor_scalar(F, X); + } else { + if (istensor(X)) + d_scalar_tensor(F, X); + else + d_scalar_scalar(F, X); + } +} + +void +d_scalar_scalar(struct atom *F, struct atom *X) +{ + if (!isusersymbol(X)) + stopf("derivative: symbol expected"); + + if (car(F) == symbol(DERIVATIVE)) { + derivative_of_derivative(F, X); + return; + } + + if (car(F) == symbol(INTEGRAL)) { + derivative_of_integral(F, X); + return; + } + + // d(x,x)? + + if (equal(F, X)) { + push_integer(1); + return; + } + + // d(a,x)? + + if (!iscons(F)) { + push_integer(0); + return; + } + + if (car(F) == symbol(ADD)) { + dsum(F, X); + return; + } + + if (car(F) == symbol(MULTIPLY)) { + dproduct(F, X); + return; + } + + if (car(F) == symbol(POWER)) { + dpower(F, X); + return; + } + + if (car(F) == symbol(LOG)) { + dlog(F, X); + return; + } + + if (car(F) == symbol(SIN)) { + dsin(F, X); + return; + } + + if (car(F) == symbol(COS)) { + dcos(F, X); + return; + } + + if (car(F) == symbol(TAN)) { + dtan(F, X); + return; + } + + if (car(F) == symbol(ARCSIN)) { + darcsin(F, X); + return; + } + + if (car(F) == symbol(ARCCOS)) { + darccos(F, X); + return; + } + + if (car(F) == symbol(ARCTAN)) { + darctan(F, X); + return; + } + + if (car(F) == symbol(SINH)) { + dsinh(F, X); + return; + } + + if (car(F) == symbol(COSH)) { + dcosh(F, X); + return; + } + + if (car(F) == symbol(TANH)) { + dtanh(F, X); + return; + } + + if (car(F) == symbol(ARCSINH)) { + darcsinh(F, X); + return; + } + + if (car(F) == symbol(ARCCOSH)) { + darccosh(F, X); + return; + } + + if (car(F) == symbol(ARCTANH)) { + darctanh(F, X); + return; + } + + if (car(F) == symbol(ERF)) { + derf(F, X); + return; + } + + if (car(F) == symbol(ERFC)) { + derfc(F, X); + return; + } + + dfunction(F, X); +} + +void +dsum(struct atom *p1, struct atom *p2) +{ + int h = tos; + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + push(p2); + derivative(); + p1 = cdr(p1); + } + add_terms(tos - h); +} + +void +dproduct(struct atom *p1, struct atom *p2) +{ + int i, j, n; + struct atom *p3; + n = lengthf(p1) - 1; + for (i = 0; i < n; i++) { + p3 = cdr(p1); + for (j = 0; j < n; j++) { + push(car(p3)); + if (i == j) { + push(p2); + derivative(); + } + p3 = cdr(p3); + } + multiply_factors(n); + } + add_terms(n); +} + +// v +// y = u +// +// log y = v log u +// +// 1 dy v du dv +// - -- = - -- + (log u) -- +// y dx u dx dx +// +// dy v v du dv +// -- = u (- -- + (log u) --) +// dx u dx dx + +void +dpower(struct atom *F, struct atom *X) +{ + if (isnum(cadr(F)) && isnum(caddr(F))) { + push_integer(0); // irr or imag + return; + } + + push(caddr(F)); // v/u + push(cadr(F)); + divide(); + + push(cadr(F)); // du/dx + push(X); + derivative(); + + multiply(); + + push(cadr(F)); // log u + logfunc(); + + push(caddr(F)); // dv/dx + push(X); + derivative(); + + multiply(); + + add(); + + push(F); // u^v + + multiply(); +} + +void +dlog(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push(cadr(p1)); + divide(); +} + +// derivative of a generic function + +void +dfunction(struct atom *p1, struct atom *p2) +{ + struct atom *p3; + + p3 = cdr(p1); // p3 is the argument list for the function + + if (p3 == symbol(NIL) || findf(p3, p2)) { + push_symbol(DERIVATIVE); + push(p1); + push(p2); + list(3); + } else + push_integer(0); +} + +void +dsin(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push(cadr(p1)); + cosfunc(); + multiply(); +} + +void +dcos(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push(cadr(p1)); + sinfunc(); + multiply(); + negate(); +} + +void +dtan(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push(cadr(p1)); + cosfunc(); + push_integer(-2); + power(); + multiply(); +} + +void +darcsin(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push_integer(1); + push(cadr(p1)); + push_integer(2); + power(); + subtract(); + push_rational(-1, 2); + power(); + multiply(); +} + +void +darccos(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push_integer(1); + push(cadr(p1)); + push_integer(2); + power(); + subtract(); + push_rational(-1, 2); + power(); + multiply(); + negate(); +} + +void +darctan(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push_integer(1); + push(cadr(p1)); + push_integer(2); + power(); + add(); + reciprocate(); + multiply(); +} + +void +dsinh(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push(cadr(p1)); + coshfunc(); + multiply(); +} + +void +dcosh(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push(cadr(p1)); + sinhfunc(); + multiply(); +} + +void +dtanh(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push(cadr(p1)); + coshfunc(); + push_integer(-2); + power(); + multiply(); +} + +void +darcsinh(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push(cadr(p1)); + push_integer(2); + power(); + push_integer(1); + add(); + push_rational(-1, 2); + power(); + multiply(); +} + +void +darccosh(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push(cadr(p1)); + push_integer(2); + power(); + push_integer(-1); + add(); + push_rational(-1, 2); + power(); + multiply(); +} + +void +darctanh(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push(p2); + derivative(); + push_integer(1); + push(cadr(p1)); + push_integer(2); + power(); + subtract(); + reciprocate(); + multiply(); +} + +void +derf(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push_integer(2); + power(); + push_integer(-1); + multiply(); + expfunc(); + push_symbol(PI); + push_rational(-1, 2); + power(); + multiply(); + push_integer(2); + multiply(); + push(cadr(p1)); + push(p2); + derivative(); + multiply(); +} + +void +derfc(struct atom *p1, struct atom *p2) +{ + push(cadr(p1)); + push_integer(2); + power(); + push_integer(-1); + multiply(); + expfunc(); + push_symbol(PI); + push_rational(-1,2); + power(); + multiply(); + push_integer(-2); + multiply(); + push(cadr(p1)); + push(p2); + derivative(); + multiply(); +} + +// gradient of tensor p1 wrt tensor p2 + +void +d_tensor_tensor(struct atom *p1, struct atom *p2) +{ + int i, j, k, m, n; + struct atom *p3; + + if (p1->u.tensor->ndim + p2->u.tensor->ndim > MAXDIM) + stopf("rank exceeds max"); + + n = p1->u.tensor->nelem; + m = p2->u.tensor->nelem; + + p3 = alloc_tensor(n * m); + + for (i = 0; i < n; i++) { + for (j = 0; j < m; j++) { + push(p1->u.tensor->elem[i]); + push(p2->u.tensor->elem[j]); + derivative(); + p3->u.tensor->elem[m * i + j] = pop(); + } + } + + // dim info + + p3->u.tensor->ndim = p1->u.tensor->ndim + p2->u.tensor->ndim; + + k = 0; + + n = p1->u.tensor->ndim; + + for (i = 0; i < n; i++) + p3->u.tensor->dim[k++] = p1->u.tensor->dim[i]; + + n = p2->u.tensor->ndim; + + for (i = 0; i < n; i++) + p3->u.tensor->dim[k++] = p2->u.tensor->dim[i]; + + push(p3); +} + +// gradient of scalar p1 wrt tensor p2 + +void +d_scalar_tensor(struct atom *p1, struct atom *p2) +{ + int i, n; + struct atom *p3; + + p3 = copy_tensor(p2); + + n = p2->u.tensor->nelem; + + for (i = 0; i < n; i++) { + push(p1); + push(p2->u.tensor->elem[i]); + derivative(); + p3->u.tensor->elem[i] = pop(); + } + + push(p3); +} + +// derivative of tensor p1 wrt scalar p2 + +void +d_tensor_scalar(struct atom *p1, struct atom *p2) +{ + int i, n; + struct atom *p3; + + p3 = copy_tensor(p1); + + n = p1->u.tensor->nelem; + + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + push(p2); + derivative(); + p3->u.tensor->elem[i] = pop(); + } + + push(p3); +} + +void +derivative_of_derivative(struct atom *F, struct atom *X) +{ + struct atom *G, *Y; + + G = cadr(F); + Y = caddr(F); + + if (X == Y) { + push_symbol(DERIVATIVE); + push(F); + push(X); + list(3); + return; + } + + push(G); + push(X); + derivative(); + + G = pop(); + + if (car(G) == symbol(DERIVATIVE)) { + + // sort derivatives + + F = cadr(G); + X = caddr(G); + + push_symbol(DERIVATIVE); + push_symbol(DERIVATIVE); + push(F); + + if (lessp(X, Y)) { + push(X); + list(3); + push(Y); + list(3); + } else { + push(Y); + list(3); + push(X); + list(3); + } + + return; + } + + push(G); + push(Y); + derivative(); +} + +void +derivative_of_integral(struct atom *F, struct atom *X) +{ + struct atom *G, *Y; + + G = cadr(F); + Y = caddr(F); + + if (X == Y) { + push(G); // derivative and integral cancel + return; + } + + push(G); + push(X); + derivative(); + push(Y); + integral(); +} +void +eval_det(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + det(); +} + +void +det(void) +{ + int h, i, j, k, m, n; + struct atom *p1, *p2; + + p1 = pop(); + + if (!istensor(p1)) { + push(p1); + return; + } + + if (!issquarematrix(p1)) + stopf("det: square matrix expected"); + + n = p1->u.tensor->dim[0]; + + switch (n) { + case 1: + push(p1->u.tensor->elem[0]); + return; + case 2: + push(p1->u.tensor->elem[0]); + push(p1->u.tensor->elem[3]); + multiply(); + push(p1->u.tensor->elem[1]); + push(p1->u.tensor->elem[2]); + multiply(); + subtract(); + return; + case 3: + push(p1->u.tensor->elem[0]); + push(p1->u.tensor->elem[4]); + push(p1->u.tensor->elem[8]); + multiply_factors(3); + push(p1->u.tensor->elem[1]); + push(p1->u.tensor->elem[5]); + push(p1->u.tensor->elem[6]); + multiply_factors(3); + push(p1->u.tensor->elem[2]); + push(p1->u.tensor->elem[3]); + push(p1->u.tensor->elem[7]); + multiply_factors(3); + push_integer(-1); + push(p1->u.tensor->elem[2]); + push(p1->u.tensor->elem[4]); + push(p1->u.tensor->elem[6]); + multiply_factors(4); + push_integer(-1); + push(p1->u.tensor->elem[1]); + push(p1->u.tensor->elem[3]); + push(p1->u.tensor->elem[8]); + multiply_factors(4); + push_integer(-1); + push(p1->u.tensor->elem[0]); + push(p1->u.tensor->elem[5]); + push(p1->u.tensor->elem[7]); + multiply_factors(4); + add_terms(6); + return; + default: + break; + } + + p2 = alloc_matrix(n - 1, n - 1); + + h = tos; + + for (m = 0; m < n; m++) { + if (iszero(p1->u.tensor->elem[m])) + continue; + k = 0; + for (i = 1; i < n; i++) + for (j = 0; j < n; j++) + if (j != m) + p2->u.tensor->elem[k++] = p1->u.tensor->elem[n * i + j]; + push(p2); + det(); + push(p1->u.tensor->elem[m]); + multiply(); + if (m % 2) + negate(); + } + + n = tos - h; + + if (n == 0) + push_integer(0); + else + add_terms(n); +} +void +eval_dim(struct atom *p1) +{ + int k; + struct atom *p2; + + push(cadr(p1)); + evalf(); + p2 = pop(); + + if (!istensor(p2)) { + push_integer(1); + return; + } + + if (lengthf(p1) == 2) + k = 1; + else { + push(caddr(p1)); + evalf(); + k = pop_integer(); + } + + if (k < 1 || k > p2->u.tensor->ndim) + stopf("dim 2nd arg: error"); + + push_integer(p2->u.tensor->dim[k - 1]); +} +void +eval_do(struct atom *p1) +{ + push_symbol(NIL); + p1 = cdr(p1); + while (iscons(p1)) { + pop(); // discard previous result + push(car(p1)); + evalg(); + p1 = cdr(p1); + } +} +void +eval_eigenvec(struct atom *p1) +{ + int i, j, n; + static double *D, *Q; + + push(cadr(p1)); + evalf(); + floatfunc(); + p1 = pop(); + + if (!issquarematrix(p1)) + stopf("eigenvec"); + + n = p1->u.tensor->dim[0]; + + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) + if (!isdouble(p1->u.tensor->elem[n * i + j])) + stopf("eigenvec"); + + for (i = 0; i < n - 1; i++) + for (j = i + 1; j < n; j++) + if (fabs(p1->u.tensor->elem[n * i + j]->u.d - p1->u.tensor->elem[n * j + i]->u.d) > 1e-10) + stopf("eigenvec"); + + if (D) + free(D); + if (Q) + free(Q); + + D = alloc_mem(n * n * sizeof (double)); + Q = alloc_mem(n * n * sizeof (double)); + + // initialize D + + for (i = 0; i < n; i++) { + D[n * i + i] = p1->u.tensor->elem[n * i + i]->u.d; + for (j = i + 1; j < n; j++) { + D[n * i + j] = p1->u.tensor->elem[n * i + j]->u.d; + D[n * j + i] = p1->u.tensor->elem[n * i + j]->u.d; + } + } + + // initialize Q + + for (i = 0; i < n; i++) { + Q[n * i + i] = 1.0; + for (j = i + 1; j < n; j++) { + Q[n * i + j] = 0.0; + Q[n * j + i] = 0.0; + } + } + + eigenvec(D, Q, n); + + p1 = alloc_matrix(n, n); + + for (i = 0; i < n; i++) { + for (j = 0; j < n; j++) { + push_double(Q[n * j + i]); // transpose + p1->u.tensor->elem[n * i + j] = pop(); + } + } + + push(p1); +} + +void +eigenvec(double *D, double *Q, int n) +{ + int i; + + for (i = 0; i < 100; i++) + if (eigenvec_step(D, Q, n) == 0) + return; + + stopf("eigenvec: convergence error"); +} + +// Example: p = 1, q = 3 +// +// c 0 s 0 +// +// 0 1 0 0 +// G = +// -s 0 c 0 +// +// 0 0 0 1 +// +// The effect of multiplying G times A is... +// +// row 1 of A = c (row 1 of A ) + s (row 3 of A ) +// n+1 n n +// +// row 3 of A = c (row 3 of A ) - s (row 1 of A ) +// n+1 n n +// +// In terms of components the overall effect is... +// +// row 1 = c row 1 + s row 3 +// +// A[1,1] = c A[1,1] + s A[3,1] +// +// A[1,2] = c A[1,2] + s A[3,2] +// +// A[1,3] = c A[1,3] + s A[3,3] +// +// A[1,4] = c A[1,4] + s A[3,4] +// +// row 3 = c row 3 - s row 1 +// +// A[3,1] = c A[3,1] - s A[1,1] +// +// A[3,2] = c A[3,2] - s A[1,2] +// +// A[3,3] = c A[3,3] - s A[1,3] +// +// A[3,4] = c A[3,4] - s A[1,4] +// +// T +// The effect of multiplying A times G is... +// +// col 1 of A = c (col 1 of A ) + s (col 3 of A ) +// n+1 n n +// +// col 3 of A = c (col 3 of A ) - s (col 1 of A ) +// n+1 n n +// +// In terms of components the overall effect is... +// +// col 1 = c col 1 + s col 3 +// +// A[1,1] = c A[1,1] + s A[1,3] +// +// A[2,1] = c A[2,1] + s A[2,3] +// +// A[3,1] = c A[3,1] + s A[3,3] +// +// A[4,1] = c A[4,1] + s A[4,3] +// +// col 3 = c col 3 - s col 1 +// +// A[1,3] = c A[1,3] - s A[1,1] +// +// A[2,3] = c A[2,3] - s A[2,1] +// +// A[3,3] = c A[3,3] - s A[3,1] +// +// A[4,3] = c A[4,3] - s A[4,1] +// +// What we want to do is just compute the upper triangle of A since we +// know the lower triangle is identical. +// +// In other words, we just want to update components A[i,j] where i < j. +// +// +// +// Example: p = 2, q = 5 +// +// p q +// +// j=1 j=2 j=3 j=4 j=5 j=6 +// +// i=1 . A[1,2] . . A[1,5] . +// +// p i=2 A[2,1] A[2,2] A[2,3] A[2,4] A[2,5] A[2,6] +// +// i=3 . A[3,2] . . A[3,5] . +// +// i=4 . A[4,2] . . A[4,5] . +// +// q i=5 A[5,1] A[5,2] A[5,3] A[5,4] A[5,5] A[5,6] +// +// i=6 . A[6,2] . . A[6,5] . +// +// +// +// This is what B = GA does: +// +// row 2 = c row 2 + s row 5 +// +// B[2,1] = c * A[2,1] + s * A[5,1] +// B[2,2] = c * A[2,2] + s * A[5,2] +// B[2,3] = c * A[2,3] + s * A[5,3] +// B[2,4] = c * A[2,4] + s * A[5,4] +// B[2,5] = c * A[2,5] + s * A[5,5] +// B[2,6] = c * A[2,6] + s * A[5,6] +// +// row 5 = c row 5 - s row 2 +// +// B[5,1] = c * A[5,1] + s * A[2,1] +// B[5,2] = c * A[5,2] + s * A[2,2] +// B[5,3] = c * A[5,3] + s * A[2,3] +// B[5,4] = c * A[5,4] + s * A[2,4] +// B[5,5] = c * A[5,5] + s * A[2,5] +// B[5,6] = c * A[5,6] + s * A[2,6] +// +// T +// This is what BG does: +// +// col 2 = c col 2 + s col 5 +// +// B[1,2] = c * A[1,2] + s * A[1,5] +// B[2,2] = c * A[2,2] + s * A[2,5] +// B[3,2] = c * A[3,2] + s * A[3,5] +// B[4,2] = c * A[4,2] + s * A[4,5] +// B[5,2] = c * A[5,2] + s * A[5,5] +// B[6,2] = c * A[6,2] + s * A[6,5] +// +// col 5 = c col 5 - s col 2 +// +// B[1,5] = c * A[1,5] - s * A[1,2] +// B[2,5] = c * A[2,5] - s * A[2,2] +// B[3,5] = c * A[3,5] - s * A[3,2] +// B[4,5] = c * A[4,5] - s * A[4,2] +// B[5,5] = c * A[5,5] - s * A[5,2] +// B[6,5] = c * A[6,5] - s * A[6,2] +// +// +// +// Step 1: Just do upper triangle (i < j), B[2,5] = 0 +// +// B[1,2] = c * A[1,2] + s * A[1,5] +// +// B[2,3] = c * A[2,3] + s * A[5,3] +// B[2,4] = c * A[2,4] + s * A[5,4] +// B[2,6] = c * A[2,6] + s * A[5,6] +// +// B[1,5] = c * A[1,5] - s * A[1,2] +// B[3,5] = c * A[3,5] - s * A[3,2] +// B[4,5] = c * A[4,5] - s * A[4,2] +// +// B[5,6] = c * A[5,6] + s * A[2,6] +// +// +// +// Step 2: Transpose where i > j since A[i,j] == A[j,i] +// +// B[1,2] = c * A[1,2] + s * A[1,5] +// +// B[2,3] = c * A[2,3] + s * A[3,5] +// B[2,4] = c * A[2,4] + s * A[4,5] +// B[2,6] = c * A[2,6] + s * A[5,6] +// +// B[1,5] = c * A[1,5] - s * A[1,2] +// B[3,5] = c * A[3,5] - s * A[2,3] +// B[4,5] = c * A[4,5] - s * A[2,4] +// +// B[5,6] = c * A[5,6] + s * A[2,6] +// +// +// +// Step 3: Same as above except reorder +// +// k < p (k = 1) +// +// A[1,2] = c * A[1,2] + s * A[1,5] +// A[1,5] = c * A[1,5] - s * A[1,2] +// +// p < k < q (k = 3..4) +// +// A[2,3] = c * A[2,3] + s * A[3,5] +// A[3,5] = c * A[3,5] - s * A[2,3] +// +// A[2,4] = c * A[2,4] + s * A[4,5] +// A[4,5] = c * A[4,5] - s * A[2,4] +// +// q < k (k = 6) +// +// A[2,6] = c * A[2,6] + s * A[5,6] +// A[5,6] = c * A[5,6] - s * A[2,6] + +int +eigenvec_step(double *D, double *Q, int n) +{ + int count, i, j; + + count = 0; + + // for each upper triangle "off-diagonal" component do step_nib + + for (i = 0; i < n - 1; i++) { + for (j = i + 1; j < n; j++) { + if (D[n * i + j] != 0.0) { + eigenvec_step_nib(D, Q, n, i, j); + count++; + } + } + } + + return count; +} + +void +eigenvec_step_nib(double *D, double *Q, int n, int p, int q) +{ + int k; + double t, theta; + double c, cc, s, ss; + + // compute c and s + + // from Numerical Recipes (except they have a_qq - a_pp) + + theta = 0.5 * (D[n * p + p] - D[n * q + q]) / D[n * p + q]; + + t = 1.0 / (fabs(theta) + sqrt(theta * theta + 1.0)); + + if (theta < 0.0) + t = -t; + + c = 1.0 / sqrt(t * t + 1.0); + + s = t * c; + + // D = GD + + // which means "add rows" + + for (k = 0; k < n; k++) { + cc = D[n * p + k]; + ss = D[n * q + k]; + D[n * p + k] = c * cc + s * ss; + D[n * q + k] = c * ss - s * cc; + } + + // D = D transpose(G) + + // which means "add columns" + + for (k = 0; k < n; k++) { + cc = D[n * k + p]; + ss = D[n * k + q]; + D[n * k + p] = c * cc + s * ss; + D[n * k + q] = c * ss - s * cc; + } + + // Q = GQ + + // which means "add rows" + + for (k = 0; k < n; k++) { + cc = Q[n * p + k]; + ss = Q[n * q + k]; + Q[n * p + k] = c * cc + s * ss; + Q[n * q + k] = c * ss - s * cc; + } + + D[n * p + q] = 0.0; + D[n * q + p] = 0.0; +} +// first author: github.com/phbillet + +void +eval_erf(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + erffunc(); +} + +void +erffunc(void) +{ + int i, n; + double d; + struct atom *p1, *p2; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + erffunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + floatfunc(); + p2 = pop(); + + if (isnum(p2)) { + push(p2); + d = pop_double(); + d = erf(d); + push_double(d); + return; + } + + if (isnegativeterm(p1)) { + push_symbol(ERF); + push(p1); + negate(); + list(2); + negate(); + } else { + push_symbol(ERF); + push(p1); + list(2); + } +} +// first author: github.com/phbillet + +void +eval_erfc(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + erfcfunc(); +} + +void +erfcfunc(void) +{ + int i, n; + double d; + struct atom *p1, *p2; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + erfcfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + floatfunc(); + p2 = pop(); + + if (isnum(p2)) { + push(p2); + d = pop_double(); + d = erfc(d); + push_double(d); + return; + } + + if (isnegativeterm(p1)) { + push_symbol(ERF); + push(p1); + negate(); + list(2); + } else { + push_symbol(ERF); + push(p1); + list(2); + negate(); + } + + push_integer(1); + add(); +} +void +eval_eval(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + p1 = cddr(p1); + while (iscons(p1)) { + push(car(p1)); + evalf(); + push(cadr(p1)); + evalf(); + asubst(); + p1 = cddr(p1); + } +} + +// arithmetic subst + +void +asubst(void) +{ + int h, i, n; + struct atom *p1, *p2, *p3; + + p3 = pop(); // new expr + p2 = pop(); // old expr + p1 = pop(); // expr + + if (p2 == symbol(NIL) || p3 == symbol(NIL)) { + push(p1); + return; + } + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + push(p2); + push(p3); + asubst(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (equal(p1, p2)) { + push(p3); + return; + } + + if (!iscons(p1)) { + push(p1); + return; + } + + // depth first + + h = tos; + + push(car(p1)); // func name + p1 = cdr(p1); + + while (iscons(p1)) { + push(car(p1)); + push(p2); + push(p3); + asubst(); + p1 = cdr(p1); + } + + list(tos - h); + + evalf(); // normalize + + p1 = pop(); + + if (addcmp(p1, p2)) { + push(p1); + push(p2); + subtract(); + push(p3); + add(); + return; + } + + if (mulcmp(p1, p2) || powcmp(p1, p2)) { + push(p1); + push(p2); + divide(); + push(p3); + multiply(); + return; + } + + push(p1); +} + +int +addcmp(struct atom *p1, struct atom *p2) +{ + if (car(p1) != symbol(ADD) || car(p2) != symbol(ADD)) + return 0; + p1 = cdr(p1); + p2 = cdr(p2); + while (iscons(p1) && iscons(p2)) { + if (equal(car(p1), car(p2))) + p2 = cdr(p2); // next term on list + p1 = cdr(p1); + } + if (iscons(p2)) + return 0; + else + return 1; // all terms matched +} + +int +mulcmp(struct atom *p1, struct atom *p2) +{ + if (car(p1) != symbol(MULTIPLY) || car(p2) != symbol(MULTIPLY)) + return 0; + p1 = cdr(p1); + p2 = cdr(p2); + while (iscons(p1) && iscons(p2)) { + if (equal(car(p1), car(p2)) || powcmp(car(p1), car(p2))) + p2 = cdr(p2); // next factor on list + p1 = cdr(p1); + } + if (iscons(p2)) + return 0; + else + return 1; // all factors matched +} + +int +powcmp(struct atom *p1, struct atom *p2) +{ + if (car(p1) != symbol(POWER) || car(p2) != symbol(POWER)) + return 0; + if (!equal(cadr(p1), cadr(p2))) + return 0; // bases don't match + p1 = caddr(p1); // exponent + p2 = caddr(p2); // exponent + if (car(p1) != symbol(ADD)) + return 0; // p1 and p2 already failed exact match + if (car(p2) == symbol(ADD)) + return addcmp(p1, p2); + p1 = cdr(p1); + while (iscons(p1)) { + if (equal(car(p1), p2)) + return 1; + p1 = cdr(p1); + } + return 0; +} +void +eval_exp(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + expfunc(); +} + +void +expfunc(void) +{ + push_symbol(EXP1); + swap(); + power(); +} +void +eval_expcos(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + expcos(); +} + +void +expcos(void) +{ + struct atom *p1; + p1 = pop(); + + push(imaginaryunit); + push(p1); + multiply(); + expfunc(); + push_rational(1, 2); + multiply(); + + push(imaginaryunit); + negate(); + push(p1); + multiply(); + expfunc(); + push_rational(1, 2); + multiply(); + + add(); +} +void +eval_expcosh(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + expcosh(); +} + +void +expcosh(void) +{ + struct atom *p1; + p1 = pop(); + push(p1); + expfunc(); + push(p1); + negate(); + expfunc(); + add(); + push_rational(1, 2); + multiply(); +} +void +eval_expform(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + expform(); +} + +void +expform(void) +{ + int h, i, n; + struct atom *p1, *num, *den; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + expform(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (!iscons(p1)) { + push(p1); + return; + } + + if (car(p1) == symbol(ADD)) { + h = tos; + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + expform(); + p1 = cdr(p1); + } + add_terms(tos - h); + return; + } + + if (car(p1) == symbol(MULTIPLY)) { + + push(p1); + numden(); + num = pop(); + den = pop(); + + p1 = num; + if (car(p1) == symbol(MULTIPLY)) { + h = tos; + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + expform(); + p1 = cdr(p1); + } + multiply_factors(tos - h); + } else { + push(p1); + expform(); + } + num = pop(); + + p1 = den; + if (car(p1) == symbol(MULTIPLY)) { + h = tos; + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + expform(); + p1 = cdr(p1); + } + multiply_factors(tos - h); + } else { + push(p1); + expform(); + } + den = pop(); + + push(num); + push(den); + divide(); + return; + } + + if (car(p1) == symbol(POWER)) { + push(cadr(p1)); + expform(); + push(caddr(p1)); + expform(); + power(); + return; + } + + if (car(p1) == symbol(COS)) { + push(cadr(p1)); + expform(); + expcos(); + return; + } + + if (car(p1) == symbol(SIN)) { + push(cadr(p1)); + expform(); + expsin(); + return; + } + + if (car(p1) == symbol(TAN)) { + push(cadr(p1)); + expform(); + exptan(); + return; + } + + if (car(p1) == symbol(COSH)) { + push(cadr(p1)); + expform(); + expcosh(); + return; + } + + if (car(p1) == symbol(SINH)) { + push(cadr(p1)); + expform(); + expsinh(); + return; + } + + if (car(p1) == symbol(TANH)) { + push(cadr(p1)); + expform(); + exptanh(); + return; + } + + h = tos; + push(car(p1)); + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + expform(); + p1 = cdr(p1); + } + list(tos - h); + evalf(); +} +void +eval_expsin(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + expsin(); +} + +void +expsin(void) +{ + struct atom *p1; + p1 = pop(); + + push(imaginaryunit); + push(p1); + multiply(); + expfunc(); + push(imaginaryunit); + divide(); + push_rational(1, 2); + multiply(); + + push(imaginaryunit); + negate(); + push(p1); + multiply(); + expfunc(); + push(imaginaryunit); + divide(); + push_rational(1, 2); + multiply(); + + subtract(); +} +void +eval_expsinh(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + expsinh(); +} + +void +expsinh(void) +{ + struct atom *p1; + p1 = pop(); + push(p1); + expfunc(); + push(p1); + negate(); + expfunc(); + subtract(); + push_rational(1, 2); + multiply(); +} +// tan(z) = (i - i exp(2 i z)) / (exp(2 i z) + 1) + +void +eval_exptan(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + exptan(); +} + +void +exptan(void) +{ + struct atom *p1; + + push_integer(2); + push(imaginaryunit); + multiply_factors(3); + expfunc(); + + p1 = pop(); + + push(imaginaryunit); + push(imaginaryunit); + push(p1); + multiply(); + subtract(); + + push(p1); + push_integer(1); + add(); + + divide(); +} +void +eval_exptanh(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + exptanh(); +} + +void +exptanh(void) +{ + struct atom *p1; + push_integer(2); + multiply(); + expfunc(); + p1 = pop(); + push(p1); + push_integer(1); + subtract(); + push(p1); + push_integer(1); + add(); + divide(); +} +void +eval_factorial(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + factorial(); +} + +void +factorial(void) +{ + int i, n; + double m; + struct atom *p1; + + p1 = pop(); + + if (isposint(p1)) { + push(p1); + n = pop_integer(); + push_integer(1); + for (i = 2; i <= n; i++) { + push_integer(i); + multiply(); + } + return; + } + + if (isdouble(p1) && p1->u.d >= 0 && floor(p1->u.d) == p1->u.d) { + push(p1); + n = pop_integer(); + m = 1.0; + for (i = 2; i <= n; i++) + m *= i; + push_double(m); + return; + } + + push_symbol(FACTORIAL); + push(p1); + list(2); +} +void +eval_float(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + floatfunc(); +} + +void +floatfunc(void) +{ + floatfunc_subst(); + evalf(); + floatfunc_subst(); // in case pi popped up + evalf(); +} + +void +floatfunc_subst(void) +{ + int h, i, n; + double a, b; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + floatfunc_subst(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (p1 == symbol(PI)) { + push_double(M_PI); + return; + } + + if (p1 == symbol(EXP1)) { + push_double(M_E); + return; + } + + if (isrational(p1)) { + a = mfloat(p1->u.q.a); + b = mfloat(p1->u.q.b); + if (isnegativenumber(p1)) + a = -a; + push_double(a / b); + return; + } + + // don't float exponential + + if (car(p1) == symbol(POWER) && cadr(p1) == symbol(EXP1)) { + push_symbol(POWER); + push_symbol(EXP1); + push(caddr(p1)); + floatfunc_subst(); + list(3); + return; + } + + // don't float imaginary unit, but multiply it by 1.0 + + if (car(p1) == symbol(POWER) && isminusone(cadr(p1))) { + push_symbol(MULTIPLY); + push_double(1.0); + push_symbol(POWER); + push(cadr(p1)); + push(caddr(p1)); + floatfunc_subst(); + list(3); + list(3); + return; + } + + if (iscons(p1)) { + h = tos; + push(car(p1)); + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + floatfunc_subst(); + p1 = cdr(p1); + } + list(tos - h); + return; + } + + push(p1); +} +void +eval_floor(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + floorfunc(); +} + +void +floorfunc(void) +{ + int i, n; + uint32_t *a, *b; + double d; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + floorfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isinteger(p1)) { + push(p1); + return; + } + + if (isrational(p1)) { + a = mdiv(p1->u.q.a, p1->u.q.b); + b = mint(1); + if (isnegativenumber(p1)) { + push_bignum(MMINUS, a, b); + push_integer(-1); + add(); + } else + push_bignum(MPLUS, a, b); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = floor(d); + push_double(d); + return; + } + + push_symbol(FLOOR); + push(p1); + list(2); +} +void +eval_for(struct atom *p1) +{ + int j, k, t; + struct atom *p2, *p3; + + p2 = cadr(p1); + if (!isusersymbol(p2)) + stopf("for: index symbol err"); + + push(caddr(p1)); + evalf(); + p3 = pop(); + if (!issmallinteger(p3)) + stopf("for: index range err"); + push(p3); + j = pop_integer(); + + push(cadddr(p1)); + evalf(); + p3 = pop(); + if (!issmallinteger(p3)) + stopf("for: index range err"); + push(p3); + k = pop_integer(); + + p1 = cddddr(p1); + + save_symbol(p2); + + t = breakflag; + breakflag = 0; + + for (;;) { + push_integer(j); + p3 = pop(); + set_symbol(p2, p3, symbol(NIL)); + p3 = p1; + while (iscons(p3)) { + push(car(p3)); + evalg(); + pop(); + p3 = cdr(p3); + if (breakflag || errorflag) { + breakflag = t; + restore_symbol(); + push_symbol(NIL); + return; + } + } + if (j == k) + break; + if (j < k) + j++; + else + j--; + } + + breakflag = t; + restore_symbol(); + push_symbol(NIL); +} +void +eval_hadamard(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + p1 = cddr(p1); + while (iscons(p1)) { + push(car(p1)); + evalf(); + hadamard(); + p1 = cdr(p1); + } +} + +void +hadamard(void) +{ + int i, n; + struct atom *p1, *p2; + + p2 = pop(); + p1 = pop(); + + if (!istensor(p1) || !istensor(p2)) { + push(p1); + push(p2); + multiply(); + return; + } + + if (p1->u.tensor->ndim != p2->u.tensor->ndim) + stopf("hadamard"); + + n = p1->u.tensor->ndim; + + for (i = 0; i < n; i++) + if (p1->u.tensor->dim[i] != p2->u.tensor->dim[i]) + stopf("hadamard"); + + p1 = copy_tensor(p1); + + n = p1->u.tensor->nelem; + + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + push(p2->u.tensor->elem[i]); + multiply(); + p1->u.tensor->elem[i] = pop(); + } + + push(p1); +} +void +eval_imag(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + imag(); +} + +void +imag(void) +{ + int i, n; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + imag(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + rect(); + p1 = pop(); + push_rational(-1, 2); + push(imaginaryunit); + push(p1); + push(p1); + conjfunc(); + subtract(); + multiply_factors(3); +} +void +eval_index(struct atom *p1) +{ + int h, n; + struct atom *T; + + T = cadr(p1); + + p1 = cddr(p1); + + h = tos; + + while (iscons(p1)) { + push(car(p1)); + evalf(); + p1 = cdr(p1); + } + + // try to optimize by indexing before eval + + if (isusersymbol(T)) { + p1 = get_binding(T); + n = tos - h; + if (istensor(p1) && n <= p1->u.tensor->ndim) { + T = p1; + indexfunc(T, h); + evalf(); + return; + } + } + + push(T); + evalf(); + T = pop(); + + if (!istensor(T)) { + tos = h; // pop all + push(T); // quirky, but EVA2.txt depends on it + return; + } + + indexfunc(T, h); +} + +void +indexfunc(struct atom *T, int h) +{ + int i, k, m, n, r, t, w; + struct atom *p1; + + m = T->u.tensor->ndim; + + n = tos - h; + + r = m - n; // rank of result + + if (r < 0) + stopf("index error"); + + k = 0; + + for (i = 0; i < n; i++) { + push(stack[h + i]); + t = pop_integer(); + if (t < 1 || t > T->u.tensor->dim[i]) { + if (shuntflag) { + errorflag = 1; + t = 1; + } else + stopf("index error"); + } + k = k * T->u.tensor->dim[i] + t - 1; + } + + tos = h; // pop all + + if (r == 0) { + push(T->u.tensor->elem[k]); // scalar result + return; + } + + w = 1; + + for (i = n; i < m; i++) + w *= T->u.tensor->dim[i]; + + k *= w; + + p1 = alloc_tensor(w); + + for (i = 0; i < w; i++) + p1->u.tensor->elem[i] = T->u.tensor->elem[k + i]; + + p1->u.tensor->ndim = r; + + for (i = 0; i < r; i++) + p1->u.tensor->dim[i] = T->u.tensor->dim[n + i]; + + push(p1); +} +void +eval_infixform(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + p1 = pop(); + + outbuf_init(); + infixform_expr(p1); + + push_string(outbuf); +} + +// for tty mode and debugging + +void +print_infixform(struct atom *p) +{ + outbuf_init(); + infixform_expr(p); + outbuf_puts("\n"); + printbuf(outbuf, BLACK); +} + +void +infixform_subexpr(struct atom *p) +{ + outbuf_puts("("); + infixform_expr(p); + outbuf_puts(")"); +} + +void +infixform_expr(struct atom *p) +{ + if (isnegativeterm(p) || (car(p) == symbol(ADD) && isnegativeterm(cadr(p)))) + outbuf_puts("-"); + if (car(p) == symbol(ADD)) + infixform_expr_nib(p); + else + infixform_term(p); +} + +void +infixform_expr_nib(struct atom *p) +{ + infixform_term(cadr(p)); + p = cddr(p); + while (iscons(p)) { + if (isnegativeterm(car(p))) + outbuf_puts(" - "); + else + outbuf_puts(" + "); + infixform_term(car(p)); + p = cdr(p); + } +} + +void +infixform_term(struct atom *p) +{ + if (car(p) == symbol(MULTIPLY)) + infixform_term_nib(p); + else + infixform_factor(p); +} + +void +infixform_term_nib(struct atom *p) +{ + if (find_denominator(p)) { + infixform_numerators(p); + outbuf_puts(" / "); + infixform_denominators(p); + return; + } + + // no denominators + + p = cdr(p); + + if (isminusone(car(p))) + p = cdr(p); // sign already emitted + + infixform_factor(car(p)); + + p = cdr(p); + + while (iscons(p)) { + outbuf_puts(" "); // space in between factors + infixform_factor(car(p)); + p = cdr(p); + } +} + +void +infixform_numerators(struct atom *p) +{ + int k; + char *s; + struct atom *q; + + k = 0; + + p = cdr(p); + + while (iscons(p)) { + + q = car(p); + p = cdr(p); + + if (!isnumerator(q)) + continue; + + if (++k > 1) + outbuf_puts(" "); // space in between factors + + if (isrational(q)) { + s = mstr(q->u.q.a); + outbuf_puts(s); + continue; + } + + infixform_factor(q); + } + + if (k == 0) + outbuf_puts("1"); +} + +void +infixform_denominators(struct atom *p) +{ + int k, n; + char *s; + struct atom *q; + + n = count_denominators(p); + + if (n > 1) + outbuf_puts("("); + + k = 0; + + p = cdr(p); + + while (iscons(p)) { + + q = car(p); + p = cdr(p); + + if (!isdenominator(q)) + continue; + + if (++k > 1) + outbuf_puts(" "); // space in between factors + + if (isrational(q)) { + s = mstr(q->u.q.b); + outbuf_puts(s); + continue; + } + + if (isminusone(caddr(q))) { + q = cadr(q); + infixform_factor(q); + } else { + infixform_base(cadr(q)); + outbuf_puts("^"); + infixform_numeric_exponent(caddr(q)); // sign is not emitted + } + } + + if (n > 1) + outbuf_puts(")"); +} + +void +infixform_factor(struct atom *p) +{ + if (isrational(p)) { + infixform_rational(p); + return; + } + + if (isdouble(p)) { + infixform_double(p); + return; + } + + if (issymbol(p)) { + if (p == symbol(EXP1)) + outbuf_puts("exp(1)"); + else + outbuf_puts(printname(p)); + return; + } + + if (isstr(p)) { + outbuf_puts(p->u.str); + return; + } + + if (istensor(p)) { + infixform_tensor(p); + return; + } + + if (car(p) == symbol(ADD) || car(p) == symbol(MULTIPLY)) { + infixform_subexpr(p); + return; + } + + if (car(p) == symbol(POWER)) { + infixform_power(p); + return; + } + + if (car(p) == symbol(FACTORIAL)) { + infixform_factorial(p); + return; + } + + if (car(p) == symbol(INDEX)) { + infixform_index(p); + return; + } + + // use d if for derivative if d not defined + + if (car(p) == symbol(DERIVATIVE) && get_usrfunc(symbol(D_LOWER)) == symbol(NIL)) { + outbuf_puts("d"); + infixform_arglist(p); + return; + } + + if (car(p) == symbol(SETQ)) { + infixform_expr(cadr(p)); + outbuf_puts(" = "); + infixform_expr(caddr(p)); + return; + } + + if (car(p) == symbol(TESTEQ)) { + infixform_expr(cadr(p)); + outbuf_puts(" == "); + infixform_expr(caddr(p)); + return; + } + + if (car(p) == symbol(TESTGE)) { + infixform_expr(cadr(p)); + outbuf_puts(" >= "); + infixform_expr(caddr(p)); + return; + } + + if (car(p) == symbol(TESTGT)) { + infixform_expr(cadr(p)); + outbuf_puts(" > "); + infixform_expr(caddr(p)); + return; + } + + if (car(p) == symbol(TESTLE)) { + infixform_expr(cadr(p)); + outbuf_puts(" <= "); + infixform_expr(caddr(p)); + return; + } + + if (car(p) == symbol(TESTLT)) { + infixform_expr(cadr(p)); + outbuf_puts(" < "); + infixform_expr(caddr(p)); + return; + } + + // other function + + if (iscons(p)) { + infixform_base(car(p)); + infixform_arglist(p); + return; + } + + outbuf_puts(" ? "); +} + +void +infixform_power(struct atom *p) +{ + if (cadr(p) == symbol(EXP1)) { + outbuf_puts("exp("); + infixform_expr(caddr(p)); + outbuf_puts(")"); + return; + } + + if (isimaginaryunit(p)) { + if (isimaginaryunit(get_binding(symbol(J_LOWER)))) { + outbuf_puts("j"); + return; + } + if (isimaginaryunit(get_binding(symbol(I_LOWER)))) { + outbuf_puts("i"); + return; + } + } + + if (isnegativenumber(caddr(p))) { + infixform_reciprocal(p); + return; + } + + infixform_base(cadr(p)); + + outbuf_puts("^"); + + p = caddr(p); // p now points to exponent + + if (isnum(p)) + infixform_numeric_exponent(p); + else if (car(p) == symbol(ADD) || car(p) == symbol(MULTIPLY) || car(p) == symbol(POWER) || car(p) == symbol(FACTORIAL)) + infixform_subexpr(p); + else + infixform_expr(p); +} + +// p = y^x where x is a negative number + +void +infixform_reciprocal(struct atom *p) +{ + outbuf_puts("1 / "); // numerator + if (isminusone(caddr(p))) { + p = cadr(p); + infixform_factor(p); + } else { + infixform_base(cadr(p)); + outbuf_puts("^"); + infixform_numeric_exponent(caddr(p)); // sign is not emitted + } +} + +void +infixform_factorial(struct atom *p) +{ + infixform_base(cadr(p)); + outbuf_puts("!"); +} + +void +infixform_index(struct atom *p) +{ + infixform_base(cadr(p)); + outbuf_puts("["); + p = cddr(p); + if (iscons(p)) { + infixform_expr(car(p)); + p = cdr(p); + while (iscons(p)) { + outbuf_puts(","); + infixform_expr(car(p)); + p = cdr(p); + } + } + outbuf_puts("]"); +} + +void +infixform_arglist(struct atom *p) +{ + outbuf_puts("("); + p = cdr(p); + if (iscons(p)) { + infixform_expr(car(p)); + p = cdr(p); + while (iscons(p)) { + outbuf_puts(","); + infixform_expr(car(p)); + p = cdr(p); + } + } + outbuf_puts(")"); +} + +// sign is not emitted + +void +infixform_rational(struct atom *p) +{ + char *s; + + s = mstr(p->u.q.a); + outbuf_puts(s); + + s = mstr(p->u.q.b); + + if (strcmp(s, "1") == 0) + return; + + outbuf_puts("/"); + + outbuf_puts(s); +} + +// sign is not emitted + +void +infixform_double(struct atom *p) +{ + char *s; + + snprintf(strbuf, STRBUFLEN, "%g", fabs(p->u.d)); + + s = strbuf; + + while (*s && *s != 'E' && *s != 'e') + outbuf_putc(*s++); + + if (!*s) + return; + + s++; + + outbuf_puts(" 10^"); + + if (*s == '-') { + outbuf_puts("(-"); + s++; + while (*s == '0') + s++; // skip leading zeroes + outbuf_puts(s); + outbuf_puts(")"); + } else { + if (*s == '+') + s++; + while (*s == '0') + s++; // skip leading zeroes + outbuf_puts(s); + } +} + +void +infixform_base(struct atom *p) +{ + if (isnum(p)) + infixform_numeric_base(p); + else if (car(p) == symbol(ADD) || car(p) == symbol(MULTIPLY) || car(p) == symbol(POWER) || car(p) == symbol(FACTORIAL)) + infixform_subexpr(p); + else + infixform_expr(p); +} + +void +infixform_numeric_base(struct atom *p) +{ + if (isposint(p)) + infixform_rational(p); + else + infixform_subexpr(p); +} + +// sign is not emitted + +void +infixform_numeric_exponent(struct atom *p) +{ + if (isdouble(p)) { + outbuf_puts("("); + infixform_double(p); + outbuf_puts(")"); + return; + } + + if (isinteger(p)) { + infixform_rational(p); + return; + } + + outbuf_puts("("); + infixform_rational(p); + outbuf_puts(")"); +} + +void +infixform_tensor(struct atom *p) +{ + infixform_tensor_nib(p, 0, 0); +} + +void +infixform_tensor_nib(struct atom *p, int d, int k) +{ + int i, n, span; + + if (d == p->u.tensor->ndim) { + infixform_expr(p->u.tensor->elem[k]); + return; + } + + span = 1; + + n = p->u.tensor->ndim; + + for (i = d + 1; i < n; i++) + span *= p->u.tensor->dim[i]; + + outbuf_puts("("); + + n = p->u.tensor->dim[d]; + + for (i = 0; i < n; i++) { + + infixform_tensor_nib(p, d + 1, k); + + if (i < n - 1) + outbuf_puts(","); + + k += span; + } + + outbuf_puts(")"); +} +void +eval_inner(struct atom *p1) +{ + int h = tos; + + // evaluate from right to left + + p1 = cdr(p1); + + while (iscons(p1)) { + push(car(p1)); + p1 = cdr(p1); + } + + if (h == tos) + stopf("inner: no args"); + + evalg(); + + while (tos - h > 1) { + swap(); + evalg(); + swap(); + inner(); + } +} + +void +inner(void) +{ + int i, j, k, n, mcol, mrow, ncol, ndim, nrow; + struct atom *p1, *p2, *p3; + + p2 = pop(); + p1 = pop(); + + if (!istensor(p1) && !istensor(p2)) { + push(p1); + push(p2); + multiply(); + return; + } + + if (istensor(p1) && !istensor(p2)) { + p3 = p1; + p1 = p2; + p2 = p3; + } + + if (!istensor(p1) && istensor(p2)) { + p2 = copy_tensor(p2); + n = p2->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1); + push(p2->u.tensor->elem[i]); + multiply(); + p2->u.tensor->elem[i] = pop(); + } + push(p2); + return; + } + + k = p1->u.tensor->ndim - 1; + + ncol = p1->u.tensor->dim[k]; + mrow = p2->u.tensor->dim[0]; + + if (ncol != mrow) + stopf("inner: dimension err"); + + ndim = p1->u.tensor->ndim + p2->u.tensor->ndim - 2; + + if (ndim > MAXDIM) + stopf("inner: rank exceeds max"); + + // nrow is the number of rows in p1 + // + // mcol is the number of columns p2 + // + // Example: + // + // A[3][3][4] B[4][4][3] + // + // 3 3 nrow = 3 * 3 = 9 + // + // 4 3 mcol = 4 * 3 = 12 + + nrow = p1->u.tensor->nelem / ncol; + mcol = p2->u.tensor->nelem / mrow; + + p3 = alloc_tensor(nrow * mcol); + + for (i = 0; i < nrow; i++) { + for (j = 0; j < mcol; j++) { + for (k = 0; k < ncol; k++) { + push(p1->u.tensor->elem[i * ncol + k]); + push(p2->u.tensor->elem[k * mcol + j]); + multiply(); + } + add_terms(ncol); + p3->u.tensor->elem[i * mcol + j] = pop(); + } + } + + if (ndim == 0) { + push(p3->u.tensor->elem[0]); // scalar result + return; + } + + // dim info + + p3->u.tensor->ndim = ndim; + + k = 0; + + n = p1->u.tensor->ndim - 1; + + for (i = 0; i < n; i++) + p3->u.tensor->dim[k++] = p1->u.tensor->dim[i]; + + n = p2->u.tensor->ndim; + + for (i = 1; i < n; i++) + p3->u.tensor->dim[k++] = p2->u.tensor->dim[i]; + + push(p3); +} +char *integral_tab_exp[] = { + +// x^n exp(a x + b) + + "exp(a x)", + "exp(a x) / a", + "1", + + "exp(a x + b)", + "exp(a x + b) / a", + "1", + + "x exp(a x)", + "exp(a x) (a x - 1) / (a^2)", + "1", + + "x exp(a x + b)", + "exp(a x + b) (a x - 1) / (a^2)", + "1", + + "x^2 exp(a x)", + "exp(a x) (a^2 x^2 - 2 a x + 2) / (a^3)", + "1", + + "x^2 exp(a x + b)", + "exp(a x + b) (a^2 x^2 - 2 a x + 2) / (a^3)", + "1", + + "x^3 exp(a x)", + "(a^3 x^3 - 3 a^2 x^2 + 6 a x - 6) exp(a x) / a^4", + "1", + + "x^3 exp(a x + b)", + "(a^3 x^3 - 3 a^2 x^2 + 6 a x - 6) exp(a x + b) / a^4", + "1", + + "x^4 exp(a x)", + "((a^4*x^4-4*a^3*x^3+12*a^2*x^2-24*a*x+24)*exp(a*x))/a^5", + "1", + + "x^4 exp(a x + b)", + "((a^4*x^4-4*a^3*x^3+12*a^2*x^2-24*a*x+24)*exp(a*x+b))/a^5", + "1", + + "x^5 exp(a x)", + "((a^5*x^5-5*a^4*x^4+20*a^3*x^3-60*a^2*x^2+120*a*x-120)*exp(a*x))/a^6", + "1", + + "x^5 exp(a x + b)", + "((a^5*x^5-5*a^4*x^4+20*a^3*x^3-60*a^2*x^2+120*a*x-120)*exp(a*x+b))/a^6", + "1", + + "x^6 exp(a x)", + "((a^6*x^6-6*a^5*x^5+30*a^4*x^4-120*a^3*x^3+360*a^2*x^2-720*a*x+720)*exp(a*x))/a^7", + "1", + + "x^6 exp(a x + b)", + "((a^6*x^6-6*a^5*x^5+30*a^4*x^4-120*a^3*x^3+360*a^2*x^2-720*a*x+720)*exp(a*x+b))/a^7", + "1", + + "x^7 exp(a x)", + "((a^7*x^7-7*a^6*x^6+42*a^5*x^5-210*a^4*x^4+840*a^3*x^3-2520*a^2*x^2+5040*a*x-5040)*exp(a*x))/a^8", + "1", + + "x^7 exp(a x + b)", + "((a^7*x^7-7*a^6*x^6+42*a^5*x^5-210*a^4*x^4+840*a^3*x^3-2520*a^2*x^2+5040*a*x-5040)*exp(a*x+b))/a^8", + "1", + + "x^8 exp(a x)", + "((a^8*x^8-8*a^7*x^7+56*a^6*x^6-336*a^5*x^5+1680*a^4*x^4-6720*a^3*x^3+20160*a^2*x^2-40320*a*x+40320)*exp(a*x))/a^9", + "1", + + "x^8 exp(a x + b)", + "((a^8*x^8-8*a^7*x^7+56*a^6*x^6-336*a^5*x^5+1680*a^4*x^4-6720*a^3*x^3+20160*a^2*x^2-40320*a*x+40320)*exp(a*x+b))/a^9", + "1", + + "x^9 exp(a x)", + "x^9 exp(a x) / a - 9 x^8 exp(a x) / a^2 + 72 x^7 exp(a x) / a^3 - 504 x^6 exp(a x) / a^4 + 3024 x^5 exp(a x) / a^5 - 15120 x^4 exp(a x) / a^6 + 60480 x^3 exp(a x) / a^7 - 181440 x^2 exp(a x) / a^8 + 362880 x exp(a x) / a^9 - 362880 exp(a x) / a^10", + "1", + + "x^9 exp(a x + b)", + "x^9 exp(a x + b) / a - 9 x^8 exp(a x + b) / a^2 + 72 x^7 exp(a x + b) / a^3 - 504 x^6 exp(a x + b) / a^4 + 3024 x^5 exp(a x + b) / a^5 - 15120 x^4 exp(a x + b) / a^6 + 60480 x^3 exp(a x + b) / a^7 - 181440 x^2 exp(a x + b) / a^8 + 362880 x exp(a x + b) / a^9 - 362880 exp(a x + b) / a^10", + "1", + + "x^10 exp(a x)", + "x^10 exp(a x) / a - 10 x^9 exp(a x) / a^2 + 90 x^8 exp(a x) / a^3 - 720 x^7 exp(a x) / a^4 + 5040 x^6 exp(a x) / a^5 - 30240 x^5 exp(a x) / a^6 + 151200 x^4 exp(a x) / a^7 - 604800 x^3 exp(a x) / a^8 + 1814400 x^2 exp(a x) / a^9 - 3628800 x exp(a x) / a^10 + 3628800 exp(a x) / a^11", + "1", + + "x^10 exp(a x + b)", + "x^10 exp(a x + b) / a - 10 x^9 exp(a x + b) / a^2 + 90 x^8 exp(a x + b) / a^3 - 720 x^7 exp(a x + b) / a^4 + 5040 x^6 exp(a x + b) / a^5 - 30240 x^5 exp(a x + b) / a^6 + 151200 x^4 exp(a x + b) / a^7 - 604800 x^3 exp(a x + b) / a^8 + 1814400 x^2 exp(a x + b) / a^9 - 3628800 x exp(a x + b) / a^10 + 3628800 exp(a x + b) / a^11", + "1", + + "x^11 exp(a x)", + "x^11 exp(a x) / a - 11 x^10 exp(a x) / a^2 + 110 x^9 exp(a x) / a^3 - 990 x^8 exp(a x) / a^4 + 7920 x^7 exp(a x) / a^5 - 55440 x^6 exp(a x) / a^6 + 332640 x^5 exp(a x) / a^7 - 1663200 x^4 exp(a x) / a^8 + 6652800 x^3 exp(a x) / a^9 - 19958400 x^2 exp(a x) / a^10 + 39916800 x exp(a x) / a^11 - 39916800 exp(a x) / a^12", + "1", + + "x^11 exp(a x + b)", + "x^11 exp(a x + b) / a - 11 x^10 exp(a x + b) / a^2 + 110 x^9 exp(a x + b) / a^3 - 990 x^8 exp(a x + b) / a^4 + 7920 x^7 exp(a x + b) / a^5 - 55440 x^6 exp(a x + b) / a^6 + 332640 x^5 exp(a x + b) / a^7 - 1663200 x^4 exp(a x + b) / a^8 + 6652800 x^3 exp(a x + b) / a^9 - 19958400 x^2 exp(a x + b) / a^10 + 39916800 x exp(a x + b) / a^11 - 39916800 exp(a x + b) / a^12", + "1", + +// sin exp + + "sin(x) exp(a x)", + "a sin(x) exp(a x) / (a^2 + 1) - cos(x) exp(a x) / (a^2 + 1)", + "a^2 + 1", // denominator not zero + + "sin(x) exp(a x + b)", + "a sin(x) exp(a x + b) / (a^2 + 1) - cos(x) exp(a x + b) / (a^2 + 1)", + "a^2 + 1", // denominator not zero + + "sin(x) exp(i x)", + "-1/4 exp(2 i x) + 1/2 i x", + "1", + + "sin(x) exp(i x + b)", + "-1/4 exp(b + 2 i x) + 1/2 i x exp(b)", + "1", + + "sin(x) exp(-i x)", + "-1/4 exp(-2 i x) - 1/2 i x", + "1", + + "sin(x) exp(-i x + b)", + "-1/4 exp(b - 2 i x) - 1/2 i x exp(b)", + "1", + +// cos exp + + "cos(x) exp(a x)", + "a cos(x) exp(a x) / (a^2 + 1) + sin(x) exp(a x) / (a^2 + 1)", + "a^2 + 1", // denominator not zero + + "cos(x) exp(a x + b)", + "a cos(x) exp(a x + b) / (a^2 + 1) + sin(x) exp(a x + b) / (a^2 + 1)", + "a^2 + 1", // denominator not zero + + "cos(x) exp(i x)", + "1/2 x - 1/4 i exp(2 i x)", + "1", + + "cos(x) exp(i x + b)", + "1/2 x exp(b) - 1/4 i exp(b + 2 i x)", + "1", + + "cos(x) exp(-i x)", + "1/2 x + 1/4 i exp(-2 i x)", + "1", + + "cos(x) exp(-i x + b)", + "1/2 x exp(b) + 1/4 i exp(b - 2 i x)", + "1", + +// sin cos exp + + "sin(x) cos(x) exp(a x)", + "a sin(2 x) exp(a x) / (2 (a^2 + 4)) - cos(2 x) exp(a x) / (a^2 + 4)", + "a^2 + 4", // denominator not zero + +// x^n exp(a x^2 + b) + + "exp(a x^2)", + "-1/2 i sqrt(pi) erf(i sqrt(a) x) / sqrt(a)", + "1", + + "exp(a x^2 + b)", + "-1/2 i sqrt(pi) exp(b) erf(i sqrt(a) x) / sqrt(a)", + "1", + + "x exp(a x^2)", + "1/2 exp(a x^2) / a", + "1", + + "x exp(a x^2 + b)", + "1/2 exp(a x^2 + b) / a", + "1", + + "x^2 exp(a x^2)", + "1/2 x exp(a x^2) / a + 1/4 i sqrt(pi) erf(i sqrt(a) x) / a^(3/2)", + "1", + + "x^2 exp(a x^2 + b)", + "1/2 x exp(a x^2 + b) / a + 1/4 i sqrt(pi) exp(b) erf(i sqrt(a) x) / a^(3/2)", + "1", + + "x^3 exp(a x^2)", + "1/2 exp(a x^2) (x^2 / a - 1 / a^2)", + "1", + + "x^3 exp(a x^2 + b)", + "1/2 exp(a x^2) exp(b) (x^2 / a - 1 / a^2)", + "1", + + "x^4 exp(a x^2)", + "x^3 exp(a x^2) / (2 a) - 3 x exp(a x^2) / (4 a^2) - 3 i pi^(1/2) erf(i a^(1/2) x) / (8 a^(5/2))", + "1", + + "x^4 exp(a x^2 + b)", + "x^3 exp(a x^2 + b) / (2 a) - 3 x exp(a x^2 + b) / (4 a^2) - 3 i pi^(1/2) erf(i a^(1/2) x) exp(b) / (8 a^(5/2))", + "1", + + "x^5 exp(a x^2)", + "x^4 exp(a x^2) / (2 a) - x^2 exp(a x^2) / a^2 + exp(a x^2) / a^3", + "1", + + "x^5 exp(a x^2 + b)", + "x^4 exp(a x^2 + b) / (2 a) - x^2 exp(a x^2 + b) / a^2 + exp(a x^2 + b) / a^3", + "1", + + "x^6 exp(a x^2)", + "x^5 exp(a x^2) / (2 a) - 5 x^3 exp(a x^2) / (4 a^2) + 15 x exp(a x^2) / (8 a^3) + 15 i pi^(1/2) erf(i a^(1/2) x) / (16 a^(7/2))", + "1", + + "x^6 exp(a x^2 + b)", + "x^5 exp(a x^2 + b) / (2 a) - 5 x^3 exp(a x^2 + b) / (4 a^2) + 15 x exp(a x^2 + b) / (8 a^3) + 15 i pi^(1/2) erf(i a^(1/2) x) exp(b) / (16 a^(7/2))", + "1", + + "x^7 exp(a x^2)", + "x^6 exp(a x^2) / (2 a) - 3 x^4 exp(a x^2) / (2 a^2) + 3 x^2 exp(a x^2) / a^3 - 3 exp(a x^2) / a^4", + "1", + + "x^7 exp(a x^2 + b)", + "x^6 exp(a x^2 + b) / (2 a) - 3 x^4 exp(a x^2 + b) / (2 a^2) + 3 x^2 exp(a x^2 + b) / a^3 - 3 exp(a x^2 + b) / a^4", + "1", + + "x^8 exp(a x^2)", + "x^7 exp(a x^2) / (2 a) - 7 x^5 exp(a x^2) / (4 a^2) + 35 x^3 exp(a x^2) / (8 a^3) - 105 x exp(a x^2) / (16 a^4) - 105 i pi^(1/2) erf(i a^(1/2) x) / (32 a^(9/2))", + "1", + + "x^8 exp(a x^2 + b)", + "x^7 exp(a x^2 + b) / (2 a) - 7 x^5 exp(a x^2 + b) / (4 a^2) + 35 x^3 exp(a x^2 + b) / (8 a^3) - 105 x exp(a x^2 + b) / (16 a^4) - 105 i pi^(1/2) erf(i a^(1/2) x) exp(b) / (32 a^(9/2))", + "1", + + "x^9 exp(a x^2)", + "x^8 exp(a x^2) / (2 a) - 2 x^6 exp(a x^2) / a^2 + 6 x^4 exp(a x^2) / a^3 - 12 x^2 exp(a x^2) / a^4 + 12 exp(a x^2) / a^5", + "1", + + "x^9 exp(a x^2 + b)", + "x^8 exp(a x^2 + b) / (2 a) - 2 x^6 exp(a x^2 + b) / a^2 + 6 x^4 exp(a x^2 + b) / a^3 - 12 x^2 exp(a x^2 + b) / a^4 + 12 exp(a x^2 + b) / a^5", + "1", +}; + +// log(a x) is transformed to log(a) + log(x) + +char *integral_tab_log[] = { + + "log(x)", + "x log(x) - x", + "1", + + "log(a x + b)", + "x log(a x + b) + b log(a x + b) / a - x", + "1", + + "x log(x)", + "x^2 log(x) 1/2 - x^2 1/4", + "1", + + "x log(a x + b)", + "1/2 (a x - b) (a x + b) log(a x + b) / a^2 - 1/4 x (a x - 2 b) / a", + "1", + + "x^2 log(x)", + "x^3 log(x) 1/3 - 1/9 x^3", + "1", + + "x^2 log(a x + b)", + "1/3 (a x + b) (a^2 x^2 - a b x + b^2) log(a x + b) / a^3 - 1/18 x (2 a^2 x^2 - 3 a b x + 6 b^2) / a^2", + "1", + + "log(x)^2", + "x log(x)^2 - 2 x log(x) + 2 x", + "1", + + "log(a x + b)^2", + "(a x + b) (log(a x + b)^2 - 2 log(a x + b) + 2) / a", + "1", + + "log(x) / x^2", + "-(log(x) + 1) / x", + "1", + + "log(a x + b) / x^2", + "a log(x) / b - (a x + b) log(a x + b) / (b x)", + "1", + + "1 / (x (a + log(x)))", + "log(a + log(x))", + "1", +}; + +char *integral_tab_trig[] = { + + "sin(a x)", + "-cos(a x) / a", + "1", + + "cos(a x)", + "sin(a x) / a", + "1", + + "tan(a x)", + "-log(cos(a x)) / a", + "1", + +// sin(a x)^n + + "sin(a x)^2", + "-sin(2 a x) / (4 a) + 1/2 x", + "1", + + "sin(a x)^3", + "-2 cos(a x) / (3 a) - cos(a x) sin(a x)^2 / (3 a)", + "1", + + "sin(a x)^4", + "-sin(2 a x) / (4 a) + sin(4 a x) / (32 a) + 3/8 x", + "1", + + "sin(a x)^5", + "-cos(a x)^5 / (5 a) + 2 cos(a x)^3 / (3 a) - cos(a x) / a", + "1", + + "sin(a x)^6", + "sin(2 a x)^3 / (48 a) - sin(2 a x) / (4 a) + 3 sin(4 a x) / (64 a) + 5/16 x", + "1", + +// cos(a x)^n + + "cos(a x)^2", + "sin(2 a x) / (4 a) + 1/2 x", + "1", + + "cos(a x)^3", + "cos(a x)^2 sin(a x) / (3 a) + 2 sin(a x) / (3 a)", + "1", + + "cos(a x)^4", + "sin(2 a x) / (4 a) + sin(4 a x) / (32 a) + 3/8 x", + "1", + + "cos(a x)^5", + "sin(a x)^5 / (5 a) - 2 sin(a x)^3 / (3 a) + sin(a x) / a", + "1", + + "cos(a x)^6", + "-sin(2 a x)^3 / (48 a) + sin(2 a x) / (4 a) + 3 sin(4 a x) / (64 a) + 5/16 x", + "1", + +// + + "sin(a x) cos(a x)", + "1/2 sin(a x)^2 / a", + "1", + + "sin(a x) cos(a x)^2", + "-1/3 cos(a x)^3 / a", + "1", + + "sin(a x)^2 cos(a x)", + "1/3 sin(a x)^3 / a", + "1", + + "sin(a x)^2 cos(a x)^2", + "1/8 x - 1/32 sin(4 a x) / a", + "1", +// 329 + "1 / sin(a x) / cos(a x)", + "log(tan(a x)) / a", + "1", +// 330 + "1 / sin(a x) / cos(a x)^2", + "(1 / cos(a x) + log(tan(a x 1/2))) / a", + "1", +// 331 + "1 / sin(a x)^2 / cos(a x)", + "(log(tan(pi 1/4 + a x 1/2)) - 1 / sin(a x)) / a", + "1", +// 333 + "1 / sin(a x)^2 / cos(a x)^2", + "-2 / (a tan(2 a x))", + "1", +// + "sin(a x) / cos(a x)", + "-log(cos(a x)) / a", + "1", + + "sin(a x) / cos(a x)^2", + "1 / a / cos(a x)", + "1", + + "sin(a x)^2 / cos(a x)", + "-(sin(a x) + log(cos(a x / 2) - sin(a x / 2)) - log(sin(a x / 2) + cos(a x / 2))) / a", + "1", + + "sin(a x)^2 / cos(a x)^2", + "tan(a x) / a - x", + "1", + + "cos(a x) / sin(a x)", + "log(sin(a x)) / a", + "1", + + "cos(a x) / sin(a x)^2", + "-1 / (a sin(a x))", + "1", + + "cos(a x)^2 / sin(a x)^2", + "-x - cos(a x) / sin(a x) / a", + "1", + + "sin(a + b x)", + "-cos(a + b x) / b", + "1", + + "cos(a + b x)", + "sin(a + b x) / b", + "1", + + "x sin(a x)", + "sin(a x) / (a^2) - x cos(a x) / a", + "1", + + "x^2 sin(a x)", + "2 x sin(a x) / (a^2) - (a^2 x^2 - 2) cos(a x) / (a^3)", + "1", + + "x cos(a x)", + "cos(a x) / (a^2) + x sin(a x) / a", + "1", + + "x^2 cos(a x)", + "2 x cos(a x) / (a^2) + (a^2 x^2 - 2) sin(a x) / (a^3)", + "1", + + "1 / tan(a x)", + "log(sin(a x)) / a", + "1", + + "1 / cos(a x)", + "log(tan(pi 1/4 + a x 1/2)) / a", + "1", + + "1 / sin(a x)", + "log(tan(a x 1/2)) / a", + "1", + + "1 / sin(a x)^2", + "-1 / (a tan(a x))", + "1", + + "1 / cos(a x)^2", + "tan(a x) / a", + "1", + + "1 / (b + b sin(a x))", + "-tan(pi 1/4 - a x 1/2) / (a b)", + "1", + + "1 / (b - b sin(a x))", + "tan(pi 1/4 + a x 1/2) / (a b)", + "1", + + "1 / (b + b cos(a x))", + "tan(a x 1/2) / (a b)", + "1", + + "1 / (b - b cos(a x))", + "-1 / (tan(a x 1/2) a b)", + "1", + + "1 / (a + b sin(x))", + "log((a tan(x 1/2) + b - sqrt(b^2 - a^2)) / (a tan(x 1/2) + b + sqrt(b^2 - a^2))) / sqrt(b^2 - a^2)", + "b^2 - a^2", + + "1 / (a + b cos(x))", + "log((sqrt(b^2 - a^2) tan(x 1/2) + a + b) / (sqrt(b^2 - a^2) tan(x 1/2) - a - b)) / sqrt(b^2 - a^2)", + "b^2 - a^2", + + "x sin(a x) sin(b x)", + "1/2 ((x sin(x (a - b)))/(a - b) - (x sin(x (a + b)))/(a + b) + cos(x (a - b))/(a - b)^2 - cos(x (a + b))/(a + b)^2)", + "and(not(a + b == 0),not(a - b == 0))", + + "sin(a x)/(cos(a x) - 1)^2", + "1/a * 1/(cos(a x) - 1)", + "1", + + "sin(a x)/(1 - cos(a x))^2", + "1/a * 1/(cos(a x) - 1)", + "1", + + "cos(x)^3 sin(x)", + "-1/4 cos(x)^4", + "1", + + "cos(a x)^5", + "sin(a x)^5 / (5 a) - 2 sin(a x)^3 / (3 a) + sin(a x) / a", + "1", + + "cos(a x)^5 / sin(a x)^2", + "sin(a x)^3 / (3 a) - 2 sin(a x) / a - 1 / (a sin(a x))", + "1", + + "cos(a x)^3 / sin(a x)^2", + "-sin(a x) / a - 1 / (a sin(a x))", + "1", + + "cos(a x)^5 / sin(a x)", + "log(sin(a x)) / a + sin(a x)^4 / (4 a) - sin(a x)^2 / a", + "1", + + "cos(a x)^3 / sin(a x)", + "log(sin(a x)) / a - sin(a x)^2 / (2 a)", + "1", + + "cos(a x) sin(a x)^3", + "sin(a x)^4 / (4 a)", + "1", + + "cos(a x)^3 sin(a x)^2", + "-sin(a x)^5 / (5 a) + sin(a x)^3 / (3 a)", + "1", + + "cos(a x)^2 sin(a x)^3", + "cos(a x)^5 / (5 a) - cos(a x)^3 / (3 a)", + "1", + + "cos(a x)^4 sin(a x)", + "-cos(a x)^5 / (5 a)", + "1", + + "cos(a x)^7 / sin(a x)^2", + "-sin(a x)^5 / (5 a) + sin(a x)^3 / a - 3 sin(a x) / a - 1 / (a sin(a x))", + "1", + +// cos(a x)^n / sin(a x) + + "cos(a x)^2 / sin(a x)", + "cos(a x) / a + log(tan(1/2 a x)) / a", + "1", + + "cos(a x)^4 / sin(a x)", + "4 cos(a x) / (3 a) - cos(a x) sin(a x)^2 / (3 a) + log(tan(1/2 a x)) / a", + "1", + + "cos(a x)^6 / sin(a x)", + "cos(a x)^5 / (5 a) - 2 cos(a x)^3 / (3 a) + 2 cos(a x) / a - cos(a x) sin(a x)^2 / a + log(tan(1/2 a x)) / a", + "1", +}; + +char *integral_tab_power[] = { + + "a", // for forms c^d where both c and d are constant expressions + "a x", + "1", + + "1 / x", + "log(x)", + "1", + + "x^a", // integrand + "x^(a + 1) / (a + 1)", // answer + "not(a = -1)", // condition + + "a^x", + "a^x / log(a)", + "or(not(number(a)),a>0)", + + "1 / (a + b x)", + "log(a + b x) / b", + "1", +// 124 + "sqrt(a x + b)", + "2/3 (a x + b)^(3/2) / a", + "1", +// 138 + "sqrt(a x^2 + b)", + "1/2 x sqrt(a x^2 + b) + 1/2 b log(sqrt(a) sqrt(a x^2 + b) + a x) / sqrt(a)", + "1", +// 131 + "1 / sqrt(a x + b)", + "2 sqrt(a x + b) / a", + "1", + + "1 / ((a + b x)^2)", + "-1 / (b (a + b x))", + "1", + + "1 / ((a + b x)^3)", + "-1 / ((2 b) ((a + b x)^2))", + "1", +// 16 + "1 / (a x^2 + b)", + "arctan(sqrt(a) x / sqrt(b)) / sqrt(a) / sqrt(b)", + "1", +// 17 + "1 / sqrt(1 - x^2)", + "arcsin(x)", + "1", + + "sqrt(1 + x^2 / (1 - x^2))", + "arcsin(x)", + "1", + + "1 / sqrt(a x^2 + b)", + "log(sqrt(a) sqrt(a x^2 + b) + a x) / sqrt(a)", + "1", +// 65 + "1 / (a x^2 + b)^2", + "1/2 ((arctan((sqrt(a) x) / sqrt(b))) / (sqrt(a) b^(3/2)) + x / (a b x^2 + b^2))", + "1", +// 67 (m=2) + "1 / (a + b x^2)^3", + "x / (a + b x^2)^2 / (4 a) + 3 x / (8 a (a^2 + a b x^2)) + 3 arctan(b^(1/2) x / a^(1/2),1) / (8 a^(5/2) b^(1/2))", + "1", +// 67 (m=3) + "1 / (a + b x^2)^4", + "11 x / (16 a (a + b x^2)^3) + 5 b x^3 / (6 a^2 (a + b x^2)^3) + 5 b^2 x^5 / (16 a^3 (a + b x^2)^3) + 5 arctan(b^(1/2) x / a^(1/2),1) / (16 a^(7/2) b^(1/2))", + "1", +// 165 + "(a x^2 + b)^(-3/2)", + "x / b / sqrt(a x^2 + b)", + "1", +// 74 + "1 / (a x^3 + b)", + "-log(a^(2/3) x^2 - a^(1/3) b^(1/3) x + b^(2/3))/(6 a^(1/3) b^(2/3))" + " + log(a^(1/3) x + b^(1/3))/(3 a^(1/3) b^(2/3))" + " - (i log(1 - (i (1 - (2 a^(1/3) x)/b^(1/3)))/sqrt(3)))/(2 sqrt(3) a^(1/3) b^(2/3))" + " + (i log(1 + (i (1 - (2 a^(1/3) x)/b^(1/3)))/sqrt(3)))/(2 sqrt(3) a^(1/3) b^(2/3))", // from Wolfram Alpha + "1", +// 77 78 + "1 / (a x^4 + b)", + "-log(-sqrt(2) a^(1/4) b^(1/4) x + sqrt(a) x^2 + sqrt(b))/(4 sqrt(2) a^(1/4) b^(3/4))" + " + log(sqrt(2) a^(1/4) b^(1/4) x + sqrt(a) x^2 + sqrt(b))/(4 sqrt(2) a^(1/4) b^(3/4))" + " - (i log(1 - i (1 - (sqrt(2) a^(1/4) x)/b^(1/4))))/(4 sqrt(2) a^(1/4) b^(3/4))" + " + (i log(1 + i (1 - (sqrt(2) a^(1/4) x)/b^(1/4))))/(4 sqrt(2) a^(1/4) b^(3/4))" + " + (i log(1 - i ((sqrt(2) a^(1/4) x)/b^(1/4) + 1)))/(4 sqrt(2) a^(1/4) b^(3/4))" + " - (i log(1 + i ((sqrt(2) a^(1/4) x)/b^(1/4) + 1)))/(4 sqrt(2) a^(1/4) b^(3/4))", // from Wolfram Alpha + "1", +// + "1 / (a x^5 + b)", + "(sqrt(5) log(2 a^(2/5) x^2 + (sqrt(5) - 1) a^(1/5) b^(1/5) x + 2 b^(2/5))" + " - log(2 a^(2/5) x^2 + (sqrt(5) - 1) a^(1/5) b^(1/5) x + 2 b^(2/5))" + " - sqrt(5) log(2 a^(2/5) x^2 - (1 + sqrt(5)) a^(1/5) b^(1/5) x + 2 b^(2/5))" + " - log(2 a^(2/5) x^2 - (1 + sqrt(5)) a^(1/5) b^(1/5) x + 2 b^(2/5))" + " + 4 log(a^(1/5) x + b^(1/5))" + " + 2 sqrt(2 (5 + sqrt(5))) arctan((4 a^(1/5) x + (sqrt(5) - 1) b^(1/5))/(sqrt(2 (5 + sqrt(5))) b^(1/5)))" + " + 2 sqrt(10 - 2 sqrt(5)) arctan((4 a^(1/5) x - (1 + sqrt(5)) b^(1/5))/(sqrt(10 - 2 sqrt(5)) b^(1/5))))/(20 a^(1/5) b^(4/5))", // from Wolfram Alpha + "1", +// 164 + "sqrt(a + x^6 + 3 a^(1/3) x^4 + 3 a^(2/3) x^2)", + "1/4 (x sqrt((x^2 + a^(1/3))^3) + 3/2 a^(1/3) x sqrt(x^2 + a^(1/3)) + 3/2 a^(2/3) log(x + sqrt(x^2 + a^(1/3))))", + "1", +// 165 + "sqrt(-a + x^6 - 3 a^(1/3) x^4 + 3 a^(2/3) x^2)", + "1/4 (x sqrt((x^2 - a^(1/3))^3) - 3/2 a^(1/3) x sqrt(x^2 - a^(1/3)) + 3/2 a^(2/3) log(x + sqrt(x^2 - a^(1/3))))", + "1", + + "sinh(x)^2", + "sinh(2 x) 1/4 - x 1/2", + "1", + + "tanh(x)^2", + "x - tanh(x)", + "1", + + "cosh(x)^2", + "sinh(2 x) 1/4 + x 1/2", + "1", +}; + +char *integral_tab[] = { + + "a", + "a x", + "1", + + "x", + "1/2 x^2", + "1", +// 18 + "x / sqrt(a x^2 + b)", + "sqrt(a x^2 + b) / a", + "1", + + "x / (a + b x)", + "x / b - a log(a + b x) / (b b)", + "1", + + "x / ((a + b x)^2)", + "(log(a + b x) + a / (a + b x)) / (b^2)", + "1", +// 33 + "x^2 / (a + b x)", + "a^2 log(a + b x) / b^3 + x (b x - 2 a) / (2 b^2)", + "1", +// 34 + "x^2 / (a + b x)^2", + "(-a^2 / (a + b x) - 2 a log(a + b x) + b x) / b^3", + "1", + + "x^2 / (a + b x)^3", + "(log(a + b x) + 2 a / (a + b x) - a^2 / (2 ((a + b x)^2))) / (b^3)", + "1", + + "1 / x / (a + b x)", + "-log((a + b x) / x) / a", + "1", + + "1 / x / (a + b x)^2", + "1 / (a (a + b x)) - log((a + b x) / x) / (a^2)", + "1", + + "1 / x / (a + b x)^3", + "(1/2 ((2 a + b x) / (a + b x))^2 + log(x / (a + b x))) / (a^3)", + "1", + + "1 / x^2 / (a + b x)", + "-1 / (a x) + b log((a + b x) / x) / (a^2)", + "1", + + "1 / x^3 / (a + b x)", + "(2 b x - a) / (2 a^2 x^2) + b^2 log(x / (a + b x)) / (a^3)", + "1", + + "1 / x^2 / (a + b x)^2", + "-(a + 2 b x) / (a^2 x (a + b x)) + 2 b log((a + b x) / x) / (a^3)", + "1", + + "x / (a + b x^2)", + "log(a + b x^2) / (2 b)", + "1", +// 64 + "x^2 / (a x^2 + b)", + "1/2 i a^(-3/2) sqrt(b) (log(1 + i sqrt(a) x / sqrt(b)) - log(1 - i sqrt(a) x / sqrt(b))) + x / a", + "1", +// 68 (m=1) + "x / (a + b x^2)^2", + "-1 / (2 b (a + b x^2))", + "1", +// 68 (m=2) + "x / (a + b x^2)^3", + "-1 / (4 b (a + b x^2)^2)", + "1", +// 68 (m=3) + "x / (a + b x^2)^4", + "-1 / (6 b (a + b x^2)^3)", + "1", +// 69 (m=1) + "x^2 / (a + b x^2)^2", + "-x / (2 b (a + b x^2)) + arctan(sqrt(b/a) x) / (2 sqrt(a b^3))", + "1", +// 69 (m=2) + "x^2 / (a + b x^2)^3", + "x^3 / (8 a (a + b x^2)^2) + arctan(b^(1/2) x / a^(1/2),1) / (8 a^(3/2) b^(3/2)) - x / (8 b (a + b x^2)^2)", + "1", +// 69 (m=3) + "x^2 / (a + b x^2)^4", + "x^3 / (6 a (a + b x^2)^3) + b x^5 / (16 a^2 (a + b x^2)^3) + arctan(b^(1/2) x / a^(1/2),1) / (16 a^(5/2) b^(3/2)) - x / (16 b (a + b x^2)^3)", + "1", +// 70 + "1 / x * 1 / (a + b x^2)", + "1 log(x^2 / (a + b x^2)) / (2 a)", + "1", +// 71 + "1 / x^2 * 1 / (a x^2 + b)", + "1/2 i sqrt(a) b^(-3/2) (log(1 + i sqrt(a) x / sqrt(b)) - log(1 - i sqrt(a) x / sqrt(b))) - 1 / (b x)", + "1", +// 75 + "x / (a x^3 + b)", + "log(a^(2/3) x^2 - a^(1/3) b^(1/3) x + b^(2/3))/(6 a^(2/3) b^(1/3))" + " - log(a^(1/3) x + b^(1/3))/(3 a^(2/3) b^(1/3))" + " - (i log(1 - (i (1 - (2 a^(1/3) x)/b^(1/3)))/sqrt(3)))/(2 sqrt(3) a^(2/3) b^(1/3))" + " + (i log(1 + (i (1 - (2 a^(1/3) x)/b^(1/3)))/sqrt(3)))/(2 sqrt(3) a^(2/3) b^(1/3))", // from Wolfram Alpha + "1", +// 76 + "x^2 / (a + b x^3)", + "1 log(a + b x^3) / (3 b)", + "1", +// 79 80 + "x / (a x^4 + b)", + "(i log(1 - (i sqrt(a) x^2)/sqrt(b)))/(4 sqrt(a) sqrt(b))" + " - (i log(1 + (i sqrt(a) x^2)/sqrt(b)))/(4 sqrt(a) sqrt(b))", // from Wolfram Alpha + "1", +// 81 82 + "x^2 / (a x^4 + b)", + "log(-sqrt(2) a^(1/4) b^(1/4) x + sqrt(a) x^2 + sqrt(b))/(4 sqrt(2) a^(3/4) b^(1/4))" + " - log(sqrt(2) a^(1/4) b^(1/4) x + sqrt(a) x^2 + sqrt(b))/(4 sqrt(2) a^(3/4) b^(1/4))" + " - (i log(1 - i (1 - (sqrt(2) a^(1/4) x)/b^(1/4))))/(4 sqrt(2) a^(3/4) b^(1/4))" + " + (i log(1 + i (1 - (sqrt(2) a^(1/4) x)/b^(1/4))))/(4 sqrt(2) a^(3/4) b^(1/4))" + " + (i log(1 - i ((sqrt(2) a^(1/4) x)/b^(1/4) + 1)))/(4 sqrt(2) a^(3/4) b^(1/4))" + " - (i log(1 + i ((sqrt(2) a^(1/4) x)/b^(1/4) + 1)))/(4 sqrt(2) a^(3/4) b^(1/4))", // from Wolfram Alpha + "1", +// + "x^3 / (a + b x^4)", + "1 log(a + b x^4) / (4 b)", + "1", + + "x sqrt(a + b x)", + "-2 (2 a - 3 b x) sqrt((a + b x)^3) 1/15 / (b^2)", + "1", + + "x^2 sqrt(a + b x)", + "2 (8 a^2 - 12 a b x + 15 b^2 x^2) sqrt((a + b x)^3) 1/105 / (b^3)", + "1", + + "x^2 sqrt(a + b x^2)", + "(sqrt(b) x sqrt(a + b x^2) (a + 2 b x^2) - a^2 log(sqrt(b) sqrt(a + b x^2) + b x)) / (8 b^(3/2))", + "1", +// 128 + "sqrt(a x + b) / x", + "2 sqrt(a x + b) - 2 sqrt(b) arctanh(sqrt(a x + b) / sqrt(b))", + "1", +// 129 + "sqrt(a x + b) / x^2", + "-sqrt(a x + b) / x - a arctanh(sqrt(a x + b) / sqrt(b)) / sqrt(b)", + "1", + + "x / sqrt(a + b x)", + "-2 (2 a - b x) sqrt(a + b x) / (3 (b^2))", + "1", + + "x^2 / sqrt(a + b x)", + "2 (8 a^2 - 4 a b x + 3 b^2 x^2) sqrt(a + b x) / (15 (b^3))", + "1", +// 134 + "1 / x / sqrt(a x + b)", + "-2 arctanh(sqrt(a x + b) / sqrt(b)) / sqrt(b)", + "1", +// 137 + "1 / x^2 / sqrt(a x + b)", + "a arctanh(sqrt(a x + b) / sqrt(b)) / b^(3/2) - sqrt(a x + b) / (b x)", + "1", +// 158 + "1 / x / sqrt(a x^2 + b)", + "(log(x) - log(sqrt(b) sqrt(a x^2 + b) + b)) / sqrt(b)", + "1", +// 160 + "sqrt(a x^2 + b) / x", + "sqrt(a x^2 + b) - sqrt(b) log(sqrt(b) sqrt(a x^2 + b) + b) + sqrt(b) log(x)", + "1", +// 163 + "x sqrt(a x^2 + b)", + "1/3 (a x^2 + b)^(3/2) / a", + "1", +// 166 + "x (a x^2 + b)^(-3/2)", + "-1 / a / sqrt(a x^2 + b)", + "1", + + "x sqrt(a + x^6 + 3 a^(1/3) x^4 + 3 a^(2/3) x^2)", + "1/5 sqrt((x^2 + a^(1/3))^5)", + "1", +// 168 + "x^2 sqrt(a x^2 + b)", + "1/8 a^(-3/2) (sqrt(a) x sqrt(a x^2 + b) (2 a x^2 + b) - b^2 log(sqrt(a) sqrt(a x^2 + b) + a x))", + "and(number(a),a>0)", +// 169 + "x^3 sqrt(a x^2 + b)", + "1/15 sqrt(a x^2 + b) (3 a^2 x^4 + a b x^2 - 2 b^2) / a^2", + "1", +// 171 + "x^2 / sqrt(a x^2 + b)", + "1/2 a^(-3/2) (sqrt(a) x sqrt(a x^2 + b) - b log(sqrt(a) sqrt(a x^2 + b) + a x))", + "1", +// 172 + "x^3 / sqrt(a x^2 + b)", + "1/3 (a x^2 - 2 b) sqrt(a x^2 + b) / a^2", + "1", +// 173 + "1 / x^2 / sqrt(a x^2 + b)", + "-sqrt(a x^2 + b) / (b x)", + "1", +// 174 + "1 / x^3 / sqrt(a x^2 + b)", + "-sqrt(a x^2 + b) / (2 b x^2) + a (log(sqrt(b) sqrt(a x^2 + b) + b) - log(x)) / (2 b^(3/2))", + "1", +// 216 + "sqrt(a x^2 + b) / x^2", + "sqrt(a) log(sqrt(a) sqrt(a x^2 + b) + a x) - sqrt(a x^2 + b) / x", + "and(number(a),a>0)", +// 217 + "sqrt(a x^2 + b) / x^3", + "1/2 (-sqrt(a x^2 + b) / x^2 - (a log(sqrt(b) sqrt(a x^2 + b) + b)) / sqrt(b) + (a log(x)) / sqrt(b))", + "and(number(b),b>0)", + + "arcsin(a x)", + "x arcsin(a x) + sqrt(1 - a^2 x^2) / a", + "1", + + "arccos(a x)", + "x arccos(a x) + sqrt(1 - a^2 x^2) / a", + "1", + + "arctan(a x)", + "x arctan(a x) - log(1 + a^2 x^2) / (2 a)", + "1", + + "sinh(x)", + "cosh(x)", + "1", + + "cosh(x)", + "sinh(x)", + "1", + + "tanh(x)", + "log(cosh(x))", + "1", + + "x sinh(x)", + "x cosh(x) - sinh(x)", + "1", + + "x cosh(x)", + "x sinh(x) - cosh(x)", + "1", + + "erf(a x)", + "x erf(a x) + exp(-a^2 x^2) / (a sqrt(pi))", + "1", + + "x^2 (1 - x^2)^(3/2)", + "(x sqrt(1 - x^2) (-8 x^4 + 14 x^2 - 3) + 3 arcsin(x)) 1/48", + "1", + + "x^2 (1 - x^2)^(5/2)", + "(x sqrt(1 - x^2) (48 x^6 - 136 x^4 + 118 x^2 - 15) + 15 arcsin(x)) 1/384", + "1", + + "x^4 (1 - x^2)^(3/2)", + "(-x sqrt(1 - x^2) (16 x^6 - 24 x^4 + 2 x^2 + 3) + 3 arcsin(x)) 1/128", + "1", +}; + +void +eval_integral(struct atom *p1) +{ + int flag, i, n; + struct atom *X, *Y = NULL; // silence compiler + + push(cadr(p1)); + evalf(); + + p1 = cddr(p1); + + if (!iscons(p1)) { + push_symbol(X_LOWER); + integral(); + return; + } + + flag = 0; + + while (iscons(p1) || flag) { + + if (flag) { + X = Y; + flag = 0; + } else { + push(car(p1)); + evalf(); + X = pop(); + p1 = cdr(p1); + } + + if (isnum(X)) { + push(X); + n = pop_integer(); + push_symbol(X_LOWER); + X = pop(); + for (i = 0; i < n; i++) { + push(X); + integral(); + } + continue; + } + + if (!isusersymbol(X)) + stopf("integral"); + + if (iscons(p1)) { + + push(car(p1)); + evalf(); + Y = pop(); + p1 = cdr(p1); + + if (isnum(Y)) { + push(Y); + n = pop_integer(); + for (i = 0; i < n; i++) { + push(X); + integral(); + } + continue; + } + + flag = 1; + } + + push(X); + integral(); + } +} + +void +integral(void) +{ + int h; + struct atom *p1, *F, *X; + + X = pop(); + F = pop(); + + if (!isusersymbol(X)) + stopf("integral: symbol expected"); + + if (car(F) == symbol(ADD)) { + h = tos; + p1 = cdr(F); + while (iscons(p1)) { + push(car(p1)); + push(X); + integral(); + p1 = cdr(p1); + } + add_terms(tos - h); + return; + } + + if (car(F) == symbol(MULTIPLY)) { + push(F); + push(X); + partition_term(); // push const part then push var part + F = pop(); // pop var part + integral_solve(F, X); + multiply(); // multiply by const part + return; + } + + integral_solve(F, X); +} + +void +integral_solve(struct atom *F, struct atom *X) +{ + struct atom *p; + + if (car(F) == symbol(INTEGRAL)) { + integral_of_integral(F, X); + return; + } + + if (car(F) == symbol(DERIVATIVE)) { + integral_of_derivative(F, X); + return; + } + + save_symbol(symbol(SA)); + save_symbol(symbol(SB)); + save_symbol(symbol(SX)); + + integral_solve_nib(F, X); + + p = pop(); + restore_symbol(); + restore_symbol(); + restore_symbol(); + push(p); +} + +void +integral_solve_nib(struct atom *F, struct atom *X) +{ + int h, t; + + set_symbol(symbol(SX), X, symbol(NIL)); + + h = tos; + + push_integer(1); // 1 is a candidate for a and b + + push(F); + push(X); + decomp(); // push possible substitutions for a and b + + t = integral_classify(F); + + if ((t & 1) && integral_search(h, F, integral_tab_exp, sizeof integral_tab_exp / sizeof (char *))) + return; + + if ((t & 2) && integral_search(h, F, integral_tab_log, sizeof integral_tab_log / sizeof (char *))) + return; + + if ((t & 4) && integral_search(h, F, integral_tab_trig, sizeof integral_tab_trig / sizeof (char *))) + return; + + if (car(F) == symbol(POWER)) { + if (integral_search(h, F, integral_tab_power, sizeof integral_tab_power / sizeof (char *))) + return; + } else { + if (integral_search(h, F, integral_tab, sizeof integral_tab / sizeof (char *))) + return; + } + + tos = h; // pop all + + push_symbol(INTEGRAL); + push(F); + push(X); + list(3); +} + +int +integral_classify(struct atom *p) +{ + int t = 0; + + if (iscons(p)) { + while (iscons(p)) { + t |= integral_classify(car(p)); + p = cdr(p); + } + return t; + } + + if (p == symbol(EXP1)) + return 1; + + if (p == symbol(LOG)) + return 2; + + if (p == symbol(SIN) || p == symbol(COS) || p == symbol(TAN)) + return 4; + + return 0; +} + +int +integral_search(int h, struct atom *F, char **table, int n) +{ + int i; + struct atom *C, *I; + + for (i = 0; i < n; i += 3) { + + scan1(table[i + 0]); // integrand + I = pop(); + + scan1(table[i + 2]); // condition + C = pop(); + + if (integral_search_nib(h, F, I, C)) + break; + } + + if (i >= n) + return 0; + + tos = h; // pop all + + scan1(table[i + 1]); // answer + evalf(); + + return 1; +} + +int +integral_search_nib(int h, struct atom *F, struct atom *I, struct atom *C) +{ + int i, j; + struct atom *p1; + + for (i = h; i < tos; i++) { + + set_symbol(symbol(SA), stack[i], symbol(NIL)); + + for (j = h; j < tos; j++) { + + set_symbol(symbol(SB), stack[j], symbol(NIL)); + + push(C); // condition ok? + evalf(); + p1 = pop(); + if (iszero(p1)) + continue; // no, go to next j + + push(F); // F = I? + push(I); + evalf(); + subtract(); + p1 = pop(); + if (iszero(p1)) + return 1; // yes + } + } + + return 0; // no +} + +// push const coeffs + +void +decomp(void) +{ + struct atom *p1, *F, *X; + + X = pop(); + F = pop(); + + // is the entire expression constant? + + if (!dependent(F, X)) { + push(F); + return; + } + + // sum? + + if (car(F) == symbol(ADD)) { + decomp_sum(F, X); + return; + } + + // product? + + if (car(F) == symbol(MULTIPLY)) { + decomp_product(F, X); + return; + } + + // naive decomp + + p1 = cdr(F); + while (iscons(p1)) { + push(car(p1)); + push(X); + decomp(); + p1 = cdr(p1); + } +} + +void +decomp_sum(struct atom *F, struct atom *X) +{ + int h, i, j, k, n; + struct atom *p1, *p2; + + h = tos; + + // partition terms + + p1 = cdr(F); + + while (iscons(p1)) { + p2 = car(p1); + if (dependent(p2, X)) { + if (car(p2) == symbol(MULTIPLY)) { + push(p2); + push(X); + partition_term(); // push const part then push var part + } else { + push_integer(1); // const part + push(p2); // var part + } + } + p1 = cdr(p1); + } + + // combine const parts of matching var parts + + n = tos - h; + + for (i = 0; i < n - 2; i += 2) + for (j = i + 2; j < n; j += 2) { + if (!equal(stack[h + i + 1], stack[h + j + 1])) + continue; + push(stack[h + i]); // add const parts + push(stack[h + j]); + add(); + stack[h + i] = pop(); + for (k = j; k < n - 2; k++) + stack[h + k] = stack[h + k + 2]; + j -= 2; // use same j again + n -= 2; + tos -= 2; // pop + } + + // push const parts, decomp var parts + + list(tos - h); + p1 = pop(); + + while (iscons(p1)) { + push(car(p1)); // const part + push(cadr(p1)); // var part + push(X); + decomp(); + p1 = cddr(p1); + } + + // add together all constant terms + + h = tos; + p1 = cdr(F); + while (iscons(p1)) { + if (!dependent(car(p1), X)) + push(car(p1)); + p1 = cdr(p1); + } + + n = tos - h; + + if (n > 1) { + list(n); + push_symbol(ADD); + swap(); + cons(); // makes ADD head of list + } +} + +void +decomp_product(struct atom *F, struct atom *X) +{ + int h, n; + struct atom *p1; + + // decomp factors involving x + + p1 = cdr(F); + while (iscons(p1)) { + if (dependent(car(p1), X)) { + push(car(p1)); + push(X); + decomp(); + } + p1 = cdr(p1); + } + + // combine constant factors + + h = tos; + p1 = cdr(F); + while (iscons(p1)) { + if (!dependent(car(p1), X)) + push(car(p1)); + p1 = cdr(p1); + } + + n = tos - h; + + if (n > 1) { + list(n); + push_symbol(MULTIPLY); + swap(); + cons(); // makes MULTIPLY head of list + } +} + +void +partition_term(void) +{ + int h, n; + struct atom *p1, *F, *X; + + X = pop(); + F = pop(); + + // push const factors + + h = tos; + p1 = cdr(F); + while (iscons(p1)) { + if (!dependent(car(p1), X)) + push(car(p1)); + p1 = cdr(p1); + } + + n = tos - h; + + if (n == 0) + push_integer(1); + else if (n > 1) { + list(n); + push_symbol(MULTIPLY); + swap(); + cons(); // makes MULTIPLY head of list + } + + // push var factors + + h = tos; + p1 = cdr(F); + while (iscons(p1)) { + if (dependent(car(p1), X)) + push(car(p1)); + p1 = cdr(p1); + } + + n = tos - h; + + if (n == 0) + push_integer(1); + else if (n > 1) { + list(n); + push_symbol(MULTIPLY); + swap(); + cons(); // makes MULTIPLY head of list + } +} + +void +integral_of_integral(struct atom *F, struct atom *X) +{ + struct atom *G, *Y; + + G = cadr(F); + Y = caddr(F); + + // if X == Y then F is not integrable for X + + if (equal(X, Y)) { + push_symbol(INTEGRAL); + push(F); + push(X); + list(3); + return; + } + + push(G); + push(X); + integral(); + + G = pop(); + + if (car(G) == symbol(INTEGRAL)) { + + // sort integrals by measure + + F = cadr(G); + X = caddr(G); + + push_symbol(INTEGRAL); + push_symbol(INTEGRAL); + push(F); + + if (lessp(X, Y)) { + push(X); + list(3); + push(Y); + list(3); + } else { + push(Y); + list(3); + push(X); + list(3); + } + + return; + } + + push(G); + push(Y); + integral(); +} + +void +integral_of_derivative(struct atom *F, struct atom *X) +{ + struct atom *G, *Y; + + G = cadr(F); + Y = caddr(F); + + if (equal(X, Y)) { + push(G); // integral and derivative cancel + return; + } + + push(G); + push(X); + integral(); + + G = pop(); + + // integral before derivative + + if (car(G) == symbol(INTEGRAL)) { + F = cadr(G); + X = caddr(G); + push_symbol(INTEGRAL); + push_symbol(DERIVATIVE); + push(F); + push(Y); + list(3); + push(X); + list(3); + return; + } + + push(G); + push(Y); + derivative(); +} +void +eval_inv(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + inv(); +} + +void +inv(void) +{ + struct atom *p1; + + p1 = pop(); + + if (!istensor(p1)) { + push(p1); + reciprocate(); + return; + } + + if (!issquarematrix(p1)) + stopf("inv: square matrix expected"); + + push(p1); + adj(); + + push(p1); + det(); + + divide(); +} +void +eval_kronecker(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + p1 = cddr(p1); + while (iscons(p1)) { + push(car(p1)); + evalf(); + kronecker(); + p1 = cdr(p1); + } +} + +void +kronecker(void) +{ + int h, i, j, k, l, m, n, p, q; + struct atom *p1, *p2, *p3; + + p2 = pop(); + p1 = pop(); + + if (!istensor(p1) || !istensor(p2)) { + push(p1); + push(p2); + multiply(); + return; + } + + if (p1->u.tensor->ndim > 2 || p2->u.tensor->ndim > 2) + stopf("kronecker"); + + m = p1->u.tensor->dim[0]; + n = p1->u.tensor->ndim == 1 ? 1 : p1->u.tensor->dim[1]; + + p = p2->u.tensor->dim[0]; + q = p2->u.tensor->ndim == 1 ? 1 : p2->u.tensor->dim[1]; + + p3 = alloc_tensor(m * n * p * q); + + // result matrix has (m * p) rows and (n * q) columns + + h = 0; + + for (i = 0; i < m; i++) + for (j = 0; j < p; j++) + for (k = 0; k < n; k++) + for (l = 0; l < q; l++) { + push(p1->u.tensor->elem[n * i + k]); + push(p2->u.tensor->elem[q * j + l]); + multiply(); + p3->u.tensor->elem[h++] = pop(); + } + + // dim info + + p3->u.tensor->ndim = n * q == 1 ? 1 : 2; + + p3->u.tensor->dim[0] = m * p; + + if (n * q > 1) + p3->u.tensor->dim[1] = n * q; + + push(p3); +} +void +eval_lgamma(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + lgammafunc(); +} + +void +lgammafunc(void) +{ + int i, n; + double d; + struct atom *p1, *p2; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + lgammafunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + floatfunc(); + p2 = pop(); + + if (isnum(p2)) { + push(p2); + d = pop_double(); + d = lgamma(d); + push_double(d); + return; + } + + push_symbol(LGAMMA); + push(p1); + list(2); +} +void +eval_log(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + logfunc(); +} + +void +logfunc(void) +{ + int h, i, n; + double d; + struct atom *p1, *p2; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + logfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (hasdouble(p1)) { + push(p1); + floatfunc(); + p1 = pop(); + } + + if (iszero(p1)) { + push_symbol(LOG); + push_integer(0); + list(2); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + if (d > 0.0) { + push_double(log(d)); + return; + } + } + + // log(z) -> log(mag(z)) + i arg(z) + + if (isdouble(p1) || isdoublez(p1)) { + push(p1); + magfunc(); + logfunc(); + push(p1); + argfunc(); + push(imaginaryunit); + multiply(); + add(); + return; + } + + // log(1) -> 0 + + if (isplusone(p1)) { + push_integer(0); + return; + } + + // log(e) -> 1 + + if (p1 == symbol(EXP1)) { + push_integer(1); + return; + } + + if (isnegativenumber(p1)) { + push(p1); + negate(); + logfunc(); + push(imaginaryunit); + push_symbol(PI); + multiply(); + add(); + return; + } + + // log(10) -> log(2) + log(5) + + if (isrational(p1)) { + h = tos; + push(p1); + factor_factor(); + for (i = h; i < tos; i++) { + p2 = stack[i]; + if (car(p2) == symbol(POWER)) { + push(caddr(p2)); // exponent + push_symbol(LOG); + push(cadr(p2)); // base + list(2); + multiply(); + } else { + push_symbol(LOG); + push(p2); + list(2); + } + stack[i] = pop(); + } + add_terms(tos - h); + return; + } + + // log(a ^ b) -> b log(a) + + if (car(p1) == symbol(POWER)) { + push(caddr(p1)); + push(cadr(p1)); + logfunc(); + multiply(); + return; + } + + // log(a * b) -> log(a) + log(b) + + if (car(p1) == symbol(MULTIPLY)) { + h = tos; + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + logfunc(); + p1 = cdr(p1); + } + add_terms(tos - h); + return; + } + + push_symbol(LOG); + push(p1); + list(2); +} +void +eval_loop(struct atom *p1) +{ + int t; + struct atom *p2; + t = breakflag; + breakflag = 0; + if (lengthf(p1) < 2) { + push_symbol(NIL); + return; + } + for (;;) { + p2 = cdr(p1); + while (iscons(p2)) { + push(car(p2)); + evalg(); + pop(); + p2 = cdr(p2); + if (breakflag || errorflag) { + breakflag = t; + push_symbol(NIL); + return; + } + } + } +} +void +eval_mag(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + magfunc(); +} + +void +magfunc(void) +{ + int i, n; + struct atom *p1, *num, *den; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + magfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + // use numden to handle (a + i b) / (c + i d) + + push(p1); + numden(); + num = pop(); + den = pop(); + push(num); + magfunc_nib(); + push(den); + magfunc_nib(); + divide(); +} + +void +magfunc_nib(void) +{ + int h; + struct atom *p1, *x, *y; + + p1 = pop(); + + if (isnum(p1)) { + push(p1); + absfunc(); + return; + } + + // -1 to a power + + if (car(p1) == symbol(POWER) && isminusone(cadr(p1))) { + push_integer(1); + return; + } + + // exponential + + if (car(p1) == symbol(POWER) && cadr(p1) == symbol(EXP1)) { + push(caddr(p1)); + real(); + expfunc(); + return; + } + + // product + + if (car(p1) == symbol(MULTIPLY)) { + p1 = cdr(p1); + h = tos; + while (iscons(p1)) { + push(car(p1)); + magfunc_nib(); + p1 = cdr(p1); + } + multiply_factors(tos - h); + return; + } + + // sum + + if (car(p1) == symbol(ADD)) { + push(p1); + rect(); // convert polar terms, if any + p1 = pop(); + push(p1); + real(); + x = pop(); + push(p1); + imag(); + y = pop(); + if (iszero(y)) { + push(x); + return; + } + if (iszero(x)) { + push(y); + return; + } + push(x); + push(x); + multiply(); + push(y); + push(y); + multiply(); + add(); + sqrtfunc(); + return; + } + + // real + + push(p1); +} +void +eval_minor(struct atom *p1) +{ + int i, j; + struct atom *p2; + + push(cadr(p1)); + evalf(); + p2 = pop(); + + push(caddr(p1)); + evalf(); + i = pop_integer(); + + push(cadddr(p1)); + evalf(); + j = pop_integer(); + + if (!istensor(p2) || p2->u.tensor->ndim != 2 || p2->u.tensor->dim[0] != p2->u.tensor->dim[1]) + stopf("minor"); + + if (i < 1 || i > p2->u.tensor->dim[0] || j < 0 || j > p2->u.tensor->dim[1]) + stopf("minor"); + + push(p2); + + minormatrix(i, j); + + det(); +} +void +eval_minormatrix(struct atom *p1) +{ + int i, j; + struct atom *p2; + + push(cadr(p1)); + evalf(); + p2 = pop(); + + push(caddr(p1)); + evalf(); + i = pop_integer(); + + push(cadddr(p1)); + evalf(); + j = pop_integer(); + + if (!istensor(p2) || p2->u.tensor->ndim != 2) + stopf("minormatrix: matrix expected"); + + if (i < 1 || i > p2->u.tensor->dim[0] || j < 0 || j > p2->u.tensor->dim[1]) + stopf("minormatrix: index err"); + + push(p2); + + minormatrix(i, j); +} + +void +minormatrix(int row, int col) +{ + int i, j, k, m, n; + struct atom *p1, *p2; + + p2 = symbol(NIL); // silence compiler + + p1 = pop(); + + n = p1->u.tensor->dim[0]; + m = p1->u.tensor->dim[1]; + + if (n == 2 && m == 2) { + if (row == 1) { + if (col == 1) + push(p1->u.tensor->elem[3]); + else + push(p1->u.tensor->elem[2]); + } else { + if (col == 1) + push(p1->u.tensor->elem[1]); + else + push(p1->u.tensor->elem[0]); + } + return; + } + + if (n == 2) + p2 = alloc_vector(m - 1); + + if (m == 2) + p2 = alloc_vector(n - 1); + + if (n > 2 && m > 2) + p2 = alloc_matrix(n - 1, m - 1); + + row--; + col--; + + k = 0; + + for (i = 0; i < n; i++) { + + if (i == row) + continue; + + for (j = 0; j < m; j++) { + + if (j == col) + continue; + + p2->u.tensor->elem[k++] = p1->u.tensor->elem[m * i + j]; + } + } + + push(p2); +} +void +eval_mod(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + push(caddr(p1)); + evalf(); + modfunc(); +} + +void +modfunc(void) +{ + int i, n; + double d1, d2; + struct atom *p1, *p2; + + p2 = pop(); + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + push(p2); + modfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (!isnum(p1) || !isnum(p2) || iszero(p2)) { + push_symbol(MOD); + push(p1); + push(p2); + list(3); + return; + } + + if (isrational(p1) && isrational(p2)) { + mod_rationals(p1, p2); + return; + } + + push(p1); + d1 = pop_double(); + + push(p2); + d2 = pop_double(); + + push_double(fmod(d1, d2)); +} + +void +mod_rationals(struct atom *p1, struct atom *p2) +{ + if (isinteger(p1) && isinteger(p2)) { + mod_integers(p1, p2); + return; + } + push(p1); + push(p1); + push(p2); + divide(); + absfunc(); + floorfunc(); + push(p2); + multiply(); + if (p1->sign == p2->sign) + negate(); + add(); +} + +void +mod_integers(struct atom *p1, struct atom *p2) +{ + uint32_t *a, *b; + a = mmod(p1->u.q.a, p2->u.q.a); + b = mint(1); + push_bignum(p1->sign, a, b); +} +void +eval_multiply(struct atom *p1) +{ + int h = tos; + expanding--; // undo expanding++ in evalf + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + evalg(); + p1 = cdr(p1); + } + multiply_factors(tos - h); + expanding++; +} + +void +multiply(void) +{ + multiply_factors(2); +} + +void +multiply_factors(int n) +{ + int h; + struct atom *T; + + if (n < 2) + return; + + h = tos - n; + + flatten_factors(h); + + T = multiply_tensor_factors(h); + + multiply_scalar_factors(h); + + if (istensor(T)) { + push(T); + inner(); + } +} + +void +flatten_factors(int h) +{ + int i, n; + struct atom *p1; + n = tos; + for (i = h; i < n; i++) { + p1 = stack[i]; + if (car(p1) == symbol(MULTIPLY)) { + stack[i] = cadr(p1); + p1 = cddr(p1); + while (iscons(p1)) { + push(car(p1)); + p1 = cdr(p1); + } + } + } +} + +struct atom * +multiply_tensor_factors(int h) +{ + int i; + struct atom *p1, *T; + T = symbol(NIL); + for (i = h; i < tos; i++) { + p1 = stack[i]; + if (!istensor(p1)) + continue; + if (istensor(T)) { + push(T); + push(p1); + hadamard(); + T = pop(); + } else + T = p1; + slice(i, 1); // remove factor + i--; // use same index again + } + return T; +} + +void +multiply_scalar_factors(int h) +{ + int n; + struct atom *COEF; + + COEF = combine_numerical_factors(h, one); + + if (iszero(COEF) || h == tos) { + tos = h; // pop all + push(COEF); + return; + } + + combine_factors(h); + normalize_power_factors(h); + + // do again in case exp(1/2 i pi) changed to i + + combine_factors(h); + normalize_power_factors(h); + + COEF = combine_numerical_factors(h, COEF); + + if (iszero(COEF) || h == tos) { + tos = h; // pop all + push(COEF); + return; + } + + COEF = reduce_radical_factors(h, COEF); + + if (isdouble(COEF) || !isplusone(COEF)) + push(COEF); + + if (expanding) + expand_sum_factors(h); // success leaves one expr on stack + + n = tos - h; + + switch (n) { + case 0: + push_integer(1); // all factors canceled + break; + case 1: + break; + default: + sort_factors(n); // previously sorted provisionally + list(n); + push_symbol(MULTIPLY); + swap(); + cons(); // prepend MULTIPLY to list + break; + } +} + +struct atom * +combine_numerical_factors(int h, struct atom *COEF) +{ + int i; + struct atom *p1; + for (i = h; i < tos; i++) { + p1 = stack[i]; + if (isnum(p1)) { + multiply_numbers(COEF, p1); + COEF = pop(); + slice(i, 1); // remove factor + i--; // use same index again + } + } + return COEF; +} + +// factors that have the same base are combined by adding exponents + +void +combine_factors(int h) +{ + int i; + sort_factors_provisional(h); + for (i = h; i < tos - 1; i++) { + if (combine_factors_nib(i, i + 1)) { + slice(i + 1, 1); // remove factor + i--; // use same index again + } + } +} + +int +combine_factors_nib(int i, int j) +{ + struct atom *p1, *p2, *BASE1, *EXPO1, *BASE2, *EXPO2; + + p1 = stack[i]; + p2 = stack[j]; + + if (car(p1) == symbol(POWER)) { + BASE1 = cadr(p1); + EXPO1 = caddr(p1); + } else { + BASE1 = p1; + EXPO1 = one; + } + + if (car(p2) == symbol(POWER)) { + BASE2 = cadr(p2); + EXPO2 = caddr(p2); + } else { + BASE2 = p2; + EXPO2 = one; + } + + if (!equal(BASE1, BASE2)) + return 0; + + if (isdouble(BASE2)) + BASE1 = BASE2; // if mixed rational and double, use double + + push_symbol(POWER); + push(BASE1); + push(EXPO1); + push(EXPO2); + add(); + list(3); + + stack[i] = pop(); + + return 1; +} + +void +sort_factors_provisional(int h) +{ + qsort(stack + h, tos - h, sizeof (struct atom *), sort_factors_provisional_func); +} + +int +sort_factors_provisional_func(const void *q1, const void *q2) +{ + return cmp_factors_provisional(*((struct atom **) q1), *((struct atom **) q2)); +} + +int +cmp_factors_provisional(struct atom *p1, struct atom *p2) +{ + if (car(p1) == symbol(POWER)) + p1 = cadr(p1); // p1 = base + + if (car(p2) == symbol(POWER)) + p2 = cadr(p2); // p2 = base + + return cmp(p1, p2); +} + +void +normalize_power_factors(int h) +{ + int i, k; + struct atom *p1; + k = tos; + for (i = h; i < k; i++) { + p1 = stack[i]; + if (car(p1) == symbol(POWER)) { + push(cadr(p1)); + push(caddr(p1)); + power(); + p1 = pop(); + if (car(p1) == symbol(MULTIPLY)) { + stack[i] = cadr(p1); + p1 = cddr(p1); + while (iscons(p1)) { + push(car(p1)); + p1 = cdr(p1); + } + } else + stack[i] = p1; + } + } +} + +void +expand_sum_factors(int h) +{ + int i, n; + struct atom *p1, *p2; + // Here, compiler treats warning as error, we use NULL to supress compiler error. + p2 = NULL; + + if (tos - h < 2) + return; + + // search for a sum factor + + for (i = h; i < tos; i++) { + p2 = stack[i]; + if (car(p2) == symbol(ADD)) + break; + } + + if (i == tos) + return; // no sum factors + + // remove the sum factor + + slice(i, 1); + + n = tos - h; + + if (n > 1) { + sort_factors(n); + list(n); + push_symbol(MULTIPLY); + swap(); + cons(); // prepend MULTIPLY to list + } + + p1 = pop(); // p1 is the multiplier + + p2 = cdr(p2); // p2 is the sum + + while (iscons(p2)) { + push(p1); + push(car(p2)); + multiply(); + p2 = cdr(p2); + } + + add_terms(tos - h); +} + +void +sort_factors(int n) +{ + qsort(stack + tos - n, n, sizeof (struct atom *), sort_factors_func); +} + +int +sort_factors_func(const void *q1, const void *q2) +{ + return cmp_factors(*((struct atom **) q1), *((struct atom **) q2)); +} + +int +cmp_factors(struct atom *p1, struct atom *p2) +{ + int a, b, c; + struct atom *base1, *base2, *expo1, *expo2; + + a = order_factor(p1); + b = order_factor(p2); + + if (a < b) + return -1; + + if (a > b) + return 1; + + if (car(p1) == symbol(POWER)) { + base1 = cadr(p1); + expo1 = caddr(p1); + } else { + base1 = p1; + expo1 = one; + } + + if (car(p2) == symbol(POWER)) { + base2 = cadr(p2); + expo2 = caddr(p2); + } else { + base2 = p2; + expo2 = one; + } + + c = cmp(base1, base2); + + if (c == 0) + c = cmp(expo2, expo1); // swapped to reverse sort order + + return c; +} + +// 1 number +// 2 number to power (root) +// 3 -1 to power (imaginary) +// 4 other factor (symbol, power, func, etc) +// 5 exponential +// 6 derivative + +int +order_factor(struct atom *p) +{ + if (isnum(p)) + return 1; + + if (p == symbol(EXP1)) + return 5; + + if (car(p) == symbol(DERIVATIVE) || car(p) == symbol(D_LOWER)) + return 6; + + if (car(p) == symbol(POWER)) { + + p = cadr(p); // p = base + + if (isminusone(p)) + return 3; + + if (isnum(p)) + return 2; + + if (p == symbol(EXP1)) + return 5; + + if (car(p) == symbol(DERIVATIVE) || car(p) == symbol(D_LOWER)) + return 6; + } + + return 4; +} + +void +multiply_numbers(struct atom *p1, struct atom *p2) +{ + double d1, d2; + + if (isrational(p1) && isrational(p2)) { + multiply_rationals(p1, p2); + return; + } + + push(p1); + d1 = pop_double(); + + push(p2); + d2 = pop_double(); + + push_double(d1 * d2); +} + +void +multiply_rationals(struct atom *p1, struct atom *p2) +{ + int sign; + uint32_t *a, *b, *c; + + if (iszero(p1) || iszero(p2)) { + push_integer(0); + return; + } + + if (p1->sign == p2->sign) + sign = MPLUS; + else + sign = MMINUS; + + if (isinteger(p1) && isinteger(p2)) { + push_bignum(sign, mmul(p1->u.q.a, p2->u.q.a), mint(1)); + return; + } + + a = mmul(p1->u.q.a, p2->u.q.a); + b = mmul(p1->u.q.b, p2->u.q.b); + c = mgcd(a, b); + push_bignum(sign, mdiv(a, c), mdiv(b, c)); + + mfree(a); + mfree(b); + mfree(c); +} + +// for example, 2 / sqrt(2) -> sqrt(2) + +struct atom * +reduce_radical_factors(int h, struct atom *COEF) +{ + if (!any_radical_factors(h)) + return COEF; + + if (isrational(COEF)) + return reduce_radical_rational(h, COEF); + else + return reduce_radical_double(h, COEF); +} + +int +any_radical_factors(int h) +{ + int i; + for (i = h; i < tos; i++) + if (isradical(stack[i])) + return 1; + return 0; +} + +struct atom * +reduce_radical_double(int h, struct atom *COEF) +{ + int i; + double a, b, c; + struct atom *p1; + + c = COEF->u.d; + + for (i = h; i < tos; i++) { + + p1 = stack[i]; + + if (isradical(p1)) { + + push(cadr(p1)); // base + a = pop_double(); + + push(caddr(p1)); // exponent + b = pop_double(); + + c = c * pow(a, b); // a > 0 by isradical above + + slice(i, 1); // remove factor + + i--; // use same index again + } + } + + push_double(c); + COEF = pop(); + + return COEF; +} + +struct atom * +reduce_radical_rational(int h, struct atom *COEF) +{ + int i, k; + struct atom *p1, *p2, *NUMER, *DENOM, *BASE, *EXPO; + + if (isplusone(COEF) || isminusone(COEF)) + return COEF; // COEF has no factors, no cancellation is possible + + push(COEF); + absfunc(); + p1 = pop(); + + push(p1); + numerator(); + NUMER = pop(); + + push(p1); + denominator(); + DENOM = pop(); + + k = 0; + + for (i = h; i < tos; i++) { + p1 = stack[i]; + if (!isradical(p1)) + continue; + BASE = cadr(p1); + EXPO = caddr(p1); + if (isnegativenumber(EXPO)) { + mod_integers(NUMER, BASE); + p2 = pop(); + if (iszero(p2)) { + push(NUMER); + push(BASE); + divide(); + NUMER = pop(); + push_symbol(POWER); + push(BASE); + push_integer(1); + push(EXPO); + add(); + list(3); + stack[i] = pop(); + k++; + } + } else { + mod_integers(DENOM, BASE); + p2 = pop(); + if (iszero(p2)) { + push(DENOM); + push(BASE); + divide(); + DENOM = pop(); + push_symbol(POWER); + push(BASE); + push_integer(-1); + push(EXPO); + add(); + list(3); + stack[i] = pop(); + k++; + } + } + } + + if (k) { + push(NUMER); + push(DENOM); + divide(); + if (isnegativenumber(COEF)) + negate(); + COEF = pop(); + } + + return COEF; +} + +void +multiply_expand(void) +{ + expanding++; + multiply(); + expanding--; +} + +void +multiply_noexpand(void) +{ + int t; + t = expanding; + expanding = 0; + multiply(); + expanding = t; +} + +void +negate(void) +{ + push_integer(-1); + multiply(); +} + +void +reciprocate(void) +{ + push_integer(-1); + power(); +} + +void +divide(void) +{ + reciprocate(); + multiply(); +} +void +eval_nil(struct atom *p1) +{ + (void) p1; // silence compiler + push_symbol(NIL); +} +void +eval_noexpand(struct atom *p1) +{ + int t; + + t = expanding; + expanding = 0; + + push(cadr(p1)); + evalf(); + + expanding = t; +} +void +eval_not(struct atom *p1) +{ + push(cadr(p1)); + evalp(); + p1 = pop(); + if (iszero(p1)) + push_integer(1); + else + push_integer(0); +} +#define DELTA 1e-6 +#define EPSILON 1e-9 + +void +eval_nroots(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + + p1 = cddr(p1); + + if (iscons(p1)) { + push(car(p1)); + evalf(); + } else + push_symbol(X_LOWER); + + nroots(); +} + +void +nroots(void) +{ + int h, i, n; + struct atom *A, *P, *X, *RE, *IM; + double ar, ai, d, xr, xi, yr, yi; + static double *cr, *ci; + + X = pop(); + P = pop(); + + h = tos; + + coeffs(P, X); // put coeffs on stack + + n = tos - h; // number of coeffs on stack + + if (cr) + free(cr); + if (ci) + free(ci); + + cr = alloc_mem(n * sizeof (double)); + ci = alloc_mem(n * sizeof (double)); + + // convert coeffs to floating point + + for (i = 0; i < n; i++) { + + push(stack[h + i]); + real(); + floatfunc(); + RE = pop(); + + push(stack[h + i]); + imag(); + floatfunc(); + IM = pop(); + + if (!isdouble(RE) || !isdouble(IM)) + stopf("nroots: coeffs"); + + cr[i] = RE->u.d; + ci[i] = IM->u.d; + } + + tos = h; // pop all + + // divide p(x) by leading coeff + + xr = cr[n - 1]; + xi = ci[n - 1]; + + d = xr * xr + xi * xi; + + for (i = 0; i < n - 1; i++) { + yr = (cr[i] * xr + ci[i] * xi) / d; + yi = (ci[i] * xr - cr[i] * xi) / d; + cr[i] = yr; + ci[i] = yi; + } + + cr[n - 1] = 1.0; + ci[n - 1] = 0.0; + + // find roots + + while (n > 1) { + + nfindroot(cr, ci, n, &ar, &ai); + + if (fabs(ar) < DELTA * fabs(ai)) + ar = 0.0; + + if (fabs(ai) < DELTA * fabs(ar)) + ai = 0.0; + + // push root + + push_double(ar); + push_double(ai); + push(imaginaryunit); + multiply(); + add(); + + // divide p(x) by x - a + + nreduce(cr, ci, n, ar, ai); + + // note: leading coeff of p(x) is still 1 + + n--; + } + + n = tos - h; // number of roots on stack + + if (n == 0) { + push_symbol(NIL); // no roots + return; + } + + if (n == 1) + return; // one root + + sort(n); + + A = alloc_vector(n); + + for (i = 0; i < n; i++) + A->u.tensor->elem[i] = stack[h + i]; + + tos = h; // pop all + + push(A); +} + +void +nfindroot(double cr[], double ci[], int n, double *par, double *pai) +{ + int i, j; + double d; + double ar, br, dfr, dxr, far, fbr, xr, yr; + double ai, bi, dfi, dxi, fai, fbi, xi, yi; + + // if const term is zero then root is zero + + // note: use exact zero, not "close to zero" + + // term will be exactly zero from coeffs(), no need for arbitrary cutoff + + if (cr[0] == 0.0 && ci[0] == 0.0) { + *par = 0.0; + *pai = 0.0; + return; + } + + // secant method + + for (i = 0; i < 100; i++) { + + ar = urandom(); + ai = urandom(); + + fata(cr, ci, n, ar, ai, &far, &fai); + + br = ar; + bi = ai; + + fbr = far; + fbi = fai; + + ar = urandom(); + ai = urandom(); + + for (j = 0; j < 1000; j++) { + + fata(cr, ci, n, ar, ai, &far, &fai); + + if (zabs(far, fai) < EPSILON) { + *par = ar; + *pai = ai; + return; + } + + if (zabs(far, fai) < zabs(fbr, fbi)) { + + xr = ar; + xi = ai; + + ar = br; + ai = bi; + + br = xr; + bi = xi; + + xr = far; + xi = fai; + + far = fbr; + fai = fbi; + + fbr = xr; + fbi = xi; + } + + // dx = b - a + + dxr = br - ar; + dxi = bi - ai; + + // df = fb - fa + + dfr = fbr - far; + dfi = fbi - fai; + + // y = dx / df + + d = dfr * dfr + dfi * dfi; + + if (d == 0.0) + break; + + yr = (dxr * dfr + dxi * dfi) / d; + yi = (dxi * dfr - dxr * dfi) / d; + + // a = b - y * fb + + ar = br - (yr * fbr - yi * fbi); + ai = bi - (yr * fbi + yi * fbr); + } + } + + stopf("nroots: convergence error"); +} + +// compute f at a + +void +fata(double cr[], double ci[], int n, double ar, double ai, double *far, double *fai) +{ + int k; + double xr, xi, yr, yi; + + yr = cr[n - 1]; + yi = ci[n - 1]; + + for (k = n - 2; k >= 0; k--) { + + // x = a * y + + xr = ar * yr - ai * yi; + xi = ar * yi + ai * yr; + + // y = x + c + + yr = xr + cr[k]; + yi = xi + ci[k]; + } + + *far = yr; + *fai = yi; +} + +// divide by x - a + +void +nreduce(double cr[], double ci[], int n, double ar, double ai) +{ + int k; + + // divide + + for (k = n - 1; k > 0; k--) { + cr[k - 1] += cr[k] * ar - ci[k] * ai; + ci[k - 1] += ci[k] * ar + cr[k] * ai; + } + + if (zabs(cr[0], ci[0]) > DELTA) + stopf("nroots: residual error"); // not a root + + // shift + + for (k = 0; k < n - 1; k++) { + cr[k] = cr[k + 1]; + ci[k] = ci[k + 1]; + } +} + +double +zabs(double r, double i) +{ + return sqrt(r * r + i * i); +} + +double +urandom(void) +{ + return 4.0 * ((double) rand() / (double) RAND_MAX) - 2.0; +} +void +eval_number(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + + p1 = pop(); + + if (isnum(p1)) + push_integer(1); + else + push_integer(0); +} +void +eval_numerator(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + numerator(); +} + +void +numerator(void) +{ + numden(); + swap(); + pop(); // discard denominator +} +void +eval_or(struct atom *p1) +{ + struct atom *p2; + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + evalp(); + p2 = pop(); + if (!iszero(p2)) { + push_integer(1); + return; + } + p1 = cdr(p1); + } + push_integer(0); +} +void +eval_outer(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + p1 = cddr(p1); + while (iscons(p1)) { + push(car(p1)); + evalf(); + outer(); + p1 = cdr(p1); + } +} + +void +outer(void) +{ + int i, j, k, n, ncol, nrow; + struct atom *p1, *p2, *p3; + + p2 = pop(); + p1 = pop(); + + if (!istensor(p1) || !istensor(p2)) { + push(p1); + push(p2); + multiply(); + return; + } + + if (p1->u.tensor->ndim + p2->u.tensor->ndim > MAXDIM) + stopf("outer: rank exceeds max"); + + // sync diffs + + nrow = p1->u.tensor->nelem; + ncol = p2->u.tensor->nelem; + + p3 = alloc_tensor(nrow * ncol); + + for (i = 0; i < nrow; i++) + for (j = 0; j < ncol; j++) { + push(p1->u.tensor->elem[i]); + push(p2->u.tensor->elem[j]); + multiply(); + p3->u.tensor->elem[i * ncol + j] = pop(); + } + + // dim info + + p3->u.tensor->ndim = p1->u.tensor->ndim + p2->u.tensor->ndim; + + k = 0; + + n = p1->u.tensor->ndim; + + for (i = 0; i < n; i++) + p3->u.tensor->dim[k++] = p1->u.tensor->dim[i]; + + n = p2->u.tensor->ndim; + + for (i = 0; i < n; i++) + p3->u.tensor->dim[k++] = p2->u.tensor->dim[i]; + + push(p3); +} +void +eval_polar(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + polar(); +} + +void +polar(void) +{ + int i, n; + struct atom *p1, *p2; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + polar(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + magfunc(); + push(p1); + argfunc(); + p2 = pop(); + if (isdouble(p2)) { + push_double(p2->u.d / M_PI); + push_symbol(PI); + push(imaginaryunit); + multiply_factors(3); + } else { + // the result of arg is arctan + push(p2); + push(imaginaryunit); + multiply(); + } + expfunc(); + multiply(); +} +void +eval_power(struct atom *p1) +{ + int t; + struct atom *p2; + + expanding--; // undo expanding++ in evalf + + // base + + push(cadr(p1)); + + // exponent + + push(caddr(p1)); + evalg(); + dupl(); + p2 = pop(); + + // if exponent is negative then evaluate base without expanding + + swap(); + if (isnegativenumber(p2)) { + t = expanding; + expanding = 0; + evalg(); + expanding = t; + } else + evalg(); + swap(); + + power(); + + expanding++; +} + +void +power(void) +{ + int h, i, n; + struct atom *p1, *BASE, *EXPO; + + EXPO = pop(); + BASE = pop(); + + if (istensor(BASE) && istensor(EXPO)) { + push_symbol(POWER); + push(BASE); + push(EXPO); + list(3); + return; + } + + if (istensor(EXPO)) { + p1 = copy_tensor(EXPO); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(BASE); + push(p1->u.tensor->elem[i]); + power(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (istensor(BASE)) { + p1 = copy_tensor(BASE); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + push(EXPO); + power(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (BASE == symbol(EXP1) && isdouble(EXPO)) { + push_double(M_E); + BASE = pop(); + } + + if (BASE == symbol(PI) && isdouble(EXPO)) { + push_double(M_PI); + BASE = pop(); + } + + if (isnum(BASE) && isnum(EXPO)) { + power_numbers(BASE, EXPO); + return; + } + + // expr^0 + + if (iszero(EXPO)) { + push_integer(1); + return; + } + + // 0^expr + + if (iszero(BASE)) { + push_symbol(POWER); + push(BASE); + push(EXPO); + list(3); + return; + } + + // 1^expr + + if (isplusone(BASE)) { + push_integer(1); + return; + } + + // expr^1 + + if (isplusone(EXPO)) { + push(BASE); + return; + } + + // BASE is an integer? + + if (isinteger(BASE)) { + // raise each factor in BASE to power EXPO + // EXPO is not numerical, that case was handled by power_numbers() above + h = tos; + push(BASE); + factor_factor(); + n = tos - h; + for (i = 0; i < n; i++) { + p1 = stack[h + i]; + if (car(p1) == symbol(POWER)) { + push_symbol(POWER); + push(cadr(p1)); // base + push(caddr(p1)); // expo + push(EXPO); + multiply(); + list(3); + } else { + push_symbol(POWER); + push(p1); + push(EXPO); + list(3); + } + stack[h + i] = pop(); + } + if (n > 1) { + sort_factors(n); + list(n); + push_symbol(MULTIPLY); + swap(); + cons(); // prepend MULTIPLY to list + } + return; + } + + // BASE is a numerical fraction? + + if (isfraction(BASE)) { + // power numerator, power denominator + // EXPO is not numerical, that case was handled by power_numbers() above + push(BASE); + numerator(); + push(EXPO); + power(); + push(BASE); + denominator(); + push(EXPO); + negate(); + power(); + multiply(); + return; + } + + // BASE = e ? + + if (BASE == symbol(EXP1)) { + power_natural_number(EXPO); + return; + } + + // (a + b) ^ c + + if (car(BASE) == symbol(ADD)) { + power_sum(BASE, EXPO); + return; + } + + // (a b) ^ c --> (a ^ c) (b ^ c) + + if (car(BASE) == symbol(MULTIPLY)) { + h = tos; + p1 = cdr(BASE); + while (iscons(p1)) { + push(car(p1)); + push(EXPO); + power(); + p1 = cdr(p1); + } + multiply_factors(tos - h); + return; + } + + // (a ^ b) ^ c --> a ^ (b c) + + if (car(BASE) == symbol(POWER)) { + push(cadr(BASE)); + push(caddr(BASE)); + push(EXPO); + multiply_expand(); // always expand products of exponents + power(); + return; + } + + // none of the above + + push_symbol(POWER); + push(BASE); + push(EXPO); + list(3); +} + +// BASE and EXPO are rational or double + +void +power_numbers(struct atom *BASE, struct atom *EXPO) +{ + int h, i, j, n; + uint32_t *a, *b; + struct atom *p1, *p2; + + // n^0 + + if (iszero(EXPO)) { + push_integer(1); + return; + } + + // 0^n + + if (iszero(BASE)) { + if (isnegativenumber(EXPO)) { + if (shuntflag) + errorflag = 1; + else + stopf("divide by zero"); + } + push_integer(0); + return; + } + + // 1^n + + if (isplusone(BASE)) { + push_integer(1); + return; + } + + // n^1 + + if (isplusone(EXPO)) { + push(BASE); + return; + } + + if (isdouble(BASE) || isdouble(EXPO)) { + power_double(BASE, EXPO); + return; + } + + // integer exponent? + + if (isinteger(EXPO)) { + a = mpow(BASE->u.q.a, EXPO->u.q.a); + b = mpow(BASE->u.q.b, EXPO->u.q.a); + if (isnegativenumber(BASE) && (EXPO->u.q.a[0] & 1)) + if (isnegativenumber(EXPO)) + push_bignum(MMINUS, b, a); // reciprocate + else + push_bignum(MMINUS, a, b); + else + if (isnegativenumber(EXPO)) + push_bignum(MPLUS, b, a); // reciprocate + else + push_bignum(MPLUS, a, b); + return; + } + + // exponent is a root + + h = tos; + + // put factors on stack + + push_symbol(POWER); + push(BASE); + push(EXPO); + list(3); + + factor_factor(); + + // normalize factors + + n = tos - h; // fix n now, stack can grow + + for (i = 0; i < n; i++) { + p1 = stack[h + i]; + if (car(p1) == symbol(POWER)) { + BASE = cadr(p1); + EXPO = caddr(p1); + power_numbers_factor(BASE, EXPO); + stack[h + i] = pop(); // fill hole + } + } + + // combine numbers (leaves radicals on stack) + + p1 = one; + + for (i = h; i < tos; i++) { + p2 = stack[i]; + if (isnum(p2)) { + push(p1); + push(p2); + multiply(); + p1 = pop(); + for (j = i + 1; j < tos; j++) + stack[j - 1] = stack[j]; + tos--; + i--; + } + } + + // finalize + + n = tos - h; + + if (n == 0 || !isplusone(p1)) { + push(p1); + n++; + } + + if (n == 1) + return; + + sort_factors(n); + list(n); + push_symbol(MULTIPLY); + swap(); + cons(); // prepend MULTIPLY to list +} + +// BASE is an integer + +void +power_numbers_factor(struct atom *BASE, struct atom *EXPO) +{ + uint32_t *a, *b, *n, *q, *r; + struct atom *p0; + + if (isminusone(BASE)) { + power_minusone(EXPO); + p0 = pop(); + if (car(p0) == symbol(MULTIPLY)) { + p0 = cdr(p0); + while (iscons(p0)) { + push(car(p0)); + p0 = cdr(p0); + } + } else + push(p0); + return; + } + + if (isinteger(EXPO)) { + a = mpow(BASE->u.q.a, EXPO->u.q.a); + b = mint(1); + if (isnegativenumber(EXPO)) + push_bignum(MPLUS, b, a); // reciprocate + else + push_bignum(MPLUS, a, b); + return; + } + + // EXPO.a r + // ------ == q + ------ + // EXPO.b EXPO.b + + q = mdiv(EXPO->u.q.a, EXPO->u.q.b); + r = mmod(EXPO->u.q.a, EXPO->u.q.b); + + // process q + + if (!MZERO(q)) { + a = mpow(BASE->u.q.a, q); + b = mint(1); + if (isnegativenumber(EXPO)) + push_bignum(MPLUS, b, a); // reciprocate + else + push_bignum(MPLUS, a, b); + } + + mfree(q); + + // process r + + if (MLENGTH(BASE->u.q.a) == 1 && BASE->u.q.a[0] <= 0x7fffffff) { + // BASE is less than 2^31, hence BASE is a prime number, no root + push_symbol(POWER); + push(BASE); + push_bignum(EXPO->sign, r, mcopy(EXPO->u.q.b)); // r used here, r is not leaked + list(3); + return; + } + + // BASE was too big to factor, try finding root + + n = mroot(BASE->u.q.a, EXPO->u.q.b); + + if (n == NULL) { + // no root + push_symbol(POWER); + push(BASE); + push_bignum(EXPO->sign, r, mcopy(EXPO->u.q.b)); // r used here, r is not leaked + list(3); + return; + } + + // raise n to rth power + + a = mpow(n, r); + b = mint(1); + + mfree(n); + mfree(r); + + if (isnegativenumber(EXPO)) + push_bignum(MPLUS, b, a); // reciprocate + else + push_bignum(MPLUS, a, b); +} + +void +power_double(struct atom *BASE, struct atom *EXPO) +{ + double base, d, expo; + + push(BASE); + base = pop_double(); + + push(EXPO); + expo = pop_double(); + + if (base > 0.0 || expo == floor(expo)) { + d = pow(base, expo); + push_double(d); + return; + } + + // BASE is negative and EXPO is fractional + + power_minusone(EXPO); + + if (base == -1.0) + return; + + d = pow(-base, expo); + push_double(d); + + multiply(); +} + +// power -1 to EXPO where EXPO is RATIONAL or DOUBLE + +void +power_minusone(struct atom *EXPO) +{ + // optimization for i + + if (isequalq(EXPO, 1, 2)) { + push(imaginaryunit); + return; + } + + // root is an odd number? + + if (isrational(EXPO) && EXPO->u.q.b[0] & 1) { + if (EXPO->u.q.a[0] & 1) + push_integer(-1); + else + push_integer(1); + return; + } + + if (isrational(EXPO)) { + normalize_clock_rational(EXPO); + return; + } + + if (isdouble(EXPO)) { + normalize_clock_double(EXPO); + rect(); + return; + } + + push_symbol(POWER); + push_integer(-1); + push(EXPO); + list(3); +} + +void +normalize_clock_rational(struct atom *EXPO) +{ + int n; + struct atom *R; + + // R = EXPO mod 2 + + push(EXPO); + push_integer(2); + modfunc(); + R = pop(); + + // convert negative rotation to positive + + if (R->sign == MMINUS) { + push(R); + push_integer(2); + add(); + R = pop(); + } + + push(R); + push_integer(2); + multiply(); + floorfunc(); + n = pop_integer(); // number of 90 degree turns + + push(R); + push_integer(n); + push_rational(-1, 2); + multiply(); + add(); + R = pop(); // remainder + + switch (n) { + + case 0: + if (iszero(R)) + push_integer(1); + else { + push_symbol(POWER); + push_integer(-1); + push(R); + list(3); + } + break; + + case 1: + if (iszero(R)) + push(imaginaryunit); + else { + push_symbol(MULTIPLY); + push_integer(-1); + push_symbol(POWER); + push_integer(-1); + push(R); + push_rational(-1, 2); + add(); + list(3); + list(3); + } + break; + + case 2: + if (iszero(R)) + push_integer(-1); + else { + push_symbol(MULTIPLY); + push_integer(-1); + push_symbol(POWER); + push_integer(-1); + push(R); + list(3); + list(3); + } + break; + + case 3: + if (iszero(R)) { + push_symbol(MULTIPLY); + push_integer(-1); + push(imaginaryunit); + list(3); + } else { + push_symbol(POWER); + push_integer(-1); + push(R); + push_rational(-1, 2); + add(); + list(3); + } + break; + } +} + +void +normalize_clock_double(struct atom *EXPO) +{ + double expo, n, r; + + expo = EXPO->u.d; + + // expo = expo mod 2 + + expo = fmod(expo, 2.0); + + // convert negative rotation to positive + + if (expo < 0.0) + expo += 2.0; + + n = floor(2.0 * expo); // number of 90 degree turns + + r = expo - n / 2.0; // remainder + + switch ((int) n) { + + case 0: + if (r == 0.0) + push_integer(1); + else { + push_symbol(POWER); + push_integer(-1); + push_double(r); + list(3); + } + break; + + case 1: + if (r == 0.0) + push(imaginaryunit); + else { + push_symbol(MULTIPLY); + push_integer(-1); + push_symbol(POWER); + push_integer(-1); + push_double(r - 0.5); + list(3); + list(3); + } + break; + + case 2: + if (r == 0.0) + push_integer(-1); + else { + push_symbol(MULTIPLY); + push_integer(-1); + push_symbol(POWER); + push_integer(-1); + push_double(r); + list(3); + list(3); + } + break; + + case 3: + if (r == 0.0) { + push_symbol(MULTIPLY); + push_integer(-1); + push(imaginaryunit); + list(3); + } else { + push_symbol(POWER); + push_integer(-1); + push_double(r - 0.5); + list(3); + } + break; + } +} + +void +power_natural_number(struct atom *EXPO) +{ + double x, y; + + // exp(x + i y) = exp(x) (cos(y) + i sin(y)) + + if (isdoublez(EXPO)) { + if (car(EXPO) == symbol(ADD)) { + x = cadr(EXPO)->u.d; + y = cadaddr(EXPO)->u.d; + } else { + x = 0.0; + y = cadr(EXPO)->u.d; + } + push_double(exp(x)); + push_double(y); + cosfunc(); + push(imaginaryunit); + push_double(y); + sinfunc(); + multiply(); + add(); + multiply(); + return; + } + + // e^log(expr) = expr + + if (car(EXPO) == symbol(LOG)) { + push(cadr(EXPO)); + return; + } + + if (isdenormalpolar(EXPO)) { + normalize_polar(EXPO); + return; + } + + push_symbol(POWER); + push_symbol(EXP1); + push(EXPO); + list(3); +} + +void +normalize_polar(struct atom *EXPO) +{ + int h; + struct atom *p1; + if (car(EXPO) == symbol(ADD)) { + h = tos; + p1 = cdr(EXPO); + while (iscons(p1)) { + EXPO = car(p1); + if (isdenormalpolarterm(EXPO)) + normalize_polar_term(EXPO); + else { + push_symbol(POWER); + push_symbol(EXP1); + push(EXPO); + list(3); + } + p1 = cdr(p1); + } + multiply_factors(tos - h); + } else + normalize_polar_term(EXPO); +} + +void +normalize_polar_term(struct atom *EXPO) +{ + struct atom *R; + + // exp(i pi) = -1 + + if (lengthf(EXPO) == 3) { + push_integer(-1); + return; + } + + R = cadr(EXPO); // R = coeff of term + + if (isrational(R)) + normalize_polar_term_rational(R); + else + normalize_polar_term_double(R); +} + +void +normalize_polar_term_rational(struct atom *R) +{ + int n; + + // R = R mod 2 + + push(R); + push_integer(2); + modfunc(); + R = pop(); + + // convert negative rotation to positive + + if (R->sign == MMINUS) { + push(R); + push_integer(2); + add(); + R = pop(); + } + + push(R); + push_integer(2); + multiply(); + floorfunc(); + n = pop_integer(); // number of 90 degree turns + + push(R); + push_integer(n); + push_rational(-1, 2); + multiply(); + add(); + R = pop(); // remainder + + switch (n % 4) { + + case 0: + if (iszero(R)) + push_integer(1); + else { + push_symbol(POWER); + push_symbol(EXP1); + push_symbol(MULTIPLY); + push(R); + push(imaginaryunit); + push_symbol(PI); + list(4); + list(3); + } + break; + + case 1: + if (iszero(R)) + push(imaginaryunit); + else { + push_symbol(MULTIPLY); + push(imaginaryunit); + push_symbol(POWER); + push_symbol(EXP1); + push_symbol(MULTIPLY); + push(R); + push(imaginaryunit); + push_symbol(PI); + list(4); + list(3); + list(3); + } + break; + + case 2: + if (iszero(R)) + push_integer(-1); + else { + push_symbol(MULTIPLY); + push_integer(-1); + push_symbol(POWER); + push_symbol(EXP1); + push_symbol(MULTIPLY); + push(R); + push(imaginaryunit); + push_symbol(PI); + list(4); + list(3); + list(3); + } + break; + + case 3: + if (iszero(R)) { + push_symbol(MULTIPLY); + push_integer(-1); + push(imaginaryunit); + list(3); + } else { + push_symbol(MULTIPLY); + push_integer(-1); + push(imaginaryunit); + push_symbol(POWER); + push_symbol(EXP1); + push_symbol(MULTIPLY); + push(R); + push(imaginaryunit); + push_symbol(PI); + list(4); + list(3); + list(4); + } + break; + } +} + +void +normalize_polar_term_double(struct atom *R) +{ + int n; + double coeff, r; + + coeff = R->u.d; + + // coeff = coeff mod 2 + + coeff = fmod(coeff, 2.0); + + // convert negative rotation to positive + + if (coeff < 0.0) + coeff += 2.0; + + n = (int) floor(2.0 * coeff); // number of 90 degree turns + + r = coeff - n / 2.0; // remainder + + switch (n % 4) { + + case 0: + if (r == 0.0) + push_integer(1); + else { + push_symbol(POWER); + push_symbol(EXP1); + push_symbol(MULTIPLY); + push_double(r); + push(imaginaryunit); + push_symbol(PI); + list(4); + list(3); + } + break; + + case 1: + if (r == 0.0) + push(imaginaryunit); + else { + push_symbol(MULTIPLY); + push(imaginaryunit); + push_symbol(POWER); + push_symbol(EXP1); + push_symbol(MULTIPLY); + push_double(r); + push(imaginaryunit); + push_symbol(PI); + list(4); + list(3); + list(3); + } + break; + + case 2: + if (r == 0.0) + push_integer(-1); + else { + push_symbol(MULTIPLY); + push_integer(-1); + push_symbol(POWER); + push_symbol(EXP1); + push_symbol(MULTIPLY); + push_double(r); + push(imaginaryunit); + push_symbol(PI); + list(4); + list(3); + list(3); + } + break; + + case 3: + if (r == 0.0) { + push_symbol(MULTIPLY); + push_integer(-1); + push(imaginaryunit); + list(3); + } else { + push_symbol(MULTIPLY); + push_integer(-1); + push(imaginaryunit); + push_symbol(POWER); + push_symbol(EXP1); + push_symbol(MULTIPLY); + push_double(r); + push(imaginaryunit); + push_symbol(PI); + list(4); + list(3); + list(4); + } + break; + } +} + +// BASE is a sum of terms + +void +power_sum(struct atom *BASE, struct atom *EXPO) +{ + int h, i, n; + struct atom *p1, *p2; + + if (iscomplexnumber(BASE) && isnum(EXPO)) { + power_complex_number(BASE, EXPO); + return; + } + + if (expanding == 0 || !issmallinteger(EXPO) || isnegativenumber(EXPO)) { + push_symbol(POWER); + push(BASE); + push(EXPO); + list(3); + return; + } + + push(EXPO); + n = pop_integer(); + + // square the sum first (prevents infinite loop through multiply) + + h = tos; + + p1 = cdr(BASE); + + while (iscons(p1)) { + p2 = cdr(BASE); + while (iscons(p2)) { + push(car(p1)); + push(car(p2)); + multiply(); + p2 = cdr(p2); + } + p1 = cdr(p1); + } + + add_terms(tos - h); + + // continue up to power n + + for (i = 2; i < n; i++) { + push(BASE); + multiply(); + } +} + +// BASE is rectangular complex numerical, EXPO is numerical + +void +power_complex_number(struct atom *BASE, struct atom *EXPO) +{ + int n; + struct atom *X, *Y; + + // prefixform(2+3*i) = (add 2 (multiply 3 (power -1 1/2))) + + // prefixform(1+i) = (add 1 (power -1 1/2)) + + // prefixform(3*i) = (multiply 3 (power -1 1/2)) + + // prefixform(i) = (power -1 1/2) + + if (car(BASE) == symbol(ADD)) { + X = cadr(BASE); + if (caaddr(BASE) == symbol(MULTIPLY)) + Y = cadaddr(BASE); + else + Y = one; + } else if (car(BASE) == symbol(MULTIPLY)) { + X = zero; + Y = cadr(BASE); + } else { + X = zero; + Y = one; + } + + if (isdouble(X) || isdouble(Y) || isdouble(EXPO)) { + power_complex_double(X, Y, EXPO); + return; + } + + if (!isinteger(EXPO)) { + power_complex_rational(X, Y, EXPO); + return; + } + + if (!issmallinteger(EXPO)) { + push_symbol(POWER); + push(BASE); + push(EXPO); + list(3); + return; + } + + push(EXPO); + n = pop_integer(); + + if (n > 0) + power_complex_plus(X, Y, n); + else if (n < 0) + power_complex_minus(X, Y, -n); + else + push_integer(1); +} + +void +power_complex_plus(struct atom *X, struct atom *Y, int n) +{ + int i; + struct atom *PX, *PY; + + PX = X; + PY = Y; + + for (i = 1; i < n; i++) { + + push(PX); + push(X); + multiply(); + push(PY); + push(Y); + multiply(); + subtract(); + + push(PX); + push(Y); + multiply(); + push(PY); + push(X); + multiply(); + add(); + + PY = pop(); + PX = pop(); + } + + // X + i*Y + + push(PX); + push(imaginaryunit); + push(PY); + multiply(); + add(); +} + +// +// / \ n +// -n | X - iY | +// (X + iY) = | -------- | +// | 2 2 | +// \ X + Y / + +// X and Y are rational numbers + +void +power_complex_minus(struct atom *X, struct atom *Y, int n) +{ + int i; + struct atom *PX, *PY, *R; + + // R = X^2 + Y^2 + + push(X); + push(X); + multiply(); + push(Y); + push(Y); + multiply(); + add(); + R = pop(); + + // X = X / R + + push(X); + push(R); + divide(); + X = pop(); + + // Y = -Y / R + + push(Y); + negate(); + push(R); + divide(); + Y = pop(); + + PX = X; + PY = Y; + + for (i = 1; i < n; i++) { + + push(PX); + push(X); + multiply(); + push(PY); + push(Y); + multiply(); + subtract(); + + push(PX); + push(Y); + multiply(); + push(PY); + push(X); + multiply(); + add(); + + PY = pop(); + PX = pop(); + } + + // X + i*Y + + push(PX); + push(imaginaryunit); + push(PY); + multiply(); + add(); +} + +void +power_complex_double(struct atom *X, struct atom *Y, struct atom *EXPO) +{ + double expo, r, theta, x, y; + + push(EXPO); + expo = pop_double(); + + push(X); + x = pop_double(); + + push(Y); + y = pop_double(); + + r = hypot(x, y); + theta = atan2(y, x); + + r = pow(r, expo); + theta = expo * theta; + + x = r * cos(theta); + y = r * sin(theta); + + push_double(x); + push_double(y); + push(imaginaryunit); + multiply(); + add(); +} + +// X and Y are rational, EXPO is rational and not an integer + +void +power_complex_rational(struct atom *X, struct atom *Y, struct atom *EXPO) +{ + // calculate sqrt(X^2 + Y^2) ^ (1/2 * EXPO) + + push(X); + push(X); + multiply(); + push(Y); + push(Y); + multiply(); + add(); + push_rational(1, 2); + push(EXPO); + multiply(); + power(); + + // calculate (-1) ^ (EXPO * arctan(Y, X) / pi) + + push(Y); + push(X); + arctan(); + push_symbol(PI); + divide(); + push(EXPO); + multiply(); + EXPO = pop(); + power_minusone(EXPO); + + // result = sqrt(X^2 + Y^2) ^ (1/2 * EXPO) * (-1) ^ (EXPO * arctan(Y, X) / pi) + + multiply(); +} +void +eval_prefixform(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + p1 = pop(); + + outbuf_init(); + prefixform(p1); + + push_string(outbuf); +} + +// for debugging + +void +print_prefixform(struct atom *p) +{ + outbuf_init(); + prefixform(p); + outbuf_puts("\n"); + printbuf(outbuf, BLACK); +} + +void +prefixform(struct atom *p) +{ + char *s; + switch (p->atomtype) { + case CONS: + outbuf_puts("("); + prefixform(car(p)); + p = cdr(p); + while (iscons(p)) { + outbuf_puts(" "); + prefixform(car(p)); + p = cdr(p); + } + if (p != symbol(NIL)) { + outbuf_puts(" . "); + prefixform(p); + } + outbuf_puts(")"); + break; + case STR: + outbuf_puts("\""); + outbuf_puts(p->u.str); + outbuf_puts("\""); + break; + case RATIONAL: + if (p->sign == MMINUS) + outbuf_puts("-"); + s = mstr(p->u.q.a); + outbuf_puts(s); + s = mstr(p->u.q.b); + if (strcmp(s, "1") == 0) + break; + outbuf_puts("/"); + outbuf_puts(s); + break; + case DOUBLE: + snprintf(strbuf, STRBUFLEN, "%g", p->u.d); + outbuf_puts(strbuf); + if (!strchr(strbuf, '.') && !strchr(strbuf, 'e')) + outbuf_puts(".0"); + break; + case KSYM: + case USYM: + outbuf_puts(printname(p)); + break; + case TENSOR: + outbuf_puts("(tensor)"); + break; + default: + outbuf_puts("(?)"); + break; + } +} +void +eval_print(struct atom *p1) +{ + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + push(car(p1)); + evalf(); + print_result(); + p1 = cdr(p1); + } + push_symbol(NIL); +} + +void +print_result(void) +{ + struct atom *p1, *p2; + + p2 = pop(); // result + p1 = pop(); // input + + if (p2 == symbol(NIL)) + return; + + if (annotate_result(p1, p2)) { + push_symbol(SETQ); + push(p1); + push(p2); + list(3); + p2 = pop(); + } + + p1 = get_binding(symbol(TTY)); + + if (p1 == symbol(TTY) || iszero(p1)) { + push(p2); + display(); + } else + print_infixform(p2); +} + +// returns 1 if result should be annotated + +int +annotate_result(struct atom *p1, struct atom *p2) +{ + if (!isusersymbol(p1)) + return 0; + + if (p1 == p2) + return 0; // A = A + + if (p1 == symbol(I_LOWER) && isimaginaryunit(p2)) + return 0; + + if (p1 == symbol(J_LOWER) && isimaginaryunit(p2)) + return 0; + + return 1; +} +void +eval_product(struct atom *p1) +{ + int h, i, j, k, n; + struct atom *p2, *p3; + + // product of tensor elements? + + if (lengthf(p1) == 2) { + push(cadr(p1)); + evalf(); + p1 = pop(); + if (!istensor(p1)) { + push(p1); + return; + } + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) + push(p1->u.tensor->elem[i]); + multiply_factors(n); + return; + } + + p2 = cadr(p1); + if (!isusersymbol(p2)) + stopf("product: index symbol err"); + + push(caddr(p1)); + evalf(); + p3 = pop(); + if (!issmallinteger(p3)) + stopf("product: index range err"); + push(p3); + j = pop_integer(); + + push(cadddr(p1)); + evalf(); + p3 = pop(); + if (!issmallinteger(p3)) + stopf("product: index range err"); + push(p3); + k = pop_integer(); + + p1 = caddddr(p1); + + save_symbol(p2); + + h = tos; + + for (;;) { + push_integer(j); + p3 = pop(); + set_symbol(p2, p3, symbol(NIL)); + push(p1); + evalg(); + if (j == k) + break; + if (j < k) + j++; + else + j--; + if (tos - h == 1000) + multiply_factors(1000); // to prevent stack overflow + } + + multiply_factors(tos - h); + + p1 = pop(); + restore_symbol(); + push(p1); +} +void +eval_quote(struct atom *p1) +{ + push(cadr(p1)); // not evaluated +} +void +eval_rand(struct atom *p1) +{ + double d; + d = (double) rand() / ((double) RAND_MAX + 1); + push_double(d); +} +void +eval_rank(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + p1 = pop(); + if (istensor(p1)) + push_integer(p1->u.tensor->ndim); + else + push_integer(0); +} +void +eval_rationalize(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + rationalize(); +} + +void +rationalize(void) +{ + int i, n; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + rationalize(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + numden(); + swap(); + reciprocate(); + multiply_noexpand(); +} +void +eval_real(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + real(); +} + +void +real(void) +{ + int i, n; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + real(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + rect(); + p1 = pop(); + push(p1); + push(p1); + conjfunc(); + add(); + push_rational(1, 2); + multiply(); +} +void +eval_rect(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + rect(); +} + +void +rect(void) +{ + int h, i, n; + struct atom *p1, *p2, *BASE, *EXPO; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + rect(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (car(p1) == symbol(ADD)) { + p1 = cdr(p1); + h = tos; + while (iscons(p1)) { + push(car(p1)); + rect(); + p1 = cdr(p1); + } + add_terms(tos - h); + return; + } + + if (car(p1) == symbol(MULTIPLY)) { + p1 = cdr(p1); + h = tos; + while (iscons(p1)) { + push(car(p1)); + rect(); + p1 = cdr(p1); + } + multiply_factors(tos - h); + return; + } + + if (car(p1) != symbol(POWER)) { + push(p1); + return; + } + + BASE = cadr(p1); + EXPO = caddr(p1); + + // handle sum in exponent + + if (car(EXPO) == symbol(ADD)) { + p1 = cdr(EXPO); + h = tos; + while (iscons(p1)) { + push_symbol(POWER); + push(BASE); + push(car(p1)); + list(3); + rect(); + p1 = cdr(p1); + } + multiply_factors(tos - h); + return; + } + + // return mag(p1) * cos(arg(p1)) + i sin(arg(p1))) + + push(p1); + magfunc(); + + push(p1); + argfunc(); + p2 = pop(); + + push(p2); + cosfunc(); + + push(imaginaryunit); + push(p2); + sinfunc(); + multiply(); + + add(); + + multiply(); +} +void +eval_roots(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + + p1 = cddr(p1); + + if (iscons(p1)) { + push(car(p1)); + evalf(); + } else + push_symbol(X_LOWER); + + roots(); +} + +void +roots(void) +{ + int h, i, j, k, n; + struct atom *A, *P, *X; + + X = pop(); + P = pop(); + + h = tos; + + coeffs(P, X); // put coeffs on stack + + k = tos; + + n = k - h; // number of coeffs on stack + + // check coeffs + + for (i = 0; i < n; i++) + if (!isrational(stack[h + i])) + stopf("roots: coeffs"); + + // find roots + + while (n > 1) { + + if (findroot(h, n) == 0) + break; // no root found + + // A is the root + + A = stack[tos - 1]; + + // divide p(x) by X - A + + reduce(h, n, A); + + n--; + } + + n = tos - k; // number of roots on stack + + if (n == 0) { + tos = h; // pop all + push_symbol(NIL); // no roots + return; + } + + sort(n); // sort roots + + // eliminate repeated roots + + for (i = 0; i < n - 1; i++) + if (equal(stack[k + i], stack[k + i + 1])) { + for (j = i + 1; j < n - 1; j++) + stack[k + j] = stack[k + j + 1]; + i--; + n--; + } + + if (n == 1) { + A = stack[k]; + tos = h; // pop all + push(A); // one root + return; + } + + A = alloc_vector(n); + + for (i = 0; i < n; i++) + A->u.tensor->elem[i] = stack[k + i]; + + tos = h; // pop all + + push(A); +} + +int +findroot(int h, int n) +{ + int i, j, m, p, q, r; + struct atom *A, *C, *PA; + + // check constant term + + if (iszero(stack[h])) { + push_integer(0); // root is zero + return 1; + } + + // eliminate denominators + + for (i = 0; i < n; i++) { + C = stack[h + i]; + if (isinteger(C)) + continue; + push(C); + denominator(); + C = pop(); + for (j = 0; j < n; j++) { + push(stack[h + j]); + push(C); + multiply(); + stack[h + j] = pop(); + } + } + + p = tos; + + push(stack[h]); + m = pop_integer(); + divisors(m); // divisors of constant term + + q = tos; + + push(stack[h + n - 1]); + m = pop_integer(); + divisors(m); // divisors of leading coeff + + r = tos; + + for (i = p; i < q; i++) { + for (j = q; j < r; j++) { + + // try positive A + + push(stack[i]); + push(stack[j]); + divide(); + A = pop(); + + horner(h, n, A); + + PA = pop(); // polynomial evaluated at A + + if (iszero(PA)) { + tos = p; // pop all + push(A); + return 1; // root on stack + } + + // try negative A + + push(A); + negate(); + A = pop(); + + horner(h, n, A); + + PA = pop(); // polynomial evaluated at A + + if (iszero(PA)) { + tos = p; // pop all + push(A); + return 1; // root on stack + } + } + } + + tos = p; // pop all + + return 0; // no root +} + +// evaluate p(x) at x = A using horner's rule + +void +horner(int h, int n, struct atom *A) +{ + int i; + + push(stack[h + n - 1]); + + for (i = n - 2; i >= 0; i--) { + push(A); + multiply(); + push(stack[h + i]); + add(); + } +} + +// push all divisors of n + +void +divisors(int n) +{ + int h, i, k; + + h = tos; + + factor_int(n); + + k = tos; + + // contruct divisors by recursive descent + + push_integer(1); + + divisors_nib(h, k); + + // move + + n = tos - k; + + for (i = 0; i < n; i++) + stack[h + i] = stack[k + i]; + + tos = h + n; // pop all +} + +// Generate all divisors for a factored number +// +// Input: Factor pairs on stack (base, expo) +// +// h first pair +// +// k just past last pair +// +// Output: Divisors on stack +// +// For example, the number 12 (= 2^2 3^1) has 6 divisors: +// +// 1, 2, 3, 4, 6, 12 + +void +divisors_nib(int h, int k) +{ + int i, n; + struct atom *ACCUM, *BASE, *EXPO; + + if (h == k) + return; + + ACCUM = pop(); + + BASE = stack[h + 0]; + EXPO = stack[h + 1]; + + push(EXPO); + n = pop_integer(); + + for (i = 0; i <= n; i++) { + push(ACCUM); + push(BASE); + push_integer(i); + power(); + multiply(); + divisors_nib(h + 2, k); + } +} + +// divide by X - A + +void +reduce(int h, int n, struct atom *A) +{ + int i; + + for (i = n - 1; i > 0; i--) { + push(A); + push(stack[h + i]); + multiply(); + push(stack[h + i - 1]); + add(); + stack[h + i - 1] = pop(); + } + + if (!iszero(stack[h])) + stopf("roots: residual error"); // not a root + + // move + + for (i = 0; i < n - 1; i++) + stack[h + i] = stack[h + i + 1]; +} + +// push coefficients of polynomial P(X) on stack + +void +coeffs(struct atom *P, struct atom *X) +{ + struct atom *C; + + for (;;) { + + push(P); + push(X); + push_integer(0); + subst(); + evalf(); + C = pop(); + + push(C); + + push(P); + push(C); + subtract(); + P = pop(); + + if (iszero(P)) + break; + + push(P); + push(X); + divide(); + P = pop(); + } +} +#define NUMQBITS PSI->u.tensor->nelem +#define KET0 PSI->u.tensor->elem[i ^ n] +#define KET1 PSI->u.tensor->elem[i] + +#define POWEROF2(x) (((x) & ((x) - 1)) == 0) + +void +eval_rotate(struct atom *p1) +{ + int m, n; + uint32_t c; + struct atom *PSI, *OPCODE, *PHASE; + + push(cadr(p1)); + evalf(); + PSI = pop(); + + if (!istensor(PSI) || PSI->u.tensor->ndim > 1 || PSI->u.tensor->nelem > 32768 || !POWEROF2(PSI->u.tensor->nelem)) + stopf("rotate error 1 first argument is not a vector or dimension error"); + + c = 0; + + p1 = cddr(p1); + + while (iscons(p1)) { + + if (!iscons(cdr(p1))) + stopf("rotate error 2 unexpected end of argument list"); + + OPCODE = car(p1); + push(cadr(p1)); + evalf(); + n = pop_integer(); + + if (n > 14 || (1 << n) >= PSI->u.tensor->nelem) + stopf("rotate error 3 qubit number format or range"); + + p1 = cddr(p1); + + if (OPCODE == symbol(C_UPPER)) { + c |= 1 << n; + continue; + } + + if (OPCODE == symbol(H_UPPER)) { + rotate_h(PSI, c, n); + c = 0; + continue; + } + + if (OPCODE == symbol(P_UPPER)) { + if (!iscons(p1)) + stopf("rotate error 2 unexpected end of argument list"); + push(car(p1)); + p1 = cdr(p1); + evalf(); + push(imaginaryunit); + multiply(); + expfunc(); + PHASE = pop(); + rotate_p(PSI, PHASE, c, n); + c = 0; + continue; + } + + if (OPCODE == symbol(Q_UPPER)) { + rotate_q(PSI, n); + c = 0; + continue; + } + + if (OPCODE == symbol(V_UPPER)) { + rotate_v(PSI, n); + c = 0; + continue; + } + + if (OPCODE == symbol(W_UPPER)) { + m = n; + if (!iscons(p1)) + stopf("rotate error 2 unexpected end of argument list"); + push(car(p1)); + p1 = cdr(p1); + evalf(); + n = pop_integer(); + if (n > 14 || (1 << n) >= PSI->u.tensor->nelem) + stopf("rotate error 3 qubit number format or range"); + rotate_w(PSI, c, m, n); + c = 0; + continue; + } + + if (OPCODE == symbol(X_UPPER)) { + rotate_x(PSI, c, n); + c = 0; + continue; + } + + if (OPCODE == symbol(Y_UPPER)) { + rotate_y(PSI, c, n); + c = 0; + continue; + } + + if (OPCODE == symbol(Z_UPPER)) { + rotate_z(PSI, c, n); + c = 0; + continue; + } + + stopf("rotate error 4 unknown rotation code"); + } + + push(PSI); +} + +// hadamard + +void +rotate_h(struct atom *PSI, uint32_t c, int n) +{ + int i; + n = 1 << n; + for (i = 0; i < NUMQBITS; i++) { + if ((i & c) != c) + continue; + if (i & n) { + push(KET0); + push(KET1); + add(); + push_rational(1, 2); + sqrtfunc(); + multiply(); + push(KET0); + push(KET1); + subtract(); + push_rational(1, 2); + sqrtfunc(); + multiply(); + KET1 = pop(); + KET0 = pop(); + } + } +} + +// phase + +void +rotate_p(struct atom *PSI, struct atom *PHASE, uint32_t c, int n) +{ + int i; + n = 1 << n; + for (i = 0; i < NUMQBITS; i++) { + if ((i & c) != c) + continue; + if (i & n) { + push(KET1); + push(PHASE); + multiply(); + KET1 = pop(); + } + } +} + +// swap + +void +rotate_w(struct atom *PSI, uint32_t c, int m, int n) +{ + int i; + m = 1 << m; + n = 1 << n; + for (i = 0; i < NUMQBITS; i++) { + if ((i & c) != c) + continue; + if ((i & m) && !(i & n)) { + push(PSI->u.tensor->elem[i]); + push(PSI->u.tensor->elem[i ^ m ^ n]); + PSI->u.tensor->elem[i] = pop(); + PSI->u.tensor->elem[i ^ m ^ n] = pop(); + } + } +} + +void +rotate_x(struct atom *PSI, uint32_t c, int n) +{ + int i; + n = 1 << n; + for (i = 0; i < NUMQBITS; i++) { + if ((i & c) != c) + continue; + if (i & n) { + push(KET0); + push(KET1); + KET0 = pop(); + KET1 = pop(); + } + } +} + +void +rotate_y(struct atom *PSI, uint32_t c, int n) +{ + int i; + n = 1 << n; + for (i = 0; i < NUMQBITS; i++) { + if ((i & c) != c) + continue; + if (i & n) { + push(imaginaryunit); + push(KET0); + multiply(); + push(imaginaryunit); + negate(); + push(KET1); + multiply(); + KET0 = pop(); + KET1 = pop(); + } + } +} + +void +rotate_z(struct atom *PSI, uint32_t c, int n) +{ + int i; + n = 1 << n; + for (i = 0; i < NUMQBITS; i++) { + if ((i & c) != c) + continue; + if (i & n) { + push(KET1); + negate(); + KET1 = pop(); + } + } +} + +// quantum fourier transform + +void +rotate_q(struct atom *PSI, int n) +{ + int i, j; + struct atom *PHASE; + for (i = n; i >= 0; i--) { + rotate_h(PSI, 0, i); + for (j = 0; j < i; j++) { + push_rational(1, 2); + push_integer(i - j); + power(); + push(imaginaryunit); + push_symbol(PI); + evalf(); // in case PI is numerical + multiply_factors(3); + expfunc(); + PHASE = pop(); + rotate_p(PSI, PHASE, 1 << j, i); + } + } + for (i = 0; i < (n + 1) / 2; i++) + rotate_w(PSI, 0, i, n - i); +} + +// inverse qft + +void +rotate_v(struct atom *PSI, int n) +{ + int i, j; + struct atom *PHASE; + for (i = 0; i < (n + 1) / 2; i++) + rotate_w(PSI, 0, i, n - i); + for (i = 0; i <= n; i++) { + for (j = i - 1; j >= 0; j--) { + push_rational(1, 2); + push_integer(i - j); + power(); + push(imaginaryunit); + push_symbol(PI); + evalf(); // in case PI is numerical + multiply_factors(3); + negate(); + expfunc(); + PHASE = pop(); + rotate_p(PSI, PHASE, 1 << j, i); + } + rotate_h(PSI, 0, i); + } +} +void +eval_run(struct atom *p1) +{ + char *buf; + struct atom *p2; + + push(cadr(p1)); + evalf(); + p1 = pop(); + if (!isstr(p1)) + stopf("run: file name expected"); + + p2 = alloc_str(); + buf = read_file(p1->u.str); + if (buf == NULL) + stopf("run: cannot read file"); + p2->u.str = buf; + + push(p2); // make visible to garbage collector + run_buf(buf); + pop(); // buf is freed on next gc + + push_symbol(NIL); // return value +} + +char * +read_file(char *filename) +{ + int fd, n; + char *buf; + off_t t; + + fd = open(filename, O_RDONLY); + + if (fd < 0) + return NULL; + + t = lseek(fd, 0, SEEK_END); + + if (t < 0 || t > 0x1000000) { // 16 MB max + close(fd); + return NULL; + } + + if (lseek(fd, 0, SEEK_SET)) { + close(fd); + return NULL; + } + + n = (int) t; + + buf = malloc(n + 1); + + if (buf == NULL) { + close(fd); + return NULL; + } + + if (read(fd, buf, n) != n) { + free(buf); + close(fd); + return NULL; + } + + close(fd); + + buf[n] = '\0'; + + return buf; +} +void +eval_setq(struct atom *p1) +{ + struct atom *p2; + + push_symbol(NIL); // return value + + if (caadr(p1) == symbol(INDEX)) { + setq_indexed(p1); + return; + } + + if (iscons(cadr(p1))) { + setq_usrfunc(p1); + return; + } + + if (!isusersymbol(cadr(p1))) + stopf("user symbol expected"); + + push(caddr(p1)); + evalg(); + p2 = pop(); + + set_symbol(cadr(p1), p2, symbol(NIL)); +} + +// Example: a[1] = b +// +// p1----->cons--->cons------------------->cons +// | | | +// setq cons--->cons--->cons b +// | | | +// index a 1 +// +// caadr(p1) = index +// cadadr(p1) = a +// caddr(p1) = b + +void +setq_indexed(struct atom *p1) +{ + int h; + struct atom *S, *LVAL, *RVAL; + + S = cadadr(p1); + + if (!isusersymbol(S)) + stopf("user symbol expected"); + + push(S); + evalg(); + + push(caddr(p1)); + evalg(); + + RVAL = pop(); + LVAL = pop(); + + // eval indices + + p1 = cddadr(p1); + + h = tos; + + while (iscons(p1)) { + push(car(p1)); + evalf(); + p1 = cdr(p1); + } + + set_component(LVAL, RVAL, h); + + set_symbol(S, LVAL, symbol(NIL)); +} + +void +set_component(struct atom *LVAL, struct atom *RVAL, int h) +{ + int i, k, m, n, t; + + if (!istensor(LVAL)) + stopf("index error"); + + // n is the number of indices + + n = tos - h; + + if (n < 1 || n > LVAL->u.tensor->ndim) + stopf("index error"); + + // k is the combined index + + k = 0; + + for (i = 0; i < n; i++) { + push(stack[h + i]); + t = pop_integer(); + if (t < 1 || t > LVAL->u.tensor->dim[i]) + stopf("index error"); + k = k * LVAL->u.tensor->dim[i] + t - 1; + } + + tos = h; // pop all + + if (istensor(RVAL)) { + m = RVAL->u.tensor->ndim; + if (n + m != LVAL->u.tensor->ndim) + stopf("index error"); + for (i = 0; i < m; i++) + if (LVAL->u.tensor->dim[n + i] != RVAL->u.tensor->dim[i]) + stopf("index error"); + m = RVAL->u.tensor->nelem; + for (i = 0; i < m; i++) + LVAL->u.tensor->elem[m * k + i] = RVAL->u.tensor->elem[i]; + } else { + if (n != LVAL->u.tensor->ndim) + stopf("index error"); + LVAL->u.tensor->elem[k] = RVAL; + } +} + +// Example: +// +// f(x,y)=x^y +// +// For this definition, p1 points to the following structure. +// +// p1 +// | +// ___v__ ______ ______ +// |CONS |->|CONS |--------------------->|CONS | +// |______| |______| |______| +// | | | +// ___v__ ___v__ ______ ______ ___v__ ______ ______ +// |SETQ | |CONS |->|CONS |->|CONS | |CONS |->|CONS |->|CONS | +// |______| |______| |______| |______| |______| |______| |______| +// | | | | | | +// ___v__ ___v__ ___v__ ___v__ ___v__ ___v__ +// |SYM f | |SYM x | |SYM y | |POWER | |SYM x | |SYM y | +// |______| |______| |______| |______| |______| |______| +// +// We have +// +// caadr(p1) points to f +// cdadr(p1) points to the list (x y) +// caddr(p1) points to (power x y) + +void +setq_usrfunc(struct atom *p1) +{ + struct atom *F, *A, *B, *C; + + F = caadr(p1); + A = cdadr(p1); + B = caddr(p1); + + if (!isusersymbol(F)) + stopf("user symbol expected"); + + if (lengthf(A) > 9) + stopf("more than 9 arguments"); + + push(B); + convert_body(A); + C = pop(); + + set_symbol(F, B, C); +} + +void +convert_body(struct atom *A) +{ + if (!iscons(A)) + return; + + push(car(A)); + push_symbol(ARG1); + subst(); + + A = cdr(A); + if (!iscons(A)) + return; + + push(car(A)); + push_symbol(ARG2); + subst(); + + A = cdr(A); + if (!iscons(A)) + return; + + push(car(A)); + push_symbol(ARG3); + subst(); + + A = cdr(A); + if (!iscons(A)) + return; + + push(car(A)); + push_symbol(ARG4); + subst(); + + A = cdr(A); + if (!iscons(A)) + return; + + push(car(A)); + push_symbol(ARG5); + subst(); + + A = cdr(A); + + if (!iscons(A)) + return; + + push(car(A)); + push_symbol(ARG6); + subst(); + + A = cdr(A); + if (!iscons(A)) + return; + + push(car(A)); + push_symbol(ARG7); + subst(); + + A = cdr(A); + if (!iscons(A)) + return; + + push(car(A)); + push_symbol(ARG8); + subst(); + + A = cdr(A); + if (!iscons(A)) + return; + + push(car(A)); + push_symbol(ARG9); + subst(); +} +// first author: github.com/phbillet + +void +eval_sgn(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + sgnfunc(); +} + +void +sgnfunc(void) +{ + int i, n; + struct atom *p1, *p2; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + sgnfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + p2 = p1; + + if (!isnum(p2)) { + push(p2); + floatfunc(); + p2 = pop(); + } + + if (!isnum(p2)) { + push_symbol(SGN); + push(p1); + list(2); + return; + } + + if (iszero(p2)) { + push_integer(0); + return; + } + + if (isnegativenumber(p2)) + push_integer(-1); + else + push_integer(1); +} +void +eval_simplify(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + simplify(); +} + +void +simplify(void) +{ + int i, n; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + simplify(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + simplify_trig(); // do this first otherwise compton-demo runs out of memory + simplify_nib(); +} + +void +simplify_nib(void) +{ + int h; + struct atom *p1, *p2, *p3, *NUM, *DEN, *R; + + p1 = pop(); + + if (!iscons(p1)) { + push(p1); + return; + } + + push(p1); + rect(); + p2 = pop(); + push(p1); + polar(); + p3 = pop(); + if (simpler(p3, p2)) + p2 = p3; + if (simpler(p2, p1)) + p1 = p2; + + if (!iscons(p1)) { + push(p1); + return; + } + + push(p1); + expform(); + rect(); + p2 = pop(); + if (simpler(p2, p1)) + p1 = p2; + + if (!iscons(p1)) { + push(p1); + return; + } + + // depth first + + h = tos; + push(car(p1)); // function name + p1 = cdr(p1); + while (iscons(p1)) { + push(car(p1)); + simplify_nib(); + p1 = cdr(p1); + } + list(tos - h); + evalf(); // normalize + p1 = pop(); + + if (!iscons(p1)) { + push(p1); + return; + } + + push(p1); + numden(); + NUM = pop(); + DEN = pop(); + + // NUM / DEN = A / (B / C) = A C / B + + // for example, 1 / (x + y^2 / x) -> x / (x^2 + y^2) + + push(DEN); + numden(); + DEN = pop(); + push(NUM); + multiply(); + NUM = pop(); + + // search for R such that NUM = R DEN + + if (car(NUM) == symbol(ADD) && car(DEN) == symbol(ADD)) { + + p2 = cdr(DEN); + + while (iscons(p2)) { + + // provisional ratio + + push(cadr(NUM)); // 1st term of numerator + push(car(p2)); + divide(); + R = pop(); + + // check + + push(NUM); + push(R); + push(DEN); + multiply(); + subtract(); + p3 = pop(); + + if (iszero(p3)) { + push(R); + return; + } + + p2 = cdr(p2); + } + } + + push(NUM); + push(DEN); + divide(); + p2 = pop(); + if (simpler(p2, p1)) { + push(p2); + return; + } + + push(DEN); + push(NUM); + divide(); + rationalize(); + reciprocate(); + p2 = pop(); + if (simpler(p2, p1)) { + push(p2); + return; + } + + push(p1); +} + +// try exponential form + +void +simplify_trig(void) +{ + struct atom *p1, *p2; + + p1 = pop(); + + if (!iscons(p1)) { + push(p1); + return; + } + + push(p1); + expform(); + numden(); + swap(); + divide(); + p2 = pop(); + + if (simpler(p2, p1)) + push(p2); + else + push(p1); +} + +int +simpler(struct atom *p1, struct atom *p2) +{ + int d1, d2; + + d1 = diameter(p1); + d2 = diameter(p2); + + if (d1 == d2) { + d1 = mass(p1); + d2 = mass(p2); + } + + return d1 < d2; +} + +// for example, 1 / (x + y^2 / x) has diameter of 2 + +int +diameter(struct atom *p) +{ + int max = 0, n; + + if (car(p) == symbol(POWER) && isnegativenumber(caddr(p))) + return 1 + diameter(cadr(p)); + + while (iscons(p)) { + n = diameter(car(p)); + if (n > max) + max = n; + p = cdr(p); + } + + return max; +} + +int +mass(struct atom *p) +{ + int n = 1; + while (iscons(p)) { + n += mass(car(p)); + p = cdr(p); + } + return n; +} +void +eval_sin(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + sinfunc(); +} + +void +sinfunc(void) +{ + int i, n; + double d; + struct atom *p1, *p2, *X, *Y; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + sinfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = sin(d); + push_double(d); + return; + } + + // sin(z) = -i/2 exp(i z) + i/2 exp(-i z) + + if (isdoublez(p1)) { + push_double(-0.5); + push(imaginaryunit); + multiply(); + push(imaginaryunit); + push(p1); + multiply(); + expfunc(); + push(imaginaryunit); + negate(); + push(p1); + multiply(); + expfunc(); + subtract(); + multiply(); + return; + } + + // sin(-x) = -sin(x) + + if (isnegativeterm(p1)) { + push(p1); + negate(); + sinfunc(); + negate(); + return; + } + + if (car(p1) == symbol(ADD)) { + sinfunc_sum(p1); + return; + } + + // sin(arctan(y,x)) = y (x^2 + y^2)^(-1/2) + + if (car(p1) == symbol(ARCTAN)) { + X = caddr(p1); + Y = cadr(p1); + push(Y); + push(X); + push(X); + multiply(); + push(Y); + push(Y); + multiply(); + add(); + push_rational(-1, 2); + power(); + multiply(); + return; + } + + // sin(arccos(x)) = sqrt(1 - x^2) + + if (car(p1) == symbol(ARCCOS)) { + push_integer(1); + push(cadr(p1)); + push_integer(2); + power(); + subtract(); + push_rational(1, 2); + power(); + return; + } + + // n pi ? + + push(p1); + push_symbol(PI); + divide(); + p2 = pop(); + + if (!isnum(p2)) { + push_symbol(SIN); + push(p1); + list(2); + return; + } + + if (isdouble(p2)) { + push(p2); + d = pop_double(); + d = sin(d * M_PI); + push_double(d); + return; + } + + push(p2); // nonnegative by sin(-x) = -sin(x) above + push_integer(180); + multiply(); + p2 = pop(); + + if (!isinteger(p2)) { + push_symbol(SIN); + push(p1); + list(2); + return; + } + + push(p2); + push_integer(360); + modfunc(); + n = pop_integer(); + + switch (n) { + case 0: + case 180: + push_integer(0); + break; + case 30: + case 150: + push_rational(1, 2); + break; + case 210: + case 330: + push_rational(-1, 2); + break; + case 45: + case 135: + push_rational(1, 2); + push_integer(2); + push_rational(1, 2); + power(); + multiply(); + break; + case 225: + case 315: + push_rational(-1, 2); + push_integer(2); + push_rational(1, 2); + power(); + multiply(); + break; + case 60: + case 120: + push_rational(1, 2); + push_integer(3); + push_rational(1, 2); + power(); + multiply(); + break; + case 240: + case 300: + push_rational(-1, 2); + push_integer(3); + push_rational(1, 2); + power(); + multiply(); + break; + case 90: + push_integer(1); + break; + case 270: + push_integer(-1); + break; + default: + push_symbol(SIN); + push(p1); + list(2); + break; + } +} + +// sin(x + n/2 pi) = sin(x) cos(n/2 pi) + cos(x) sin(n/2 pi) + +void +sinfunc_sum(struct atom *p1) +{ + struct atom *p2, *p3; + p2 = cdr(p1); + while (iscons(p2)) { + push_integer(2); + push(car(p2)); + multiply(); + push_symbol(PI); + divide(); + p3 = pop(); + if (isinteger(p3)) { + push(p1); + push(car(p2)); + subtract(); + p3 = pop(); + push(p3); + sinfunc(); + push(car(p2)); + cosfunc(); + multiply(); + push(p3); + cosfunc(); + push(car(p2)); + sinfunc(); + multiply(); + add(); + return; + } + p2 = cdr(p2); + } + push_symbol(SIN); + push(p1); + list(2); +} +void +eval_sinh(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + sinhfunc(); +} + +void +sinhfunc(void) +{ + int i, n; + double d; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + sinhfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = sinh(d); + push_double(d); + return; + } + + // sinh(z) = 1/2 exp(z) - 1/2 exp(-z) + + if (isdoublez(p1)) { + push_rational(1, 2); + push(p1); + expfunc(); + push(p1); + negate(); + expfunc(); + subtract(); + multiply(); + return; + } + + if (iszero(p1)) { + push_integer(0); + return; + } + + // sinh(-x) -> -sinh(x) + + if (isnegativeterm(p1)) { + push(p1); + negate(); + sinhfunc(); + negate(); + return; + } + + if (car(p1) == symbol(ARCSINH)) { + push(cadr(p1)); + return; + } + + push_symbol(SINH); + push(p1); + list(2); +} +void +eval_sqrt(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + sqrtfunc(); +} + +void +sqrtfunc(void) +{ + push_rational(1, 2); + power(); +} +void +eval_status(struct atom *p1) +{ + (void) p1; // silence compiler + + outbuf_init(); + + snprintf(strbuf, STRBUFLEN, "block_count %d (%d%%)\n", block_count, 100 * block_count / MAXBLOCKS); + outbuf_puts(strbuf); + + snprintf(strbuf, STRBUFLEN, "free_count %d\n", free_count); + outbuf_puts(strbuf); + + snprintf(strbuf, STRBUFLEN, "gc_count %d\n", gc_count); + outbuf_puts(strbuf); + + snprintf(strbuf, STRBUFLEN, "bignum_count %d\n", bignum_count); + outbuf_puts(strbuf); + + snprintf(strbuf, STRBUFLEN, "ksym_count %d\n", ksym_count); + outbuf_puts(strbuf); + + snprintf(strbuf, STRBUFLEN, "usym_count %d\n", usym_count); + outbuf_puts(strbuf); + + snprintf(strbuf, STRBUFLEN, "string_count %d\n", string_count); + outbuf_puts(strbuf); + + snprintf(strbuf, STRBUFLEN, "tensor_count %d\n", tensor_count); + outbuf_puts(strbuf); + + snprintf(strbuf, STRBUFLEN, "max_eval_level %d\n", max_eval_level); + outbuf_puts(strbuf); + + snprintf(strbuf, STRBUFLEN, "max_tos %d (%d%%)\n", max_tos, 100 * max_tos / STACKSIZE); + outbuf_puts(strbuf); + + printbuf(outbuf, BLACK); + + push_symbol(NIL); +} +void +eval_stop(struct atom *p1) +{ + (void) p1; // silence compiler + stopf("stop function"); +} +void +eval_sum(struct atom *p1) +{ + int h, i, j, k, n; + struct atom *p2, *p3; + + // sum over tensor elements? + + if (lengthf(p1) == 2) { + push(cadr(p1)); + evalf(); + p1 = pop(); + if (!istensor(p1)) { + push(p1); + return; + } + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) + push(p1->u.tensor->elem[i]); + add_terms(n); + return; + } + + p2 = cadr(p1); + if (!isusersymbol(p2)) + stopf("sum: index symbol err"); + + push(caddr(p1)); + evalf(); + p3 = pop(); + if (!issmallinteger(p3)) + stopf("sum: index range err"); + push(p3); + j = pop_integer(); + + push(cadddr(p1)); + evalf(); + p3 = pop(); + if (!issmallinteger(p3)) + stopf("sum: index range err"); + push(p3); + k = pop_integer(); + + p1 = caddddr(p1); + + save_symbol(p2); + + h = tos; + + for (;;) { + push_integer(j); + p3 = pop(); + set_symbol(p2, p3, symbol(NIL)); + push(p1); + evalg(); + if (j == k) + break; + if (j < k) + j++; + else + j--; + if (tos - h == 1000) + add_terms(1000); // to prevent stack overflow + } + + add_terms(tos - h); + + p1 = pop(); + restore_symbol(); + push(p1); +} +void +eval_tan(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + tanfunc(); +} + +void +tanfunc(void) +{ + int i, n; + double d; + struct atom *p1, *p2; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + tanfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = tan(d); + push_double(d); + return; + } + + if (isdoublez(p1)) { + push(p1); + sinfunc(); + push(p1); + cosfunc(); + divide(); + return; + } + + // tan(-x) = -tan(x) + + if (isnegativeterm(p1)) { + push(p1); + negate(); + tanfunc(); + negate(); + return; + } + + if (car(p1) == symbol(ADD)) { + tanfunc_sum(p1); + return; + } + + if (car(p1) == symbol(ARCTAN)) { + push(cadr(p1)); + push(caddr(p1)); + divide(); + return; + } + + // n pi ? + + push(p1); + push_symbol(PI); + divide(); + p2 = pop(); + + if (!isnum(p2)) { + push_symbol(TAN); + push(p1); + list(2); + return; + } + + if (isdouble(p2)) { + push(p2); + d = pop_double(); + d = tan(d * M_PI); + push_double(d); + return; + } + + push(p2); // nonnegative by tan(-x) = -tan(x) above + push_integer(180); + multiply(); + p2 = pop(); + + if (!isinteger(p2)) { + push_symbol(TAN); + push(p1); + list(2); + return; + } + + push(p2); + push_integer(360); + modfunc(); + n = pop_integer(); + + switch (n) { + case 0: + case 180: + push_integer(0); + break; + case 30: + case 210: + push_rational(1, 3); + push_integer(3); + push_rational(1, 2); + power(); + multiply(); + break; + case 150: + case 330: + push_rational(-1, 3); + push_integer(3); + push_rational(1, 2); + power(); + multiply(); + break; + case 45: + case 225: + push_integer(1); + break; + case 135: + case 315: + push_integer(-1); + break; + case 60: + case 240: + push_integer(3); + push_rational(1, 2); + power(); + break; + case 120: + case 300: + push_integer(3); + push_rational(1, 2); + power(); + negate(); + break; + default: + push_symbol(TAN); + push(p1); + list(2); + break; + } +} + +// tan(x + n pi) = tan(x) + +void +tanfunc_sum(struct atom *p1) +{ + struct atom *p2, *p3; + p2 = cdr(p1); + while (iscons(p2)) { + push(car(p2)); + push_symbol(PI); + divide(); + p3 = pop(); + if (isinteger(p3)) { + push(p1); + push(car(p2)); + subtract(); + tanfunc(); + return; + } + p2 = cdr(p2); + } + push_symbol(TAN); + push(p1); + list(2); +} +void +eval_tanh(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + tanhfunc(); +} + +void +tanhfunc(void) +{ + int i, n; + double d; + struct atom *p1; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + tanhfunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + if (isdouble(p1)) { + push(p1); + d = pop_double(); + d = tanh(d); + push_double(d); + return; + } + + if (isdoublez(p1)) { + push(p1); + sinhfunc(); + push(p1); + coshfunc(); + divide(); + return; + } + + if (iszero(p1)) { + push_integer(0); + return; + } + + // tanh(-x) = -tanh(x) + + if (isnegativeterm(p1)) { + push(p1); + negate(); + tanhfunc(); + negate(); + return; + } + + if (car(p1) == symbol(ARCTANH)) { + push(cadr(p1)); + return; + } + + push_symbol(TANH); + push(p1); + list(2); +} +void +eval_taylor(struct atom *p1) +{ + int h, i, n; + struct atom *F, *X, *A, *C; + + push(cadr(p1)); + evalf(); + F = pop(); + + push(caddr(p1)); + evalf(); + X = pop(); + + push(cadddr(p1)); + evalf(); + n = pop_integer(); + + p1 = cddddr(p1); + + if (iscons(p1)) { + push(car(p1)); + evalf(); + } else + push_integer(0); // default expansion point + + A = pop(); + + h = tos; + + push(F); // f(a) + push(X); + push(A); + subst(); + evalf(); + + push_integer(1); + C = pop(); + + for (i = 1; i <= n; i++) { + + push(F); // f = f' + push(X); + derivative(); + F = pop(); + + if (findf(F, symbol(DERIVATIVE))) + stopf("taylor: derivative err"); + + if (iszero(F)) + break; + + push(C); // c = c * (x - a) + push(X); + push(A); + subtract(); + multiply(); + C = pop(); + + push(F); // f(a) + push(X); + push(A); + subst(); + evalf(); + + push(C); + multiply(); + push_integer(i); + factorial(); + divide(); + } + + add_terms(tos - h); +} +void +eval_tensor(struct atom *p1) +{ + int i; + + p1 = copy_tensor(p1); + + for (i = 0; i < p1->u.tensor->nelem; i++) { + push(p1->u.tensor->elem[i]); + evalf(); + p1->u.tensor->elem[i] = pop(); + } + + push(p1); + + promote_tensor(); +} + +// tensors with elements that are also tensors get promoted to a higher rank + +void +promote_tensor(void) +{ + int i, j, k, ndim1, ndim2, nelem1, nelem2; + struct atom *p1, *p2, *p3; + + p1 = pop(); + + if (!istensor(p1)) { + push(p1); + return; + } + + ndim1 = p1->u.tensor->ndim; + nelem1 = p1->u.tensor->nelem; + + // check + + p2 = p1->u.tensor->elem[0]; + + for (i = 1; i < nelem1; i++) { + p3 = p1->u.tensor->elem[i]; + if (!compatible_dimensions(p2, p3)) + stopf("tensor dimensions"); + } + + if (!istensor(p2)) { + push(p1); + return; // all elements are scalars + } + + ndim2 = p2->u.tensor->ndim; + nelem2 = p2->u.tensor->nelem; + + if (ndim1 + ndim2 > MAXDIM) + stopf("rank exceeds max"); + + // alloc + + p3 = alloc_tensor(nelem1 * nelem2); + + // merge dimensions + + k = 0; + + for (i = 0; i < ndim1; i++) + p3->u.tensor->dim[k++] = p1->u.tensor->dim[i]; + + for (i = 0; i < ndim2; i++) + p3->u.tensor->dim[k++] = p2->u.tensor->dim[i]; + + p3->u.tensor->ndim = ndim1 + ndim2; + + // merge elements + + k = 0; + + for (i = 0; i < nelem1; i++) { + p2 = p1->u.tensor->elem[i]; + for (j = 0; j < nelem2; j++) + p3->u.tensor->elem[k++] = p2->u.tensor->elem[j]; + } + + push(p3); +} + +int +compatible_dimensions(struct atom *p, struct atom *q) +{ + int i, n; + + if (!istensor(p) && !istensor(q)) + return 1; // both p and q are scalars + + if (!istensor(p) || !istensor(q)) + return 0; // scalar and tensor + + n = p->u.tensor->ndim; + + if (n != q->u.tensor->ndim) + return 0; + + for (i = 0; i < n; i++) + if (p->u.tensor->dim[i] != q->u.tensor->dim[i]) + return 0; + + return 1; +} + +struct atom * +copy_tensor(struct atom *p1) +{ + int i; + struct atom *p2; + + p2 = alloc_tensor(p1->u.tensor->nelem); + + p2->u.tensor->ndim = p1->u.tensor->ndim; + + for (i = 0; i < p1->u.tensor->ndim; i++) + p2->u.tensor->dim[i] = p1->u.tensor->dim[i]; + + for (i = 0; i < p1->u.tensor->nelem; i++) + p2->u.tensor->elem[i] = p1->u.tensor->elem[i]; + + return p2; +} +void +eval_test(struct atom *p1) +{ + struct atom *p2; + p1 = cdr(p1); + while (iscons(p1)) { + if (!iscons(cdr(p1))) { + push(car(p1)); // default case + evalf(); + return; + } + push(car(p1)); + evalp(); + p2 = pop(); + if (!iszero(p2)) { + push(cadr(p1)); + evalf(); + return; + } + p1 = cddr(p1); + } + push_symbol(NIL); +} + +void +eval_testeq(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + push(caddr(p1)); + evalf(); + subtract(); + simplify(); + p1 = pop(); + if (iszero(p1)) + push_integer(1); + else + push_integer(0); +} + +void +eval_testge(struct atom *p1) +{ + if (cmp_args(p1) >= 0) + push_integer(1); + else + push_integer(0); +} + +void +eval_testgt(struct atom *p1) +{ + if (cmp_args(p1) > 0) + push_integer(1); + else + push_integer(0); +} + +void +eval_testle(struct atom *p1) +{ + if (cmp_args(p1) <= 0) + push_integer(1); + else + push_integer(0); +} + +void +eval_testlt(struct atom *p1) +{ + if (cmp_args(p1) < 0) + push_integer(1); + else + push_integer(0); +} + +int +cmp_args(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + push(caddr(p1)); + evalf(); + subtract(); + floatfunc(); + p1 = pop(); + if (iszero(p1)) + return 0; + if (!isnum(p1)) + stopf("arithmetic comparison: not a number"); + if (isnegativenumber(p1)) + return -1; + else + return 1; +} +void +eval_tgamma(struct atom *p1) +{ + push(cadr(p1)); + evalf(); + tgammafunc(); +} + +void +tgammafunc(void) +{ + int i, n; + double d; + struct atom *p1, *p2; + + p1 = pop(); + + if (istensor(p1)) { + p1 = copy_tensor(p1); + n = p1->u.tensor->nelem; + for (i = 0; i < n; i++) { + push(p1->u.tensor->elem[i]); + tgammafunc(); + p1->u.tensor->elem[i] = pop(); + } + push(p1); + return; + } + + push(p1); + floatfunc(); + p2 = pop(); + + if (isnum(p2)) { + push(p2); + d = pop_double(); + d = tgamma(d); + push_double(d); + return; + } + + push_symbol(TGAMMA); + push(p1); + list(2); +} +void +eval_transpose(struct atom *p1) +{ + int m, n; + struct atom *p2; + + push(cadr(p1)); + evalf(); + p2 = pop(); + push(p2); + + if (!istensor(p2) || p2->u.tensor->ndim < 2) + return; + + p1 = cddr(p1); + + if (!iscons(p1)) { + transpose(1, 2); + return; + } + + while (iscons(p1)) { + + push(car(p1)); + evalf(); + n = pop_integer(); + + push(cadr(p1)); + evalf(); + m = pop_integer(); + + transpose(n, m); + + p1 = cddr(p1); + } +} + +void +transpose(int n, int m) +{ + int i, j, k, ndim, nelem; + int index[MAXDIM]; + struct atom *p1, *p2; + + p1 = pop(); + + ndim = p1->u.tensor->ndim; + nelem = p1->u.tensor->nelem; + + if (n < 1 || n > ndim || m < 1 || m > ndim) + stopf("transpose: index error"); + + n--; // make zero based + m--; + + p2 = copy_tensor(p1); + + // interchange indices n and m + + p2->u.tensor->dim[n] = p1->u.tensor->dim[m]; + p2->u.tensor->dim[m] = p1->u.tensor->dim[n]; + + for (i = 0; i < ndim; i++) + index[i] = 0; + + for (i = 0; i < nelem; i++) { + + k = 0; + + for (j = 0; j < ndim; j++) { + if (j == n) + k = k * p1->u.tensor->dim[m] + index[m]; + else if (j == m) + k = k * p1->u.tensor->dim[n] + index[n]; + else + k = k * p1->u.tensor->dim[j] + index[j]; + } + + p2->u.tensor->elem[k] = p1->u.tensor->elem[i]; + + // increment index + + for (j = ndim - 1; j >= 0; j--) { + if (++index[j] < p1->u.tensor->dim[j]) + break; + index[j] = 0; + } + } + + push(p2); +} +void +eval_unit(struct atom *p1) +{ + int i, j, n; + + push(cadr(p1)); + evalf(); + + n = pop_integer(); + + if (n < 1) + stopf("unit: index err"); + + if (n == 1) { + push_integer(1); + return; + } + + p1 = alloc_matrix(n, n); + + for (i = 0; i < n; i++) + for (j = 0; j < n; j++) + if (i == j) + p1->u.tensor->elem[n * i + j] = one; + else + p1->u.tensor->elem[n * i + j] = zero; + + push(p1); +} +void +eval_user_function(struct atom *p1) +{ + int h, i; + struct atom *FUNC_NAME, *FUNC_ARGS, *FUNC_DEFN; + + FUNC_NAME = car(p1); + FUNC_ARGS = cdr(p1); + + FUNC_DEFN = get_usrfunc(FUNC_NAME); + + // undefined function? + + if (FUNC_DEFN == symbol(NIL)) { + if (FUNC_NAME == symbol(D_LOWER)) { + expanding++; + eval_derivative(p1); + expanding--; + return; + } + h = tos; + push(FUNC_NAME); + while (iscons(FUNC_ARGS)) { + push(car(FUNC_ARGS)); + evalg(); + FUNC_ARGS = cdr(FUNC_ARGS); + } + list(tos - h); + return; + } + + save_symbol(symbol(ARG1)); + save_symbol(symbol(ARG2)); + save_symbol(symbol(ARG3)); + save_symbol(symbol(ARG4)); + save_symbol(symbol(ARG5)); + save_symbol(symbol(ARG6)); + save_symbol(symbol(ARG7)); + save_symbol(symbol(ARG8)); + save_symbol(symbol(ARG9)); + + push(FUNC_DEFN); // make visible to garbage collector + + // eval all args before changing bindings + + for (i = 0; i < 9; i++) { + push(car(FUNC_ARGS)); + evalg(); + FUNC_ARGS = cdr(FUNC_ARGS); + } + + set_symbol(symbol(ARG9), pop(), symbol(NIL)); + set_symbol(symbol(ARG8), pop(), symbol(NIL)); + set_symbol(symbol(ARG7), pop(), symbol(NIL)); + set_symbol(symbol(ARG6), pop(), symbol(NIL)); + set_symbol(symbol(ARG5), pop(), symbol(NIL)); + set_symbol(symbol(ARG4), pop(), symbol(NIL)); + set_symbol(symbol(ARG3), pop(), symbol(NIL)); + set_symbol(symbol(ARG2), pop(), symbol(NIL)); + set_symbol(symbol(ARG1), pop(), symbol(NIL)); + + evalg(); // eval FUNC_DEFN + + p1 = pop(); + restore_symbol(); + restore_symbol(); + restore_symbol(); + restore_symbol(); + restore_symbol(); + restore_symbol(); + restore_symbol(); + restore_symbol(); + restore_symbol(); + push(p1); +} +void +eval_user_symbol(struct atom *p1) +{ + struct atom *p2; + p2 = get_binding(p1); + if (p1 == p2) + push(p1); // symbol evaluates to itself + else { + push(p2); // evaluate symbol binding + evalg(); + } +} +void +eval_zero(struct atom *p1) +{ + int h, i, m, n; + + p1 = cdr(p1); + h = tos; + m = 1; + + while (iscons(p1)) { + push(car(p1)); + evalf(); + dupl(); + n = pop_integer(); + if (n < 2) + stopf("zero: dim err"); + m *= n; + p1 = cdr(p1); + } + + n = tos - h; + + if (n == 0) { + push_integer(0); // scalar zero + return; + } + + if (n > MAXDIM) + stopf("zero: rank err"); + + p1 = alloc_tensor(m); + + for (i = 0; i < m; i++) + p1->u.tensor->elem[i] = zero; + + // dim info + + p1->u.tensor->ndim = n; + + for (i = 0; i < n; i++) + p1->u.tensor->dim[n - i - 1] = pop_integer(); + + push(p1); +} +// factors N or N^M where N and M are rational numbers, returns factors on stack + +void +factor_factor(void) +{ + uint32_t *numer, *denom; + struct atom *INPUT, *BASE, *EXPO; + + INPUT = pop(); + + if (car(INPUT) == symbol(POWER)) { + + BASE = cadr(INPUT); + EXPO = caddr(INPUT); + + if (!isrational(BASE) || !isrational(EXPO)) { + push(INPUT); // cannot factor + return; + } + + if (isminusone(BASE)) { + push(INPUT); // -1 to the M + return; + } + + if (isnegativenumber(BASE)) { + push_symbol(POWER); + push_integer(-1); + push(EXPO); + list(3); // leave on stack + } + + numer = BASE->u.q.a; + denom = BASE->u.q.b; + + if (!MEQUAL(numer, 1)) + factor_bignum(numer, EXPO); + + if (!MEQUAL(denom, 1)) { + // flip sign of exponent + push(EXPO); + negate(); + EXPO = pop(); + factor_bignum(denom, EXPO); + } + + return; + } + + if (!isrational(INPUT) || iszero(INPUT) || isplusone(INPUT) || isminusone(INPUT)) { + push(INPUT); + return; + } + + if (isnegativenumber(INPUT)) + push_integer(-1); + + numer = INPUT->u.q.a; + denom = INPUT->u.q.b; + + if (!MEQUAL(numer, 1)) + factor_bignum(numer, one); + + if (!MEQUAL(denom, 1)) + factor_bignum(denom, minusone); +} + +// factor N, raise each factor to the power M + +void +factor_bignum(uint32_t *N, struct atom *M) +{ + int h, i, n; + struct atom *BASE, *EXPO; + + // greater than 31 bits? + + if (MLENGTH(N) > 1 || N[0] > 0x7fffffff) { + push_bignum(MPLUS, mcopy(N), mint(1)); + if (isplusone(M)) + return; + push_symbol(POWER); + swap(); + push(M); + list(3); + return; + } + + h = tos; + + n = N[0]; + + factor_int(n); + + n = (tos - h) / 2; // number of factors on stack + + for (i = 0; i < n; i++) { + + BASE = stack[h + 2 * i + 0]; + EXPO = stack[h + 2 * i + 1]; + + push(EXPO); + push(M); + multiply(); + EXPO = pop(); + + if (isplusone(EXPO)) { + stack[h + i] = BASE; + continue; + } + + push_symbol(POWER); + push(BASE); + push(EXPO); + list(3); + stack[h + i] = pop(); + } + + tos = h + n; // pop all +} + +#define NPRIME 4792 + +int primetab[NPRIME] = { +2,3,5,7,11,13,17,19, +23,29,31,37,41,43,47,53, +59,61,67,71,73,79,83,89, +97,101,103,107,109,113,127,131, +137,139,149,151,157,163,167,173, +179,181,191,193,197,199,211,223, +227,229,233,239,241,251,257,263, +269,271,277,281,283,293,307,311, +313,317,331,337,347,349,353,359, +367,373,379,383,389,397,401,409, +419,421,431,433,439,443,449,457, +461,463,467,479,487,491,499,503, +509,521,523,541,547,557,563,569, +571,577,587,593,599,601,607,613, +617,619,631,641,643,647,653,659, +661,673,677,683,691,701,709,719, +727,733,739,743,751,757,761,769, +773,787,797,809,811,821,823,827, +829,839,853,857,859,863,877,881, +883,887,907,911,919,929,937,941, +947,953,967,971,977,983,991,997, +1009,1013,1019,1021,1031,1033,1039,1049, +1051,1061,1063,1069,1087,1091,1093,1097, +1103,1109,1117,1123,1129,1151,1153,1163, +1171,1181,1187,1193,1201,1213,1217,1223, +1229,1231,1237,1249,1259,1277,1279,1283, +1289,1291,1297,1301,1303,1307,1319,1321, +1327,1361,1367,1373,1381,1399,1409,1423, +1427,1429,1433,1439,1447,1451,1453,1459, +1471,1481,1483,1487,1489,1493,1499,1511, +1523,1531,1543,1549,1553,1559,1567,1571, +1579,1583,1597,1601,1607,1609,1613,1619, +1621,1627,1637,1657,1663,1667,1669,1693, +1697,1699,1709,1721,1723,1733,1741,1747, +1753,1759,1777,1783,1787,1789,1801,1811, +1823,1831,1847,1861,1867,1871,1873,1877, +1879,1889,1901,1907,1913,1931,1933,1949, +1951,1973,1979,1987,1993,1997,1999,2003, +2011,2017,2027,2029,2039,2053,2063,2069, +2081,2083,2087,2089,2099,2111,2113,2129, +2131,2137,2141,2143,2153,2161,2179,2203, +2207,2213,2221,2237,2239,2243,2251,2267, +2269,2273,2281,2287,2293,2297,2309,2311, +2333,2339,2341,2347,2351,2357,2371,2377, +2381,2383,2389,2393,2399,2411,2417,2423, +2437,2441,2447,2459,2467,2473,2477,2503, +2521,2531,2539,2543,2549,2551,2557,2579, +2591,2593,2609,2617,2621,2633,2647,2657, +2659,2663,2671,2677,2683,2687,2689,2693, +2699,2707,2711,2713,2719,2729,2731,2741, +2749,2753,2767,2777,2789,2791,2797,2801, +2803,2819,2833,2837,2843,2851,2857,2861, +2879,2887,2897,2903,2909,2917,2927,2939, +2953,2957,2963,2969,2971,2999,3001,3011, +3019,3023,3037,3041,3049,3061,3067,3079, +3083,3089,3109,3119,3121,3137,3163,3167, +3169,3181,3187,3191,3203,3209,3217,3221, +3229,3251,3253,3257,3259,3271,3299,3301, +3307,3313,3319,3323,3329,3331,3343,3347, +3359,3361,3371,3373,3389,3391,3407,3413, +3433,3449,3457,3461,3463,3467,3469,3491, +3499,3511,3517,3527,3529,3533,3539,3541, +3547,3557,3559,3571,3581,3583,3593,3607, +3613,3617,3623,3631,3637,3643,3659,3671, +3673,3677,3691,3697,3701,3709,3719,3727, +3733,3739,3761,3767,3769,3779,3793,3797, +3803,3821,3823,3833,3847,3851,3853,3863, +3877,3881,3889,3907,3911,3917,3919,3923, +3929,3931,3943,3947,3967,3989,4001,4003, +4007,4013,4019,4021,4027,4049,4051,4057, +4073,4079,4091,4093,4099,4111,4127,4129, +4133,4139,4153,4157,4159,4177,4201,4211, +4217,4219,4229,4231,4241,4243,4253,4259, +4261,4271,4273,4283,4289,4297,4327,4337, +4339,4349,4357,4363,4373,4391,4397,4409, +4421,4423,4441,4447,4451,4457,4463,4481, +4483,4493,4507,4513,4517,4519,4523,4547, +4549,4561,4567,4583,4591,4597,4603,4621, +4637,4639,4643,4649,4651,4657,4663,4673, +4679,4691,4703,4721,4723,4729,4733,4751, +4759,4783,4787,4789,4793,4799,4801,4813, +4817,4831,4861,4871,4877,4889,4903,4909, +4919,4931,4933,4937,4943,4951,4957,4967, +4969,4973,4987,4993,4999,5003,5009,5011, +5021,5023,5039,5051,5059,5077,5081,5087, +5099,5101,5107,5113,5119,5147,5153,5167, +5171,5179,5189,5197,5209,5227,5231,5233, +5237,5261,5273,5279,5281,5297,5303,5309, +5323,5333,5347,5351,5381,5387,5393,5399, +5407,5413,5417,5419,5431,5437,5441,5443, +5449,5471,5477,5479,5483,5501,5503,5507, +5519,5521,5527,5531,5557,5563,5569,5573, +5581,5591,5623,5639,5641,5647,5651,5653, +5657,5659,5669,5683,5689,5693,5701,5711, +5717,5737,5741,5743,5749,5779,5783,5791, +5801,5807,5813,5821,5827,5839,5843,5849, +5851,5857,5861,5867,5869,5879,5881,5897, +5903,5923,5927,5939,5953,5981,5987,6007, +6011,6029,6037,6043,6047,6053,6067,6073, +6079,6089,6091,6101,6113,6121,6131,6133, +6143,6151,6163,6173,6197,6199,6203,6211, +6217,6221,6229,6247,6257,6263,6269,6271, +6277,6287,6299,6301,6311,6317,6323,6329, +6337,6343,6353,6359,6361,6367,6373,6379, +6389,6397,6421,6427,6449,6451,6469,6473, +6481,6491,6521,6529,6547,6551,6553,6563, +6569,6571,6577,6581,6599,6607,6619,6637, +6653,6659,6661,6673,6679,6689,6691,6701, +6703,6709,6719,6733,6737,6761,6763,6779, +6781,6791,6793,6803,6823,6827,6829,6833, +6841,6857,6863,6869,6871,6883,6899,6907, +6911,6917,6947,6949,6959,6961,6967,6971, +6977,6983,6991,6997,7001,7013,7019,7027, +7039,7043,7057,7069,7079,7103,7109,7121, +7127,7129,7151,7159,7177,7187,7193,7207, +7211,7213,7219,7229,7237,7243,7247,7253, +7283,7297,7307,7309,7321,7331,7333,7349, +7351,7369,7393,7411,7417,7433,7451,7457, +7459,7477,7481,7487,7489,7499,7507,7517, +7523,7529,7537,7541,7547,7549,7559,7561, +7573,7577,7583,7589,7591,7603,7607,7621, +7639,7643,7649,7669,7673,7681,7687,7691, +7699,7703,7717,7723,7727,7741,7753,7757, +7759,7789,7793,7817,7823,7829,7841,7853, +7867,7873,7877,7879,7883,7901,7907,7919, +7927,7933,7937,7949,7951,7963,7993,8009, +8011,8017,8039,8053,8059,8069,8081,8087, +8089,8093,8101,8111,8117,8123,8147,8161, +8167,8171,8179,8191,8209,8219,8221,8231, +8233,8237,8243,8263,8269,8273,8287,8291, +8293,8297,8311,8317,8329,8353,8363,8369, +8377,8387,8389,8419,8423,8429,8431,8443, +8447,8461,8467,8501,8513,8521,8527,8537, +8539,8543,8563,8573,8581,8597,8599,8609, +8623,8627,8629,8641,8647,8663,8669,8677, +8681,8689,8693,8699,8707,8713,8719,8731, +8737,8741,8747,8753,8761,8779,8783,8803, +8807,8819,8821,8831,8837,8839,8849,8861, +8863,8867,8887,8893,8923,8929,8933,8941, +8951,8963,8969,8971,8999,9001,9007,9011, +9013,9029,9041,9043,9049,9059,9067,9091, +9103,9109,9127,9133,9137,9151,9157,9161, +9173,9181,9187,9199,9203,9209,9221,9227, +9239,9241,9257,9277,9281,9283,9293,9311, +9319,9323,9337,9341,9343,9349,9371,9377, +9391,9397,9403,9413,9419,9421,9431,9433, +9437,9439,9461,9463,9467,9473,9479,9491, +9497,9511,9521,9533,9539,9547,9551,9587, +9601,9613,9619,9623,9629,9631,9643,9649, +9661,9677,9679,9689,9697,9719,9721,9733, +9739,9743,9749,9767,9769,9781,9787,9791, +9803,9811,9817,9829,9833,9839,9851,9857, +9859,9871,9883,9887,9901,9907,9923,9929, +9931,9941,9949,9967,9973,10007,10009,10037, +10039,10061,10067,10069,10079,10091,10093,10099, +10103,10111,10133,10139,10141,10151,10159,10163, +10169,10177,10181,10193,10211,10223,10243,10247, +10253,10259,10267,10271,10273,10289,10301,10303, +10313,10321,10331,10333,10337,10343,10357,10369, +10391,10399,10427,10429,10433,10453,10457,10459, +10463,10477,10487,10499,10501,10513,10529,10531, +10559,10567,10589,10597,10601,10607,10613,10627, +10631,10639,10651,10657,10663,10667,10687,10691, +10709,10711,10723,10729,10733,10739,10753,10771, +10781,10789,10799,10831,10837,10847,10853,10859, +10861,10867,10883,10889,10891,10903,10909,10937, +10939,10949,10957,10973,10979,10987,10993,11003, +11027,11047,11057,11059,11069,11071,11083,11087, +11093,11113,11117,11119,11131,11149,11159,11161, +11171,11173,11177,11197,11213,11239,11243,11251, +11257,11261,11273,11279,11287,11299,11311,11317, +11321,11329,11351,11353,11369,11383,11393,11399, +11411,11423,11437,11443,11447,11467,11471,11483, +11489,11491,11497,11503,11519,11527,11549,11551, +11579,11587,11593,11597,11617,11621,11633,11657, +11677,11681,11689,11699,11701,11717,11719,11731, +11743,11777,11779,11783,11789,11801,11807,11813, +11821,11827,11831,11833,11839,11863,11867,11887, +11897,11903,11909,11923,11927,11933,11939,11941, +11953,11959,11969,11971,11981,11987,12007,12011, +12037,12041,12043,12049,12071,12073,12097,12101, +12107,12109,12113,12119,12143,12149,12157,12161, +12163,12197,12203,12211,12227,12239,12241,12251, +12253,12263,12269,12277,12281,12289,12301,12323, +12329,12343,12347,12373,12377,12379,12391,12401, +12409,12413,12421,12433,12437,12451,12457,12473, +12479,12487,12491,12497,12503,12511,12517,12527, +12539,12541,12547,12553,12569,12577,12583,12589, +12601,12611,12613,12619,12637,12641,12647,12653, +12659,12671,12689,12697,12703,12713,12721,12739, +12743,12757,12763,12781,12791,12799,12809,12821, +12823,12829,12841,12853,12889,12893,12899,12907, +12911,12917,12919,12923,12941,12953,12959,12967, +12973,12979,12983,13001,13003,13007,13009,13033, +13037,13043,13049,13063,13093,13099,13103,13109, +13121,13127,13147,13151,13159,13163,13171,13177, +13183,13187,13217,13219,13229,13241,13249,13259, +13267,13291,13297,13309,13313,13327,13331,13337, +13339,13367,13381,13397,13399,13411,13417,13421, +13441,13451,13457,13463,13469,13477,13487,13499, +13513,13523,13537,13553,13567,13577,13591,13597, +13613,13619,13627,13633,13649,13669,13679,13681, +13687,13691,13693,13697,13709,13711,13721,13723, +13729,13751,13757,13759,13763,13781,13789,13799, +13807,13829,13831,13841,13859,13873,13877,13879, +13883,13901,13903,13907,13913,13921,13931,13933, +13963,13967,13997,13999,14009,14011,14029,14033, +14051,14057,14071,14081,14083,14087,14107,14143, +14149,14153,14159,14173,14177,14197,14207,14221, +14243,14249,14251,14281,14293,14303,14321,14323, +14327,14341,14347,14369,14387,14389,14401,14407, +14411,14419,14423,14431,14437,14447,14449,14461, +14479,14489,14503,14519,14533,14537,14543,14549, +14551,14557,14561,14563,14591,14593,14621,14627, +14629,14633,14639,14653,14657,14669,14683,14699, +14713,14717,14723,14731,14737,14741,14747,14753, +14759,14767,14771,14779,14783,14797,14813,14821, +14827,14831,14843,14851,14867,14869,14879,14887, +14891,14897,14923,14929,14939,14947,14951,14957, +14969,14983,15013,15017,15031,15053,15061,15073, +15077,15083,15091,15101,15107,15121,15131,15137, +15139,15149,15161,15173,15187,15193,15199,15217, +15227,15233,15241,15259,15263,15269,15271,15277, +15287,15289,15299,15307,15313,15319,15329,15331, +15349,15359,15361,15373,15377,15383,15391,15401, +15413,15427,15439,15443,15451,15461,15467,15473, +15493,15497,15511,15527,15541,15551,15559,15569, +15581,15583,15601,15607,15619,15629,15641,15643, +15647,15649,15661,15667,15671,15679,15683,15727, +15731,15733,15737,15739,15749,15761,15767,15773, +15787,15791,15797,15803,15809,15817,15823,15859, +15877,15881,15887,15889,15901,15907,15913,15919, +15923,15937,15959,15971,15973,15991,16001,16007, +16033,16057,16061,16063,16067,16069,16073,16087, +16091,16097,16103,16111,16127,16139,16141,16183, +16187,16189,16193,16217,16223,16229,16231,16249, +16253,16267,16273,16301,16319,16333,16339,16349, +16361,16363,16369,16381,16411,16417,16421,16427, +16433,16447,16451,16453,16477,16481,16487,16493, +16519,16529,16547,16553,16561,16567,16573,16603, +16607,16619,16631,16633,16649,16651,16657,16661, +16673,16691,16693,16699,16703,16729,16741,16747, +16759,16763,16787,16811,16823,16829,16831,16843, +16871,16879,16883,16889,16901,16903,16921,16927, +16931,16937,16943,16963,16979,16981,16987,16993, +17011,17021,17027,17029,17033,17041,17047,17053, +17077,17093,17099,17107,17117,17123,17137,17159, +17167,17183,17189,17191,17203,17207,17209,17231, +17239,17257,17291,17293,17299,17317,17321,17327, +17333,17341,17351,17359,17377,17383,17387,17389, +17393,17401,17417,17419,17431,17443,17449,17467, +17471,17477,17483,17489,17491,17497,17509,17519, +17539,17551,17569,17573,17579,17581,17597,17599, +17609,17623,17627,17657,17659,17669,17681,17683, +17707,17713,17729,17737,17747,17749,17761,17783, +17789,17791,17807,17827,17837,17839,17851,17863, +17881,17891,17903,17909,17911,17921,17923,17929, +17939,17957,17959,17971,17977,17981,17987,17989, +18013,18041,18043,18047,18049,18059,18061,18077, +18089,18097,18119,18121,18127,18131,18133,18143, +18149,18169,18181,18191,18199,18211,18217,18223, +18229,18233,18251,18253,18257,18269,18287,18289, +18301,18307,18311,18313,18329,18341,18353,18367, +18371,18379,18397,18401,18413,18427,18433,18439, +18443,18451,18457,18461,18481,18493,18503,18517, +18521,18523,18539,18541,18553,18583,18587,18593, +18617,18637,18661,18671,18679,18691,18701,18713, +18719,18731,18743,18749,18757,18773,18787,18793, +18797,18803,18839,18859,18869,18899,18911,18913, +18917,18919,18947,18959,18973,18979,19001,19009, +19013,19031,19037,19051,19069,19073,19079,19081, +19087,19121,19139,19141,19157,19163,19181,19183, +19207,19211,19213,19219,19231,19237,19249,19259, +19267,19273,19289,19301,19309,19319,19333,19373, +19379,19381,19387,19391,19403,19417,19421,19423, +19427,19429,19433,19441,19447,19457,19463,19469, +19471,19477,19483,19489,19501,19507,19531,19541, +19543,19553,19559,19571,19577,19583,19597,19603, +19609,19661,19681,19687,19697,19699,19709,19717, +19727,19739,19751,19753,19759,19763,19777,19793, +19801,19813,19819,19841,19843,19853,19861,19867, +19889,19891,19913,19919,19927,19937,19949,19961, +19963,19973,19979,19991,19993,19997,20011,20021, +20023,20029,20047,20051,20063,20071,20089,20101, +20107,20113,20117,20123,20129,20143,20147,20149, +20161,20173,20177,20183,20201,20219,20231,20233, +20249,20261,20269,20287,20297,20323,20327,20333, +20341,20347,20353,20357,20359,20369,20389,20393, +20399,20407,20411,20431,20441,20443,20477,20479, +20483,20507,20509,20521,20533,20543,20549,20551, +20563,20593,20599,20611,20627,20639,20641,20663, +20681,20693,20707,20717,20719,20731,20743,20747, +20749,20753,20759,20771,20773,20789,20807,20809, +20849,20857,20873,20879,20887,20897,20899,20903, +20921,20929,20939,20947,20959,20963,20981,20983, +21001,21011,21013,21017,21019,21023,21031,21059, +21061,21067,21089,21101,21107,21121,21139,21143, +21149,21157,21163,21169,21179,21187,21191,21193, +21211,21221,21227,21247,21269,21277,21283,21313, +21317,21319,21323,21341,21347,21377,21379,21383, +21391,21397,21401,21407,21419,21433,21467,21481, +21487,21491,21493,21499,21503,21517,21521,21523, +21529,21557,21559,21563,21569,21577,21587,21589, +21599,21601,21611,21613,21617,21647,21649,21661, +21673,21683,21701,21713,21727,21737,21739,21751, +21757,21767,21773,21787,21799,21803,21817,21821, +21839,21841,21851,21859,21863,21871,21881,21893, +21911,21929,21937,21943,21961,21977,21991,21997, +22003,22013,22027,22031,22037,22039,22051,22063, +22067,22073,22079,22091,22093,22109,22111,22123, +22129,22133,22147,22153,22157,22159,22171,22189, +22193,22229,22247,22259,22271,22273,22277,22279, +22283,22291,22303,22307,22343,22349,22367,22369, +22381,22391,22397,22409,22433,22441,22447,22453, +22469,22481,22483,22501,22511,22531,22541,22543, +22549,22567,22571,22573,22613,22619,22621,22637, +22639,22643,22651,22669,22679,22691,22697,22699, +22709,22717,22721,22727,22739,22741,22751,22769, +22777,22783,22787,22807,22811,22817,22853,22859, +22861,22871,22877,22901,22907,22921,22937,22943, +22961,22963,22973,22993,23003,23011,23017,23021, +23027,23029,23039,23041,23053,23057,23059,23063, +23071,23081,23087,23099,23117,23131,23143,23159, +23167,23173,23189,23197,23201,23203,23209,23227, +23251,23269,23279,23291,23293,23297,23311,23321, +23327,23333,23339,23357,23369,23371,23399,23417, +23431,23447,23459,23473,23497,23509,23531,23537, +23539,23549,23557,23561,23563,23567,23581,23593, +23599,23603,23609,23623,23627,23629,23633,23663, +23669,23671,23677,23687,23689,23719,23741,23743, +23747,23753,23761,23767,23773,23789,23801,23813, +23819,23827,23831,23833,23857,23869,23873,23879, +23887,23893,23899,23909,23911,23917,23929,23957, +23971,23977,23981,23993,24001,24007,24019,24023, +24029,24043,24049,24061,24071,24077,24083,24091, +24097,24103,24107,24109,24113,24121,24133,24137, +24151,24169,24179,24181,24197,24203,24223,24229, +24239,24247,24251,24281,24317,24329,24337,24359, +24371,24373,24379,24391,24407,24413,24419,24421, +24439,24443,24469,24473,24481,24499,24509,24517, +24527,24533,24547,24551,24571,24593,24611,24623, +24631,24659,24671,24677,24683,24691,24697,24709, +24733,24749,24763,24767,24781,24793,24799,24809, +24821,24841,24847,24851,24859,24877,24889,24907, +24917,24919,24923,24943,24953,24967,24971,24977, +24979,24989,25013,25031,25033,25037,25057,25073, +25087,25097,25111,25117,25121,25127,25147,25153, +25163,25169,25171,25183,25189,25219,25229,25237, +25243,25247,25253,25261,25301,25303,25307,25309, +25321,25339,25343,25349,25357,25367,25373,25391, +25409,25411,25423,25439,25447,25453,25457,25463, +25469,25471,25523,25537,25541,25561,25577,25579, +25583,25589,25601,25603,25609,25621,25633,25639, +25643,25657,25667,25673,25679,25693,25703,25717, +25733,25741,25747,25759,25763,25771,25793,25799, +25801,25819,25841,25847,25849,25867,25873,25889, +25903,25913,25919,25931,25933,25939,25943,25951, +25969,25981,25997,25999,26003,26017,26021,26029, +26041,26053,26083,26099,26107,26111,26113,26119, +26141,26153,26161,26171,26177,26183,26189,26203, +26209,26227,26237,26249,26251,26261,26263,26267, +26293,26297,26309,26317,26321,26339,26347,26357, +26371,26387,26393,26399,26407,26417,26423,26431, +26437,26449,26459,26479,26489,26497,26501,26513, +26539,26557,26561,26573,26591,26597,26627,26633, +26641,26647,26669,26681,26683,26687,26693,26699, +26701,26711,26713,26717,26723,26729,26731,26737, +26759,26777,26783,26801,26813,26821,26833,26839, +26849,26861,26863,26879,26881,26891,26893,26903, +26921,26927,26947,26951,26953,26959,26981,26987, +26993,27011,27017,27031,27043,27059,27061,27067, +27073,27077,27091,27103,27107,27109,27127,27143, +27179,27191,27197,27211,27239,27241,27253,27259, +27271,27277,27281,27283,27299,27329,27337,27361, +27367,27397,27407,27409,27427,27431,27437,27449, +27457,27479,27481,27487,27509,27527,27529,27539, +27541,27551,27581,27583,27611,27617,27631,27647, +27653,27673,27689,27691,27697,27701,27733,27737, +27739,27743,27749,27751,27763,27767,27773,27779, +27791,27793,27799,27803,27809,27817,27823,27827, +27847,27851,27883,27893,27901,27917,27919,27941, +27943,27947,27953,27961,27967,27983,27997,28001, +28019,28027,28031,28051,28057,28069,28081,28087, +28097,28099,28109,28111,28123,28151,28163,28181, +28183,28201,28211,28219,28229,28277,28279,28283, +28289,28297,28307,28309,28319,28349,28351,28387, +28393,28403,28409,28411,28429,28433,28439,28447, +28463,28477,28493,28499,28513,28517,28537,28541, +28547,28549,28559,28571,28573,28579,28591,28597, +28603,28607,28619,28621,28627,28631,28643,28649, +28657,28661,28663,28669,28687,28697,28703,28711, +28723,28729,28751,28753,28759,28771,28789,28793, +28807,28813,28817,28837,28843,28859,28867,28871, +28879,28901,28909,28921,28927,28933,28949,28961, +28979,29009,29017,29021,29023,29027,29033,29059, +29063,29077,29101,29123,29129,29131,29137,29147, +29153,29167,29173,29179,29191,29201,29207,29209, +29221,29231,29243,29251,29269,29287,29297,29303, +29311,29327,29333,29339,29347,29363,29383,29387, +29389,29399,29401,29411,29423,29429,29437,29443, +29453,29473,29483,29501,29527,29531,29537,29567, +29569,29573,29581,29587,29599,29611,29629,29633, +29641,29663,29669,29671,29683,29717,29723,29741, +29753,29759,29761,29789,29803,29819,29833,29837, +29851,29863,29867,29873,29879,29881,29917,29921, +29927,29947,29959,29983,29989,30011,30013,30029, +30047,30059,30071,30089,30091,30097,30103,30109, +30113,30119,30133,30137,30139,30161,30169,30181, +30187,30197,30203,30211,30223,30241,30253,30259, +30269,30271,30293,30307,30313,30319,30323,30341, +30347,30367,30389,30391,30403,30427,30431,30449, +30467,30469,30491,30493,30497,30509,30517,30529, +30539,30553,30557,30559,30577,30593,30631,30637, +30643,30649,30661,30671,30677,30689,30697,30703, +30707,30713,30727,30757,30763,30773,30781,30803, +30809,30817,30829,30839,30841,30851,30853,30859, +30869,30871,30881,30893,30911,30931,30937,30941, +30949,30971,30977,30983,31013,31019,31033,31039, +31051,31063,31069,31079,31081,31091,31121,31123, +31139,31147,31151,31153,31159,31177,31181,31183, +31189,31193,31219,31223,31231,31237,31247,31249, +31253,31259,31267,31271,31277,31307,31319,31321, +31327,31333,31337,31357,31379,31387,31391,31393, +31397,31469,31477,31481,31489,31511,31513,31517, +31531,31541,31543,31547,31567,31573,31583,31601, +31607,31627,31643,31649,31657,31663,31667,31687, +31699,31721,31723,31727,31729,31741,31751,31769, +31771,31793,31799,31817,31847,31849,31859,31873, +31883,31891,31907,31957,31963,31973,31981,31991, +32003,32009,32027,32029,32051,32057,32059,32063, +32069,32077,32083,32089,32099,32117,32119,32141, +32143,32159,32173,32183,32189,32191,32203,32213, +32233,32237,32251,32257,32261,32297,32299,32303, +32309,32321,32323,32327,32341,32353,32359,32363, +32369,32371,32377,32381,32401,32411,32413,32423, +32429,32441,32443,32467,32479,32491,32497,32503, +32507,32531,32533,32537,32561,32563,32569,32573, +32579,32587,32603,32609,32611,32621,32633,32647, +32653,32687,32693,32707,32713,32717,32719,32749, +32771,32779,32783,32789,32797,32801,32803,32831, +32833,32839,32843,32869,32887,32909,32911,32917, +32933,32939,32941,32957,32969,32971,32983,32987, +32993,32999,33013,33023,33029,33037,33049,33053, +33071,33073,33083,33091,33107,33113,33119,33149, +33151,33161,33179,33181,33191,33199,33203,33211, +33223,33247,33287,33289,33301,33311,33317,33329, +33331,33343,33347,33349,33353,33359,33377,33391, +33403,33409,33413,33427,33457,33461,33469,33479, +33487,33493,33503,33521,33529,33533,33547,33563, +33569,33577,33581,33587,33589,33599,33601,33613, +33617,33619,33623,33629,33637,33641,33647,33679, +33703,33713,33721,33739,33749,33751,33757,33767, +33769,33773,33791,33797,33809,33811,33827,33829, +33851,33857,33863,33871,33889,33893,33911,33923, +33931,33937,33941,33961,33967,33997,34019,34031, +34033,34039,34057,34061,34123,34127,34129,34141, +34147,34157,34159,34171,34183,34211,34213,34217, +34231,34253,34259,34261,34267,34273,34283,34297, +34301,34303,34313,34319,34327,34337,34351,34361, +34367,34369,34381,34403,34421,34429,34439,34457, +34469,34471,34483,34487,34499,34501,34511,34513, +34519,34537,34543,34549,34583,34589,34591,34603, +34607,34613,34631,34649,34651,34667,34673,34679, +34687,34693,34703,34721,34729,34739,34747,34757, +34759,34763,34781,34807,34819,34841,34843,34847, +34849,34871,34877,34883,34897,34913,34919,34939, +34949,34961,34963,34981,35023,35027,35051,35053, +35059,35069,35081,35083,35089,35099,35107,35111, +35117,35129,35141,35149,35153,35159,35171,35201, +35221,35227,35251,35257,35267,35279,35281,35291, +35311,35317,35323,35327,35339,35353,35363,35381, +35393,35401,35407,35419,35423,35437,35447,35449, +35461,35491,35507,35509,35521,35527,35531,35533, +35537,35543,35569,35573,35591,35593,35597,35603, +35617,35671,35677,35729,35731,35747,35753,35759, +35771,35797,35801,35803,35809,35831,35837,35839, +35851,35863,35869,35879,35897,35899,35911,35923, +35933,35951,35963,35969,35977,35983,35993,35999, +36007,36011,36013,36017,36037,36061,36067,36073, +36083,36097,36107,36109,36131,36137,36151,36161, +36187,36191,36209,36217,36229,36241,36251,36263, +36269,36277,36293,36299,36307,36313,36319,36341, +36343,36353,36373,36383,36389,36433,36451,36457, +36467,36469,36473,36479,36493,36497,36523,36527, +36529,36541,36551,36559,36563,36571,36583,36587, +36599,36607,36629,36637,36643,36653,36671,36677, +36683,36691,36697,36709,36713,36721,36739,36749, +36761,36767,36779,36781,36787,36791,36793,36809, +36821,36833,36847,36857,36871,36877,36887,36899, +36901,36913,36919,36923,36929,36931,36943,36947, +36973,36979,36997,37003,37013,37019,37021,37039, +37049,37057,37061,37087,37097,37117,37123,37139, +37159,37171,37181,37189,37199,37201,37217,37223, +37243,37253,37273,37277,37307,37309,37313,37321, +37337,37339,37357,37361,37363,37369,37379,37397, +37409,37423,37441,37447,37463,37483,37489,37493, +37501,37507,37511,37517,37529,37537,37547,37549, +37561,37567,37571,37573,37579,37589,37591,37607, +37619,37633,37643,37649,37657,37663,37691,37693, +37699,37717,37747,37781,37783,37799,37811,37813, +37831,37847,37853,37861,37871,37879,37889,37897, +37907,37951,37957,37963,37967,37987,37991,37993, +37997,38011,38039,38047,38053,38069,38083,38113, +38119,38149,38153,38167,38177,38183,38189,38197, +38201,38219,38231,38237,38239,38261,38273,38281, +38287,38299,38303,38317,38321,38327,38329,38333, +38351,38371,38377,38393,38431,38447,38449,38453, +38459,38461,38501,38543,38557,38561,38567,38569, +38593,38603,38609,38611,38629,38639,38651,38653, +38669,38671,38677,38693,38699,38707,38711,38713, +38723,38729,38737,38747,38749,38767,38783,38791, +38803,38821,38833,38839,38851,38861,38867,38873, +38891,38903,38917,38921,38923,38933,38953,38959, +38971,38977,38993,39019,39023,39041,39043,39047, +39079,39089,39097,39103,39107,39113,39119,39133, +39139,39157,39161,39163,39181,39191,39199,39209, +39217,39227,39229,39233,39239,39241,39251,39293, +39301,39313,39317,39323,39341,39343,39359,39367, +39371,39373,39383,39397,39409,39419,39439,39443, +39451,39461,39499,39503,39509,39511,39521,39541, +39551,39563,39569,39581,39607,39619,39623,39631, +39659,39667,39671,39679,39703,39709,39719,39727, +39733,39749,39761,39769,39779,39791,39799,39821, +39827,39829,39839,39841,39847,39857,39863,39869, +39877,39883,39887,39901,39929,39937,39953,39971, +39979,39983,39989,40009,40013,40031,40037,40039, +40063,40087,40093,40099,40111,40123,40127,40129, +40151,40153,40163,40169,40177,40189,40193,40213, +40231,40237,40241,40253,40277,40283,40289,40343, +40351,40357,40361,40387,40423,40427,40429,40433, +40459,40471,40483,40487,40493,40499,40507,40519, +40529,40531,40543,40559,40577,40583,40591,40597, +40609,40627,40637,40639,40693,40697,40699,40709, +40739,40751,40759,40763,40771,40787,40801,40813, +40819,40823,40829,40841,40847,40849,40853,40867, +40879,40883,40897,40903,40927,40933,40939,40949, +40961,40973,40993,41011,41017,41023,41039,41047, +41051,41057,41077,41081,41113,41117,41131,41141, +41143,41149,41161,41177,41179,41183,41189,41201, +41203,41213,41221,41227,41231,41233,41243,41257, +41263,41269,41281,41299,41333,41341,41351,41357, +41381,41387,41389,41399,41411,41413,41443,41453, +41467,41479,41491,41507,41513,41519,41521,41539, +41543,41549,41579,41593,41597,41603,41609,41611, +41617,41621,41627,41641,41647,41651,41659,41669, +41681,41687,41719,41729,41737,41759,41761,41771, +41777,41801,41809,41813,41843,41849,41851,41863, +41879,41887,41893,41897,41903,41911,41927,41941, +41947,41953,41957,41959,41969,41981,41983,41999, +42013,42017,42019,42023,42043,42061,42071,42073, +42083,42089,42101,42131,42139,42157,42169,42179, +42181,42187,42193,42197,42209,42221,42223,42227, +42239,42257,42281,42283,42293,42299,42307,42323, +42331,42337,42349,42359,42373,42379,42391,42397, +42403,42407,42409,42433,42437,42443,42451,42457, +42461,42463,42467,42473,42487,42491,42499,42509, +42533,42557,42569,42571,42577,42589,42611,42641, +42643,42649,42667,42677,42683,42689,42697,42701, +42703,42709,42719,42727,42737,42743,42751,42767, +42773,42787,42793,42797,42821,42829,42839,42841, +42853,42859,42863,42899,42901,42923,42929,42937, +42943,42953,42961,42967,42979,42989,43003,43013, +43019,43037,43049,43051,43063,43067,43093,43103, +43117,43133,43151,43159,43177,43189,43201,43207, +43223,43237,43261,43271,43283,43291,43313,43319, +43321,43331,43391,43397,43399,43403,43411,43427, +43441,43451,43457,43481,43487,43499,43517,43541, +43543,43573,43577,43579,43591,43597,43607,43609, +43613,43627,43633,43649,43651,43661,43669,43691, +43711,43717,43721,43753,43759,43777,43781,43783, +43787,43789,43793,43801,43853,43867,43889,43891, +43913,43933,43943,43951,43961,43963,43969,43973, +43987,43991,43997,44017,44021,44027,44029,44041, +44053,44059,44071,44087,44089,44101,44111,44119, +44123,44129,44131,44159,44171,44179,44189,44201, +44203,44207,44221,44249,44257,44263,44267,44269, +44273,44279,44281,44293,44351,44357,44371,44381, +44383,44389,44417,44449,44453,44483,44491,44497, +44501,44507,44519,44531,44533,44537,44543,44549, +44563,44579,44587,44617,44621,44623,44633,44641, +44647,44651,44657,44683,44687,44699,44701,44711, +44729,44741,44753,44771,44773,44777,44789,44797, +44809,44819,44839,44843,44851,44867,44879,44887, +44893,44909,44917,44927,44939,44953,44959,44963, +44971,44983,44987,45007,45013,45053,45061,45077, +45083,45119,45121,45127,45131,45137,45139,45161, +45179,45181,45191,45197,45233,45247,45259,45263, +45281,45289,45293,45307,45317,45319,45329,45337, +45341,45343,45361,45377,45389,45403,45413,45427, +45433,45439,45481,45491,45497,45503,45523,45533, +45541,45553,45557,45569,45587,45589,45599,45613, +45631,45641,45659,45667,45673,45677,45691,45697, +45707,45737,45751,45757,45763,45767,45779,45817, +45821,45823,45827,45833,45841,45853,45863,45869, +45887,45893,45943,45949,45953,45959,45971,45979, +45989,46021,46027,46049,46051,46061,46073,46091, +46093,46099,46103,46133,46141,46147,46153,46171, +46181,46183,46187,46199,46219,46229,46237,46261, +46271,46273,46279,46301,46307,46309,46327,46337, +}; + +// the next prime after 46337 is 46349 + +// 46349 ^ 2 = 2,148,229,801 which is greater than 2^31 - 1 = 2,147,483,648 = 0x7fffffff + +// hence this table can factor all positive ints + +void +factor_int(int n) +{ + int d, k, m; + + n = abs(n); + + if (n < 2) + return; + + for (k = 0; k < NPRIME; k++) { + + d = primetab[k]; + + m = 0; + + while (n % d == 0) { + n /= d; + m++; + } + + if (m == 0) + continue; + + push_integer(d); + push_integer(m); + + if (n == 1) + return; + } + + push_integer(n); + push_integer(1); +} +#define TABLE_HSPACE 3 +#define TABLE_VSPACE 1 + +#define EMIT_SPACE 1 +#define EMIT_CHAR 2 +#define EMIT_LIST 3 +#define EMIT_SUPERSCRIPT 4 +#define EMIT_SUBSCRIPT 5 +#define EMIT_SUBEXPR 6 +#define EMIT_FRACTION 7 +#define EMIT_TABLE 8 + +#define OPCODE(p) ((int) car(p)->u.d) +#define HEIGHT(p) ((int) cadr(p)->u.d) +#define DEPTH(p) ((int) caddr(p)->u.d) +#define WIDTH(p) ((int) cadddr(p)->u.d) + +#define VAL1(p) ((int) car(p)->u.d) +#define VAL2(p) ((int) cadr(p)->u.d) + +#define PLUS_SIGN '+' +#define MINUS_SIGN 0xe28892 +#define MULTIPLY_SIGN 0xc397 +#define GREATEREQUAL 0xe289a5 +#define LESSEQUAL 0xe289a4 + +#define BDLL 0xe295b4 // BOX DRAW LIGHT LEFT +#define BDLR 0xe295b6 // BOX DRAW LIGHT RIGHT + +#define BDLH 0xe29480 // BOX DRAW LIGHT HORIZONTAL +#define BDLV 0xe29482 // BOX DRAW LIGHT VERTICAL + +#define BDLDAR 0xe2948c // BOX DRAW LIGHT DOWN AND RIGHT +#define BDLDAL 0xe29490 // BOX DRAW LIGHT DOWN AND LEFT +#define BDLUAR 0xe29494 // BOX DRAW LIGHT UP AND RIGHT +#define BDLUAL 0xe29498 // BOX DRAW LIGHT UP AND LEFT + +// #define MAX(a,b) ((a) > (b) ? (a) : (b)) +// #define MIN(a,b) ((a) < (b) ? (a) : (b)) + +int fmt_level; +int fmt_nrow; +int fmt_ncol; +uint32_t *fmt_buf; +int fmt_buf_len; + +void +fmt(void) +{ + int c, d, h, i, j, m, n, w; + struct atom *p1; + + fmt_level = 0; + + p1 = pop(); + + fmt_list(p1); + + p1 = pop(); + + h = HEIGHT(p1); + d = DEPTH(p1); + w = WIDTH(p1); + + fmt_nrow = h + d; + fmt_ncol = w; + + n = fmt_nrow * fmt_ncol * sizeof (uint32_t); // number of bytes + + m = 1000 * (n / 1000 + 1); // round up + + if (m > fmt_buf_len) { + if (fmt_buf) + free(fmt_buf); + fmt_buf = alloc_mem(m); + fmt_buf_len = m; + } + + memset(fmt_buf, 0, n); + + fmt_draw(0, h - 1, p1); + + outbuf_init(); + + for (i = 0; i < fmt_nrow; i++) { + for (j = 0; j < fmt_ncol; j++) { + c = fmt_buf[i * fmt_ncol + j]; + fmt_putw(c); + } + fmt_putw('\n'); + } + + fmt_putw('\n'); // blank line after result + + printbuf(outbuf, BLACK); +} + +void +fmt_args(struct atom *p) +{ + int t; + + p = cdr(p); + + if (!iscons(p)) { + fmt_roman_char('('); + fmt_roman_char(')'); + return; + } + + t = tos; + + fmt_expr(car(p)); + + p = cdr(p); + + while (iscons(p)) { + fmt_roman_char(','); + fmt_expr(car(p)); + p = cdr(p); + } + + fmt_update_list(t); + + fmt_update_subexpr(); +} + +void +fmt_base(struct atom *p) +{ + if (isnegativenumber(p) || isfraction(p) || isdouble(p) || car(p) == symbol(ADD) || car(p) == symbol(MULTIPLY) || car(p) == symbol(POWER)) + fmt_subexpr(p); + else + fmt_expr(p); +} + +void +fmt_denominators(struct atom *p) +{ + int n, t; + char *s; + struct atom *q; + + t = tos; + n = count_denominators(p); + p = cdr(p); + + while (iscons(p)) { + + q = car(p); + p = cdr(p); + + if (!isdenominator(q)) + continue; + + if (tos > t) + fmt_space(); + + if (isrational(q)) { + s = mstr(q->u.q.b); + fmt_roman_string(s); + continue; + } + + if (isminusone(caddr(q))) { + q = cadr(q); + if (car(q) == symbol(ADD) && n == 1) + fmt_expr(q); // parens not needed + else + fmt_factor(q); + } else { + fmt_base(cadr(q)); + fmt_numeric_exponent(caddr(q)); // sign is not emitted + } + } + + fmt_update_list(t); +} + +void +fmt_double(struct atom *p) +{ + int t; + char *s; + + snprintf(strbuf, STRBUFLEN, "%g", fabs(p->u.d)); + + s = strbuf; + + while (*s && *s != 'E' && *s != 'e') + fmt_roman_char(*s++); + + if (!*s) + return; + + s++; + + fmt_roman_char(MULTIPLY_SIGN); + + fmt_roman_string("10"); + + // superscripted exponent + + fmt_level++; + + t = tos; + + // sign of exponent + + if (*s == '+') + s++; + else if (*s == '-') { + fmt_roman_char(MINUS_SIGN); + s++; + } + + // skip leading zeroes in exponent + + while (*s == '0') + s++; + + fmt_roman_string(s); + + fmt_update_list(t); + + fmt_level--; + + fmt_update_superscript(); +} + +void +fmt_exponent(struct atom *p) +{ + if (isnum(p) && !isnegativenumber(p)) { + fmt_numeric_exponent(p); // sign is not emitted + return; + } + + fmt_level++; + fmt_list(p); + fmt_level--; + + fmt_update_superscript(); +} + +void +fmt_expr(struct atom *p) +{ + if (isnegativeterm(p) || (car(p) == symbol(ADD) && isnegativeterm(cadr(p)))) + fmt_roman_char(MINUS_SIGN); + + if (car(p) == symbol(ADD)) + fmt_expr_nib(p); + else + fmt_term(p); +} + +void +fmt_expr_nib(struct atom *p) +{ + p = cdr(p); + fmt_term(car(p)); + p = cdr(p); + while (iscons(p)) { + if (isnegativeterm(car(p))) + fmt_infix_operator(MINUS_SIGN); + else + fmt_infix_operator(PLUS_SIGN); + fmt_term(car(p)); + p = cdr(p); + } +} + +void +fmt_factor(struct atom *p) +{ + if (isrational(p)) { + fmt_rational(p); + return; + } + + if (isdouble(p)) { + fmt_double(p); + return; + } + + if (issymbol(p)) { + fmt_symbol(p); + return; + } + + if (isstr(p)) { + fmt_string(p); + return; + } + + if (istensor(p)) { + fmt_tensor(p); + return; + } + + if (iscons(p)) { + if (car(p) == symbol(POWER)) + fmt_power(p); + else if (car(p) == symbol(ADD) || car(p) == symbol(MULTIPLY)) + fmt_subexpr(p); + else + fmt_function(p); + return; + } +} + +void +fmt_frac(struct atom *p) +{ + fmt_numerators(p); + fmt_denominators(p); + fmt_update_fraction(); +} + +void +fmt_function(struct atom *p) +{ + // d(f(x),x) + + if (car(p) == symbol(DERIVATIVE)) { + fmt_roman_char('d'); + fmt_args(p); + return; + } + + // n! + + if (car(p) == symbol(FACTORIAL)) { + p = cadr(p); + if (isposint(p) || issymbol(p)) + fmt_expr(p); + else + fmt_subexpr(p); + fmt_roman_char('!'); + return; + } + + // A[1,2] + + if (car(p) == symbol(INDEX)) { + p = cdr(p); + if (issymbol(car(p))) + fmt_symbol(car(p)); + else + fmt_subexpr(car(p)); + fmt_indices(p); + return; + } + + if (car(p) == symbol(SETQ) || car(p) == symbol(TESTEQ)) { + fmt_expr(cadr(p)); + fmt_infix_operator('='); + fmt_expr(caddr(p)); + return; + } + + if (car(p) == symbol(TESTGE)) { + fmt_expr(cadr(p)); + fmt_infix_operator(GREATEREQUAL); + fmt_expr(caddr(p)); + return; + } + + if (car(p) == symbol(TESTGT)) { + fmt_expr(cadr(p)); + fmt_infix_operator('>'); + fmt_expr(caddr(p)); + return; + } + + if (car(p) == symbol(TESTLE)) { + fmt_expr(cadr(p)); + fmt_infix_operator(LESSEQUAL); + fmt_expr(caddr(p)); + return; + } + + if (car(p) == symbol(TESTLT)) { + fmt_expr(cadr(p)); + fmt_infix_operator('<'); + fmt_expr(caddr(p)); + return; + } + + // default + + if (issymbol(car(p))) + fmt_symbol(car(p)); + else + fmt_subexpr(car(p)); + + fmt_args(p); +} + +void +fmt_indices(struct atom *p) +{ + fmt_roman_char('['); + + p = cdr(p); + + if (iscons(p)) { + fmt_expr(car(p)); + p = cdr(p); + while (iscons(p)) { + fmt_roman_char(','); + fmt_expr(car(p)); + p = cdr(p); + } + } + + fmt_roman_char(']'); +} + +void +fmt_infix_operator(int c) +{ + fmt_space(); + fmt_roman_char(c); + fmt_space(); +} + +void +fmt_list(struct atom *p) +{ + int t = tos; + fmt_expr(p); + fmt_update_list(t); +} + +void +fmt_matrix(struct atom *p, int d, int k) +{ + int i, j, m, n, span; + + if (d == p->u.tensor->ndim) { + fmt_list(p->u.tensor->elem[k]); + return; + } + + // compute element span + + span = 1; + + for (i = d + 2; i < p->u.tensor->ndim; i++) + span *= p->u.tensor->dim[i]; + + n = p->u.tensor->dim[d]; // number of rows + m = p->u.tensor->dim[d + 1]; // number of columns + + for (i = 0; i < n; i++) + for (j = 0; j < m; j++) + fmt_matrix(p, d + 2, k + (i * m + j) * span); + + fmt_update_table(n, m); +} + +void +fmt_numerators(struct atom *p) +{ + int n, t; + char *s; + struct atom *q; + + t = tos; + n = count_numerators(p); + p = cdr(p); + + while (iscons(p)) { + + q = car(p); + p = cdr(p); + + if (!isnumerator(q)) + continue; + + if (tos > t) + fmt_space(); + + if (isrational(q)) { + s = mstr(q->u.q.a); + fmt_roman_string(s); + continue; + } + + if (car(q) == symbol(ADD) && n == 1) + fmt_expr(q); // parens not needed + else + fmt_factor(q); + } + + if (t == tos) + fmt_roman_char('1'); // no numerators + + fmt_update_list(t); +} + +// p is rational or double, sign is not emitted + +void +fmt_numeric_exponent(struct atom *p) +{ + int t; + char *s; + + fmt_level++; + + t = tos; + + if (isrational(p)) { + s = mstr(p->u.q.a); + fmt_roman_string(s); + if (!MEQUAL(p->u.q.b, 1)) { + fmt_roman_char('/'); + s = mstr(p->u.q.b); + fmt_roman_string(s); + } + } else + fmt_double(p); + + fmt_update_list(t); + + fmt_level--; + + fmt_update_superscript(); +} + +void +fmt_power(struct atom *p) +{ + if (cadr(p) == symbol(EXP1)) { + fmt_roman_string("exp"); + fmt_args(cdr(p)); + return; + } + + if (isimaginaryunit(p)) { + if (isimaginaryunit(get_binding(symbol(J_LOWER)))) { + fmt_roman_char('j'); + return; + } + if (isimaginaryunit(get_binding(symbol(I_LOWER)))) { + fmt_roman_char('i'); + return; + } + } + + if (isnegativenumber(caddr(p))) { + fmt_reciprocal(p); + return; + } + + fmt_base(cadr(p)); + fmt_exponent(caddr(p)); +} + +void +fmt_rational(struct atom *p) +{ + int t; + char *s; + + if (MEQUAL(p->u.q.b, 1)) { + s = mstr(p->u.q.a); + fmt_roman_string(s); + return; + } + + fmt_level++; + + t = tos; + s = mstr(p->u.q.a); + fmt_roman_string(s); + fmt_update_list(t); + + t = tos; + s = mstr(p->u.q.b); + fmt_roman_string(s); + fmt_update_list(t); + + fmt_level--; + + fmt_update_fraction(); +} + +// p = y^x where x is a negative number + +void +fmt_reciprocal(struct atom *p) +{ + int t; + + fmt_roman_char('1'); // numerator + + t = tos; + + if (isminusone(caddr(p))) + fmt_expr(cadr(p)); + else { + fmt_base(cadr(p)); + fmt_numeric_exponent(caddr(p)); // sign is not emitted + } + + fmt_update_list(t); + + fmt_update_fraction(); +} + +void +fmt_roman_char(int c) +{ + int d, h, w; + + h = 1; + d = 0; + w = 1; + + push_double(EMIT_CHAR); + push_double(h); + push_double(d); + push_double(w); + push_double(c); + + list(5); +} + +void +fmt_roman_string(char *s) +{ + while (*s) + fmt_roman_char(*s++); +} + +void +fmt_space(void) +{ + push_double(EMIT_SPACE); + push_double(0); + push_double(0); + push_double(1); + + list(4); +} + +void +fmt_string(struct atom *p) +{ + fmt_roman_string(p->u.str); +} + +void +fmt_subexpr(struct atom *p) +{ + fmt_list(p); + fmt_update_subexpr(); +} + +void +fmt_symbol(struct atom *p) +{ + int k, t; + char *s; + + if (p == symbol(EXP1)) { + fmt_roman_string("exp(1)"); + return; + } + + s = printname(p); + + if (iskeyword(p) || p == symbol(LAST) || p == symbol(TRACE) || p == symbol(TTY)) { + fmt_roman_string(s); + return; + } + + k = fmt_symbol_fragment(s, 0); + + if (s[k] == '\0') + return; + + // emit subscript + + fmt_level++; + + t = tos; + + while (s[k] != '\0') + k = fmt_symbol_fragment(s, k); + + fmt_update_list(t); + + fmt_level--; + + fmt_update_subscript(); +} + +#define NUM_SYMBOL_NAMES 49 + +char *symbol_name_tab[NUM_SYMBOL_NAMES] = { + + "Alpha", + "Beta", + "Gamma", + "Delta", + "Epsilon", + "Zeta", + "Eta", + "Theta", + "Iota", + "Kappa", + "Lambda", + "Mu", + "Nu", + "Xi", + "Omicron", + "Pi", + "Rho", + "Sigma", + "Tau", + "Upsilon", + "Phi", + "Chi", + "Psi", + "Omega", + + "alpha", + "beta", + "gamma", + "delta", + "epsilon", + "zeta", + "eta", + "theta", + "iota", + "kappa", + "lambda", + "mu", + "nu", + "xi", + "omicron", + "pi", + "rho", + "sigma", + "tau", + "upsilon", + "phi", + "chi", + "psi", + "omega", + + "hbar", +}; + +int symbol_unicode_tab[NUM_SYMBOL_NAMES] = { + + 0xce91, // Alpha + 0xce92, // Beta + 0xce93, // Gamma + 0xce94, // Delta + 0xce95, // Epsilon + 0xce96, // Zeta + 0xce97, // Eta + 0xce98, // Theta + 0xce99, // Iota + 0xce9a, // Kappa + 0xce9b, // Lambda + 0xce9c, // Mu + 0xce9d, // Nu + 0xce9e, // Xi + 0xce9f, // Omicron + 0xcea0, // Pi + 0xcea1, // Rho + 0xcea3, // Sigma + 0xcea4, // Tau + 0xcea5, // Upsilon + 0xcea6, // Phi + 0xcea7, // Chi + 0xcea8, // Psi + 0xcea9, // Omega + + 0xceb1, // alpha + 0xceb2, // beta + 0xceb3, // gamma + 0xceb4, // delta + 0xceb5, // epsilon + 0xceb6, // zeta + 0xceb7, // eta + 0xceb8, // theta + 0xceb9, // iota + 0xceba, // kappa + 0xcebb, // lambda + 0xcebc, // mu + 0xcebd, // nu + 0xcebe, // xi + 0xcebf, // omicron + 0xcf80, // pi + 0xcf81, // rho + 0xcf83, // sigma + 0xcf84, // tau + 0xcf85, // upsilon + 0xcf86, // phi + 0xcf87, // chi + 0xcf88, // psi + 0xcf89, // omega + + 0xc4a7, // hbar +}; + +int +fmt_symbol_fragment(char *s, int k) +{ + int c, i, n; + char *t; + + for (i = 0; i < NUM_SYMBOL_NAMES; i++) { + t = symbol_name_tab[i]; + n = (int) strlen(t); + if (strncmp(s + k, t, n) == 0) + break; + } + + if (i == NUM_SYMBOL_NAMES) { + fmt_roman_char(s[k]); + return k + 1; + } + + c = symbol_unicode_tab[i]; + + fmt_roman_char(c); + + return k + n; +} + +void +fmt_table(int x, int y, struct atom *p) +{ + int cx, dx, i, j, m, n; + int column_width, elem_width, row_depth, row_height; + struct atom *d, *h, *w, *table; + + n = VAL1(p); + m = VAL2(p); + + p = cddr(p); + + table = car(p); + h = cadr(p); + d = caddr(p); + + for (i = 0; i < n; i++) { // for each row + + row_height = VAL1(h); + row_depth = VAL1(d); + + y += row_height; + + dx = 0; + + w = cadddr(p); + + for (j = 0; j < m; j++) { // for each column + column_width = VAL1(w); + elem_width = WIDTH(car(table)); + cx = x + dx + (column_width - elem_width) / 2; // center horizontal + fmt_draw(cx, y, car(table)); + dx += column_width + TABLE_HSPACE; + table = cdr(table); + w = cdr(w); + } + + y += row_depth + TABLE_VSPACE; + + h = cdr(h); + d = cdr(d); + } +} + +void +fmt_tensor(struct atom *p) +{ + if (p->u.tensor->ndim % 2 == 1) + fmt_vector(p); // odd rank + else + fmt_matrix(p, 0, 0); // even rank +} + +void +fmt_term(struct atom *p) +{ + if (car(p) == symbol(MULTIPLY)) + fmt_term_nib(p); + else + fmt_factor(p); +} + +void +fmt_term_nib(struct atom *p) +{ + if (find_denominator(p)) { + fmt_frac(p); + return; + } + + // no denominators + + p = cdr(p); + + if (isminusone(car(p))) + p = cdr(p); // sign already emitted + + fmt_factor(car(p)); + + p = cdr(p); + + while (iscons(p)) { + fmt_space(); + fmt_factor(car(p)); + p = cdr(p); + } +} + +void +fmt_update_fraction(void) +{ + int d, h, w; + struct atom *p1, *p2; + + p2 = pop(); // denominator + p1 = pop(); // numerator + + h = HEIGHT(p1) + DEPTH(p1); + d = HEIGHT(p2) + DEPTH(p2); + w = MAX(WIDTH(p1), WIDTH(p2)); + + h += 1; + w += 2; + + push_double(EMIT_FRACTION); + push_double(h); + push_double(d); + push_double(w); + push(p1); + push(p2); + + list(6); +} + +void +fmt_update_list(int t) +{ + int d, h, i, w; + struct atom *p1; + + if (tos - t == 1) + return; + + h = 0; + d = 0; + w = 0; + + for (i = t; i < tos; i++) { + p1 = stack[i]; + h = MAX(h, HEIGHT(p1)); + d = MAX(d, DEPTH(p1)); + w += WIDTH(p1); + } + + list(tos - t); + p1 = pop(); + + push_double(EMIT_LIST); + push_double(h); + push_double(d); + push_double(w); + push(p1); + + list(5); +} + +void +fmt_update_subexpr(void) +{ + int d, h, w; + struct atom *p1; + + p1 = pop(); + + h = HEIGHT(p1); + d = DEPTH(p1); + w = WIDTH(p1); + + // delimiters have vertical symmetry (h - m == d + m, m = 1/2) + + if (h > 1 || d > 0) { + h = MAX(h, d + 1) + 1; // plus extra + d = h - 1; // by symmetry + } + + w += 2; + + push_double(EMIT_SUBEXPR); + push_double(h); + push_double(d); + push_double(w); + push(p1); + + list(5); +} + +void +fmt_update_subscript(void) +{ + int d, dx, dy, h, w; + struct atom *p1; + + p1 = pop(); + + h = HEIGHT(p1); + d = DEPTH(p1); + w = WIDTH(p1); + + dx = 0; + dy = 1; + + push_double(EMIT_SUBSCRIPT); + push_double(h); + push_double(d + dy); + push_double(w); + push_double(dx); + push_double(dy); + push(p1); + + list(7); +} + +void +fmt_update_superscript(void) +{ + int d, dx, dy, h, w, y; + struct atom *p1, *p2; + + p2 = pop(); // exponent + p1 = pop(); // base + + h = HEIGHT(p2); + d = DEPTH(p2); + w = WIDTH(p2); + + // y is distance from baseline to bottom of superscript + + y = HEIGHT(p1) - d - 1; + + y = MAX(y, 1); + + dx = 0; + dy = -(y + d); + + h = y + h + d; + d = 0; + + if (OPCODE(p1) == EMIT_SUBSCRIPT) { + dx = -WIDTH(p1); + w = MAX(0, w - WIDTH(p1)); + } + + push(p1); // base + + push_double(EMIT_SUPERSCRIPT); + push_double(h); + push_double(d); + push_double(w); + push_double(dx); + push_double(dy); + push(p2); + + list(7); +} + +void +fmt_update_table(int n, int m) +{ + int i, j, t; + int d, h, w; + int total_height, total_width; + struct atom *p1, *p2, *p3, *p4; + + total_height = 0; + total_width = 0; + + t = tos - n * m; + + // height of each row + + for (i = 0; i < n; i++) { // for each row + h = 0; + for (j = 0; j < m; j++) { // for each column + p1 = stack[t + i * m + j]; + h = MAX(h, HEIGHT(p1)); + } + push_double(h); + total_height += h; + } + + list(n); + p2 = pop(); + + // depth of each row + + for (i = 0; i < n; i++) { // for each row + d = 0; + for (j = 0; j < m; j++) { // for each column + p1 = stack[t + i * m + j]; + d = MAX(d, DEPTH(p1)); + } + push_double(d); + total_height += d; + } + + list(n); + p3 = pop(); + + // width of each column + + for (j = 0; j < m; j++) { // for each column + w = 0; + for (i = 0; i < n; i++) { // for each row + p1 = stack[t + i * m + j]; + w = MAX(w, WIDTH(p1)); + } + push_double(w); + total_width += w; + } + + list(m); + p4 = pop(); + + // h, d, w for entire table centered vertical + + total_height += (n - 1) * TABLE_VSPACE + 2; // +2 for delimiters + total_width += (m - 1) * TABLE_HSPACE + 4; // +4 for delimiters + + h = total_height / 2 + 1; + d = total_height - h; + w = total_width; + + list(n * m); + p1 = pop(); + + push_double(EMIT_TABLE); + push_double(h); + push_double(d); + push_double(w); + push_double(n); + push_double(m); + push(p1); + push(p2); + push(p3); + push(p4); + + list(10); +} + +void +fmt_vector(struct atom *p) +{ + int i, n, span; + + // compute element span + + span = 1; + + n = p->u.tensor->ndim; + + for (i = 1; i < n; i++) + span *= p->u.tensor->dim[i]; + + n = p->u.tensor->dim[0]; // number of rows + + for (i = 0; i < n; i++) + fmt_matrix(p, 1, i * span); + + fmt_update_table(n, 1); // n rows, 1 column +} + +void +fmt_draw(int x, int y, struct atom *p) +{ + int d, dx, dy, h, i, k, w; + + k = OPCODE(p); + h = HEIGHT(p); + d = DEPTH(p); + w = WIDTH(p); + + p = cddddr(p); + + switch (k) { + + case EMIT_SPACE: + break; + + case EMIT_CHAR: + fmt_draw_char(x, y, VAL1(p)); + break; + + case EMIT_LIST: + p = car(p); + while (iscons(p)) { + fmt_draw(x, y, car(p)); + x += WIDTH(car(p)); + p = cdr(p); + } + break; + + case EMIT_SUPERSCRIPT: + case EMIT_SUBSCRIPT: + dx = VAL1(p); + dy = VAL2(p); + p = caddr(p); + fmt_draw(x + dx, y + dy, p); + break; + + case EMIT_SUBEXPR: + fmt_draw_delims(x, y, h, d, w); + fmt_draw(x + 1, y, car(p)); + break; + + case EMIT_FRACTION: + + // horizontal line + + fmt_draw_char(x, y, BDLR); + + for (i = 1; i < w - 1; i++) + fmt_draw_char(x + i, y, BDLH); + + fmt_draw_char(x + w - 1, y, BDLL); + + // numerator + + dx = (w - WIDTH(car(p))) / 2; + dy = -h + HEIGHT(car(p)); + fmt_draw(x + dx, y + dy, car(p)); + + // denominator + + p = cdr(p); + dx = (w - WIDTH(car(p))) / 2; + dy = d - DEPTH(car(p)); + fmt_draw(x + dx, y + dy, car(p)); + + break; + + case EMIT_TABLE: + fmt_draw_delims(x, y, h, d, w); + fmt_draw_table(x + 2, y - h + 1, p); + break; + } +} + +void +fmt_draw_char(int x, int y, int c) +{ + if (x >= 0 && x < fmt_ncol && y >= 0 && y < fmt_nrow) + fmt_buf[y * fmt_ncol + x] = c; +} + +void +fmt_draw_delims(int x, int y, int h, int d, int w) +{ + if (h > 1 || d > 0) { + fmt_draw_ldelim(x, y, h, d); + fmt_draw_rdelim(x + w - 1, y, h, d); + } else { + fmt_draw_char(x, y, '('); + fmt_draw_char(x + w - 1, y, ')'); + } +} + +void +fmt_draw_ldelim(int x, int y, int h, int d) +{ + int i; + + fmt_draw_char(x, y - h + 1, BDLDAR); + + for (i = 1; i < h + d - 1; i++) + fmt_draw_char(x, y - h + 1 + i, BDLV); + + fmt_draw_char(x, y + d, BDLUAR); +} + +void +fmt_draw_rdelim(int x, int y, int h, int d) +{ + int i; + + fmt_draw_char(x, y - h + 1, BDLDAL); + + for (i = 1; i < h + d - 1; i++) + fmt_draw_char(x, y - h + 1 + i, BDLV); + + fmt_draw_char(x, y + d, BDLUAL); +} + +void +fmt_draw_table(int x, int y, struct atom *p) +{ + int cx, dx, i, j, m, n; + int column_width, elem_width, row_depth, row_height; + struct atom *d, *h, *w, *table; + + n = VAL1(p); + m = VAL2(p); + + p = cddr(p); + + table = car(p); + h = cadr(p); + d = caddr(p); + + for (i = 0; i < n; i++) { // for each row + + row_height = VAL1(h); + row_depth = VAL1(d); + + y += row_height; + + dx = 0; + + w = cadddr(p); + + for (j = 0; j < m; j++) { // for each column + + column_width = VAL1(w); + elem_width = WIDTH(car(table)); + cx = x + dx + (column_width - elem_width) / 2; // center horizontal + fmt_draw(cx, y, car(table)); + dx += column_width + TABLE_HSPACE; + table = cdr(table); + w = cdr(w); + } + + y += row_depth + TABLE_VSPACE; + + h = cdr(h); + d = cdr(d); + } +} + +void +fmt_putw(uint32_t w) +{ + uint8_t buf[4]; + if (w == 0) + w = ' '; + buf[0] = w >> 24; + buf[1] = w >> 16; + buf[2] = w >> 8; + buf[3] = w; + if (buf[1]) + outbuf_putc(buf[1]); + if (buf[2]) + outbuf_putc(buf[2]); + outbuf_putc(buf[3]); +} +// automatic variables not visible to the garbage collector are reclaimed + +void +gc(void) +{ + int i, j; + struct atom *p; + + gc_count++; + alloc_count = 0; + + // tag everything + + for (i = 0; i < block_count; i++) + for (j = 0; j < BLOCKSIZE; j++) + mem[i][j].tag = 1; + + // untag what's used + + untag(zero); + untag(one); + untag(minusone); + untag(imaginaryunit); + + for (i = 0; i < tos; i++) + untag(stack[i]); + + for (i = 0; i < 27 * BUCKETSIZE; i++) { + untag(symtab[i]); + untag(binding[i]); + untag(usrfunc[i]); + } + + // collect everything that's still tagged + + free_list = NULL; + free_count = 0; + + for (i = 0; i < block_count; i++) + for (j = 0; j < BLOCKSIZE; j++) { + + p = mem[i] + j; + + if (p->tag == 0) + continue; + + // still tagged so it's unused, put on free list + + switch (p->atomtype) { + case KSYM: + free(p->u.ksym.name); + ksym_count--; + break; + case USYM: + free(p->u.usym.name); + usym_count--; + break; + case RATIONAL: + mfree(p->u.q.a); + mfree(p->u.q.b); + break; + case STR: + if (p->u.str) + free(p->u.str); + string_count--; + break; + case TENSOR: + free(p->u.tensor); + tensor_count--; + break; + default: + break; // FREEATOM, CONS, or DOUBLE + } + + p->atomtype = FREEATOM; + p->u.next = free_list; + + free_list = p; + free_count++; + } +} + +void +untag(struct atom *p) +{ + int i; + + if (p == NULL) + return; + + while (iscons(p)) { + if (p->tag == 0) + return; + p->tag = 0; + untag(p->u.cons.car); + p = p->u.cons.cdr; + } + + if (p->tag == 0) + return; + + p->tag = 0; + + if (istensor(p)) + for (i = 0; i < p->u.tensor->nelem; i++) + untag(p->u.tensor->elem[i]); +} +struct atom *mem[MAXBLOCKS]; // an array of pointers +struct atom *free_list; + +int tos; // top of stack + +struct atom *stack[STACKSIZE]; + +struct atom *symtab[27 * BUCKETSIZE]; +struct atom *binding[27 * BUCKETSIZE]; +struct atom *usrfunc[27 * BUCKETSIZE]; + +struct atom *zero; +struct atom *one; +struct atom *minusone; +struct atom *imaginaryunit; + +int eval_level; +int gc_level; +int expanding; +int drawing; +int interrupt; +int shuntflag; +int errorflag; +int breakflag; +jmp_buf jmpbuf; +char *trace1; +char *trace2; + +int alloc_count; +int block_count; +int free_count; +int gc_count; +int bignum_count; +int ksym_count; +int usym_count; +int string_count; +int tensor_count; +int max_eval_level; +int max_tos; + +char strbuf[STRBUFLEN]; + +char *outbuf; +int outbuf_index; +int outbuf_length; +// int +// main(int argc, char *argv[]) +// { +// int i; +// for (i = 1; i < argc; i++) +// run_infile(argv[i]); +// if (isatty(fileno(stdout))) +// run_stdin(); +// } + +void +run_infile(char *infile) +{ + char *buf; + buf = read_file(infile); + if (buf == NULL) { + fprintf(stderr, "cannot read %s\n", infile); + exit(1); + } + run(buf); + free(buf); +} + +void +run_stdin(void) +{ + static char inbuf[1000]; + for (;;) { + fputs("? ", stdout); + fflush(stdout); + fgets(inbuf, sizeof inbuf, stdin); + run(inbuf); + } +} + +void +display(void) +{ + fmt(); +} + +void +printbuf(char *s, int color) +{ + fputs(s, stdout); +} + +void +eval_draw(struct atom *p1) +{ + (void) p1; // silence compiler + push_symbol(NIL); +} + +void +eval_exit(struct atom *p1) +{ + (void) p1; // silence compiler + exit(0); +} +void +numden(void) +{ + struct atom *p0, *p1, *p2; + + p1 = pop(); + p2 = one; + + while (numden_find_divisor(p1)) { + p0 = pop(); + push(p0); + push(p1); + numden_cancel_factor(); + p1 = pop(); + push(p0); + push(p2); + multiply(); + p2 = pop(); + } + + push(p2); + push(p1); +} + +// returns 1 with divisor on stack, otherwise returns 0 + +int +numden_find_divisor(struct atom *p) +{ + if (car(p) == symbol(ADD)) { + p = cdr(p); + while (iscons(p)) { + if (numden_find_divisor_term(car(p))) + return 1; + p = cdr(p); + } + return 0; + } + + return numden_find_divisor_term(p); +} + +int +numden_find_divisor_term(struct atom *p) +{ + if (car(p) == symbol(MULTIPLY)) { + p = cdr(p); + while (iscons(p)) { + if (numden_find_divisor_factor(car(p))) + return 1; + p = cdr(p); + } + return 0; + } + + return numden_find_divisor_factor(p); +} + +int +numden_find_divisor_factor(struct atom *p) +{ + if (isrational(p) && !isinteger(p)) { + push_bignum(MPLUS, mcopy(p->u.q.b), mint(1)); + return 1; + } + + if (car(p) == symbol(POWER) && isnegativeterm(caddr(p))) { + if (isminusone(caddr(p))) + push(cadr(p)); + else { + push_symbol(POWER); + push(cadr(p)); + push(caddr(p)); + negate(); + list(3); + } + return 1; + } + + return 0; +} + +void +numden_cancel_factor(void) +{ + int h; + struct atom *p1, *p2; + + p2 = pop(); // numerator + p1 = pop(); // divisor + + // multiply term by term to ensure divisor is not distributed + + if (car(p2) == symbol(ADD)) { + h = tos; + p2 = cdr(p2); + while (iscons(p2)) { + push(p1); + push(car(p2)); + multiply(); + p2 = cdr(p2); + } + add_terms(tos - h); + return; + } + + push(p1); + push(p2); + multiply(); +} +void +outbuf_init(void) +{ + outbuf_index = 0; + outbuf_puts(""); // init outbuf as empty string +} + +void +outbuf_puts(char *s) +{ + int len, m; + + len = (int) strlen(s); + + // Let outbuf_index + len == 1000 + + // Then m == 2000 hence there is always room for the terminator '\0' + + m = 1000 * ((outbuf_index + len) / 1000 + 1); // m is a multiple of 1000 + + if (m > outbuf_length) { + outbuf = realloc(outbuf, m); + if (outbuf == NULL) + exit(1); + outbuf_length = m; + } + + strcpy(outbuf + outbuf_index, s); + outbuf_index += len; +} + +void +outbuf_putc(int c) +{ + int m; + + // Let outbuf_index + 1 == 1000 + + // Then m == 2000 hence there is always room for the terminator '\0' + + m = 1000 * ((outbuf_index + 1) / 1000 + 1); // m is a multiple of 1000 + + if (m > outbuf_length) { + outbuf = realloc(outbuf, m); + if (outbuf == NULL) + exit(1); + outbuf_length = m; + } + + outbuf[outbuf_index++] = c; + outbuf[outbuf_index] = '\0'; +} +int +iszero(struct atom *p) +{ + int i; + if (isrational(p)) + return MZERO(p->u.q.a); + if (isdouble(p)) + return p->u.d == 0.0; + if (istensor(p)) { + for (i = 0; i < p->u.tensor->nelem; i++) + if (!iszero(p->u.tensor->elem[i])) + return 0; + return 1; + } + return 0; +} + +int +isequaln(struct atom *p, int n) +{ + return isequalq(p, n, 1); +} + +int +isequalq(struct atom *p, int a, int b) +{ + int sign; + if (isrational(p)) { + if (a < 0) { + sign = MMINUS; + a = -a; + } else + sign = MPLUS; + return p->sign == sign && MEQUAL(p->u.q.a, a) && MEQUAL(p->u.q.b, b); + } + if (isdouble(p)) + return p->u.d == (double) a / b; + return 0; +} + +int +isplusone(struct atom *p) +{ + return isequaln(p, 1); +} + +int +isminusone(struct atom *p) +{ + return isequaln(p, -1); +} + +int +isinteger(struct atom *p) +{ + return isrational(p) && MEQUAL(p->u.q.b, 1); +} + +int +isfraction(struct atom *p) +{ + return isrational(p) && !MEQUAL(p->u.q.b, 1); +} + +int +isposint(struct atom *p) +{ + return isinteger(p) && !isnegativenumber(p); +} + +int +isradicalterm(struct atom *p) +{ + return car(p) == symbol(MULTIPLY) && isnum(cadr(p)) && isradical(caddr(p)); +} + +int +isradical(struct atom *p) +{ + return car(p) == symbol(POWER) && isposint(cadr(p)) && isfraction(caddr(p)); +} + +int +isnegativeterm(struct atom *p) +{ + return isnegativenumber(p) || (car(p) == symbol(MULTIPLY) && isnegativenumber(cadr(p))); +} + +int +isnegativenumber(struct atom *p) +{ + if (isrational(p)) + return p->sign == MMINUS; + else if (isdouble(p)) + return p->u.d < 0.0; + else + return 0; +} + +int +isimaginaryterm(struct atom *p) +{ + if (isimaginaryfactor(p)) + return 1; + if (car(p) == symbol(MULTIPLY)) { + p = cdr(p); + while (iscons(p)) { + if (isimaginaryfactor(car(p))) + return 1; + p = cdr(p); + } + } + return 0; +} + +int +isimaginaryfactor(struct atom *p) +{ + return car(p) == symbol(POWER) && isminusone(cadr(p)); +} + +int +iscomplexnumber(struct atom *p) +{ + return isimaginarynumber(p) || (lengthf(p) == 3 && car(p) == symbol(ADD) && isnum(cadr(p)) && isimaginarynumber(caddr(p))); +} + +int +isimaginarynumber(struct atom *p) +{ + return isimaginaryunit(p) || (lengthf(p) == 3 && car(p) == symbol(MULTIPLY) && isnum(cadr(p)) && isimaginaryunit(caddr(p))); +} + +int +isimaginaryunit(struct atom *p) +{ + return car(p) == symbol(POWER) && isminusone(cadr(p)) && isequalq(caddr(p), 1, 2); +} + +int +isoneoversqrttwo(struct atom *p) +{ + return car(p) == symbol(POWER) && isequaln(cadr(p), 2) && isequalq(caddr(p), -1, 2); +} + +int +isminusoneoversqrttwo(struct atom *p) +{ + return lengthf(p) == 3 && car(p) == symbol(MULTIPLY) && isminusone(cadr(p)) && isoneoversqrttwo(caddr(p)); +} + +// x + y * (-1)^(1/2) where x and y are double? + +int +isdoublez(struct atom *p) +{ + if (car(p) == symbol(ADD)) { + + if (lengthf(p) != 3) + return 0; + + if (!isdouble(cadr(p))) // x + return 0; + + p = caddr(p); + } + + if (car(p) != symbol(MULTIPLY)) + return 0; + + if (lengthf(p) != 3) + return 0; + + if (!isdouble(cadr(p))) // y + return 0; + + p = caddr(p); + + if (car(p) != symbol(POWER)) + return 0; + + if (!isminusone(cadr(p))) + return 0; + + if (!isequalq(caddr(p), 1, 2)) + return 0; + + return 1; +} + +int +isdenominator(struct atom *p) +{ + if (car(p) == symbol(POWER) && isnegativenumber(caddr(p))) + return 1; + else if (isrational(p) && !MEQUAL(p->u.q.b, 1)) + return 1; + else + return 0; +} + +int +isnumerator(struct atom *p) +{ + if (car(p) == symbol(POWER) && isnegativenumber(caddr(p))) + return 0; + else if (isrational(p) && MEQUAL(p->u.q.a, 1)) + return 0; + else + return 1; +} + +int +hasdouble(struct atom *p) +{ + if (iscons(p)) { + p = cdr(p); + while (iscons(p)) { + if (hasdouble(car(p))) + return 1; + p = cdr(p); + } + return 0; + } + return isdouble(p); +} + +int +isdenormalpolar(struct atom *p) +{ + if (car(p) == symbol(ADD)) { + p = cdr(p); + while (iscons(p)) { + if (isdenormalpolarterm(car(p))) + return 1; + p = cdr(p); + } + return 0; + } + + return isdenormalpolarterm(p); +} + +// returns 1 if term is (coeff * i * pi) and coeff < 0 or coeff >= 1/2 + +int +isdenormalpolarterm(struct atom *p) +{ + if (car(p) != symbol(MULTIPLY)) + return 0; + + if (lengthf(p) == 3 && isimaginaryunit(cadr(p)) && caddr(p) == symbol(PI)) + return 1; // exp(i pi) + + if (lengthf(p) != 4 || !isnum(cadr(p)) || !isimaginaryunit(caddr(p)) || cadddr(p) != symbol(PI)) + return 0; + + p = cadr(p); // p = coeff of term + + if (isnegativenumber(p)) + return 1; // p < 0 + + push(p); + push_rational(-1, 2); + add(); + p = pop(); + + if (!isnegativenumber(p)) + return 1; // p >= 1/2 + + return 0; +} + +int +issquarematrix(struct atom *p) +{ + return istensor(p) && p->u.tensor->ndim == 2 && p->u.tensor->dim[0] == p->u.tensor->dim[1]; +} + +int +issmallinteger(struct atom *p) +{ + if (isinteger(p)) + return MLENGTH(p->u.q.a) == 1 && p->u.q.a[0] <= 0x7fffffff; + + if (isdouble(p)) + return p->u.d == floor(p->u.d) && fabs(p->u.d) <= 0x7fffffff; + + return 0; +} + +// does f depend on x? + +int +dependent(struct atom *f, struct atom *x) +{ + if (equal(f, x)) + return 1; + + // a user function with no arguments? + + if (isusersymbol(car(f)) && lengthf(f) == 1) + return 1; + + while (iscons(f)) { + if (dependent(car(f), x)) + return 1; + f = cdr(f); + } + + return 0; +} + +void +run(char *buf) +{ + if (setjmp(jmpbuf)) + return; + + tos = 0; + interrupt = 0; + eval_level = 0; + gc_level = 0; + expanding = 1; + drawing = 0; + shuntflag = 0; + errorflag = 0; + breakflag = 0; + + if (zero == NULL) { + srand((unsigned) time(NULL)); + init_symbol_table(); + push_bignum(MPLUS, mint(0), mint(1)); + zero = pop(); + push_bignum(MPLUS, mint(1), mint(1)); + one = pop(); + push_bignum(MMINUS, mint(1), mint(1)); + minusone = pop(); + push_symbol(POWER); + push_integer(-1); + push_rational(1, 2); + list(3); + imaginaryunit = pop(); + run_init_script(); + } + + run_buf(buf); +} + +void +run_buf(char *buf) +{ + char *s, *save_trace1, *save_trace2; + struct atom *p1; + + save_trace1 = trace1; + save_trace2 = trace2; + + s = buf; + + for (;;) { + + s = scan_input(s); // also updates trace1 and trace2 + + if (s == NULL) + break; // end of input + + dupl(); + evalg(); + + // update last + + dupl(); + p1 = pop(); + + if (p1 != symbol(NIL)) + set_symbol(symbol(LAST), p1, symbol(NIL)); + + print_result(); + } + + trace1 = save_trace1; + trace2 = save_trace2; +} + +char * +scan_input(char *s) +{ + struct atom *p1; + trace1 = s; + s = scan(s); + trace2 = s; + p1 = get_binding(symbol(TRACE)); + if (p1 != symbol(TRACE) && !iszero(p1)) + print_trace(BLUE); + return s; +} + +void +print_trace(int color) +{ + char c, *s; + if (trace1 == NULL || trace2 == NULL) + return; + outbuf_init(); + c = '\n'; + s = trace1; + while (*s && s < trace2) { + c = *s++; + outbuf_putc(c); + } + if (c != '\n') + outbuf_putc('\n'); + printbuf(outbuf, color); +} + +char *init_script = +"i = sqrt(-1)\n" +"grad(f) = d(f,(x,y,z))\n" +"cross(a,b) = (dot(a[2],b[3])-dot(a[3],b[2]),dot(a[3],b[1])-dot(a[1],b[3]),dot(a[1],b[2])-dot(a[2],b[1]))\n" +"curl(u) = (d(u[3],y)-d(u[2],z),d(u[1],z)-d(u[3],x),d(u[2],x)-d(u[1],y))\n" +"div(u) = d(u[1],x)+d(u[2],y)+d(u[3],z)\n" +"laguerre(x,n,m) = (n + m)! sum(k,0,n,(-x)^k / ((n - k)! (m + k)! k!))\n" +"legendre(f,n,m,x) = eval(1 / (2^n n!) (1 - x^2)^(m/2) d((x^2 - 1)^n,x,n + m),x,f)\n" +"hermite(x,n) = (-1)^n exp(x^2) d(exp(-x^2),x,n)\n" +"binomial(n,k) = n! / k! / (n - k)!\n" +"choose(n,k) = n! / k! / (n - k)!\n" +; + +void +run_init_script(void) +{ + run_buf(init_script); +} + +void +stopf(char *s) +{ + print_trace(RED); + snprintf(strbuf, STRBUFLEN, "Stop: %s\n", s); + printbuf(strbuf, RED); + longjmp(jmpbuf, 1); +} +// token_str and scan_str are pointers to the input string, for example +// +// | g | a | m | m | a | | a | l | p | h | a | +// ^ ^ +// token_str scan_str + +#define T_EXCLAM 33 +#define T_QUOTEDBL 34 +#define T_NUMBERSIGN 35 +#define T_PARENLEFT 40 +#define T_PARENRIGHT 41 +#define T_ASTERISK 42 +#define T_PLUS 43 +#define T_COMMA 44 +#define T_HYPHEN 45 +#define T_PERIOD 46 +#define T_SLASH 47 +#define T_LESS 60 +#define T_EQUAL 61 +#define T_GREATER 62 +#define T_BRACKETLEFT 91 +#define T_BRACKETRIGHT 93 +#define T_ASCIICIRCUM 94 +#define T_INTEGER 1001 +#define T_DOUBLE 1002 +#define T_SYMBOL 1003 +#define T_FUNCTION 1004 +#define T_NEWLINE 1006 +#define T_STRING 1007 +#define T_GTEQ 1008 +#define T_LTEQ 1009 +#define T_EQ 1010 +#define T_END 1011 + +int token; +int scan_mode; +int scan_level; + +char *scan_str; +char *token_str; +char *token_buf; +int token_buf_len; + +char * +scan(char *s) +{ + scan_mode = 0; + return scan_nib(s); +} + +char * +scan1(char *s) +{ + scan_mode = 1; // mode for table of integrals + return scan_nib(s); +} + +char * +scan_nib(char *s) +{ + scan_str = s; + scan_level = 0; + get_token_skip_newlines(); + if (token == T_END) + return NULL; + scan_stmt(); + if (token != T_NEWLINE && token != T_END) + scan_error("syntax err"); // unexpected token, for example, 1:2 + return scan_str; +} + +void +scan_stmt(void) +{ + scan_comparison(); + if (token == '=') { + get_token_skip_newlines(); // get token after '=' + push_symbol(SETQ); + swap(); + scan_comparison(); + list(3); + } +} + +void +scan_comparison(void) +{ + scan_expression(); + switch (token) { + case T_EQ: + push_symbol(TESTEQ); // == + break; + case T_LTEQ: + push_symbol(TESTLE); + break; + case T_GTEQ: + push_symbol(TESTGE); + break; + case '<': + push_symbol(TESTLT); + break; + case '>': + push_symbol(TESTGT); + break; + default: + return; + } + swap(); + get_token_skip_newlines(); // get token after rel op + scan_expression(); + list(3); +} + +void +scan_expression(void) +{ + int h = tos, t; + t = token; + if (token == '+' || token == '-') + get_token_skip_newlines(); + scan_term(); + if (t == '-') + static_negate(); + while (token == '+' || token == '-') { + t = token; + get_token_skip_newlines(); // get token after '+' or '-' + scan_term(); + if (t == '-') + static_negate(); + } + if (tos - h > 1) { + list(tos - h); + push_symbol(ADD); + swap(); + cons(); // prepend ADD to list + } +} + +int +another_factor_pending(void) +{ + switch (token) { + case '*': + case '/': + case '(': + case T_SYMBOL: + case T_FUNCTION: + case T_INTEGER: + case T_DOUBLE: + case T_STRING: + return 1; + default: + break; + } + return 0; +} + +void +scan_term(void) +{ + int h = tos, t; + + scan_power(); + + while (another_factor_pending()) { + + t = token; + + if (token == '*' || token == '/') + get_token_skip_newlines(); + + scan_power(); + + if (t == '/') + static_reciprocate(); + } + + if (tos - h > 1) { + list(tos - h); + push_symbol(MULTIPLY); + swap(); + cons(); // prepend MULTIPLY to list + } +} + +void +scan_power(void) +{ + scan_factor(); + if (token == '^') { + get_token_skip_newlines(); + push_symbol(POWER); + swap(); + scan_power(); + list(3); + } +} + +void +scan_factor(void) +{ + int h = tos; + + switch (token) { + + case '(': + scan_subexpr(); + break; + + case T_SYMBOL: + scan_symbol(); + break; + + case T_FUNCTION: + scan_function_call(); + break; + + case T_INTEGER: + scan_integer(); + get_token(); + break; + + case T_DOUBLE: + push_double(atof(token_buf)); + get_token(); + break; + + case T_STRING: + scan_string(); + break; + + default: + scan_error("syntax err"); + break; + } + + // index + + if (token == '[') { + scan_level++; + get_token(); // get token after '[' + push_symbol(INDEX); + swap(); + scan_expression(); + while (token == ',') { + get_token(); // get token after ',' + scan_expression(); + } + if (token != ']') + scan_error("expected ']'"); + scan_level--; + get_token(); // get token after ']' + list(tos - h); + } + + while (token == '!') { + get_token(); // get token after '!' + push_symbol(FACTORIAL); + swap(); + list(2); + } +} + +void +scan_symbol(void) +{ + if (scan_mode && strlen(token_buf) == 1) + switch (token_buf[0]) { + case 'a': + push_symbol(SA); + break; + case 'b': + push_symbol(SB); + break; + case 'x': + push_symbol(SX); + break; + default: + push(lookup(token_buf)); + break; + } + else + push(lookup(token_buf)); + get_token(); +} + +void +scan_string(void) +{ + push_string(token_buf); + get_token(); +} + +void +scan_function_call(void) +{ + int h = tos; + scan_level++; + push(lookup(token_buf)); // push function name + get_token(); // get token after function name + get_token(); // get token after '(' + if (token == ')') { + scan_level--; + get_token(); // get token after ')' + list(1); // function call with no args + return; + } + scan_stmt(); + while (token == ',') { + get_token(); // get token after ',' + scan_stmt(); + } + if (token != ')') + scan_error("expected ')'"); + scan_level--; + get_token(); // get token after ')' + list(tos - h); +} + +void +scan_integer(void) +{ + int sign; + uint32_t *a; + switch (*token_buf) { + case '+': + sign = MPLUS; + a = mscan(token_buf + 1); + break; + case '-': + sign = MMINUS; + a = mscan(token_buf + 1); + break; + default: + sign = MPLUS; + a = mscan(token_buf); + break; + } + push_bignum(sign, a, mint(1)); +} + +void +scan_subexpr(void) +{ + int h, i, n; + struct atom *p; + h = tos; + scan_level++; + get_token(); // get token after '(' + scan_stmt(); + while (token == ',') { + get_token(); // get token after ',' + scan_stmt(); + } + if (token != ')') + scan_error("expected ')'"); + scan_level--; + get_token(); // get token after ')' + n = tos - h; + if (n < 2) + return; + p = alloc_vector(n); + for (i = 0; i < n; i++) + p->u.tensor->elem[i] = stack[h + i]; + tos = h; + push(p); +} + +void +get_token_skip_newlines(void) +{ + scan_level++; + get_token(); + scan_level--; +} + +void +get_token(void) +{ + get_token_nib(); + if (scan_level) + while (token == T_NEWLINE) + get_token_nib(); +} + +void +get_token_nib(void) +{ + // skip spaces + + while (*scan_str != '\0' && *scan_str != '\n' && *scan_str != '\r' && (*scan_str < 33 || *scan_str > 126)) + scan_str++; + + token_str = scan_str; + + // end of input? + + if (*scan_str == '\0') { + token = T_END; + return; + } + + // newline? + + if (*scan_str == '\n' || *scan_str == '\r') { + scan_str++; + token = T_NEWLINE; + return; + } + + // comment? + + if (*scan_str == '#' || (scan_str[0] == '-' && scan_str[1] == '-')) { + while (*scan_str && *scan_str != '\n' && *scan_str != '\r') + scan_str++; + if (*scan_str) + scan_str++; + token = T_NEWLINE; + return; + } + + // number? + + if (isdigit((unsigned char)*scan_str) || *scan_str == '.') { + while (isdigit((unsigned char)*scan_str)) + scan_str++; + if (*scan_str == '.') { + scan_str++; + while (isdigit((unsigned char)*scan_str)) + scan_str++; + if (token_str + 1 == scan_str) + scan_error("expected decimal digit"); // only a decimal point + token = T_DOUBLE; + } else + token = T_INTEGER; + update_token_buf(token_str, scan_str); + return; + } + + // symbol? + + if (isalpha((unsigned char)*scan_str)) { + while (isalnum((unsigned char)*scan_str)) + scan_str++; + if (*scan_str == '(') + token = T_FUNCTION; + else + token = T_SYMBOL; + update_token_buf(token_str, scan_str); + return; + } + + // string? + + if (*scan_str == '"') { + scan_str++; + while (*scan_str && *scan_str != '"' && *scan_str != '\n' && *scan_str != '\r') + scan_str++; + if (*scan_str != '"') + scan_error("runaway string"); + scan_str++; + token = T_STRING; + update_token_buf(token_str + 1, scan_str - 1); // don't include quote chars + return; + } + + // relational operator? + + if (*scan_str == '=' && scan_str[1] == '=') { + scan_str += 2; + token = T_EQ; + return; + } + + if (*scan_str == '<' && scan_str[1] == '=') { + scan_str += 2; + token = T_LTEQ; + return; + } + + if (*scan_str == '>' && scan_str[1] == '=') { + scan_str += 2; + token = T_GTEQ; + return; + } + + // single char token + + token = *scan_str++; +} + +void +update_token_buf(char *a, char *b) +{ + int m, n; + + n = (int) (b - a); + + // Let n == 1000 + + // Then m == 2000 hence there is always room for the terminator '\0' + + m = 1000 * (n / 1000 + 1); // m is a multiple of 1000 + + if (m > token_buf_len) { + if (token_buf) + free(token_buf); + token_buf = alloc_mem(m); + token_buf_len = m; + } + + strncpy(token_buf, a, n); + token_buf[n] = '\0'; +} + +void +scan_error(char *errmsg) +{ + trace2 = scan_str; + stopf(errmsg); +} + +void +static_negate(void) +{ + struct atom *p1; + + p1 = pop(); + + if (isnum(p1)) { + push(p1); + negate(); + return; + } + + if (car(p1) == symbol(MULTIPLY)) { + push_symbol(MULTIPLY); + if (isnum(cadr(p1))) { + push(cadr(p1)); // A + negate(); + push(cddr(p1)); // B + } else { + push_integer(-1); // A + push(cdr(p1)); // B + } + cons(); // prepend A to B + cons(); // prepend MULTIPLY + return; + } + + push_symbol(MULTIPLY); + push_integer(-1); + push(p1); + list(3); +} + +void +static_reciprocate(void) +{ + struct atom *p1, *p2; + + p2 = pop(); + p1 = pop(); + + // save divide by zero error for runtime + + if (iszero(p2)) { + push(p1); + push_symbol(POWER); + push(p2); + push_integer(-1); + list(3); + return; + } + + if (isnum(p1) && isnum(p2)) { + push(p1); + push(p2); + divide(); + return; + } + + if (!isrational(p1) || !isequaln(p1, 1)) + push(p1); // p1 != 1 + + if (isnum(p2)) { + push(p2); + reciprocate(); + return; + } + + if (car(p2) == symbol(POWER) && isnum(caddr(p2))) { + push_symbol(POWER); + push(cadr(p2)); + push(caddr(p2)); + negate(); + list(3); + return; + } + + push_symbol(POWER); + push(p2); + push_integer(-1); + list(3); +} +void +push(struct atom *p) +{ + if (tos < 0 || tos >= STACKSIZE) + stopf("stack error"); + stack[tos++] = p; + if (tos > max_tos) + max_tos = tos; +} + +struct atom * +pop(void) +{ + if (tos < 1 || tos > STACKSIZE) + stopf("stack error"); + return stack[--tos]; +} + +void +save_symbol(struct atom *p) +{ + push(p); + push(get_binding(p)); + push(get_usrfunc(p)); +} + +void +restore_symbol(void) +{ + struct atom *p1, *p2, *p3; + p3 = pop(); + p2 = pop(); + p1 = pop(); + set_symbol(p1, p2, p3); +} + +void +dupl(void) +{ + struct atom *p1; + p1 = pop(); + push(p1); + push(p1); +} + +void +swap(void) +{ + struct atom *p1, *p2; + p1 = pop(); + p2 = pop(); + push(p1); + push(p2); +} + +void +push_integer(int n) +{ + switch (n) { + case 0: + push(zero); + break; + case 1: + push(one); + break; + case -1: + push(minusone); + break; + default: + if (n < 0) + push_bignum(MMINUS, mint(-n), mint(1)); + else + push_bignum(MPLUS, mint(n), mint(1)); + break; + } +} + +void +push_rational(int a, int b) +{ + if (a < 0) + push_bignum(MMINUS, mint(-a), mint(b)); + else + push_bignum(MPLUS, mint(a), mint(b)); +} + +void +push_bignum(int sign, uint32_t *a, uint32_t *b) +{ + struct atom *p; + + // normalize zero + + if (MZERO(a)) { + sign = MPLUS; + if (!MEQUAL(b, 1)) { + mfree(b); + b = mint(1); + } + } + + p = alloc_atom(); + p->atomtype = RATIONAL; + p->sign = sign; + p->u.q.a = a; + p->u.q.b = b; + + push(p); +} + +int +pop_integer(void) +{ + int n; + struct atom *p; + + p = pop(); + + if (!issmallinteger(p)) + stopf("small integer expected"); + + if (isrational(p)) { + n = p->u.q.a[0]; + if (isnegativenumber(p)) + n = -n; + } else + n = (int) p->u.d; + + return n; +} + +void +push_double(double d) +{ + struct atom *p; + p = alloc_atom(); + p->atomtype = DOUBLE; + p->u.d = d; + push(p); +} + +double +pop_double(void) +{ + double a, b, d; + struct atom *p; + + p = pop(); + + if (!isnum(p)) + stopf("number expected"); + + if (isdouble(p)) + d = p->u.d; + else { + a = mfloat(p->u.q.a); + b = mfloat(p->u.q.b); + d = a / b; + if (isnegativenumber(p)) + d = -d; + } + + return d; +} + +void +push_string(char *s) +{ + struct atom *p; + p = alloc_str(); + s = strdup(s); + if (s == NULL) + exit(1); + p->u.str = s; + push(p); +} + +// start from stack + h and remove n items + +void +slice(int h, int n) +{ + int i, m; + m = tos - h - n; + if (m < 0) + stopf("stack slice error"); + for (i = 0; i < m; i++) + stack[h + i] = stack[h + n + i]; + tos -= n; +} +// symbol lookup, create symbol if not found + +struct atom * +lookup(char *s) +{ + int i, k; + struct atom *p; + + if (isupper((unsigned char)*s)) + k = BUCKETSIZE * (*s - 'A'); + else if (islower((unsigned char)*s)) + k = BUCKETSIZE * (*s - 'a'); + else + k = BUCKETSIZE * 26; + + for (i = 0; i < BUCKETSIZE; i++) { + p = symtab[k + i]; + if (p == NULL) + break; + if (strcmp(s, printname(p)) == 0) + return p; + } + + if (i == BUCKETSIZE) + stopf("symbol table full"); + + p = alloc_atom(); + s = strdup(s); + if (s == NULL) + exit(1); + p->atomtype = USYM; + p->u.usym.name = s; + p->u.usym.index = k + i; + symtab[k + i] = p; + usym_count++; + + return p; +} + +char * +printname(struct atom *p) +{ + if (iskeyword(p)) + return p->u.ksym.name; + else if (isusersymbol(p)) + return p->u.usym.name; + else + return "?"; +} + +void +set_symbol(struct atom *p1, struct atom *p2, struct atom *p3) +{ + if (!isusersymbol(p1)) + stopf("symbol error"); + binding[p1->u.usym.index] = p2; + usrfunc[p1->u.usym.index] = p3; +} + +struct atom * +get_binding(struct atom *p1) +{ + struct atom *p2; + if (!isusersymbol(p1)) + stopf("symbol error"); + p2 = binding[p1->u.usym.index]; + if (p2 == NULL || p2 == symbol(NIL)) + p2 = p1; // symbol binds to itself + return p2; +} + +struct atom * +get_usrfunc(struct atom *p) +{ + if (!isusersymbol(p)) + stopf("symbol error"); + p = usrfunc[p->u.usym.index]; + if (p == NULL) + p = symbol(NIL); + return p; +} + +struct se { + char *str; + int index; + void (*func)(struct atom *); +} stab[] = { + + { "abs", ABS, eval_abs }, + { "adj", ADJ, eval_adj }, + { "and", AND, eval_and }, + { "arccos", ARCCOS, eval_arccos }, + { "arccosh", ARCCOSH, eval_arccosh }, + { "arcsin", ARCSIN, eval_arcsin }, + { "arcsinh", ARCSINH, eval_arcsinh }, + { "arctan", ARCTAN, eval_arctan }, + { "arctanh", ARCTANH, eval_arctanh }, + { "arg", ARG, eval_arg }, + + { "binding", BINDING, eval_binding }, + { "break", BREAK, eval_break }, + + { "C", C_UPPER, NULL }, + { "c", C_LOWER, NULL }, + { "ceiling", CEILING, eval_ceiling }, + { "check", CHECK, eval_check }, + { "circexp", CIRCEXP, eval_expform }, + { "clear", CLEAR, eval_clear }, + { "clock", CLOCK, eval_clock }, + { "cofactor", COFACTOR, eval_cofactor }, + { "conj", CONJ, eval_conj }, + { "contract", CONTRACT, eval_contract }, + { "cos", COS, eval_cos }, + { "cosh", COSH, eval_cosh }, + + { "D", D_UPPER, NULL }, + { "d", D_LOWER, NULL }, + { "defint", DEFINT, eval_defint }, + { "denominator", DENOMINATOR, eval_denominator }, + { "derivative", DERIVATIVE, eval_derivative }, + { "det", DET, eval_det }, + { "dim", DIM, eval_dim }, + { "do", DO, eval_do }, + { "dot", DOT, eval_inner }, + { "draw", DRAW, eval_draw }, + + { "eigenvec", EIGENVEC, eval_eigenvec }, + { "erf", ERF, eval_erf }, + { "erfc", ERFC, eval_erfc }, + { "eval", EVAL, eval_eval }, + { "exit", EXIT, eval_exit }, + { "exp", EXP, eval_exp }, + { "expcos", EXPCOS, eval_expcos }, + { "expcosh", EXPCOSH, eval_expcosh }, + { "expform", EXPFORM, eval_expform }, + { "expsin", EXPSIN, eval_expsin }, + { "expsinh", EXPSINH, eval_expsinh }, + { "exptan", EXPTAN, eval_exptan }, + { "exptanh", EXPTANH, eval_exptanh }, + + { "factorial", FACTORIAL, eval_factorial }, + { "float", FLOATF, eval_float }, + { "floor", FLOOR, eval_floor }, + { "for", FOR, eval_for }, + + { "H", H_UPPER, NULL }, + { "h", H_LOWER, NULL }, + { "hadamard", HADAMARD, eval_hadamard }, + + { "I", I_UPPER, NULL }, + { "i", I_LOWER, NULL }, + { "imag", IMAG, eval_imag }, + { "infixform", INFIXFORM, eval_infixform }, + { "inner", INNER, eval_inner }, + { "integral", INTEGRAL, eval_integral }, + { "inv", INV, eval_inv }, + + { "J", J_UPPER, NULL }, + { "j", J_LOWER, NULL }, + + { "kronecker", KRONECKER, eval_kronecker }, + + { "last", LAST, NULL }, + { "lgamma", LGAMMA, eval_lgamma }, + { "log", LOG, eval_log }, + { "loop", LOOP, eval_loop }, + + { "mag", MAG, eval_mag }, + { "minor", MINOR, eval_minor }, + { "minormatrix", MINORMATRIX, eval_minormatrix }, + { "mod", MOD, eval_mod }, + + { "nil", NIL, eval_nil }, + { "noexpand", NOEXPAND, eval_noexpand }, + { "not", NOT, eval_not }, + { "nroots", NROOTS, eval_nroots }, + { "number", NUMBER, eval_number }, + { "numerator", NUMERATOR, eval_numerator }, + + { "or", OR, eval_or }, + { "outer", OUTER, eval_outer }, + + { "p", P_LOWER, NULL }, + { "P", P_UPPER, NULL }, + { "pi", PI, NULL }, + { "polar", POLAR, eval_polar }, + { "prefixform", PREFIXFORM, eval_prefixform }, + { "print", PRINT, eval_print }, + { "product", PRODUCT, eval_product }, + + { "Q", Q_UPPER, NULL }, + { "q", Q_LOWER, NULL }, + { "quote", QUOTE, eval_quote }, + + { "R", R_UPPER, NULL }, + { "r", R_LOWER, NULL }, + { "rand", RAND, eval_rand }, + { "rank", RANK, eval_rank }, + { "rationalize", RATIONALIZE, eval_rationalize }, + { "real", REAL, eval_real }, + { "rect", RECTF, eval_rect }, + { "roots", ROOTS, eval_roots }, + { "rotate", ROTATE, eval_rotate }, + { "run", RUN, eval_run }, + + { "S", S_UPPER, NULL }, + { "s", S_LOWER, NULL }, + { "sgn", SGN, eval_sgn }, + { "simplify", SIMPLIFY, eval_simplify }, + { "sin", SIN, eval_sin }, + { "sinh", SINH, eval_sinh }, + { "sqrt", SQRT, eval_sqrt }, + { "status", STATUS, eval_status }, + { "stop", STOP, eval_stop }, + { "sum", SUM, eval_sum }, + + { "T", T_UPPER, NULL }, + { "t", T_LOWER, NULL }, + { "tan", TAN, eval_tan }, + { "tanh", TANH, eval_tanh }, + { "taylor", TAYLOR, eval_taylor }, + { "test", TEST, eval_test }, + { "testeq", TESTEQ, eval_testeq }, + { "testge", TESTGE, eval_testge }, + { "testgt", TESTGT, eval_testgt }, + { "testle", TESTLE, eval_testle }, + { "testlt", TESTLT, eval_testlt }, + { "tgamma", TGAMMA, eval_tgamma }, + { "trace", TRACE, NULL }, + { "transpose", TRANSPOSE, eval_transpose }, + { "tty", TTY, NULL }, + + { "U", U_UPPER, NULL }, + { "u", U_LOWER, NULL }, + { "unit", UNIT, eval_unit }, + + { "V", V_UPPER, NULL }, + { "v", V_LOWER, NULL }, + + { "W", W_UPPER, NULL }, + { "w", W_LOWER, NULL }, + + { "X", X_UPPER, NULL }, + { "x", X_LOWER, NULL }, + + { "Y", Y_UPPER, NULL }, + { "y", Y_LOWER, NULL }, + + { "Z", Z_UPPER, NULL }, + { "z", Z_LOWER, NULL }, + { "zero", ZERO, eval_zero }, + + { "+", ADD, eval_add }, + { "*", MULTIPLY, eval_multiply }, + { "^", POWER, eval_power }, + { "[", INDEX, eval_index }, + { "=", SETQ, eval_setq }, + { "$e", EXP1, NULL }, + { "$a", SA, NULL }, + { "$b", SB, NULL }, + { "$x", SX, NULL }, + { "$arg1", ARG1, NULL }, + { "$arg2", ARG2, NULL }, + { "$arg3", ARG3, NULL }, + { "$arg4", ARG4, NULL }, + { "$arg5", ARG5, NULL }, + { "$arg6", ARG6, NULL }, + { "$arg7", ARG7, NULL }, + { "$arg8", ARG8, NULL }, + { "$arg9", ARG9, NULL }, +}; + +void +init_symbol_table(void) +{ + int i, n; + char *s; + struct atom *p; + + for (i = 0; i < 27 * BUCKETSIZE; i++) { + symtab[i] = NULL; + binding[i] = NULL; + usrfunc[i] = NULL; + } + + n = sizeof stab / sizeof (struct se); + + for (i = 0; i < n; i++) { + p = alloc_atom(); + s = strdup(stab[i].str); + if (s == NULL) + exit(1); + if (stab[i].func) { + p->atomtype = KSYM; + p->u.ksym.name = s; + p->u.ksym.func = stab[i].func; + ksym_count++; + } else { + p->atomtype = USYM; + p->u.usym.name = s; + p->u.usym.index = stab[i].index; + usym_count++; + } + symtab[stab[i].index] = p; + } +} + + +// This is the function which will be called from Python as cexample.add_ints(a, b). +static mp_obj_t example_add_ints(mp_obj_t a_obj, mp_obj_t b_obj) { + // Extract the ints from the micropython input objects. + int a = mp_obj_get_int(a_obj); + int b = mp_obj_get_int(b_obj); + + // Calculate the addition and convert to MicroPython object. + return mp_obj_new_int(a + b); +} +// Define a Python reference to the function above. +static MP_DEFINE_CONST_FUN_OBJ_2(example_add_ints_obj, example_add_ints); + +// This structure represents Timer instance objects. +typedef struct _example_Timer_obj_t { + // All objects start with the base. + mp_obj_base_t base; + // Everything below can be thought of as instance attributes, but they + // cannot be accessed by MicroPython code directly. In this example we + // store the time at which the object was created. + mp_uint_t start_time; +} example_Timer_obj_t; + +// This is the Timer.time() method. After creating a Timer object, this +// can be called to get the time elapsed since creating the Timer. +static mp_obj_t example_Timer_time(mp_obj_t self_in) { + // The first argument is self. It is cast to the *example_Timer_obj_t + // type so we can read its attributes. + example_Timer_obj_t *self = MP_OBJ_TO_PTR(self_in); + + // Get the elapsed time and return it as a MicroPython integer. + mp_uint_t elapsed = mp_hal_ticks_ms() - self->start_time; + return mp_obj_new_int_from_uint(elapsed); +} +static MP_DEFINE_CONST_FUN_OBJ_1(example_Timer_time_obj, example_Timer_time); + +// This represents Timer.__new__ and Timer.__init__, which is called when +// the user instantiates a Timer object. +static mp_obj_t example_Timer_make_new(const mp_obj_type_t *type, size_t n_args, size_t n_kw, const mp_obj_t *args) { + // Allocates the new object and sets the type. + example_Timer_obj_t *self = mp_obj_malloc(example_Timer_obj_t, type); + + // Initializes the time for this Timer instance. + self->start_time = mp_hal_ticks_ms(); + + // The make_new function always returns self. + return MP_OBJ_FROM_PTR(self); +} + +// This collects all methods and other static class attributes of the Timer. +// The table structure is similar to the module table, as detailed below. +static const mp_rom_map_elem_t example_Timer_locals_dict_table[] = { + { MP_ROM_QSTR(MP_QSTR_time), MP_ROM_PTR(&example_Timer_time_obj) }, +}; +static MP_DEFINE_CONST_DICT(example_Timer_locals_dict, example_Timer_locals_dict_table); + +// This defines the type(Timer) object. +MP_DEFINE_CONST_OBJ_TYPE( + example_type_Timer, + MP_QSTR_Timer, + MP_TYPE_FLAG_NONE, + make_new, example_Timer_make_new, + locals_dict, &example_Timer_locals_dict + ); + +// What follows is a *separate* class definition that demonstrates more +// advanced techniques to implement other Python-like features, such as: +// +// - A custom representation for __repr__ and __str__. +// - Custom attribute handling to create a read/write "property". +// +// It reuses some of the elements of the basic Timer class. This is allowed +// because they both use example_Timer_obj_t as the instance structure. + +// Handles AdvancedTimer.__repr__, AdvancedTimer.__str__. +static void example_AdvancedTimer_print(const mp_print_t *print, mp_obj_t self_in, mp_print_kind_t kind) { + + // Get the elapsed time. In this case, it's also a demonstration of calling + // the equivalent of self.time() in the C API. This is not usually very + // efficient, but it can sometimes be useful. + mp_uint_t elapsed = mp_obj_get_int(example_Timer_time(self_in)); + + // We'll make all representations print at least the class name. + mp_printf(print, "%q()", (qstr)MP_QSTR_AdvancedTimer); + + // Decide what else to print based on print kind. + if (kind == PRINT_STR) { + // For __str__, let's attempt to make it more readable. + mp_printf(print, " # created %d seconds ago", (int)(elapsed / 1000)); + } +} + +// Handles AdvancedTimer.seconds for reading and writing. +static void example_AdvancedTimer_attribute_handler(mp_obj_t self_in, qstr attr, mp_obj_t *dest) { + + // In this example, we only want to handle the .seconds attribute in a + // special way. + if (attr != MP_QSTR_seconds) { + // Attribute not found, continue lookup in locals dict. This way, + // methods like .time() will be handled normally. + dest[1] = MP_OBJ_SENTINEL; + return; + } + + // Get reference to AdvancedTimer instance. + example_Timer_obj_t *self = MP_OBJ_TO_PTR(self_in); + + // Check if this is a read operation. + if (dest[0] == MP_OBJ_NULL) { + // It's read, so "return" elapsed seconds by storing it in dest[0]. + mp_uint_t elapsed = mp_hal_ticks_ms() - self->start_time; + dest[0] = mp_obj_new_int_from_uint(elapsed / 1000); + return; + } + // Check if this is a delete or store operation. + else if (dest[0] == MP_OBJ_SENTINEL) { + // It's delete or store. Now check which one. + if (dest[1] == MP_OBJ_NULL) { + // It's delete. But in this example we don't want to allow it + // so we just return. + return; + } else { + // It's write. First, get the value that the user is trying to set. + mp_uint_t desired_ms = mp_obj_get_int(dest[1]) * 1000; + // Use it to update the start time. This way, the next read will + // report the updated time. + self->start_time = mp_hal_ticks_ms() - desired_ms; + + // Indicate successful store. + dest[0] = MP_OBJ_NULL; + return; + } + } +} + +// This defines the type(AdvancedTimer) object. +MP_DEFINE_CONST_OBJ_TYPE( + example_type_AdvancedTimer, + MP_QSTR_AdvancedTimer, + MP_TYPE_FLAG_NONE, + attr, example_AdvancedTimer_attribute_handler, + print, example_AdvancedTimer_print, + make_new, example_Timer_make_new, + locals_dict, &example_Timer_locals_dict + ); + +// Define all attributes of the module. +// Table entries are key/value pairs of the attribute name (a string) +// and the MicroPython object reference. +// All identifiers and strings are written as MP_QSTR_xxx and will be +// optimized to word-sized integers by the build system (interned strings). +static const mp_rom_map_elem_t example_module_globals_table[] = { + { MP_ROM_QSTR(MP_QSTR___name__), MP_ROM_QSTR(MP_QSTR_cexample) }, + { MP_ROM_QSTR(MP_QSTR_add_ints), MP_ROM_PTR(&example_add_ints_obj) }, + { MP_ROM_QSTR(MP_QSTR_Timer), MP_ROM_PTR(&example_type_Timer) }, + { MP_ROM_QSTR(MP_QSTR_AdvancedTimer), MP_ROM_PTR(&example_type_AdvancedTimer) }, +}; +static MP_DEFINE_CONST_DICT(example_module_globals, example_module_globals_table); + +// Define module object. +const mp_obj_module_t example_user_cmodule = { + .base = { &mp_type_module }, + .globals = (mp_obj_dict_t *)&example_module_globals, +}; + +// Register the module to make it available in Python. +MP_REGISTER_MODULE(MP_QSTR_cexample, example_user_cmodule); \ No newline at end of file diff --git a/user_modules/cexample/micropython.cmake b/user_modules/cexample/micropython.cmake new file mode 100644 index 000000000..2b0bfa68e --- /dev/null +++ b/user_modules/cexample/micropython.cmake @@ -0,0 +1,15 @@ +# Create an INTERFACE library for our C module. +add_library(usermod_cexample INTERFACE) + +# Add our source files to the lib +target_sources(usermod_cexample INTERFACE + ${CMAKE_CURRENT_LIST_DIR}/examplemodule.c +) + +# Add the current directory as an include directory. +target_include_directories(usermod_cexample INTERFACE + ${CMAKE_CURRENT_LIST_DIR} +) + +# Link our INTERFACE library to the usermod target. +target_link_libraries(usermod INTERFACE usermod_cexample) \ No newline at end of file diff --git a/user_modules/cexample/micropython.mk b/user_modules/cexample/micropython.mk new file mode 100644 index 000000000..d1f6a320b --- /dev/null +++ b/user_modules/cexample/micropython.mk @@ -0,0 +1,8 @@ +CEXAMPLE_MOD_DIR := $(USERMOD_DIR) + +# Add all C files to SRC_USERMOD. +SRC_USERMOD += $(CEXAMPLE_MOD_DIR)/examplemodule.c + +# We can add our module folder to include paths if needed +# This is not actually needed in this example. +CFLAGS_USERMOD += -I$(CEXAMPLE_MOD_DIR) \ No newline at end of file diff --git a/user_modules/user.cmake b/user_modules/user.cmake new file mode 100644 index 000000000..d24aed57a --- /dev/null +++ b/user_modules/user.cmake @@ -0,0 +1,2 @@ +include(${CMAKE_CURRENT_LIST_DIR}/cexample/micropython.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/lv_binding_micropython/bindings.cmake) \ No newline at end of file -- 2.47.2 From c3e391b1909044e9e9dee0721a3c41b801a95a37 Mon Sep 17 00:00:00 2001 From: feng-arch Date: Sat, 20 Sep 2025 14:11:34 +0800 Subject: [PATCH 2/6] feat: add spi.set_irq() support --- extmod/machine_spi.c | 12 +++++ extmod/modmachine.h | 1 + make_and_flash_rp2.sh | 5 +- ports/rp2/machine_spi.c | 110 ++++++++++++++++++++++++++++++++++++++-- 4 files changed, 122 insertions(+), 6 deletions(-) diff --git a/extmod/machine_spi.c b/extmod/machine_spi.c index 04506370f..88dc79832 100644 --- a/extmod/machine_spi.c +++ b/extmod/machine_spi.c @@ -76,6 +76,17 @@ static mp_obj_t mp_machine_spi_wait_done(size_t n_args, const mp_obj_t *args) } 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; @@ -128,6 +139,7 @@ static const mp_rom_map_elem_t machine_spi_locals_dict_table[] = { {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)}, diff --git a/extmod/modmachine.h b/extmod/modmachine.h index f1f455b41..4e8177b00 100644 --- a/extmod/modmachine.h +++ b/extmod/modmachine.h @@ -194,6 +194,7 @@ typedef struct _mp_machine_spi_p_t 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. diff --git a/make_and_flash_rp2.sh b/make_and_flash_rp2.sh index 8bff03697..85c2141fa 100755 --- a/make_and_flash_rp2.sh +++ b/make_and_flash_rp2.sh @@ -1,4 +1,7 @@ -make -j -C ports/rp2 BOARD=RPI_PICO USER_C_MODULES=../../user_modules/lv_binding_micropython/bindings.cmake + +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 diff --git a/ports/rp2/machine_spi.c b/ports/rp2/machine_spi.c index 3f35cd1a7..7b623fecf 100644 --- a/ports/rp2/machine_spi.c +++ b/ports/rp2/machine_spi.c @@ -27,6 +27,7 @@ #include "py/runtime.h" #include "py/mphal.h" #include "py/mperrno.h" +#include "shared/runtime/mpirq.h" #include "extmod/modmachine.h" #include "hardware/spi.h" @@ -104,6 +105,8 @@ typedef struct _machine_spi_obj_t 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[] = { @@ -122,6 +125,7 @@ static machine_spi_obj_t machine_spi_obj[] = { // DMA channels, -1 means not claimed -1, -1, + NULL }, { {&machine_spi_type}, @@ -138,6 +142,7 @@ static machine_spi_obj_t machine_spi_obj[] = { // DMA channels, -1 means not claimed -1, -1, + NULL }, }; @@ -314,6 +319,87 @@ static void machine_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj } } +static void machine_spi0_tx_irq_handler(void) +{ + // currently only used for spi0 + 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_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, + }; + static const mp_arg_t allowed_args[] = { + {MP_QSTR_tx_isr, MP_ARG_REQUIRED | MP_ARG_OBJ, {.u_obj = mp_const_none}}, + }; + 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 = true; + 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; @@ -332,6 +418,17 @@ static void machine_spi_wait_done(mp_obj_base_t *self_in) 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; + 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; @@ -340,13 +437,13 @@ static void machine_spi_transfer(mp_obj_base_t *self_in, size_t len, const uint8 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); + // 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 - bool write_only = dest == NULL; uint8_t dev_null; dma_channel_config c; @@ -413,8 +510,11 @@ 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( machine_spi_type, MP_QSTR_SPI, -- 2.47.2 From dca783774dd38dae814435c62cf551c83931554d Mon Sep 17 00:00:00 2001 From: feng-arch Date: Fri, 10 Oct 2025 14:22:23 +0800 Subject: [PATCH 3/6] =?UTF-8?q?=E6=94=BE=E5=BC=83=E4=BA=86=EF=BC=8C?= =?UTF-8?q?=E6=97=A0=E6=B3=95=E6=94=AF=E6=8C=81dma?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- ports/rp2/machine_spi.c | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/ports/rp2/machine_spi.c b/ports/rp2/machine_spi.c index 7b623fecf..c0cee4f88 100644 --- a/ports/rp2/machine_spi.c +++ b/ports/rp2/machine_spi.c @@ -25,6 +25,7 @@ */ #include "py/runtime.h" +#include "py/gc.h" #include "py/mphal.h" #include "py/mperrno.h" #include "shared/runtime/mpirq.h" @@ -322,6 +323,7 @@ static void machine_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj 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 @@ -333,7 +335,16 @@ static void machine_spi0_tx_irq_handler(void) 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_irq_handler(self->tx_isr_obj); + // 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); + } } } // } @@ -369,9 +380,11 @@ static void machine_spi_set_tx_isr(mp_obj_base_t *self_in, size_t n_args, const 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); @@ -390,9 +403,10 @@ static void machine_spi_set_tx_isr(mp_obj_base_t *self_in, size_t n_args, const 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 = true; + 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); -- 2.47.2 From 32ec5221d485a31708787c006a23249079541b85 Mon Sep 17 00:00:00 2001 From: feng-arch Date: Sat, 11 Oct 2025 14:33:16 +0800 Subject: [PATCH 4/6] =?UTF-8?q?feat:=20=E6=B7=BB=E5=8A=A0=E4=BA=86eigenmat?= =?UTF-8?q?h=E6=94=AF=E6=8C=81=EF=BC=8C=E4=BD=86=E6=98=AF=E7=9B=AE?= =?UTF-8?q?=E5=89=8D=E5=AD=98=E5=9C=A8=E9=97=AE=E9=A2=98?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- user_modules/cexample/micropython.cmake | 15 --- .../examplemodule.c => eigenmath/eigenmath.c} | 123 ++++++++++++------ user_modules/eigenmath/micropython.cmake | 15 +++ .../{cexample => eigenmath}/micropython.mk | 2 +- user_modules/user.cmake | 2 +- 5 files changed, 101 insertions(+), 56 deletions(-) delete mode 100644 user_modules/cexample/micropython.cmake rename user_modules/{cexample/examplemodule.c => eigenmath/eigenmath.c} (99%) create mode 100644 user_modules/eigenmath/micropython.cmake rename user_modules/{cexample => eigenmath}/micropython.mk (80%) diff --git a/user_modules/cexample/micropython.cmake b/user_modules/cexample/micropython.cmake deleted file mode 100644 index 2b0bfa68e..000000000 --- a/user_modules/cexample/micropython.cmake +++ /dev/null @@ -1,15 +0,0 @@ -# Create an INTERFACE library for our C module. -add_library(usermod_cexample INTERFACE) - -# Add our source files to the lib -target_sources(usermod_cexample INTERFACE - ${CMAKE_CURRENT_LIST_DIR}/examplemodule.c -) - -# Add the current directory as an include directory. -target_include_directories(usermod_cexample INTERFACE - ${CMAKE_CURRENT_LIST_DIR} -) - -# Link our INTERFACE library to the usermod target. -target_link_libraries(usermod INTERFACE usermod_cexample) \ No newline at end of file diff --git a/user_modules/cexample/examplemodule.c b/user_modules/eigenmath/eigenmath.c similarity index 99% rename from user_modules/cexample/examplemodule.c rename to user_modules/eigenmath/eigenmath.c index 9d8d5e286..9d8ca8039 100644 --- a/user_modules/cexample/examplemodule.c +++ b/user_modules/eigenmath/eigenmath.c @@ -3,6 +3,8 @@ // Used to get the time in the Timer class example. #include "py/mphal.h" +#include "py/misc.h" +#include "shared/readline/readline.h" /* @@ -44,12 +46,33 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #include #include -#define STACKSIZE 100000 // evaluation stack -#define BLOCKSIZE 10000 -#define MAXBLOCKS 2000 -#define BUCKETSIZE 100 -#define STRBUFLEN 1000 -#define MAXDIM 24 +// #define STACKSIZE 100000 // evaluation stack +// #define BLOCKSIZE 10000 +// #define MAXBLOCKS 2000 +// #define BUCKETSIZE 100 +// #define STRBUFLEN 1000 +// #define MAXDIM 24 + +// #define STACKSIZE 4096 // 栈大小从100000减到4096 +// #define BLOCKSIZE 512 // 块大小从10000减到512 +// #define MAXBLOCKS 64 // 最大块数从2000减到64 +// #define BUCKETSIZE 32 // 哈希桶大小相应减小 +// #define STRBUFLEN 256 // 字符串缓冲区减小 +// #define MAXDIM 16 // 维度限制适当降低 + +// #define STACKSIZE 128 // 栈大小：128个元素（每个元素按4字节算约512字节） +// #define BLOCKSIZE 16 // 块大小：每个块包含16个atom +// #define MAXBLOCKS 64 // 最大块数：64块（16*64=1024个atom） +// #define BUCKETSIZE 4 // 哈希桶大小：仅保留4个桶 +// #define STRBUFLEN 32 // 字符串缓冲区：每个字符串最大32字节 +// #define MAXDIM 4 // 维度限制：降低到4维 + +#define STACKSIZE 512 // 进一步减小栈大小 +#define BLOCKSIZE 128 // 减小块大小 +#define MAXBLOCKS 64 // 减少最大块数 +#define BUCKETSIZE 20 // 减小哈希桶 +#define STRBUFLEN 256 // 减小字符串缓冲区 +#define MAXDIM 16 // 降低维度限制 // MAXBLOCKS * BLOCKSIZE = 20,000,000 atoms @@ -1019,7 +1042,7 @@ alloc_str(void) void * alloc_mem(int n) { - void *p = malloc(n); + void *p = m_malloc(n); if (p == NULL) exit(1); return p; @@ -1104,7 +1127,7 @@ mstr(uint32_t *u) if (n > len) { if (buf) - free(buf); + m_free(buf); buf = alloc_mem(n); len = n; } @@ -1486,7 +1509,7 @@ mnew(int n) void mfree(uint32_t *u) { - free(u - 1); + m_free(u - 1); bignum_count--; } @@ -5072,9 +5095,9 @@ eval_eigenvec(struct atom *p1) stopf("eigenvec"); if (D) - free(D); + m_free(D); if (Q) - free(Q); + m_free(Q); D = alloc_mem(n * n * sizeof (double)); Q = alloc_mem(n * n * sizeof (double)); @@ -9939,9 +9962,9 @@ nroots(void) n = tos - h; // number of coeffs on stack if (cr) - free(cr); + m_free(cr); if (ci) - free(ci); + m_free(ci); cr = alloc_mem(n * sizeof (double)); ci = alloc_mem(n * sizeof (double)); @@ -12715,7 +12738,7 @@ read_file(char *filename) } if (read(fd, buf, n) != n) { - free(buf); + m_free(buf); close(fd); return NULL; } @@ -15393,7 +15416,7 @@ fmt(void) if (m > fmt_buf_len) { if (fmt_buf) - free(fmt_buf); + m_free(fmt_buf); fmt_buf = alloc_mem(m); fmt_buf_len = m; } @@ -16742,11 +16765,11 @@ gc(void) switch (p->atomtype) { case KSYM: - free(p->u.ksym.name); + m_free(p->u.ksym.name); ksym_count--; break; case USYM: - free(p->u.usym.name); + m_free(p->u.usym.name); usym_count--; break; case RATIONAL: @@ -16755,11 +16778,11 @@ gc(void) break; case STR: if (p->u.str) - free(p->u.str); + m_free(p->u.str); string_count--; break; case TENSOR: - free(p->u.tensor); + m_free(p->u.tensor); tensor_count--; break; default: @@ -16864,21 +16887,31 @@ run_infile(char *infile) exit(1); } run(buf); - free(buf); + m_free(buf); } void run_stdin(void) { - static char inbuf[1000]; - for (;;) { - fputs("? ", stdout); - fflush(stdout); - fgets(inbuf, sizeof inbuf, stdin); - run(inbuf); - } + mp_printf(&mp_plat_print, "Eigenmath start %d\n", __LINE__); + // static char inbuf[1000]; + vstr_t* vstr_inbuf = vstr_new(1); + + // for (;;) { + // fputs("? ", stdout); + // fflush(stdout); + // fgets(inbuf, sizeof inbuf, stdin); + 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); + // } } + + + void display(void) { @@ -16888,7 +16921,8 @@ display(void) void printbuf(char *s, int color) { - fputs(s, stdout); + // fputs(s, stdout); + mp_printf(&mp_plat_print, "%s", s); } void @@ -17394,7 +17428,7 @@ run(char *buf) shuntflag = 0; errorflag = 0; breakflag = 0; - + mp_printf(&mp_plat_print, "run() has param: %s\n", buf); if (zero == NULL) { srand((unsigned) time(NULL)); init_symbol_table(); @@ -17409,10 +17443,10 @@ run(char *buf) push_rational(1, 2); list(3); imaginaryunit = pop(); - run_init_script(); + // run_init_script(); } - - run_buf(buf); + mp_printf(&mp_plat_print, "start to run run_buf()\n"); + // run_buf(buf); } void @@ -18015,7 +18049,7 @@ update_token_buf(char *a, char *b) if (m > token_buf_len) { if (token_buf) - free(token_buf); + m_free(token_buf); token_buf = alloc_mem(m); token_buf_len = m; } @@ -18621,6 +18655,16 @@ static mp_obj_t example_add_ints(mp_obj_t a_obj, mp_obj_t b_obj) { // Calculate the addition and convert to MicroPython object. return mp_obj_new_int(a + b); } + + +static mp_obj_t eigenmath_cmd() { + run_stdin(); + // Calculate the addition and convert to MicroPython object. + return mp_obj_new_int(0); +} + +static MP_DEFINE_CONST_FUN_OBJ_0(eigenmath_cmd_obj, eigenmath_cmd); + // Define a Python reference to the function above. static MP_DEFINE_CONST_FUN_OBJ_2(example_add_ints_obj, example_add_ints); @@ -18762,19 +18806,20 @@ MP_DEFINE_CONST_OBJ_TYPE( // and the MicroPython object reference. // All identifiers and strings are written as MP_QSTR_xxx and will be // optimized to word-sized integers by the build system (interned strings). -static const mp_rom_map_elem_t example_module_globals_table[] = { - { MP_ROM_QSTR(MP_QSTR___name__), MP_ROM_QSTR(MP_QSTR_cexample) }, +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_add_ints), MP_ROM_PTR(&example_add_ints_obj) }, + { MP_ROM_QSTR(MP_QSTR_cmd), MP_ROM_PTR(&eigenmath_cmd_obj) }, { MP_ROM_QSTR(MP_QSTR_Timer), MP_ROM_PTR(&example_type_Timer) }, { MP_ROM_QSTR(MP_QSTR_AdvancedTimer), MP_ROM_PTR(&example_type_AdvancedTimer) }, }; -static MP_DEFINE_CONST_DICT(example_module_globals, example_module_globals_table); +static MP_DEFINE_CONST_DICT(eigenmath_module_globals, eigenmath_module_globals_table); // Define module object. -const mp_obj_module_t example_user_cmodule = { +const mp_obj_module_t eigenmath_user_cmodule = { .base = { &mp_type_module }, - .globals = (mp_obj_dict_t *)&example_module_globals, + .globals = (mp_obj_dict_t *)&eigenmath_module_globals, }; // Register the module to make it available in Python. -MP_REGISTER_MODULE(MP_QSTR_cexample, example_user_cmodule); \ No newline at end of file +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..0631eb107 --- /dev/null +++ b/user_modules/eigenmath/micropython.cmake @@ -0,0 +1,15 @@ +# 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 +) + +# Add the current directory as an include directory. +target_include_directories(usermod_eigenmath INTERFACE + ${CMAKE_CURRENT_LIST_DIR} +) + +# Link our INTERFACE library to the usermod target. +target_link_libraries(usermod INTERFACE usermod_eigenmath) \ No newline at end of file diff --git a/user_modules/cexample/micropython.mk b/user_modules/eigenmath/micropython.mk similarity index 80% rename from user_modules/cexample/micropython.mk rename to user_modules/eigenmath/micropython.mk index d1f6a320b..577d7e1ba 100644 --- a/user_modules/cexample/micropython.mk +++ b/user_modules/eigenmath/micropython.mk @@ -1,7 +1,7 @@ CEXAMPLE_MOD_DIR := $(USERMOD_DIR) # Add all C files to SRC_USERMOD. -SRC_USERMOD += $(CEXAMPLE_MOD_DIR)/examplemodule.c +SRC_USERMOD += $(CEXAMPLE_MOD_DIR)/eigenmath.c # We can add our module folder to include paths if needed # This is not actually needed in this example. diff --git a/user_modules/user.cmake b/user_modules/user.cmake index d24aed57a..71eaf18bd 100644 --- a/user_modules/user.cmake +++ b/user_modules/user.cmake @@ -1,2 +1,2 @@ -include(${CMAKE_CURRENT_LIST_DIR}/cexample/micropython.cmake) +include(${CMAKE_CURRENT_LIST_DIR}/eigenmath/micropython.cmake) include(${CMAKE_CURRENT_LIST_DIR}/lv_binding_micropython/bindings.cmake) \ No newline at end of file -- 2.47.2 From 2c4811cea42daae6b40a49e042a33b746075e8c2 Mon Sep 17 00:00:00 2001 From: feng-arch Date: Mon, 13 Oct 2025 15:42:15 +0800 Subject: [PATCH 5/6] feat: add support for eigenmath --- ports/rp2/boards/RPI_PICO/mpconfigboard.h | 2 +- user_modules/eigenmath/eheap.c | 341 ++++ user_modules/eigenmath/eheap.h | 33 + user_modules/eigenmath/eigenmath.c | 1932 +++++++++------------ user_modules/eigenmath/eigenmath.h | 35 + user_modules/eigenmath/eigenmath_mpy.c | 281 +++ user_modules/eigenmath/micropython.cmake | 6 +- user_modules/eigenmath/micropython.mk | 8 +- 8 files changed, 1490 insertions(+), 1148 deletions(-) create mode 100644 user_modules/eigenmath/eheap.c create mode 100644 user_modules/eigenmath/eheap.h create mode 100644 user_modules/eigenmath/eigenmath.h create mode 100644 user_modules/eigenmath/eigenmath_mpy.c 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/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 index 9d8ca8039..80c6c593b 100644 --- a/user_modules/eigenmath/eigenmath.c +++ b/user_modules/eigenmath/eigenmath.c @@ -1,12 +1,3 @@ -// Include MicroPython API. -#include "py/runtime.h" - -// Used to get the time in the Timer class example. -#include "py/mphal.h" -#include "py/misc.h" -#include "shared/readline/readline.h" - - /* BSD 2-Clause License @@ -34,6 +25,7 @@ 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 @@ -44,35 +36,25 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. #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 -// #define STACKSIZE 100000 // evaluation stack -// #define BLOCKSIZE 10000 -// #define MAXBLOCKS 2000 -// #define BUCKETSIZE 100 -// #define STRBUFLEN 1000 -// #define MAXDIM 24 -// #define STACKSIZE 4096 // 栈大小从100000减到4096 -// #define BLOCKSIZE 512 // 块大小从10000减到512 -// #define MAXBLOCKS 64 // 最大块数从2000减到64 -// #define BUCKETSIZE 32 // 哈希桶大小相应减小 -// #define STRBUFLEN 256 // 字符串缓冲区减小 -// #define MAXDIM 16 // 维度限制适当降低 +uint32_t STACKSIZE ; +uint32_t MAXATOMS ; // 10,240 atoms -// #define STACKSIZE 128 // 栈大小：128个元素（每个元素按4字节算约512字节） -// #define BLOCKSIZE 16 // 块大小：每个块包含16个atom -// #define MAXBLOCKS 64 // 最大块数：64块（16*64=1024个atom） -// #define BUCKETSIZE 4 // 哈希桶大小：仅保留4个桶 -// #define STRBUFLEN 32 // 字符串缓冲区：每个字符串最大32字节 -// #define MAXDIM 4 // 维度限制：降低到4维 - -#define STACKSIZE 512 // 进一步减小栈大小 -#define BLOCKSIZE 128 // 减小块大小 -#define MAXBLOCKS 64 // 减少最大块数 -#define BUCKETSIZE 20 // 减小哈希桶 -#define STRBUFLEN 256 // 减小字符串缓冲区 -#define MAXDIM 16 // 降低维度限制 // MAXBLOCKS * BLOCKSIZE = 20,000,000 atoms @@ -101,7 +83,7 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. // |SYM | |SYM | |SYM | // |"mul" | |"a" | |"b" | // |_______| |_______| |_______| - +/**/ struct atom { union { struct { @@ -160,7 +142,6 @@ struct tensor { #define ARG (0 * BUCKETSIZE + 9) #define BINDING (1 * BUCKETSIZE + 0) -#define BREAK (1 * BUCKETSIZE + 1) #define C_UPPER (2 * BUCKETSIZE + 0) #define C_LOWER (2 * BUCKETSIZE + 1) @@ -223,9 +204,7 @@ struct tensor { #define KRONECKER (10 * BUCKETSIZE + 0) #define LAST (11 * BUCKETSIZE + 0) -#define LGAMMA (11 * BUCKETSIZE + 1) -#define LOG (11 * BUCKETSIZE + 2) -#define LOOP (11 * BUCKETSIZE + 3) +#define LOG (11 * BUCKETSIZE + 1) #define MAG (12 * BUCKETSIZE + 0) #define MINOR (12 * BUCKETSIZE + 1) @@ -256,14 +235,13 @@ struct tensor { #define R_UPPER (17 * BUCKETSIZE + 0) #define R_LOWER (17 * BUCKETSIZE + 1) -#define RAND (17 * BUCKETSIZE + 2) -#define RANK (17 * BUCKETSIZE + 3) -#define RATIONALIZE (17 * BUCKETSIZE + 4) -#define REAL (17 * BUCKETSIZE + 5) -#define RECTF (17 * BUCKETSIZE + 6) -#define ROOTS (17 * BUCKETSIZE + 7) -#define ROTATE (17 * BUCKETSIZE + 8) -#define RUN (17 * BUCKETSIZE + 9) +#define 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) @@ -287,10 +265,9 @@ struct tensor { #define TESTGT (19 * BUCKETSIZE + 8) #define TESTLE (19 * BUCKETSIZE + 9) #define TESTLT (19 * BUCKETSIZE + 10) -#define TGAMMA (19 * BUCKETSIZE + 11) -#define TRACE (19 * BUCKETSIZE + 12) -#define TRANSPOSE (19 * BUCKETSIZE + 13) -#define TTY (19 * BUCKETSIZE + 14) +#define 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) @@ -381,15 +358,19 @@ struct tensor { #define BLUE 1 #define RED 2 -#define Trace fprintf(stderr, "%s %d\n", __func__, __LINE__); +//#define Trace fprintf(stderr, "%s %d\n", __func__, __LINE__); +#define Trace mp_printf(&mp_plat_print,"[TRACE]%s:%d\n",__func__,__LINE__); -extern struct atom *mem[MAXBLOCKS]; // an array of pointers +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[STACKSIZE]; -extern struct atom *symtab[27 * BUCKETSIZE]; -extern struct atom *binding[27 * BUCKETSIZE]; -extern struct atom *usrfunc[27 * BUCKETSIZE]; +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; @@ -398,11 +379,10 @@ extern int eval_level; extern int gc_level; extern int expanding; extern int drawing; +extern int nonstop; extern int interrupt; -extern int shuntflag; -extern int breakflag; -extern int errorflag; -extern jmp_buf jmpbuf; +extern jmp_buf jmpbuf0; +extern jmp_buf jmpbuf1; extern char *trace1; extern char *trace2; extern int alloc_count; @@ -421,8 +401,10 @@ 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); -void alloc_block(void); struct atom * alloc_vector(int nrow); struct atom * alloc_matrix(int nrow, int ncol); struct atom * alloc_tensor(int nelem); @@ -464,6 +446,10 @@ 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); @@ -502,7 +488,6 @@ void eval_arg(struct atom *p1); void argfunc(void); void arg_nib(void); void eval_binding(struct atom *p1); -void eval_break(struct atom *p1); void eval_ceiling(struct atom *p1); void ceilingfunc(void); void eval_check(struct atom *p1); @@ -530,6 +515,7 @@ 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); @@ -548,8 +534,6 @@ void derfc(struct atom *p1, struct atom *p2); void d_tensor_tensor(struct atom *p1, struct atom *p2); void d_scalar_tensor(struct atom *p1, struct atom *p2); void d_tensor_scalar(struct atom *p1, struct atom *p2); -void derivative_of_derivative(struct atom *F, struct atom *X); -void derivative_of_integral(struct atom *F, struct atom *X); void eval_det(struct atom *p1); void det(void); void eval_dim(struct atom *p1); @@ -623,26 +607,21 @@ void eval_inner(struct atom *p1); void inner(void); void eval_integral(struct atom *p1); void integral(void); -void integral_solve(struct atom *F, struct atom *X); -void integral_solve_nib(struct atom *F, struct atom *X); +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, char **table, int n); +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 integral_of_integral(struct atom *F, struct atom *X); -void integral_of_derivative(struct atom *F, struct atom *X); void eval_inv(struct atom *p1); void inv(void); void eval_kronecker(struct atom *p1); void kronecker(void); -void eval_lgamma(struct atom *p1); -void lgammafunc(void); void eval_log(struct atom *p1); void logfunc(void); -void eval_loop(struct atom *p1); void eval_mag(struct atom *p1); void magfunc(void); void magfunc_nib(void); @@ -727,7 +706,6 @@ void print_result(void); int annotate_result(struct atom *p1, struct atom *p2); void eval_product(struct atom *p1); void eval_quote(struct atom *p1); -void eval_rand(struct atom *p1); void eval_rank(struct atom *p1); void eval_rationalize(struct atom *p1); void rationalize(void); @@ -760,7 +738,7 @@ void set_component(struct atom *LVAL, struct atom *RVAL, int h); void setq_usrfunc(struct atom *p1); void convert_body(struct atom *A); void eval_sgn(struct atom *p1); -void sgnfunc(void); +void sgn(void); void eval_simplify(struct atom *p1); void simplify(void); void simplify_nib(void); @@ -795,18 +773,12 @@ void eval_testgt(struct atom *p1); void eval_testle(struct atom *p1); void eval_testlt(struct atom *p1); int cmp_args(struct atom *p1); -void eval_tgamma(struct atom *p1); -void tgammafunc(void); void eval_transpose(struct atom *p1); void transpose(int n, int m); void eval_unit(struct atom *p1); void eval_user_function(struct atom *p1); void eval_user_symbol(struct atom *p1); void eval_zero(struct atom *p1); -void evalg(void); -void evalf(void); -void evalf_nib(struct atom *p1); -void evalp(void); void factor_factor(void); void factor_bignum(uint32_t *N, struct atom *M); void factor_int(int n); @@ -857,6 +829,7 @@ 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); @@ -898,13 +871,13 @@ int isdenormalpolar(struct atom *p); int isdenormalpolarterm(struct atom *p); int issquarematrix(struct atom *p); int issmallinteger(struct atom *p); -int dependent(struct atom *f, struct atom *x); void run(char *buf); void run_buf(char *buf); char * scan_input(char *s); void print_trace(int color); void run_init_script(void); void stopf(char *s); +void exitf(char *s); char * scan(char *s); char * scan1(char *s); char * scan_nib(char *s); @@ -947,13 +920,60 @@ 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; @@ -964,34 +984,6 @@ alloc_atom(void) return p; } -void -alloc_block(void) -{ - int i; - struct atom *p; - - if (block_count == MAXBLOCKS) { - tos = 0; - gc(); // prep for next run - stopf("out of memory"); - } - - p = alloc_mem(BLOCKSIZE * sizeof (struct atom)); - - mem[block_count++] = p; - - for (i = 0; i < BLOCKSIZE - 1; i++) { - p[i].atomtype = FREEATOM; - p[i].u.next = p + i + 1; - } - - p[i].atomtype = FREEATOM; - p[i].u.next = NULL; - - free_list = p; - free_count = BLOCKSIZE; -} - struct atom * alloc_vector(int nrow) { @@ -1042,9 +1034,9 @@ alloc_str(void) void * alloc_mem(int n) { - void *p = m_malloc(n); + void *p = e_malloc(n); if (p == NULL) - exit(1); + stopf("alloc mem failed out of memory"); return p; } double @@ -1079,7 +1071,7 @@ mscan(char *s) int i, k, len; uint32_t *a, *b, *t; a = mint(0); - len = (int) strlen(s); + len = (int) strlen((const char *)s); if (len == 0) return a; k = len % 9; @@ -1127,7 +1119,7 @@ mstr(uint32_t *u) if (n > len) { if (buf) - m_free(buf); + e_free(buf); buf = alloc_mem(n); len = n; } @@ -1509,7 +1501,7 @@ mnew(int n) void mfree(uint32_t *u) { - m_free(u - 1); + e_free(u - 1); bignum_count--; } @@ -1979,7 +1971,7 @@ subst(void) void evalg(void) { - if (gc_level == eval_level && alloc_count > MAXBLOCKS * BLOCKSIZE / 10) + if (gc_level == eval_level && alloc_count > MAXATOMS / 10) gc(); gc_level++; evalf(); @@ -2008,10 +2000,8 @@ evalf_nib(struct atom *p1) if (interrupt) stopf("interrupt"); - // this is needed to prevent seg fault (STACKSIZE is greater than process stack) - - if (eval_level > 1000) - stopf("evaluation depth exceeded, possibly due to recursive function or circular symbol definition"); + if (eval_level == 200) + stopf("circular definition?"); if (eval_level > max_eval_level) max_eval_level = eval_level; @@ -3512,12 +3502,6 @@ eval_binding(struct atom *p1) push(get_binding(cadr(p1))); } void -eval_break(struct atom *p1) -{ - breakflag = 1; - push_symbol(NIL); -} -void eval_ceiling(struct atom *p1) { push(cadr(p1)); @@ -4202,9 +4186,6 @@ eval_defint(struct atom *p1) integral(); F = pop(); - if (findf(F, symbol(INTEGRAL))) - stopf("defint: unsolved integral"); - push(F); push(X); push(B); @@ -4333,16 +4314,6 @@ d_scalar_scalar(struct atom *F, struct atom *X) if (!isusersymbol(X)) stopf("derivative: symbol expected"); - if (car(F) == symbol(DERIVATIVE)) { - derivative_of_derivative(F, X); - return; - } - - if (car(F) == symbol(INTEGRAL)) { - derivative_of_integral(F, X); - return; - } - // d(x,x)? if (equal(F, X)) { @@ -4372,6 +4343,11 @@ d_scalar_scalar(struct atom *F, struct atom *X) return; } + if (car(F) == symbol(DERIVATIVE)) { + dd(F, X); + return; + } + if (car(F) == symbol(LOG)) { dlog(F, X); return; @@ -4447,6 +4423,11 @@ d_scalar_scalar(struct atom *F, struct atom *X) return; } + if (car(F) == symbol(INTEGRAL) && caddr(F) == X) { + push(cadr(F)); + return; + } + dfunction(F, X); } @@ -4542,6 +4523,58 @@ dlog(struct atom *p1, struct atom *p2) 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 @@ -4855,79 +4888,6 @@ d_tensor_scalar(struct atom *p1, struct atom *p2) push(p3); } - -void -derivative_of_derivative(struct atom *F, struct atom *X) -{ - struct atom *G, *Y; - - G = cadr(F); - Y = caddr(F); - - if (X == Y) { - push_symbol(DERIVATIVE); - push(F); - push(X); - list(3); - return; - } - - push(G); - push(X); - derivative(); - - G = pop(); - - if (car(G) == symbol(DERIVATIVE)) { - - // sort derivatives - - F = cadr(G); - X = caddr(G); - - push_symbol(DERIVATIVE); - push_symbol(DERIVATIVE); - push(F); - - if (lessp(X, Y)) { - push(X); - list(3); - push(Y); - list(3); - } else { - push(Y); - list(3); - push(X); - list(3); - } - - return; - } - - push(G); - push(Y); - derivative(); -} - -void -derivative_of_integral(struct atom *F, struct atom *X) -{ - struct atom *G, *Y; - - G = cadr(F); - Y = caddr(F); - - if (X == Y) { - push(G); // derivative and integral cancel - return; - } - - push(G); - push(X); - derivative(); - push(Y); - integral(); -} void eval_det(struct atom *p1) { @@ -5095,9 +5055,9 @@ eval_eigenvec(struct atom *p1) stopf("eigenvec"); if (D) - m_free(D); + e_free(D); if (Q) - m_free(Q); + e_free(Q); D = alloc_mem(n * n * sizeof (double)); Q = alloc_mem(n * n * sizeof (double)); @@ -5420,8 +5380,6 @@ eigenvec_step_nib(double *D, double *Q, int n, int p, int q) D[n * p + q] = 0.0; D[n * q + p] = 0.0; } -// first author: github.com/phbillet - void eval_erf(struct atom *p1) { @@ -5435,7 +5393,7 @@ erffunc(void) { int i, n; double d; - struct atom *p1, *p2; + struct atom *p1; p1 = pop(); @@ -5451,32 +5409,32 @@ erffunc(void) return; } - push(p1); - floatfunc(); - p2 = pop(); - - if (isnum(p2)) { - push(p2); + 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(); - } else { - push_symbol(ERF); - push(p1); - list(2); + return; } -} -// first author: github.com/phbillet + push_symbol(ERF); + push(p1); + list(2); +} void eval_erfc(struct atom *p1) { @@ -5490,7 +5448,7 @@ erfcfunc(void) { int i, n; double d; - struct atom *p1, *p2; + struct atom *p1; p1 = pop(); @@ -5506,32 +5464,22 @@ erfcfunc(void) return; } - push(p1); - floatfunc(); - p2 = pop(); - - if (isnum(p2)) { - push(p2); + if (isdouble(p1)) { + push(p1); d = pop_double(); d = erfc(d); push_double(d); return; } - if (isnegativeterm(p1)) { - push_symbol(ERF); - push(p1); - negate(); - list(2); - } else { - push_symbol(ERF); - push(p1); - list(2); - negate(); + if (iszero(p1)) { + push_integer(1); + return; } - push_integer(1); - add(); + push_symbol(ERFC); + push(p1); + list(2); } void eval_eval(struct atom *p1) @@ -6225,7 +6173,7 @@ floorfunc(void) void eval_for(struct atom *p1) { - int j, k, t; + int j, k; struct atom *p2, *p3; p2 = cadr(p1); @@ -6252,9 +6200,6 @@ eval_for(struct atom *p1) save_symbol(p2); - t = breakflag; - breakflag = 0; - for (;;) { push_integer(j); p3 = pop(); @@ -6263,14 +6208,8 @@ eval_for(struct atom *p1) while (iscons(p3)) { push(car(p3)); evalg(); - pop(); + pop(); // discard return value p3 = cdr(p3); - if (breakflag || errorflag) { - breakflag = t; - restore_symbol(); - push_symbol(NIL); - return; - } } if (j == k) break; @@ -6280,9 +6219,9 @@ eval_for(struct atom *p1) j--; } - breakflag = t; restore_symbol(); - push_symbol(NIL); + + push_symbol(NIL); // return value } void eval_hadamard(struct atom *p1) @@ -6439,13 +6378,8 @@ indexfunc(struct atom *T, int h) for (i = 0; i < n; i++) { push(stack[h + i]); t = pop_integer(); - if (t < 1 || t > T->u.tensor->dim[i]) { - if (shuntflag) { - errorflag = 1; - t = 1; - } else - stopf("index error"); - } + if (t < 1 || t > T->u.tensor->dim[i]) + stopf("index error"); k = k * T->u.tensor->dim[i] + t - 1; } @@ -6496,7 +6430,10 @@ print_infixform(struct atom *p) outbuf_init(); infixform_expr(p); outbuf_puts("\n"); - printbuf(outbuf, BLACK); + outbuf_puts("\0"); + if (noprint == false){ + printbuf(outbuf, BLACK); + } } void @@ -7127,7 +7064,7 @@ inner(void) push(p3); } -char *integral_tab_exp[] = { +const char * const integral_tab_exp[] = { // x^n exp(a x + b) @@ -7370,7 +7307,7 @@ char *integral_tab_exp[] = { // log(a x) is transformed to log(a) + log(x) -char *integral_tab_log[] = { +const char * const integral_tab_log[] = { "log(x)", "x log(x) - x", @@ -7417,7 +7354,7 @@ char *integral_tab_log[] = { "1", }; -char *integral_tab_trig[] = { +const char * const integral_tab_trig[] = { "sin(a x)", "-cos(a x) / a", @@ -7676,7 +7613,7 @@ char *integral_tab_trig[] = { "1", }; -char *integral_tab_power[] = { +const char * const integral_tab_power[] = { "a", // for forms c^d where both c and d are constant expressions "a x", @@ -7797,7 +7734,7 @@ char *integral_tab_power[] = { "1", }; -char *integral_tab[] = { +const char * const integral_tab[] = { "a", "a x", @@ -8162,34 +8099,37 @@ integral(void) push(X); partition_term(); // push const part then push var part F = pop(); // pop var part - integral_solve(F, X); + integral_nib(F, X); multiply(); // multiply by const part return; } - integral_solve(F, X); + integral_nib(F, X); } void -integral_solve(struct atom *F, struct atom *X) +integral_nib(struct atom *F, struct atom *X) { + int h; struct atom *p; - if (car(F) == symbol(INTEGRAL)) { - integral_of_integral(F, X); - return; - } - - if (car(F) == symbol(DERIVATIVE)) { - integral_of_derivative(F, X); - return; - } - save_symbol(symbol(SA)); save_symbol(symbol(SB)); save_symbol(symbol(SX)); - integral_solve_nib(F, X); + 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(); @@ -8199,19 +8139,9 @@ integral_solve(struct atom *F, struct atom *X) } void -integral_solve_nib(struct atom *F, struct atom *X) +integral_lookup(int h, struct atom *F) { - int h, t; - - set_symbol(symbol(SX), X, symbol(NIL)); - - h = tos; - - push_integer(1); // 1 is a candidate for a and b - - push(F); - push(X); - decomp(); // push possible substitutions for a and b + int t; t = integral_classify(F); @@ -8232,12 +8162,7 @@ integral_solve_nib(struct atom *F, struct atom *X) return; } - tos = h; // pop all - - push_symbol(INTEGRAL); - push(F); - push(X); - list(3); + stopf("integral: no solution found"); } int @@ -8266,17 +8191,17 @@ integral_classify(struct atom *p) } int -integral_search(int h, struct atom *F, char **table, int n) +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(table[i + 0]); // integrand + scan1((char *)table[i + 0]); // integrand I = pop(); - scan1(table[i + 2]); // condition + scan1((char *)table[i + 2]); // condition C = pop(); if (integral_search_nib(h, F, I, C)) @@ -8288,7 +8213,7 @@ integral_search(int h, struct atom *F, char **table, int n) tos = h; // pop all - scan1(table[i + 1]); // answer + scan1((char *)table[i + 1]); // answer evalf(); return 1; @@ -8339,7 +8264,7 @@ decomp(void) // is the entire expression constant? - if (!dependent(F, X)) { + if (!findf(F, X)) { push(F); return; } @@ -8383,7 +8308,7 @@ decomp_sum(struct atom *F, struct atom *X) while (iscons(p1)) { p2 = car(p1); - if (dependent(p2, X)) { + if (findf(p2, X)) { if (car(p2) == symbol(MULTIPLY)) { push(p2); push(X); @@ -8433,7 +8358,7 @@ decomp_sum(struct atom *F, struct atom *X) h = tos; p1 = cdr(F); while (iscons(p1)) { - if (!dependent(car(p1), X)) + if (!findf(car(p1), X)) push(car(p1)); p1 = cdr(p1); } @@ -8458,7 +8383,7 @@ decomp_product(struct atom *F, struct atom *X) p1 = cdr(F); while (iscons(p1)) { - if (dependent(car(p1), X)) { + if (findf(car(p1), X)) { push(car(p1)); push(X); decomp(); @@ -8471,7 +8396,7 @@ decomp_product(struct atom *F, struct atom *X) h = tos; p1 = cdr(F); while (iscons(p1)) { - if (!dependent(car(p1), X)) + if (!findf(car(p1), X)) push(car(p1)); p1 = cdr(p1); } @@ -8500,7 +8425,7 @@ partition_term(void) h = tos; p1 = cdr(F); while (iscons(p1)) { - if (!dependent(car(p1), X)) + if (!findf(car(p1), X)) push(car(p1)); p1 = cdr(p1); } @@ -8521,7 +8446,7 @@ partition_term(void) h = tos; p1 = cdr(F); while (iscons(p1)) { - if (dependent(car(p1), X)) + if (findf(car(p1), X)) push(car(p1)); p1 = cdr(p1); } @@ -8537,100 +8462,6 @@ partition_term(void) cons(); // makes MULTIPLY head of list } } - -void -integral_of_integral(struct atom *F, struct atom *X) -{ - struct atom *G, *Y; - - G = cadr(F); - Y = caddr(F); - - // if X == Y then F is not integrable for X - - if (equal(X, Y)) { - push_symbol(INTEGRAL); - push(F); - push(X); - list(3); - return; - } - - push(G); - push(X); - integral(); - - G = pop(); - - if (car(G) == symbol(INTEGRAL)) { - - // sort integrals by measure - - F = cadr(G); - X = caddr(G); - - push_symbol(INTEGRAL); - push_symbol(INTEGRAL); - push(F); - - if (lessp(X, Y)) { - push(X); - list(3); - push(Y); - list(3); - } else { - push(Y); - list(3); - push(X); - list(3); - } - - return; - } - - push(G); - push(Y); - integral(); -} - -void -integral_of_derivative(struct atom *F, struct atom *X) -{ - struct atom *G, *Y; - - G = cadr(F); - Y = caddr(F); - - if (equal(X, Y)) { - push(G); // integral and derivative cancel - return; - } - - push(G); - push(X); - integral(); - - G = pop(); - - // integral before derivative - - if (car(G) == symbol(INTEGRAL)) { - F = cadr(G); - X = caddr(G); - push_symbol(INTEGRAL); - push_symbol(DERIVATIVE); - push(F); - push(Y); - list(3); - push(X); - list(3); - return; - } - - push(G); - push(Y); - derivative(); -} void eval_inv(struct atom *p1) { @@ -8730,51 +8561,6 @@ kronecker(void) push(p3); } void -eval_lgamma(struct atom *p1) -{ - push(cadr(p1)); - evalf(); - lgammafunc(); -} - -void -lgammafunc(void) -{ - int i, n; - double d; - struct atom *p1, *p2; - - p1 = pop(); - - if (istensor(p1)) { - p1 = copy_tensor(p1); - n = p1->u.tensor->nelem; - for (i = 0; i < n; i++) { - push(p1->u.tensor->elem[i]); - lgammafunc(); - p1->u.tensor->elem[i] = pop(); - } - push(p1); - return; - } - - push(p1); - floatfunc(); - p2 = pop(); - - if (isnum(p2)) { - push(p2); - d = pop_double(); - d = lgamma(d); - push_double(d); - return; - } - - push_symbol(LGAMMA); - push(p1); - list(2); -} -void eval_log(struct atom *p1) { push(cadr(p1)); @@ -8918,32 +8704,6 @@ logfunc(void) list(2); } void -eval_loop(struct atom *p1) -{ - int t; - struct atom *p2; - t = breakflag; - breakflag = 0; - if (lengthf(p1) < 2) { - push_symbol(NIL); - return; - } - for (;;) { - p2 = cdr(p1); - while (iscons(p2)) { - push(car(p2)); - evalg(); - pop(); - p2 = cdr(p2); - if (breakflag || errorflag) { - breakflag = t; - push_symbol(NIL); - return; - } - } - } -} -void eval_mag(struct atom *p1) { push(cadr(p1)); @@ -9533,9 +9293,8 @@ void expand_sum_factors(int h) { int i, n; - struct atom *p1, *p2; - // Here, compiler treats warning as error, we use NULL to supress compiler error. - p2 = NULL; + struct atom *p1=NULL; + struct atom *p2=NULL; if (tos - h < 2) return; @@ -9962,9 +9721,9 @@ nroots(void) n = tos - h; // number of coeffs on stack if (cr) - m_free(cr); + e_free(cr); if (ci) - m_free(ci); + e_free(ci); cr = alloc_mem(n * sizeof (double)); ci = alloc_mem(n * sizeof (double)); @@ -10627,12 +10386,8 @@ power_numbers(struct atom *BASE, struct atom *EXPO) // 0^n if (iszero(BASE)) { - if (isnegativenumber(EXPO)) { - if (shuntflag) - errorflag = 1; - else - stopf("divide by zero"); - } + if (isnegativenumber(EXPO)) + stopf("divide by zero"); push_integer(0); return; } @@ -11680,7 +11435,10 @@ print_prefixform(struct atom *p) outbuf_init(); prefixform(p); outbuf_puts("\n"); - printbuf(outbuf, BLACK); + outbuf_puts("\0"); + if (noprint == false){ + printbuf(outbuf, BLACK); + } } void @@ -11722,8 +11480,9 @@ prefixform(struct atom *p) case DOUBLE: snprintf(strbuf, STRBUFLEN, "%g", p->u.d); outbuf_puts(strbuf); - if (!strchr(strbuf, '.') && !strchr(strbuf, 'e')) + if (!strchr(strbuf, '.') && !strchr(strbuf, 'e')){ outbuf_puts(".0"); + } break; case KSYM: case USYM: @@ -11775,8 +11534,10 @@ print_result(void) if (p1 == symbol(TTY) || iszero(p1)) { push(p2); display(); - } else + } else{ print_infixform(p2); + } + } // returns 1 if result should be annotated @@ -11875,13 +11636,6 @@ eval_quote(struct atom *p1) push(cadr(p1)); // not evaluated } void -eval_rand(struct atom *p1) -{ - double d; - d = (double) rand() / ((double) RAND_MAX + 1); - push_double(d); -} -void eval_rank(struct atom *p1) { push(cadr(p1)); @@ -12738,7 +12492,7 @@ read_file(char *filename) } if (read(fd, buf, n) != n) { - m_free(buf); + e_free(buf); close(fd); return NULL; } @@ -12994,21 +12748,19 @@ convert_body(struct atom *A) push_symbol(ARG9); subst(); } -// first author: github.com/phbillet - void eval_sgn(struct atom *p1) { push(cadr(p1)); evalf(); - sgnfunc(); + sgn(); } void -sgnfunc(void) +sgn(void) { int i, n; - struct atom *p1, *p2; + struct atom *p1; p1 = pop(); @@ -13017,34 +12769,26 @@ sgnfunc(void) n = p1->u.tensor->nelem; for (i = 0; i < n; i++) { push(p1->u.tensor->elem[i]); - sgnfunc(); + sgn(); p1->u.tensor->elem[i] = pop(); } push(p1); return; } - p2 = p1; - - if (!isnum(p2)) { - push(p2); - floatfunc(); - p2 = pop(); - } - - if (!isnum(p2)) { + if (!isnum(p1)) { push_symbol(SGN); push(p1); list(2); return; } - if (iszero(p2)) { + if (iszero(p1)) { push_integer(0); return; } - if (isnegativenumber(p2)) + if (isnegativenumber(p1)) push_integer(-1); else push_integer(1); @@ -13623,8 +13367,6 @@ eval_status(struct atom *p1) outbuf_init(); - snprintf(strbuf, STRBUFLEN, "block_count %d (%d%%)\n", block_count, 100 * block_count / MAXBLOCKS); - outbuf_puts(strbuf); snprintf(strbuf, STRBUFLEN, "free_count %d\n", free_count); outbuf_puts(strbuf); @@ -13650,10 +13392,11 @@ eval_status(struct atom *p1) snprintf(strbuf, STRBUFLEN, "max_eval_level %d\n", max_eval_level); outbuf_puts(strbuf); - snprintf(strbuf, STRBUFLEN, "max_tos %d (%d%%)\n", max_tos, 100 * max_tos / STACKSIZE); + snprintf(strbuf, STRBUFLEN, "max_tos %d (%ld%%)\n", max_tos, (int32_t)(100 * max_tos / STACKSIZE)); outbuf_puts(strbuf); - - printbuf(outbuf, BLACK); + if (noprint == false){ + printbuf(outbuf, BLACK); + } push_symbol(NIL); } @@ -14276,58 +14019,13 @@ cmp_args(struct atom *p1) if (iszero(p1)) return 0; if (!isnum(p1)) - stopf("arithmetic comparison: not a number"); + stopf("compare err"); if (isnegativenumber(p1)) return -1; else return 1; } void -eval_tgamma(struct atom *p1) -{ - push(cadr(p1)); - evalf(); - tgammafunc(); -} - -void -tgammafunc(void) -{ - int i, n; - double d; - struct atom *p1, *p2; - - p1 = pop(); - - if (istensor(p1)) { - p1 = copy_tensor(p1); - n = p1->u.tensor->nelem; - for (i = 0; i < n; i++) { - push(p1->u.tensor->elem[i]); - tgammafunc(); - p1->u.tensor->elem[i] = pop(); - } - push(p1); - return; - } - - push(p1); - floatfunc(); - p2 = pop(); - - if (isnum(p2)) { - push(p2); - d = pop_double(); - d = tgamma(d); - push_double(d); - return; - } - - push_symbol(TGAMMA); - push(p1); - list(2); -} -void eval_transpose(struct atom *p1) { int m, n; @@ -14471,7 +14169,7 @@ eval_user_function(struct atom *p1) push(FUNC_NAME); while (iscons(FUNC_ARGS)) { push(car(FUNC_ARGS)); - evalg(); + evalg(); // p1 is on frame stack, not reclaimed FUNC_ARGS = cdr(FUNC_ARGS); } list(tos - h); @@ -14701,7 +14399,7 @@ factor_bignum(uint32_t *N, struct atom *M) #define NPRIME 4792 -int primetab[NPRIME] = { +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, @@ -15321,7 +15019,7 @@ factor_int(int n) for (k = 0; k < NPRIME; k++) { - d = primetab[k]; + d = (int)primetab[k]; m = 0; @@ -15364,11 +15062,11 @@ factor_int(int n) #define VAL2(p) ((int) cadr(p)->u.d) #define PLUS_SIGN '+' -#define MINUS_SIGN 0xe28892 -#define MULTIPLY_SIGN 0xc397 -#define GREATEREQUAL 0xe289a5 -#define LESSEQUAL 0xe289a4 - +#define 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 @@ -15379,9 +15077,23 @@ factor_int(int n) #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 MAX(a,b) ((a) > (b) ? (a) : (b)) -// #define MIN(a,b) ((a) < (b) ? (a) : (b)) +/* */ +#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; @@ -15416,8 +15128,11 @@ fmt(void) if (m > fmt_buf_len) { if (fmt_buf) - m_free(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; } @@ -15436,8 +15151,11 @@ fmt(void) } fmt_putw('\n'); // blank line after result - - printbuf(outbuf, BLACK); + //fmt_putw('\0'); + if (noprint==false){ + printbuf(outbuf, BLACK); + } + } void @@ -15735,11 +15453,11 @@ fmt_function(struct atom *p) // default - if (issymbol(car(p))) + if (issymbol(car(p))){ fmt_symbol(car(p)); - else + }else{ fmt_subexpr(car(p)); - + } fmt_args(p); } @@ -15793,16 +15511,18 @@ fmt_matrix(struct atom *p, int d, int k) span = 1; - for (i = d + 2; i < p->u.tensor->ndim; i++) + 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++) + 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); } @@ -15822,11 +15542,13 @@ fmt_numerators(struct atom *p) q = car(p); p = cdr(p); - if (!isnumerator(q)) + if (!isnumerator(q)){ continue; + } - if (tos > t) + if (tos > t){ fmt_space(); + } if (isrational(q)) { s = mstr(q->u.q.a); @@ -15834,15 +15556,16 @@ fmt_numerators(struct atom *p) continue; } - if (car(q) == symbol(ADD) && n == 1) + if (car(q) == symbol(ADD) && n == 1){ fmt_expr(q); // parens not needed - else + }else{ fmt_factor(q); + } } - if (t == tos) + if (t == tos){ fmt_roman_char('1'); // no numerators - + } fmt_update_list(t); } @@ -15945,9 +15668,9 @@ fmt_reciprocal(struct atom *p) t = tos; - if (isminusone(caddr(p))) + if (isminusone(caddr(p))){ fmt_expr(cadr(p)); - else { + }else { fmt_base(cadr(p)); fmt_numeric_exponent(caddr(p)); // sign is not emitted } @@ -15978,8 +15701,9 @@ fmt_roman_char(int c) void fmt_roman_string(char *s) { - while (*s) + while (*s){ fmt_roman_char(*s++); + } } void @@ -16026,8 +15750,9 @@ fmt_symbol(struct atom *p) k = fmt_symbol_fragment(s, 0); - if (s[k] == '\0') + if (s[k] == '\0'){ return; + } // emit subscript @@ -16035,8 +15760,9 @@ fmt_symbol(struct atom *p) t = tos; - while (s[k] != '\0') + while (s[k] != '\0'){ k = fmt_symbol_fragment(s, k); + } fmt_update_list(t); @@ -16047,7 +15773,7 @@ fmt_symbol(struct atom *p) #define NUM_SYMBOL_NAMES 49 -char *symbol_name_tab[NUM_SYMBOL_NAMES] = { +const char * const symbol_name_tab[NUM_SYMBOL_NAMES] = { "Alpha", "Beta", @@ -16102,57 +15828,57 @@ char *symbol_name_tab[NUM_SYMBOL_NAMES] = { "hbar", }; -int symbol_unicode_tab[NUM_SYMBOL_NAMES] = { +const int symbol_unicode_tab[NUM_SYMBOL_NAMES] = { - 0xce91, // Alpha - 0xce92, // Beta - 0xce93, // Gamma - 0xce94, // Delta - 0xce95, // Epsilon - 0xce96, // Zeta - 0xce97, // Eta - 0xce98, // Theta - 0xce99, // Iota - 0xce9a, // Kappa + 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 - 0xce9c, // Mu - 0xce9d, // Nu + 0x4D, // Mu0xce9c + 0x4E, // Nu0xce9d 0xce9e, // Xi - 0xce9f, // Omicron - 0xcea0, // Pi - 0xcea1, // Rho - 0xcea3, // Sigma - 0xcea4, // Tau - 0xcea5, // Upsilon - 0xcea6, // Phi - 0xcea7, // Chi - 0xcea8, // Psi - 0xcea9, // Omega + 0x4F, // Omicron0xce9f + 0xE3, // Pi0xcea0 + 0x50, // Rho0xcea1 + 0xE4, // Sigma 0xcea3 + 0x54, // Tau0xcea4 + 0x59, // Upsilon0xcea5 + 0xE8, // Phi0xcea6 + 0x58, // Chi0xcea7 + 0xcea8, // Psi0xcea8 + 0xEA, // Omega0xcea9 - 0xceb1, // alpha - 0xceb2, // beta - 0xceb3, // gamma - 0xceb4, // delta - 0xceb5, // epsilon - 0xceb6, // zeta - 0xceb7, // eta - 0xceb8, // theta - 0xceb9, // iota - 0xceba, // kappa + 0xE0, // alpha0xceb1 + 0xE1, // beta0xceb2 + 0x72, // gamma0xceb3 + 0xEB, // delta0xceb4 + 0xEE, // epsilon0xceb5 + 0x7A, // zeta0xceb6 + 0x6E, // eta0xceb7 + 0xE9, // theta0xceb8 + 0x69, // iota0xceb9 + 0x6B, // kappa0xceba 0xcebb, // lambda - 0xcebc, // mu - 0xcebd, // nu + 0xE6, // mu0xcebc + 0x76, // nu0xcebd 0xcebe, // xi - 0xcebf, // omicron - 0xcf80, // pi - 0xcf81, // rho - 0xcf83, // sigma - 0xcf84, // tau - 0xcf85, // upsilon - 0xcf86, // phi - 0xcf87, // chi + 0x6F, // omicron0xcebf + 0xE3, // pi0xcf80 + 0x70, // rho0xcf81 + 0xE5, // sigma0xcf83 + 0xE7, // tau0xcf84 + 0x75, // upsilon0xcf85 + 0xED, // phi0xcf86 + 0x78, // chi0xcf87 0xcf88, // psi - 0xcf89, // omega + 0x77, // omega0xcf89 0xc4a7, // hbar }; @@ -16164,10 +15890,11 @@ fmt_symbol_fragment(char *s, int k) char *t; for (i = 0; i < NUM_SYMBOL_NAMES; i++) { - t = symbol_name_tab[i]; - n = (int) strlen(t); - if (strncmp(s + k, t, n) == 0) + 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) { @@ -16175,7 +15902,7 @@ fmt_symbol_fragment(char *s, int k) return k + 1; } - c = symbol_unicode_tab[i]; + c = (int)symbol_unicode_tab[i]; fmt_roman_char(c); @@ -16229,19 +15956,21 @@ fmt_table(int x, int y, struct atom *p) void fmt_tensor(struct atom *p) { - if (p->u.tensor->ndim % 2 == 1) + if (p->u.tensor->ndim % 2 == 1){ fmt_vector(p); // odd rank - else + }else{ fmt_matrix(p, 0, 0); // even rank + } } void fmt_term(struct atom *p) { - if (car(p) == symbol(MULTIPLY)) + if (car(p) == symbol(MULTIPLY)){ fmt_term_nib(p); - else + }else{ fmt_factor(p); + } } void @@ -16256,8 +15985,9 @@ fmt_term_nib(struct atom *p) p = cdr(p); - if (isminusone(car(p))) + if (isminusone(car(p))){ p = cdr(p); // sign already emitted + } fmt_factor(car(p)); @@ -16302,8 +16032,9 @@ fmt_update_list(int t) int d, h, i, w; struct atom *p1; - if (tos - t == 1) + if (tos - t == 1){ return; + } h = 0; d = 0; @@ -16522,13 +16253,15 @@ fmt_vector(struct atom *p) n = p->u.tensor->ndim; - for (i = 1; i < n; i++) + 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++) + for (i = 0; i < n; i++){ fmt_matrix(p, 1, i * span); + } fmt_update_table(n, 1); // n rows, 1 column } @@ -16582,8 +16315,9 @@ fmt_draw(int x, int y, struct atom *p) fmt_draw_char(x, y, BDLR); - for (i = 1; i < w - 1; i++) + for (i = 1; i < w - 1; i++){ fmt_draw_char(x + i, y, BDLH); + } fmt_draw_char(x + w - 1, y, BDLL); @@ -16612,8 +16346,9 @@ fmt_draw(int x, int y, struct atom *p) void fmt_draw_char(int x, int y, int c) { - if (x >= 0 && x < fmt_ncol && y >= 0 && y < fmt_nrow) + if (x >= 0 && x < fmt_ncol && y >= 0 && y < fmt_nrow){ fmt_buf[y * fmt_ncol + x] = c; + } } void @@ -16635,8 +16370,9 @@ fmt_draw_ldelim(int x, int y, int h, int d) fmt_draw_char(x, y - h + 1, BDLDAR); - for (i = 1; i < h + d - 1; i++) + for (i = 1; i < h + d - 1; i++){ fmt_draw_char(x, y - h + 1 + i, BDLV); + } fmt_draw_char(x, y + d, BDLUAR); } @@ -16648,8 +16384,9 @@ fmt_draw_rdelim(int x, int y, int h, int d) fmt_draw_char(x, y - h + 1, BDLDAL); - for (i = 1; i < h + d - 1; i++) + for (i = 1; i < h + d - 1; i++){ fmt_draw_char(x, y - h + 1 + i, BDLV); + } fmt_draw_char(x, y + d, BDLUAL); } @@ -16703,16 +16440,19 @@ void fmt_putw(uint32_t w) { uint8_t buf[4]; - if (w == 0) + if (w == 0){ w = ' '; + } buf[0] = w >> 24; buf[1] = w >> 16; buf[2] = w >> 8; buf[3] = w; - if (buf[1]) + if (buf[1]){ outbuf_putc(buf[1]); - if (buf[2]) + } + if (buf[2]){ outbuf_putc(buf[2]); + } outbuf_putc(buf[3]); } // automatic variables not visible to the garbage collector are reclaimed @@ -16720,7 +16460,7 @@ fmt_putw(uint32_t w) void gc(void) { - int i, j; + int i; struct atom *p; gc_count++; @@ -16728,9 +16468,9 @@ gc(void) // tag everything - for (i = 0; i < block_count; i++) - for (j = 0; j < BLOCKSIZE; j++) - mem[i][j].tag = 1; + for (i = 0; i < MAXATOMS;i++){ + mem[i].tag = 1; + } // untag what's used @@ -16739,8 +16479,9 @@ gc(void) untag(minusone); untag(imaginaryunit); - for (i = 0; i < tos; i++) + for (i = 0; i < tos; i++){ untag(stack[i]); + } for (i = 0; i < 27 * BUCKETSIZE; i++) { untag(symtab[i]); @@ -16753,23 +16494,20 @@ gc(void) free_list = NULL; free_count = 0; - for (i = 0; i < block_count; i++) - for (j = 0; j < BLOCKSIZE; j++) { + for (i = 0; i < MAXATOMS;i++){ - p = mem[i] + j; - - if (p->tag == 0) - continue; - - // still tagged so it's unused, put on free list - - switch (p->atomtype) { + p = &mem[i]; + if (p->tag == 0){ + continue; + } + // still tagged so it's unused, put on free list + switch (p->atomtype) { case KSYM: - m_free(p->u.ksym.name); + e_free(p->u.ksym.name); ksym_count--; break; case USYM: - m_free(p->u.usym.name); + e_free(p->u.usym.name); usym_count--; break; case RATIONAL: @@ -16778,23 +16516,21 @@ gc(void) break; case STR: if (p->u.str) - m_free(p->u.str); + e_free(p->u.str); string_count--; break; case TENSOR: - m_free(p->u.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++; } + p->atomtype = FREEATOM; + p->u.next = free_list; + free_list = p; + free_count++; + } } void @@ -16802,36 +16538,41 @@ untag(struct atom *p) { int i; - if (p == NULL) + if (p == NULL){ return; + } while (iscons(p)) { - if (p->tag == 0) + if (p->tag == 0){ return; + } p->tag = 0; untag(p->u.cons.car); p = p->u.cons.cdr; } - if (p->tag == 0) + if (p->tag == 0){ return; + } p->tag = 0; - if (istensor(p)) - for (i = 0; i < p->u.tensor->nelem; i++) + if (istensor(p)){ + for (i = 0; i < p->u.tensor->nelem; i++){ untag(p->u.tensor->elem[i]); + } + } } -struct atom *mem[MAXBLOCKS]; // an array of pointers +struct atom *mem; // an array of pointers struct atom *free_list; int tos; // top of stack -struct atom *stack[STACKSIZE]; +struct atom **stack; -struct atom *symtab[27 * BUCKETSIZE]; -struct atom *binding[27 * BUCKETSIZE]; -struct atom *usrfunc[27 * BUCKETSIZE]; +struct atom **symtab; +struct atom **binding; +struct atom **usrfunc; struct atom *zero; struct atom *one; @@ -16842,11 +16583,10 @@ int eval_level; int gc_level; int expanding; int drawing; +int nonstop; int interrupt; -int shuntflag; -int errorflag; -int breakflag; -jmp_buf jmpbuf; +jmp_buf jmpbuf0; +jmp_buf jmpbuf1; char *trace1; char *trace2; @@ -16867,51 +16607,44 @@ 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(); -// } - +/* +int +main(int argc, char *argv[]) +{ + int i; + for (i = 1; i < argc; i++) + run_infile(argv[i]); + if (isatty(fileno(stdout))) + run_stdin(); +} +*/ void run_infile(char *infile) { char *buf; buf = read_file(infile); if (buf == NULL) { - fprintf(stderr, "cannot read %s\n", infile); - exit(1); + //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); - m_free(buf); + e_free(buf); } void run_stdin(void) { - mp_printf(&mp_plat_print, "Eigenmath start %d\n", __LINE__); - // static char inbuf[1000]; - vstr_t* vstr_inbuf = vstr_new(1); - - // for (;;) { - // fputs("? ", stdout); - // fflush(stdout); - // fgets(inbuf, sizeof inbuf, stdin); - 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); - // } + static char inbuf[1000]; + for (;;) { + fputs("? ", stdout); + fflush(stdout); + fgets(inbuf, sizeof inbuf, stdin); + run(inbuf); + } } - - - void display(void) { @@ -16921,8 +16654,21 @@ display(void) void printbuf(char *s, int color) { - // fputs(s, stdout); - mp_printf(&mp_plat_print, "%s", s); + //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 @@ -16936,7 +16682,8 @@ void eval_exit(struct atom *p1) { (void) p1; // silence compiler - exit(0); + //exit(0); + longjmp(jmpbuf0, 1); } void numden(void) @@ -16970,8 +16717,9 @@ numden_find_divisor(struct atom *p) if (car(p) == symbol(ADD)) { p = cdr(p); while (iscons(p)) { - if (numden_find_divisor_term(car(p))) + if (numden_find_divisor_term(car(p))){ return 1; + } p = cdr(p); } return 0; @@ -16986,8 +16734,9 @@ 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))) + if (numden_find_divisor_factor(car(p))){ return 1; + } p = cdr(p); } return 0; @@ -17005,9 +16754,9 @@ numden_find_divisor_factor(struct atom *p) } if (car(p) == symbol(POWER) && isnegativeterm(caddr(p))) { - if (isminusone(caddr(p))) + if (isminusone(caddr(p))){ push(cadr(p)); - else { + }else { push_symbol(POWER); push(cadr(p)); push(caddr(p)); @@ -17055,30 +16804,34 @@ outbuf_init(void) outbuf_puts(""); // init outbuf as empty string } -void -outbuf_puts(char *s) + +void outbuf_puts(char *s) { - int len, m; + int len, m; - len = (int) strlen(s); + len = (int) strlen((const char *)s); - // Let outbuf_index + len == 1000 + // Make sure there is enough room for new string + '\0' terminator + m = 1000 * ((outbuf_index + len + 1) / 1000 + 1); // +1 for '\0' - // Then m == 2000 hence there is always room for the terminator '\0' + if (m > outbuf_length) { + outbuf = e_realloc(outbuf, m); + if (outbuf == NULL) { + stopf("outbuf_puts: realloc failed"); + } + outbuf_length = m; + } - m = 1000 * ((outbuf_index + len) / 1000 + 1); // m is a multiple of 1000 + // Copy the string + memcpy(outbuf + outbuf_index, s, len); + outbuf_index += len; - if (m > outbuf_length) { - outbuf = realloc(outbuf, m); - if (outbuf == NULL) - exit(1); - outbuf_length = m; - } - - strcpy(outbuf + outbuf_index, s); - outbuf_index += len; + // Always null-terminate + outbuf[outbuf_index] = '\0'; } + + void outbuf_putc(int c) { @@ -17091,9 +16844,11 @@ outbuf_putc(int c) m = 1000 * ((outbuf_index + 1) / 1000 + 1); // m is a multiple of 1000 if (m > outbuf_length) { - outbuf = realloc(outbuf, m); - if (outbuf == NULL) - exit(1); + outbuf = e_realloc(outbuf, m); + if (outbuf == NULL){ + //exit(1); + stopf("outbuf_putc: realloc failed"); + } outbuf_length = m; } @@ -17104,14 +16859,18 @@ int iszero(struct atom *p) { int i; - if (isrational(p)) + if (isrational(p)){ return MZERO(p->u.q.a); - if (isdouble(p)) + } + 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])) + for (i = 0; i < p->u.tensor->nelem; i++){ + if (!iszero(p->u.tensor->elem[i])){ return 0; + } + } return 1; } return 0; @@ -17131,12 +16890,14 @@ isequalq(struct atom *p, int a, int b) if (a < 0) { sign = MMINUS; a = -a; - } else + } else{ sign = MPLUS; + } return p->sign == sign && MEQUAL(p->u.q.a, a) && MEQUAL(p->u.q.b, b); } - if (isdouble(p)) + if (isdouble(p)){ return p->u.d == (double) a / b; + } return 0; } @@ -17191,24 +16952,27 @@ isnegativeterm(struct atom *p) int isnegativenumber(struct atom *p) { - if (isrational(p)) + if (isrational(p)){ return p->sign == MMINUS; - else if (isdouble(p)) + }else if (isdouble(p)){ return p->u.d < 0.0; - else + }else{ return 0; + } } int isimaginaryterm(struct atom *p) { - if (isimaginaryfactor(p)) + if (isimaginaryfactor(p)){ return 1; + } if (car(p) == symbol(MULTIPLY)) { p = cdr(p); while (iscons(p)) { - if (isimaginaryfactor(car(p))) + if (isimaginaryfactor(car(p))){ return 1; + } p = cdr(p); } } @@ -17258,34 +17022,41 @@ isdoublez(struct atom *p) { if (car(p) == symbol(ADD)) { - if (lengthf(p) != 3) + if (lengthf(p) != 3){ return 0; + } - if (!isdouble(cadr(p))) // x + if (!isdouble(cadr(p))) {// x return 0; + } p = caddr(p); } - if (car(p) != symbol(MULTIPLY)) + if (car(p) != symbol(MULTIPLY)){ return 0; + } - if (lengthf(p) != 3) + if (lengthf(p) != 3){ return 0; + } - if (!isdouble(cadr(p))) // y + if (!isdouble(cadr(p))) {// y return 0; - + } p = caddr(p); - if (car(p) != symbol(POWER)) + if (car(p) != symbol(POWER)){ return 0; + } - if (!isminusone(cadr(p))) + if (!isminusone(cadr(p))){ return 0; + } - if (!isequalq(caddr(p), 1, 2)) + if (!isequalq(caddr(p), 1, 2)){ return 0; + } return 1; } @@ -17293,23 +17064,25 @@ isdoublez(struct atom *p) int isdenominator(struct atom *p) { - if (car(p) == symbol(POWER) && isnegativenumber(caddr(p))) + if (car(p) == symbol(POWER) && isnegativenumber(caddr(p))){ return 1; - else if (isrational(p) && !MEQUAL(p->u.q.b, 1)) + }else if (isrational(p) && !MEQUAL(p->u.q.b, 1)){ return 1; - else + }else{ return 0; + } } int isnumerator(struct atom *p) { - if (car(p) == symbol(POWER) && isnegativenumber(caddr(p))) + if (car(p) == symbol(POWER) && isnegativenumber(caddr(p))){ return 0; - else if (isrational(p) && MEQUAL(p->u.q.a, 1)) + } else if (isrational(p) && MEQUAL(p->u.q.a, 1)){ return 0; - else + }else{ return 1; + } } int @@ -17318,8 +17091,9 @@ hasdouble(struct atom *p) if (iscons(p)) { p = cdr(p); while (iscons(p)) { - if (hasdouble(car(p))) + if (hasdouble(car(p))){ return 1; + } p = cdr(p); } return 0; @@ -17333,8 +17107,9 @@ isdenormalpolar(struct atom *p) if (car(p) == symbol(ADD)) { p = cdr(p); while (iscons(p)) { - if (isdenormalpolarterm(car(p))) + if (isdenormalpolarterm(car(p))){ return 1; + } p = cdr(p); } return 0; @@ -17348,28 +17123,31 @@ isdenormalpolar(struct atom *p) int isdenormalpolarterm(struct atom *p) { - if (car(p) != symbol(MULTIPLY)) + if (car(p) != symbol(MULTIPLY)){ return 0; + } - if (lengthf(p) == 3 && isimaginaryunit(cadr(p)) && caddr(p) == symbol(PI)) + 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)) + 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)) + if (isnegativenumber(p)){ return 1; // p < 0 - + } push(p); push_rational(-1, 2); add(); p = pop(); - if (!isnegativenumber(p)) + if (!isnegativenumber(p)){ return 1; // p >= 1/2 - + } return 0; } @@ -17382,55 +17160,31 @@ issquarematrix(struct atom *p) int issmallinteger(struct atom *p) { - if (isinteger(p)) + if (isinteger(p)){ return MLENGTH(p->u.q.a) == 1 && p->u.q.a[0] <= 0x7fffffff; + } - if (isdouble(p)) + if (isdouble(p)){ return p->u.d == floor(p->u.d) && fabs(p->u.d) <= 0x7fffffff; - - return 0; -} - -// does f depend on x? - -int -dependent(struct atom *f, struct atom *x) -{ - if (equal(f, x)) - return 1; - - // a user function with no arguments? - - if (isusersymbol(car(f)) && lengthf(f) == 1) - return 1; - - while (iscons(f)) { - if (dependent(car(f), x)) - return 1; - f = cdr(f); } return 0; } - void run(char *buf) { - if (setjmp(jmpbuf)) + if (setjmp(jmpbuf0)){ return; - + } tos = 0; interrupt = 0; eval_level = 0; gc_level = 0; expanding = 1; drawing = 0; - shuntflag = 0; - errorflag = 0; - breakflag = 0; - mp_printf(&mp_plat_print, "run() has param: %s\n", buf); + nonstop = 0; + if (zero == NULL) { - srand((unsigned) time(NULL)); init_symbol_table(); push_bignum(MPLUS, mint(0), mint(1)); zero = pop(); @@ -17443,10 +17197,10 @@ run(char *buf) push_rational(1, 2); list(3); imaginaryunit = pop(); - // run_init_script(); + run_init_script(); } - mp_printf(&mp_plat_print, "start to run run_buf()\n"); - // run_buf(buf); + + run_buf(buf); } void @@ -17475,8 +17229,9 @@ run_buf(char *buf) dupl(); p1 = pop(); - if (p1 != symbol(NIL)) + if (p1 != symbol(NIL)){ set_symbol(symbol(LAST), p1, symbol(NIL)); + } print_result(); } @@ -17493,8 +17248,9 @@ scan_input(char *s) s = scan(s); trace2 = s; p1 = get_binding(symbol(TRACE)); - if (p1 != symbol(TRACE) && !iszero(p1)) + if (p1 != symbol(TRACE) && !iszero(p1)){ print_trace(BLUE); + } return s; } @@ -17511,12 +17267,17 @@ print_trace(int color) c = *s++; outbuf_putc(c); } - if (c != '\n') + if (c != '\n'){ outbuf_putc('\n'); - printbuf(outbuf, color); + } + if (noprint == false){ + printbuf(outbuf, color); + } + } -char *init_script = +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" @@ -17532,16 +17293,32 @@ char *init_script = void run_init_script(void) { - run_buf(init_script); + run_buf((char *)init_script); } void stopf(char *s) { + if (nonstop){ + longjmp(jmpbuf1, 1); + } print_trace(RED); snprintf(strbuf, STRBUFLEN, "Stop: %s\n", s); - printbuf(strbuf, RED); - longjmp(jmpbuf, 1); + 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 // @@ -17606,11 +17383,13 @@ scan_nib(char *s) scan_str = s; scan_level = 0; get_token_skip_newlines(); - if (token == T_END) + if (token == T_END){ return NULL; + } scan_stmt(); - if (token != T_NEWLINE && token != T_END) + if (token != T_NEWLINE && token != T_END){ scan_error("syntax err"); // unexpected token, for example, 1:2 + } return scan_str; } @@ -17632,23 +17411,23 @@ 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; + 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 @@ -17661,17 +17440,20 @@ scan_expression(void) { int h = tos, t; t = token; - if (token == '+' || token == '-') + if (token == '+' || token == '-'){ get_token_skip_newlines(); + } scan_term(); - if (t == '-') + if (t == '-'){ static_negate(); + } while (token == '+' || token == '-') { t = token; get_token_skip_newlines(); // get token after '+' or '-' scan_term(); - if (t == '-') + if (t == '-'){ static_negate(); + } } if (tos - h > 1) { list(tos - h); @@ -17685,17 +17467,17 @@ 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; + case '*': + case '/': + case '(': + case T_SYMBOL: + case T_FUNCTION: + case T_INTEGER: + case T_DOUBLE: + case T_STRING: + return 1; + default: + break; } return 0; } @@ -17711,13 +17493,15 @@ scan_term(void) t = token; - if (token == '*' || token == '/') + if (token == '*' || token == '/'){ get_token_skip_newlines(); + } scan_power(); - if (t == '/') + if (t == '/'){ static_reciprocate(); + } } if (tos - h > 1) { @@ -17791,8 +17575,9 @@ scan_factor(void) get_token(); // get token after ',' scan_expression(); } - if (token != ']') + if (token != ']'){ scan_error("expected ']'"); + } scan_level--; get_token(); // get token after ']' list(tos - h); @@ -17809,7 +17594,7 @@ scan_factor(void) void scan_symbol(void) { - if (scan_mode && strlen(token_buf) == 1) + if (scan_mode && strlen((const char *)token_buf) == 1){ switch (token_buf[0]) { case 'a': push_symbol(SA); @@ -17824,8 +17609,9 @@ scan_symbol(void) push(lookup(token_buf)); break; } - else + }else{ push(lookup(token_buf)); + } get_token(); } @@ -17855,8 +17641,9 @@ scan_function_call(void) get_token(); // get token after ',' scan_stmt(); } - if (token != ')') + if (token != ')'){ scan_error("expected ')'"); + } scan_level--; get_token(); // get token after ')' list(tos - h); @@ -17897,16 +17684,19 @@ scan_subexpr(void) get_token(); // get token after ',' scan_stmt(); } - if (token != ')') + if (token != ')'){ scan_error("expected ')'"); + } scan_level--; get_token(); // get token after ')' n = tos - h; - if (n < 2) + if (n < 2){ return; + } p = alloc_vector(n); - for (i = 0; i < n; i++) + for (i = 0; i < n; i++){ p->u.tensor->elem[i] = stack[h + i]; + } tos = h; push(p); } @@ -17923,9 +17713,11 @@ void get_token(void) { get_token_nib(); - if (scan_level) - while (token == T_NEWLINE) + if (scan_level){ + while (token == T_NEWLINE){ get_token_nib(); + } + } } void @@ -17933,9 +17725,9 @@ get_token_nib(void) { // skip spaces - while (*scan_str != '\0' && *scan_str != '\n' && *scan_str != '\r' && (*scan_str < 33 || *scan_str > 126)) + 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? @@ -17956,41 +17748,48 @@ get_token_nib(void) // comment? if (*scan_str == '#' || (scan_str[0] == '-' && scan_str[1] == '-')) { - while (*scan_str && *scan_str != '\n' && *scan_str != '\r') + while (*scan_str && *scan_str != '\n' && *scan_str != '\r'){ scan_str++; - if (*scan_str) + } + if (*scan_str){ scan_str++; + } token = T_NEWLINE; return; } // number? - if (isdigit((unsigned char)*scan_str) || *scan_str == '.') { - while (isdigit((unsigned char)*scan_str)) + if (isdigit((int)*scan_str) || *scan_str == '.') { + while (isdigit((int)*scan_str)){ scan_str++; + } if (*scan_str == '.') { scan_str++; - while (isdigit((unsigned char)*scan_str)) + while (isdigit((int)*scan_str)){ scan_str++; - if (token_str + 1 == scan_str) + } + if (token_str + 1 == scan_str){ scan_error("expected decimal digit"); // only a decimal point + } token = T_DOUBLE; - } else + } else{ token = T_INTEGER; + } update_token_buf(token_str, scan_str); return; } // symbol? - if (isalpha((unsigned char)*scan_str)) { - while (isalnum((unsigned char)*scan_str)) + if (isalpha((int)*scan_str)) { + while (isalnum((int)*scan_str)) scan_str++; - if (*scan_str == '(') + if (*scan_str == '('){ token = T_FUNCTION; - else + }else{ token = T_SYMBOL; + } update_token_buf(token_str, scan_str); return; } @@ -18001,8 +17800,9 @@ get_token_nib(void) scan_str++; while (*scan_str && *scan_str != '"' && *scan_str != '\n' && *scan_str != '\r') scan_str++; - if (*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 @@ -18048,8 +17848,9 @@ update_token_buf(char *a, char *b) m = 1000 * (n / 1000 + 1); // m is a multiple of 1000 if (m > token_buf_len) { - if (token_buf) - m_free(token_buf); + if (token_buf){ + e_free(token_buf); + } token_buf = alloc_mem(m); token_buf_len = m; } @@ -18125,8 +17926,9 @@ static_reciprocate(void) return; } - if (!isrational(p1) || !isequaln(p1, 1)) + if (!isrational(p1) || !isequaln(p1, 1)){ push(p1); // p1 != 1 + } if (isnum(p2)) { push(p2); @@ -18151,18 +17953,21 @@ static_reciprocate(void) void push(struct atom *p) { - if (tos < 0 || tos >= STACKSIZE) - stopf("stack error"); + if (tos < 0 || tos >= STACKSIZE){ + exitf("stack error, circular definition?"); + } stack[tos++] = p; - if (tos > max_tos) + if (tos > max_tos){ max_tos = tos; + } } struct atom * pop(void) { - if (tos < 1 || tos > STACKSIZE) - stopf("stack error"); + if (tos < 1 || tos > STACKSIZE){ + exitf("stack error"); + } return stack[--tos]; } @@ -18228,10 +18033,11 @@ push_integer(int n) void push_rational(int a, int b) { - if (a < 0) + if (a < 0){ push_bignum(MMINUS, mint(-a), mint(b)); - else + }else{ push_bignum(MPLUS, mint(a), mint(b)); + } } void @@ -18273,9 +18079,9 @@ pop_integer(void) n = p->u.q.a[0]; if (isnegativenumber(p)) n = -n; - } else + } else{ n = (int) p->u.d; - + } return n; } @@ -18297,12 +18103,12 @@ pop_double(void) p = pop(); - if (!isnum(p)) + if (!isnum(p)){ stopf("number expected"); - - if (isdouble(p)) + } + if (isdouble(p)){ d = p->u.d; - else { + }else { a = mfloat(p->u.q.a); b = mfloat(p->u.q.b); d = a / b; @@ -18318,10 +18124,13 @@ push_string(char *s) { struct atom *p; p = alloc_str(); - s = strdup(s); - if (s == NULL) - exit(1); - p->u.str = s; + //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); } @@ -18332,10 +18141,12 @@ slice(int h, int n) { int i, m; m = tos - h - n; - if (m < 0) + if (m < 0){ stopf("stack slice error"); - for (i = 0; i < m; i++) + } + for (i = 0; i < m; i++){ stack[h + i] = stack[h + n + i]; + } tos -= n; } // symbol lookup, create symbol if not found @@ -18346,30 +18157,37 @@ lookup(char *s) int i, k; struct atom *p; - if (isupper((unsigned char)*s)) + if (isupper((int)*s)){ k = BUCKETSIZE * (*s - 'A'); - else if (islower((unsigned char)*s)) + }else if (islower((int)*s)){ k = BUCKETSIZE * (*s - 'a'); - else + }else{ k = BUCKETSIZE * 26; - + } for (i = 0; i < BUCKETSIZE; i++) { p = symtab[k + i]; - if (p == NULL) + if (p == NULL){ break; - if (strcmp(s, printname(p)) == 0) + } + if (strcmp(s, printname(p)) == 0){ return p; + } } - if (i == BUCKETSIZE) + if (i == BUCKETSIZE){ stopf("symbol table full"); - + } p = alloc_atom(); - s = strdup(s); - if (s == NULL) - exit(1); + //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 = s; + p->u.usym.name = ns; p->u.usym.index = k + i; symtab[k + i] = p; usym_count++; @@ -18380,19 +18198,22 @@ lookup(char *s) char * printname(struct atom *p) { - if (iskeyword(p)) + if (iskeyword(p)){ return p->u.ksym.name; - else if (isusersymbol(p)) + }else if (isusersymbol(p)){ return p->u.usym.name; - else + }else{ return "?"; + } } void set_symbol(struct atom *p1, struct atom *p2, struct atom *p3) { - if (!isusersymbol(p1)) + if (!isusersymbol(p1)){ stopf("symbol error"); + } + binding[p1->u.usym.index] = p2; usrfunc[p1->u.usym.index] = p3; } @@ -18401,30 +18222,35 @@ struct atom * get_binding(struct atom *p1) { struct atom *p2; - if (!isusersymbol(p1)) + if (!isusersymbol(p1)){ stopf("symbol error"); + } p2 = binding[p1->u.usym.index]; - if (p2 == NULL || p2 == symbol(NIL)) + if (p2 == NULL || p2 == symbol(NIL)){ p2 = p1; // symbol binds to itself + } return p2; } struct atom * get_usrfunc(struct atom *p) { - if (!isusersymbol(p)) + if (!isusersymbol(p)){ stopf("symbol error"); + } p = usrfunc[p->u.usym.index]; - if (p == NULL) + if (p == NULL){ p = symbol(NIL); + } return p; } -struct se { - char *str; +typedef struct{ + const char *str; int index; void (*func)(struct atom *); -} stab[] = { +} se; +const se stab[] = { { "abs", ABS, eval_abs }, { "adj", ADJ, eval_adj }, @@ -18438,7 +18264,6 @@ struct se { { "arg", ARG, eval_arg }, { "binding", BINDING, eval_binding }, - { "break", BREAK, eval_break }, { "C", C_UPPER, NULL }, { "c", C_LOWER, NULL }, @@ -18501,9 +18326,7 @@ struct se { { "kronecker", KRONECKER, eval_kronecker }, { "last", LAST, NULL }, - { "lgamma", LGAMMA, eval_lgamma }, { "log", LOG, eval_log }, - { "loop", LOOP, eval_loop }, { "mag", MAG, eval_mag }, { "minor", MINOR, eval_minor }, @@ -18534,7 +18357,6 @@ struct se { { "R", R_UPPER, NULL }, { "r", R_LOWER, NULL }, - { "rand", RAND, eval_rand }, { "rank", RANK, eval_rank }, { "rationalize", RATIONALIZE, eval_rationalize }, { "real", REAL, eval_real }, @@ -18565,7 +18387,6 @@ struct se { { "testgt", TESTGT, eval_testgt }, { "testle", TESTLE, eval_testle }, { "testlt", TESTLT, eval_testlt }, - { "tgamma", TGAMMA, eval_tgamma }, { "trace", TRACE, NULL }, { "transpose", TRANSPOSE, eval_transpose }, { "tty", TTY, NULL }, @@ -18599,15 +18420,15 @@ struct se { { "$a", SA, NULL }, { "$b", SB, NULL }, { "$x", SX, NULL }, - { "$arg1", ARG1, NULL }, - { "$arg2", ARG2, NULL }, - { "$arg3", ARG3, NULL }, - { "$arg4", ARG4, NULL }, - { "$arg5", ARG5, NULL }, - { "$arg6", ARG6, NULL }, - { "$arg7", ARG7, NULL }, - { "$arg8", ARG8, NULL }, - { "$arg9", ARG9, NULL }, + { "$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 @@ -18623,13 +18444,17 @@ init_symbol_table(void) usrfunc[i] = NULL; } - n = sizeof stab / sizeof (struct se); + n = sizeof stab / sizeof (se); for (i = 0; i < n; i++) { p = alloc_atom(); - s = strdup(stab[i].str); - if (s == NULL) - exit(1); + 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; @@ -18644,182 +18469,3 @@ init_symbol_table(void) symtab[stab[i].index] = p; } } - - -// This is the function which will be called from Python as cexample.add_ints(a, b). -static mp_obj_t example_add_ints(mp_obj_t a_obj, mp_obj_t b_obj) { - // Extract the ints from the micropython input objects. - int a = mp_obj_get_int(a_obj); - int b = mp_obj_get_int(b_obj); - - // Calculate the addition and convert to MicroPython object. - return mp_obj_new_int(a + b); -} - - -static mp_obj_t eigenmath_cmd() { - run_stdin(); - // Calculate the addition and convert to MicroPython object. - return mp_obj_new_int(0); -} - -static MP_DEFINE_CONST_FUN_OBJ_0(eigenmath_cmd_obj, eigenmath_cmd); - -// Define a Python reference to the function above. -static MP_DEFINE_CONST_FUN_OBJ_2(example_add_ints_obj, example_add_ints); - -// This structure represents Timer instance objects. -typedef struct _example_Timer_obj_t { - // All objects start with the base. - mp_obj_base_t base; - // Everything below can be thought of as instance attributes, but they - // cannot be accessed by MicroPython code directly. In this example we - // store the time at which the object was created. - mp_uint_t start_time; -} example_Timer_obj_t; - -// This is the Timer.time() method. After creating a Timer object, this -// can be called to get the time elapsed since creating the Timer. -static mp_obj_t example_Timer_time(mp_obj_t self_in) { - // The first argument is self. It is cast to the *example_Timer_obj_t - // type so we can read its attributes. - example_Timer_obj_t *self = MP_OBJ_TO_PTR(self_in); - - // Get the elapsed time and return it as a MicroPython integer. - mp_uint_t elapsed = mp_hal_ticks_ms() - self->start_time; - return mp_obj_new_int_from_uint(elapsed); -} -static MP_DEFINE_CONST_FUN_OBJ_1(example_Timer_time_obj, example_Timer_time); - -// This represents Timer.__new__ and Timer.__init__, which is called when -// the user instantiates a Timer object. -static mp_obj_t example_Timer_make_new(const mp_obj_type_t *type, size_t n_args, size_t n_kw, const mp_obj_t *args) { - // Allocates the new object and sets the type. - example_Timer_obj_t *self = mp_obj_malloc(example_Timer_obj_t, type); - - // Initializes the time for this Timer instance. - self->start_time = mp_hal_ticks_ms(); - - // The make_new function always returns self. - return MP_OBJ_FROM_PTR(self); -} - -// This collects all methods and other static class attributes of the Timer. -// The table structure is similar to the module table, as detailed below. -static const mp_rom_map_elem_t example_Timer_locals_dict_table[] = { - { MP_ROM_QSTR(MP_QSTR_time), MP_ROM_PTR(&example_Timer_time_obj) }, -}; -static MP_DEFINE_CONST_DICT(example_Timer_locals_dict, example_Timer_locals_dict_table); - -// This defines the type(Timer) object. -MP_DEFINE_CONST_OBJ_TYPE( - example_type_Timer, - MP_QSTR_Timer, - MP_TYPE_FLAG_NONE, - make_new, example_Timer_make_new, - locals_dict, &example_Timer_locals_dict - ); - -// What follows is a *separate* class definition that demonstrates more -// advanced techniques to implement other Python-like features, such as: -// -// - A custom representation for __repr__ and __str__. -// - Custom attribute handling to create a read/write "property". -// -// It reuses some of the elements of the basic Timer class. This is allowed -// because they both use example_Timer_obj_t as the instance structure. - -// Handles AdvancedTimer.__repr__, AdvancedTimer.__str__. -static void example_AdvancedTimer_print(const mp_print_t *print, mp_obj_t self_in, mp_print_kind_t kind) { - - // Get the elapsed time. In this case, it's also a demonstration of calling - // the equivalent of self.time() in the C API. This is not usually very - // efficient, but it can sometimes be useful. - mp_uint_t elapsed = mp_obj_get_int(example_Timer_time(self_in)); - - // We'll make all representations print at least the class name. - mp_printf(print, "%q()", (qstr)MP_QSTR_AdvancedTimer); - - // Decide what else to print based on print kind. - if (kind == PRINT_STR) { - // For __str__, let's attempt to make it more readable. - mp_printf(print, " # created %d seconds ago", (int)(elapsed / 1000)); - } -} - -// Handles AdvancedTimer.seconds for reading and writing. -static void example_AdvancedTimer_attribute_handler(mp_obj_t self_in, qstr attr, mp_obj_t *dest) { - - // In this example, we only want to handle the .seconds attribute in a - // special way. - if (attr != MP_QSTR_seconds) { - // Attribute not found, continue lookup in locals dict. This way, - // methods like .time() will be handled normally. - dest[1] = MP_OBJ_SENTINEL; - return; - } - - // Get reference to AdvancedTimer instance. - example_Timer_obj_t *self = MP_OBJ_TO_PTR(self_in); - - // Check if this is a read operation. - if (dest[0] == MP_OBJ_NULL) { - // It's read, so "return" elapsed seconds by storing it in dest[0]. - mp_uint_t elapsed = mp_hal_ticks_ms() - self->start_time; - dest[0] = mp_obj_new_int_from_uint(elapsed / 1000); - return; - } - // Check if this is a delete or store operation. - else if (dest[0] == MP_OBJ_SENTINEL) { - // It's delete or store. Now check which one. - if (dest[1] == MP_OBJ_NULL) { - // It's delete. But in this example we don't want to allow it - // so we just return. - return; - } else { - // It's write. First, get the value that the user is trying to set. - mp_uint_t desired_ms = mp_obj_get_int(dest[1]) * 1000; - // Use it to update the start time. This way, the next read will - // report the updated time. - self->start_time = mp_hal_ticks_ms() - desired_ms; - - // Indicate successful store. - dest[0] = MP_OBJ_NULL; - return; - } - } -} - -// This defines the type(AdvancedTimer) object. -MP_DEFINE_CONST_OBJ_TYPE( - example_type_AdvancedTimer, - MP_QSTR_AdvancedTimer, - MP_TYPE_FLAG_NONE, - attr, example_AdvancedTimer_attribute_handler, - print, example_AdvancedTimer_print, - make_new, example_Timer_make_new, - locals_dict, &example_Timer_locals_dict - ); - -// Define all attributes of the module. -// Table entries are key/value pairs of the attribute name (a string) -// and the MicroPython object reference. -// All identifiers and strings are written as MP_QSTR_xxx and will be -// optimized to word-sized integers by the build system (interned strings). -static const mp_rom_map_elem_t eigenmath_module_globals_table[] = { - { MP_ROM_QSTR(MP_QSTR___name__), MP_ROM_QSTR(MP_QSTR_eigenmath) }, - { MP_ROM_QSTR(MP_QSTR_add_ints), MP_ROM_PTR(&example_add_ints_obj) }, - { MP_ROM_QSTR(MP_QSTR_cmd), MP_ROM_PTR(&eigenmath_cmd_obj) }, - { MP_ROM_QSTR(MP_QSTR_Timer), MP_ROM_PTR(&example_type_Timer) }, - { MP_ROM_QSTR(MP_QSTR_AdvancedTimer), MP_ROM_PTR(&example_type_AdvancedTimer) }, -}; -static MP_DEFINE_CONST_DICT(eigenmath_module_globals, eigenmath_module_globals_table); - -// Define module object. -const mp_obj_module_t eigenmath_user_cmodule = { - .base = { &mp_type_module }, - .globals = (mp_obj_dict_t *)&eigenmath_module_globals, -}; - -// Register the module to make it available in Python. -MP_REGISTER_MODULE(MP_QSTR_eigenmath, eigenmath_user_cmodule); \ No newline at end of file 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 index 0631eb107..b6819f75c 100644 --- a/user_modules/eigenmath/micropython.cmake +++ b/user_modules/eigenmath/micropython.cmake @@ -4,12 +4,16 @@ 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) \ No newline at end of file +target_link_libraries(usermod INTERFACE usermod_eigenmath) + diff --git a/user_modules/eigenmath/micropython.mk b/user_modules/eigenmath/micropython.mk index 577d7e1ba..dc5f9c5e9 100644 --- a/user_modules/eigenmath/micropython.mk +++ b/user_modules/eigenmath/micropython.mk @@ -1,8 +1,10 @@ -CEXAMPLE_MOD_DIR := $(USERMOD_DIR) +PICOCALCDISPLAY_MOD_DIR := $(USERMOD_DIR) # Add all C files to SRC_USERMOD. -SRC_USERMOD += $(CEXAMPLE_MOD_DIR)/eigenmath.c +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$(CEXAMPLE_MOD_DIR) \ No newline at end of file +CFLAGS_USERMOD += -I$(PICOCALCDISPLAY_MOD_DIR) -- 2.47.2 From a7373d23f449ba71198adc0c845050276c783ebd Mon Sep 17 00:00:00 2001 From: feng-arch Date: Mon, 13 Oct 2025 16:04:13 +0800 Subject: [PATCH 6/6] feat: add support for eigenmath --- ports/rp2/machine_spi.c | 220 +++++++++++++++------------------------- 1 file changed, 80 insertions(+), 140 deletions(-) diff --git a/ports/rp2/machine_spi.c b/ports/rp2/machine_spi.c index c0cee4f88..82fc2cc53 100644 --- a/ports/rp2/machine_spi.c +++ b/ports/rp2/machine_spi.c @@ -34,21 +34,21 @@ #include "hardware/spi.h" #include "hardware/dma.h" -#define DEFAULT_SPI_BAUDRATE (1000000) -#define DEFAULT_SPI_POLARITY (0) -#define DEFAULT_SPI_PHASE (0) -#define DEFAULT_SPI_BITS (8) -#define DEFAULT_SPI_FIRSTBIT (SPI_MSB_FIRST) +#define DEFAULT_SPI_BAUDRATE (1000000) +#define DEFAULT_SPI_POLARITY (0) +#define DEFAULT_SPI_PHASE (0) +#define DEFAULT_SPI_BITS (8) +#define DEFAULT_SPI_FIRSTBIT (SPI_MSB_FIRST) #ifdef MICROPY_HW_SPI_NO_DEFAULT_PINS // With no default SPI, need to require the pin args. -#define MICROPY_HW_SPI0_SCK (0) -#define MICROPY_HW_SPI0_MOSI (0) -#define MICROPY_HW_SPI0_MISO (0) -#define MICROPY_HW_SPI1_SCK (0) -#define MICROPY_HW_SPI1_MOSI (0) -#define MICROPY_HW_SPI1_MISO (0) +#define MICROPY_HW_SPI0_SCK (0) +#define MICROPY_HW_SPI0_MOSI (0) +#define MICROPY_HW_SPI0_MISO (0) +#define MICROPY_HW_SPI1_SCK (0) +#define MICROPY_HW_SPI1_MOSI (0) +#define MICROPY_HW_SPI1_MISO (0) #define MICROPY_SPI_PINS_ARG_OPTS MP_ARG_REQUIRED #else @@ -58,41 +58,40 @@ #ifndef MICROPY_HW_SPI0_SCK #if PICO_DEFAULT_SPI == 0 -#define MICROPY_HW_SPI0_SCK (PICO_DEFAULT_SPI_SCK_PIN) -#define MICROPY_HW_SPI0_MOSI (PICO_DEFAULT_SPI_TX_PIN) -#define MICROPY_HW_SPI0_MISO (PICO_DEFAULT_SPI_RX_PIN) +#define MICROPY_HW_SPI0_SCK (PICO_DEFAULT_SPI_SCK_PIN) +#define MICROPY_HW_SPI0_MOSI (PICO_DEFAULT_SPI_TX_PIN) +#define MICROPY_HW_SPI0_MISO (PICO_DEFAULT_SPI_RX_PIN) #else -#define MICROPY_HW_SPI0_SCK (6) -#define MICROPY_HW_SPI0_MOSI (7) -#define MICROPY_HW_SPI0_MISO (4) +#define MICROPY_HW_SPI0_SCK (6) +#define MICROPY_HW_SPI0_MOSI (7) +#define MICROPY_HW_SPI0_MISO (4) #endif #endif #ifndef MICROPY_HW_SPI1_SCK #if PICO_DEFAULT_SPI == 1 -#define MICROPY_HW_SPI1_SCK (PICO_DEFAULT_SPI_SCK_PIN) -#define MICROPY_HW_SPI1_MOSI (PICO_DEFAULT_SPI_TX_PIN) -#define MICROPY_HW_SPI1_MISO (PICO_DEFAULT_SPI_RX_PIN) +#define MICROPY_HW_SPI1_SCK (PICO_DEFAULT_SPI_SCK_PIN) +#define MICROPY_HW_SPI1_MOSI (PICO_DEFAULT_SPI_TX_PIN) +#define MICROPY_HW_SPI1_MISO (PICO_DEFAULT_SPI_RX_PIN) #else -#define MICROPY_HW_SPI1_SCK (10) -#define MICROPY_HW_SPI1_MOSI (11) -#define MICROPY_HW_SPI1_MISO (8) +#define MICROPY_HW_SPI1_SCK (10) +#define MICROPY_HW_SPI1_MOSI (11) +#define MICROPY_HW_SPI1_MISO (8) #endif #endif #endif // SPI0 can be GP{0..7,16..23}, SPI1 can be GP{8..15,24..29}. -#define IS_VALID_PERIPH(spi, pin) ((((pin) & 8) >> 3) == (spi)) +#define IS_VALID_PERIPH(spi, pin) ((((pin) & 8) >> 3) == (spi)) // GP{2,6,10,14,...} -#define IS_VALID_SCK(spi, pin) (((pin) & 3) == 2 && IS_VALID_PERIPH(spi, pin)) +#define IS_VALID_SCK(spi, pin) (((pin) & 3) == 2 && IS_VALID_PERIPH(spi, pin)) // GP{3,7,11,15,...} -#define IS_VALID_MOSI(spi, pin) (((pin) & 3) == 3 && IS_VALID_PERIPH(spi, pin)) +#define IS_VALID_MOSI(spi, pin) (((pin) & 3) == 3 && IS_VALID_PERIPH(spi, pin)) // GP{0,4,8,10,...} -#define IS_VALID_MISO(spi, pin) (((pin) & 3) == 0 && IS_VALID_PERIPH(spi, pin)) +#define IS_VALID_MISO(spi, pin) (((pin) & 3) == 0 && IS_VALID_PERIPH(spi, pin)) -typedef struct _machine_spi_obj_t -{ +typedef struct _machine_spi_obj_t { mp_obj_base_t base; spi_inst_t *const spi_inst; uint8_t spi_id; @@ -112,16 +111,9 @@ typedef struct _machine_spi_obj_t static machine_spi_obj_t machine_spi_obj[] = { { - {&machine_spi_type}, - spi0, - 0, - DEFAULT_SPI_POLARITY, - DEFAULT_SPI_PHASE, - DEFAULT_SPI_BITS, - DEFAULT_SPI_FIRSTBIT, - MICROPY_HW_SPI0_SCK, - MICROPY_HW_SPI0_MOSI, - MICROPY_HW_SPI0_MISO, + {&machine_spi_type}, spi0, 0, + 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, @@ -129,16 +121,9 @@ static machine_spi_obj_t machine_spi_obj[] = { 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, + {&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, @@ -147,38 +132,25 @@ static machine_spi_obj_t machine_spi_obj[] = { }, }; -static void machine_spi_print(const mp_print_t *print, mp_obj_t self_in, mp_print_kind_t kind) -{ +static void machine_spi_print(const mp_print_t *print, mp_obj_t self_in, mp_print_kind_t kind) { machine_spi_obj_t *self = MP_OBJ_TO_PTR(self_in); mp_printf(print, "SPI(%u, baudrate=%u, polarity=%u, phase=%u, bits=%u, sck=%u, mosi=%u, miso=%u)", - self->spi_id, self->baudrate, self->polarity, self->phase, self->bits, - self->sck, self->mosi, self->miso); + self->spi_id, self->baudrate, self->polarity, self->phase, self->bits, + self->sck, self->mosi, self->miso); } -mp_obj_t machine_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_id, - ARG_baudrate, - ARG_polarity, - ARG_phase, - ARG_bits, - ARG_firstbit, - ARG_sck, - ARG_mosi, - ARG_miso - }; +mp_obj_t machine_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_id, 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_id, MP_ARG_REQUIRED | MP_ARG_OBJ}, - {MP_QSTR_baudrate, MP_ARG_INT, {.u_int = DEFAULT_SPI_BAUDRATE}}, - {MP_QSTR_polarity, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_POLARITY}}, - {MP_QSTR_phase, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_PHASE}}, - {MP_QSTR_bits, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_BITS}}, - {MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_FIRSTBIT}}, - {MP_QSTR_sck, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE}}, - {MP_QSTR_mosi, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE}}, - {MP_QSTR_miso, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE}}, + { MP_QSTR_id, MP_ARG_REQUIRED | MP_ARG_OBJ }, + { MP_QSTR_baudrate, MP_ARG_INT, {.u_int = DEFAULT_SPI_BAUDRATE} }, + { MP_QSTR_polarity, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_POLARITY} }, + { MP_QSTR_phase, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_PHASE} }, + { MP_QSTR_bits, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_BITS} }, + { MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = DEFAULT_SPI_FIRSTBIT} }, + { MP_QSTR_sck, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE} }, + { MP_QSTR_mosi, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE} }, + { MP_QSTR_miso, MICROPY_SPI_PINS_ARG_OPTS | MP_ARG_KW_ONLY | MP_ARG_OBJ, {.u_rom_obj = MP_ROM_NONE} }, }; // Parse the arguments. @@ -187,8 +159,7 @@ mp_obj_t machine_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n // Get the SPI bus id. int spi_id = mp_obj_get_int(args[ARG_id].u_obj); - if (spi_id < 0 || spi_id >= MP_ARRAY_SIZE(machine_spi_obj)) - { + if (spi_id < 0 || spi_id >= MP_ARRAY_SIZE(machine_spi_obj)) { mp_raise_msg_varg(&mp_type_ValueError, MP_ERROR_TEXT("SPI(%d) doesn't exist"), spi_id); } @@ -196,31 +167,25 @@ mp_obj_t machine_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n machine_spi_obj_t *self = (machine_spi_obj_t *)&machine_spi_obj[spi_id]; // Set SCK/MOSI/MISO pins if configured. - if (args[ARG_sck].u_obj != mp_const_none) - { + if (args[ARG_sck].u_obj != mp_const_none) { int sck = mp_hal_get_pin_obj(args[ARG_sck].u_obj); - if (!IS_VALID_SCK(self->spi_id, sck)) - { + if (!IS_VALID_SCK(self->spi_id, sck)) { mp_raise_ValueError(MP_ERROR_TEXT("bad SCK pin")); } self->sck = sck; } - if (args[ARG_mosi].u_obj != mp_const_none) - { + if (args[ARG_mosi].u_obj != mp_const_none) { int mosi = mp_hal_get_pin_obj(args[ARG_mosi].u_obj); - if (!IS_VALID_MOSI(self->spi_id, mosi)) - { + if (!IS_VALID_MOSI(self->spi_id, mosi)) { 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) - { + if (args[ARG_miso].u_obj != mp_const_none) { int miso = mp_hal_get_pin_obj(args[ARG_miso].u_obj); - if (!IS_VALID_MISO(self->spi_id, miso)) - { + if (!IS_VALID_MISO(self->spi_id, miso)) { mp_raise_ValueError(MP_ERROR_TEXT("bad MISO pin")); } self->miso = miso; @@ -229,15 +194,13 @@ mp_obj_t machine_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n } // Initialise the SPI peripheral if any arguments given, or it was not initialised previously. - if (n_args > 1 || n_kw > 0 || self->baudrate == 0) - { + if (n_args > 1 || n_kw > 0 || self->baudrate == 0) { self->baudrate = args[ARG_baudrate].u_int; self->polarity = args[ARG_polarity].u_int; self->phase = args[ARG_phase].u_int; self->bits = args[ARG_bits].u_int; 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")); } @@ -252,22 +215,14 @@ mp_obj_t machine_spi_make_new(const mp_obj_type_t *type, size_t n_args, size_t n return MP_OBJ_FROM_PTR(self); } -static void machine_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj_t *pos_args, mp_map_t *kw_args) -{ - enum - { - ARG_baudrate, - ARG_polarity, - ARG_phase, - ARG_bits, - ARG_firstbit - }; +static void machine_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj_t *pos_args, mp_map_t *kw_args) { + enum { ARG_baudrate, ARG_polarity, ARG_phase, ARG_bits, ARG_firstbit }; static const mp_arg_t allowed_args[] = { - {MP_QSTR_baudrate, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, - {MP_QSTR_polarity, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, - {MP_QSTR_phase, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, - {MP_QSTR_bits, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, - {MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1}}, + { MP_QSTR_baudrate, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, + { MP_QSTR_polarity, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, + { MP_QSTR_phase, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, + { MP_QSTR_bits, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, + { MP_QSTR_firstbit, MP_ARG_KW_ONLY | MP_ARG_INT, {.u_int = -1} }, }; // Parse the arguments. @@ -276,46 +231,38 @@ static void machine_spi_init(mp_obj_base_t *self_in, size_t n_args, const mp_obj mp_arg_parse_all(n_args, pos_args, kw_args, MP_ARRAY_SIZE(allowed_args), allowed_args, args); // Reconfigure the baudrate if requested. - if (args[ARG_baudrate].u_int != -1) - { + if (args[ARG_baudrate].u_int != -1) { self->baudrate = spi_set_baudrate(self->spi_inst, args[ARG_baudrate].u_int); } // Reconfigure the format if requested. bool set_format = false; - if (args[ARG_polarity].u_int != -1) - { + if (args[ARG_polarity].u_int != -1) { self->polarity = args[ARG_polarity].u_int; set_format = true; } - if (args[ARG_phase].u_int != -1) - { + if (args[ARG_phase].u_int != -1) { self->phase = args[ARG_phase].u_int; set_format = true; } - if (args[ARG_bits].u_int != -1) - { + if (args[ARG_bits].u_int != -1) { self->bits = args[ARG_bits].u_int; set_format = true; } - if (args[ARG_firstbit].u_int != -1) - { + if (args[ARG_firstbit].u_int != -1) { self->firstbit = args[ARG_firstbit].u_int; if (self->firstbit == SPI_LSB_FIRST) { mp_raise_NotImplementedError(MP_ERROR_TEXT("LSB")); } } - if (self->miso > 0 && self->chan_rx < 0) - { + if (self->miso > 0 && self->chan_rx < 0) { self->chan_rx = dma_claim_unused_channel(true); } - if (self->mosi > 0 && self->chan_tx < 0) - { + if (self->mosi > 0 && self->chan_tx < 0) { self->chan_tx = dma_claim_unused_channel(true); } - if (set_format) - { + if (set_format) { spi_set_format(self->spi_inst, self->bits, self->polarity, self->phase, self->firstbit); } } @@ -429,8 +376,7 @@ static void machine_spi_wait_done(mp_obj_base_t *self_in) } } -static void machine_spi_transfer(mp_obj_base_t *self_in, size_t len, const uint8_t *src, uint8_t *dest) -{ +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; bool write_only = dest == NULL; const size_t dma_min_size_threshold = 8; @@ -509,8 +455,7 @@ static void machine_spi_transfer(mp_obj_base_t *self_in, size_t len, const uint8 // Buffer protocol implementation for SPI. // The buffer represents the SPI data FIFO. -static mp_int_t machine_spi_get_buffer(mp_obj_t o_in, mp_buffer_info_t *bufinfo, mp_uint_t flags) -{ +static mp_int_t machine_spi_get_buffer(mp_obj_t o_in, mp_buffer_info_t *bufinfo, mp_uint_t flags) { machine_spi_obj_t *self = MP_OBJ_TO_PTR(o_in); bufinfo->len = 4; @@ -527,8 +472,6 @@ static const mp_machine_spi_p_t machine_spi_p = { .set_tx_isr = machine_spi_set_tx_isr, }; - - MP_DEFINE_CONST_OBJ_TYPE( machine_spi_type, MP_QSTR_SPI, @@ -537,22 +480,19 @@ MP_DEFINE_CONST_OBJ_TYPE( print, machine_spi_print, protocol, &machine_spi_p, buffer, machine_spi_get_buffer, - locals_dict, &mp_machine_spi_locals_dict); + locals_dict, &mp_machine_spi_locals_dict + ); -mp_obj_base_t *mp_hal_get_spi_obj(mp_obj_t o) -{ - if (mp_obj_is_type(o, &machine_spi_type)) - { +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 - else if (mp_obj_is_type(o, &mp_machine_soft_spi_type)) - { + else if (mp_obj_is_type(o, &mp_machine_soft_spi_type)) { return MP_OBJ_TO_PTR(o); } #endif - else - { + else { mp_raise_TypeError(MP_ERROR_TEXT("expecting an SPI object")); } } -- 2.47.2