Nothing
#' Convert a M2 object into an R object
#'
#' Convert a M2 object into an R object
#'
#' @param s a character(1), typically the result of running toExternalString on
#' an M2 object
#' @param x an object to be printed
#' @param ... ...
#' @return an R object
#' @name m2_parser
#' @references D. Kahle, C. O'Neill, and J. Sommars (2020). "A Computer Algebra
#' System for R: Macaulay2 and the m2r Package." Journal of Statistical
#' Software, 93(9):1-31.
#' @examples
#'
#' \dontrun{ requires Macaulay2
#'
#' m2("1+1")
#' m2.("1+1")
#' m2_parse(m2.("1+1"))
#'
#' m2("QQ[x,y]")
#' m2.("QQ[x,y]")
#' m2_parse(m2.("QQ[x,y]"))
#'
#' get_m2_gmp()
#' m2("3/2") %>% m2_parse()
#' m2_toggle_gmp() # gmp on
#' m2("3/2") %>% m2_parse()
#' m2("6/4") %>% m2_parse()
#' m2("3345234524352435432/223454325235432524352433245") %>% m2_parse()
#' m2_toggle_gmp() # gmp off
#'
#'
#'
#' m2("50!") %>% m2_parse()
#' m2_toggle_gmp() # gmp on
#' m2("50!") %>% m2_parse()
#' m2_toggle_gmp() # gmp off
#'
#' }
#' @rdname m2_parser
#' @export
m2_parse <- function(s) {
if (is.m2_pointer(s)) {
tokens <- m2_tokenize(m2_meta(s, "ext_str"))
} else if (is.m2(s)) {
return(s)
} else {
tokens <- m2_tokenize(s)
}
memoise::forget(mem_m2.)
memoise::forget(mem_m2_parse)
ret <- m2_parse_internal(tokens)
ret <- ret$result
if (
is.m2_pointer(s) && is.m2(ret) &&
!is.null(m2_name(ret)) && m2_name(ret) == ""
) {
m2_name(ret) <- m2_name(s)
}
memoise::forget(mem_m2.)
memoise::forget(mem_m2_parse)
ret
}
# m2 symbol name character
m2_symbol_chars <- function() {
c(letters, toupper(letters), 0:9, "'")
}
# m2 operators, sorted by length for easier tokenizing
m2_operators <- function() {
c(
"===>", "<==>", "<===",
"==>", "===", "=!=", "<==", "^**", "(*)", "..<",
"||", "|-", ">>", ">=", "=>", "==", "<=", "<<", "<-", "++", "^^",
"^*", "#?", "//", "**", "@@", "..", ".?", "!=", ":=", "->", "_*",
"~", "|", ">", "=", "<", "+", "^", "%", "#", "&", "\\", "/", "*",
"@", ".", "?", "!", ":", ";", ",", "-", "_",
"[", "]", "{", "}", "(", ")"
)
}
# splits a string containing M2 code into tokens to ease parsing
# places an empty string between each line
m2_tokenize <- function(s) {
# operatorchars <- unlist(strsplit("=<>!&|_^{}[]()+-*/\\:;.,?`~@#$", "", fixed = TRUE))
operatorstartchars <- unlist(lapply(m2_operators(), function(s) substr(s,1,1)))
tokens <- character()
i <- 1
while (i <= nchar(s)) {
curchar <- substr(s, i, i)
if (curchar %in% m2_symbol_chars()) {
start <- i
i <- i + 1
while (i <= nchar(s) && substr(s, i, i) %in% m2_symbol_chars()) {
i <- i + 1
}
i <- i - 1
end <- i
tokens <- append(tokens, substr(s,start,end))
} else if (curchar %in% operatorstartchars) {
# substr() is smart enough to not index past the end of the string
for (op in m2_operators()) {
if (op == substr(s, i, i + nchar(op) - 1)) {
tokens <- append(tokens, op)
i <- i + nchar(op) - 1
break
}
}
} else if (curchar == "\"") {
i <- i + 1
start <- i
while (i <= nchar(s) && substr(s, i, i) != "\"") {
if (substr(s, i, i) == "\\") i <- i + 1
i <- i + 1
}
end <- i - 1
tokens <- append(tokens, c("\"", substr(s,start,end), "\""))
} else if (curchar == "\n") {
tokens <- append(tokens, "")
}
# skip other whitespace, etc.
i <- i + 1
}
tokens
}
# only used for ring parsing! Don't get greedy!!!!
mem_m2. <- memoise::memoise(function(x) m2.(x))
mem_m2_parse <- memoise::memoise(function(x) m2_parse(x))
m2_parse_internal <- function(tokens, start = 1) {
i <- start
if (tokens[i] == "{") {
# list: {A, A2 => B2, A3 => B3, C, ...}
elem <- m2_parse_list(tokens, start = i)
ret <- elem$result
i <- elem$nIndex
} else if (tokens[i] == "[") {
# array: [A, B, ...]
elem <- m2_parse_array(tokens, start = i)
ret <- elem$result
i <- elem$nIndex
} else if (tokens[i] == "(") {
# sequence: (A, B, ...) returned as classed list OR (A) returned as A
elem <- m2_parse_sequence(tokens, start = i)
ret <- elem$result
i <- elem$nIndex
} else if (tokens[i] == "\"") {
# string: "stuff"
error_on_fail(tokens[i+2] == "\"", "Parsing error: malformed string.")
ret <- m2_structure(tokens[i+1], m2_class = "m2_string")
i <- i + 3
} else if (substr(tokens[i], 1, 1) %in% 0:9) {
# positive integer or rational
if (length(tokens) > i && str_detect(tokens[i+1], "/")) { # is fraction
if (get_m2_gmp()) {
ret <- m2_structure(
as.bigq(tokens[i], tokens[i+2]),
m2_class = "m2_rational"
)
class(ret) <- c(class(ret), "bigq")
i <- i + 3
} else {
ret <- m2_structure(
as.integer(tokens[i]) / as.integer(tokens[i+2]),
m2_class = "m2_float"
)
i <- i + 3
}
} else if (length(tokens) > i && tokens[i+1] == ".") { # is an unusual float
ret <- m2_structure(
as.double(paste0(tokens[i], ".", str_replace(tokens[i+2], "p[0-9]+", ""))),
m2_class = "m2_float"
)
i <- i + 3
} else { # positive integer
if (get_m2_gmp()) {
ret <- m2_structure(
as.bigz(tokens[i]),
m2_class = "m2_integer"
)
class(ret) <- c(class(ret), "bigz")
i <- i + 1
} else {
ret <- m2_structure(
as.integer(tokens[i]),
m2_class = "m2_integer"
)
i <- i + 1
}
}
} else if (tokens[i] == ".") {
# positive float
ret <- m2_structure(
as.double(paste0(".", str_replace(tokens[i+1], "p[0-9]+", ""))),
m2_class = "m2_float"
)
i <- i + 2
} else if (tokens[i] == "-" && i != length(tokens) && tokens[i+1] == ".") {
# negative float
ret <- m2_structure(
-as.double(paste0(".", str_replace(tokens[i+2], "p[0-9]+", ""))),
m2_class = "m2_float"
)
i <- i + 3
} else if (tokens[i] == "-") {
# -expression
elem <- m2_parse_internal(tokens,start = i+1)
ret <- elem$result
i <- elem$nIndex
if (is.integer(ret)) {
ret <- -ret
} else {
ret <- m2_structure(paste0("-", ret), m2_class = "m2_string")
}
} else if (tokens[i] == "new") {
# object creation: new TYPENAME from DATA
elem <- m2_parse_new(tokens, start = i)
ret <- elem$result
i <- elem$nIndex
} else if (substr(tokens[i], 1, 1) %in% m2_symbol_chars()) {
# symbol, must be final case handled
elem <- m2_parse_symbol(tokens, start = i)
ret <- elem$result
i <- elem$nIndex
} else {
# we can't handle this input
stop(paste("Parsing error: format not supported: ", tokens[i]))
}
if (i > length(tokens)) {
return(list(result = ret, nIndex = i))
}
if (tokens[i] == "=>") {
# option: A => B
key <- ret
elem <- m2_parse_internal(tokens, start = i+1)
val <- elem$result
i <- elem$nIndex
ret <- list(key, val)
class(ret) <- c("m2_option","m2")
} else if (tokens[i] == "..") {
# sequence: (a..c) = (a, b, c)
start <- ret
elem <- m2_parse_internal(tokens, start = i+1)
end <- elem$result
i <- elem$nIndex
if (all(c(start,end) %in% letters) && start <= end) {
ret <- as.list(start %:% end)
ret <- lapply(ret, `class<-`, c("m2_symbol","m2"))
} else if (all(c(start,end) %in% toupper(letters)) && start <= end) {
ret <- as.list(start %:% end)
ret <- lapply(ret, `class<-`, c("m2_symbol","m2"))
} else if (is.integer(start) && is.integer(end) && start <= end) {
ret <- as.list(start:end)
} else {
ret <- list()
}
class(ret) <- c("m2_sequence","m2")
} else if (tokens[i] == ":") {
# sequence: (n:x) = (x,...,x)
num_copies <- ret
elem <- m2_parse_internal(tokens, start = i+1)
item <- elem$result
i <- elem$nIndex
ret <- replicate(num_copies, item, simplify = FALSE)
class(ret) <- c("m2_sequence","m2")
} else if (#class(ret)[1] %in% c("m2_ring","m2_symbol") &&
(tokens[i] %notin% c(m2_operators(),",") ||
tokens[i] %in% c("(","{","["))) {
# function call
if (tokens[i] == "(") {
elem <- m2_parse_sequence(tokens, start = i, save_paren = TRUE)
} else {
elem <- m2_parse_internal(tokens, start = i)
elem$result <- list(elem$result)
}
params <- elem$result
i <- elem$nIndex
ret <- m2_parse_object_as_function(ret, params)
} else if (tokens[i] %in% c("+","-","*","^")) {
# start of an expression, consume rest of expression
lhs <- ret
operand <- tokens[i]
elem <- m2_parse_internal(tokens, start = i + 1)
rhs <- elem$result
i <- elem$nIndex
if (is.m2_polynomialring(lhs)) {
ret <- list(lhs, rhs)
class(ret) <- c("m2_module","m2")
} else {
ret <- paste0(lhs, operand, rhs)
if ((is.integer(lhs) || class(lhs)[1] %in% c("m2_expression", "m2_symbol")) &&
(is.integer(rhs) || class(rhs)[1] %in% c("m2_expression", "m2_symbol"))) {
class(ret) <- c("m2_expression", "m2")
}
}
}
list(result = ret, nIndex = i)
}
# x is a list interpreted as a M2 list
# class name is m2_M2CLASSNAME in all lower case
# example: x = list(1,2,3), class(x) = c("m2_verticallist","m2")
m2_parse_class <- function(x) UseMethod("m2_parse_class")
m2_parse_class.default <- function(x) x
m2_parse_class.m2_hashtable <- m2_parse_class.default
m2_parse_class.m2_optiontable <- m2_parse_class.m2_hashtable
m2_parse_class.m2_verticallist <- m2_parse_class.m2_hashtable
# x is a list of function parameters
# class name is m2_M2FUNCTIONNAME in all lower case
# example: x = list(mpoly("x")), class(x) = c("m2_symbol","m2")
m2_parse_function <- function(x) UseMethod("m2_parse_function")
m2_parse_function.default <- function(x) stop(paste0("Unsupported function ", class(x)[1]))
m2_parse_function.m2_hashtable <- function(x) x[[1]]
m2_parse_function.m2_optiontable <- m2_parse_function.m2_hashtable
m2_parse_function.m2_verticallist <- m2_parse_function.m2_hashtable
m2_parse_function.m2_symbol <- function(x) {
class(x[[1]]) <- c("m2_symbol","m2")
x[[1]]
}
m2_parse_function.m2_monoid <- function(x) {
class(x[[1]]) <- c("m2_monoid","m2")
x[[1]]
}
m2_parse_function.m2_tocc <- function(x) {
m2_structure(complex(real = x[[1]], imaginary = x[[2]]), m2_class = "m2_complex")
}
# x is an object being applied (as a function) to params
# example: x = monoid, params = [x,y,z]
# example: x = QQ, params = monoid [x..z]
m2_parse_object_as_function <- function(x, params) UseMethod("m2_parse_object_as_function")
m2_parse_object_as_function.default <- function(x, params) stop(paste0("Unsupported object ", class(x)[1], " used as function"))
# x is a function name
# dispatch for function call
m2_parse_object_as_function.m2_symbol <- function(x, params) {
class(params) <- c(paste0("m2_",tolower(x)),"m2")
ret <- m2_parse_function(params)
}
m2_parse_new <- function(tokens, start = 1) {
i <- start
error_on_fail(tokens[i] == "new", "Parsing error: malformed new object")
error_on_fail(tokens[i+2] == "from", "Parsing error: malformed new object")
elem <- m2_parse_internal(tokens, start = i+3)
ret <- elem$result
i <- elem$nIndex
class(ret) <- c(paste0("m2_",tolower(tokens[start+1])),"m2")
m2_parse_class(ret)
list(result = ret, nIndex = i)
}
m2_parse_symbol <- function(tokens, start = 1) {
i <- start + 1
sym_name <- tokens[i-1]
ptr <- mem_m2.(sym_name)
if (m2_meta(ptr, "m2_class") %in% m2_ring_class_names()) {
ret <- ""
if (sym_name %in% m2_coefrings()) {
ret <- coefring_as_ring(sym_name)
} else {
ret <- mem_m2_parse(ptr)
m2_name(ret) <- sym_name
}
while (i <= length(tokens) && tokens[i] == "_") i <- i + 2
return(list(result = ret, nIndex = i))
}
ret <- sym_name
while (i <= length(tokens) && tokens[i] == "_") {
i <- i + 1
if (tokens[i] == "(") {
seqret <- m2_parse_sequence(tokens, start = i)
ret <- paste0(
ret,
paste0(unlist(tokens[i:seqret$nIndex-1]), collapse = "")
)
i <- seqret$nIndex
} else {
ret <- paste0(ret,"_",tokens[i])
}
i <- i + 1
}
if (ret == "true") {
ret <- m2_structure(TRUE, m2_class = "m2_boolean")
} else if (ret == "false") {
ret <- m2_structure(FALSE, m2_class = "m2_boolean")
} else if (ret == "null") {
ret <- NULL
} else {
# this is an actual symbol
class(ret) <- c("m2_symbol","m2")
}
list(result = ret, nIndex = i)
}
# {A1 => B1, A2 => B2, ...}
m2_parse_list <- function(tokens, start = 1, open_char = "{", close_char = "}", type_name = "list") {
ret <- list()
i <- start + 1
error_on_fail(tokens[i-1] == open_char, paste0("Parsing error: malformed ", type_name))
if (tokens[i] == close_char) {
i <- i + 1
} else {
repeat {
elem <- m2_parse_internal(tokens, start = i)
ret <- append(ret, list(elem$result))
i <- elem$nIndex + 1
if (tokens[i-1] == close_char) {
break()
}
error_on_fail(tokens[i-1] == ",", paste0("Parsing error: malformed ", type_name))
error_on_fail(i <= length(tokens), paste0("Parsing error: malformed ", type_name))
}
}
class(ret) <- c(paste0("m2_",type_name),"m2")
list(result = ret, nIndex = i)
}
# [A, B, ...]
m2_parse_array <- function(tokens, start = 1) {
m2_parse_list(tokens, start = start, open_char = "[", close_char = "]", type_name = "array")
}
# (A, B, ...) as classed list
# (A1) as A1
m2_parse_sequence <- function(tokens, start = 1, save_paren = FALSE) {
elem <- m2_parse_list(tokens, start = start, open_char = "(", close_char = ")", type_name = "sequence")
# if sequence has only one element
if (length(elem$result) == 1 && !save_paren) {
elem$result <- elem$result[[1]]
}
elem
}
#' @rdname m2_parser
#' @export
print.m2_integer <- function(x, ...) {
if(inherits(x, "bigz")) return(get("print.bigz", envir = asNamespace("gmp"))(x))
class(x) <- "numeric"
print(x)
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_float <- function(x, ...) {
class(x) <- "numeric"
print(x)
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_complex <- function(x, ...) {
class(x) <- "complex"
print(x)
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_string <- function(x, ...) {
class(x) <- "character"
print(x)
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_boolean <- function(x, ...) {
print(unclass(x))
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_list <- function(x, ...) {
cat("M2 List\n")
print(unclass(x))
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_array <- function(x, ...) {
cat("M2 Array\n")
print(unclass(x))
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_sequence <- function(x, ...) {
cat("M2 Sequence\n")
print(unclass(x))
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_symbol <- function(x, ...) {
cat("M2 Symbol:", x, "\n")
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_option <- function(x, ...) {
cat("M2 Option\n")
cat(x[[1]], "=>", x[[2]])
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_hashtable <- function(x, ...) {
cat("M2 HashTable\n")
print(unclass(x))
invisible(x)
}
#' @rdname m2_parser
#' @export
print.m2_module <- function(x, ...) {
cat("M2 Module\n")
print(unclass(x))
invisible(x)
}
error_on_fail <- function(t, e) {
if (!t) stop(e)
}
#' @rdname m2_parser
#' @export
m2_toggle_gmp <- function() {
options <- getOption("m2r")
options$gmp <- !options$gmp
if (options$gmp) {
message("m2r is now using gmp.")
} else {
message("m2r is no longer using gmp.")
}
options(m2r = options)
}
#' @rdname m2_parser
#' @export
get_m2_gmp <- function() getOption("m2r")$gmp
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.