polynomial <- function(coef = c(0, 1)) {
    a <- as.numeric(coef)
    while((la <- length(a)) > 1 && a[la] == 0) a <- a[-la]
    structure(a, class = "polynomial")
}

as.polynomial <- function(p)
    if(is.polynomial(p)) p else polynomial(p)
is.polynomial <- function(p)
    inherits(p, "polynomial")

Ops.polynomial <- function(e1, e2) {
    if(missing(e2))
        return(switch(.Generic,
                      "+" = e1, 
                      "-" = polynomial(NextMethod(.Generic)),
                      stop("unsupported unary operation")))
    e1 <- unclass(e1)
    e2 <- unclass(e2)
    l1 <- length(e1)
    l2 <- length(e2)
    e1.op.e2 <- 
        switch(.Generic,
               "+" = ,
               "-" = {
                   e1 <- c(e1, rep(0, max(0, l2 - l1)))
                   e2 <- c(e2, rep(0, max(0, l1 - l2)))
                   NextMethod(.Generic)
               },
               "*" = if(l1 == 1 || l2 == 1) e1 * e2 else {
                   m <- outer(e1, e2)
                   as.vector(tapply(m, row(m) + col(m), sum))
               },
               "/" = {
                   if(e2 == 0)
                       stop("unsupported polynomial division")
                   if(l2 == 1)
                       e1 / e2
                   else {
                       p <- rev(e1)
                       q <- rev(e2)
                       r <- rep(0, length(p))
                       i <- 0
                       while(length(p) >= length(q)) {
                           i <- i + 1
                           d <- p[1]/q[1]
                           r[i] <- d
                           p[1:lq] <- p[1:lq] - d * q
                           p <- p[-1]
                       }
                       if(i == 0) 0 else r[i:1]
                   }
               },
               "^" = {
                   if(e2 < 0 || e2 %% 1 != 0)
                       stop("unsupported polynomial power")
                   switch(as.character(e2),
                          "0" = 1,
                          "1" = e1,
                      {
                          p <- q <- polynomial(e1)
                          for(i in 2:e2)
                              p <- p * q
                          as.numeric(p)
                      })
               },
               "%%" = {
                   if(l2 == 1)
                       0
                   else {
                       p <- rev(e1)
                       q <- rev(e2)
                       while(length(p) >= length(q)) {
                           d <- p[1]/q[1]
                           p[1:lq] <- p[1:lq] - d * q
                           p <- p[-1]
                       }
                       if(length(p) == 0) 0 else rev(p)
                   }
               },
               "==" = return(l1 == l2 && all(e1 == e2)),
               "!=" = return(l1 != l2 || any(e1 != e2)),
               stop("unsupported operation on polynomials"))
    polynomial(e1.op.e2)
}
Summary.polynomial <- function(p) {
    stop(paste(.Generic, "invalid for polynomials"))
}
Math.polynomial <- function(p, digits) {
    switch(.Generic,
           round = ,
           signif = ,
           floor = ,
           ceiling = ,
           trunc = polynomial(NextMethod(.Generic)),
           stop(paste(.Generic, "unsupported for polynomials")))
}

horner <- function(p) {
    a <- as.character(rev(unclass(p)))
    h <- a[1]
    while(length(a <- a[-1]) > 0) {
        h <- paste("x*(", h, ")", sep = "")
        if(a[1] != 0)
            h <- paste(a[1], " + ", h, sep = "")
    }
    h
}

as.character.polynomial <- function(p) {
    p <- unclass(p)
    lp <- length(p) - 1
    names(p) <- 0:lp
    p <- p[p != 0]

    if(length(p) == 0) return("0")

    signs <- ifelse(p < 0, "- ", "+ ")
    if(signs[1] == "- ")
        signs[1] <- "-"
    else
        signs[1] <- ""

    np <- names(p)
    p <- as.character(abs(p))
    p[p == "1" & np != "0"] <- ""

    pow <- paste("x^", np, sep = "")
    pow[np == "0"] <- ""
    pow[np == "1"] <- "x"
    stars <- rep("*", length(p))
    stars[p == "" | pow == ""] <- ""
    paste(signs, p, stars, pow, sep = "", collapse = " ")
}

print.polynomial <- function(p0, ...) {
    p <- as.character.polynomial(signif(p0, 
                                        digits =
                                        options("digits")$digits))
    pc <- nchar(p)
    ow <- max(35, options("width")$width)
    m2 <- 0
    while(m2 < pc) {
        m1 <- m2 + 1
        m2 <- min(pc, m2 + ow)
        if(m2 < pc)
            while(substring(p, m2, m2) != " " && m2 > m1 + 1) 
                m2 <- m2 - 1
        cat(substring(p, m1, m2), "\n")
    }
    invisible(p0)
}  

as.function.polynomial <- function(p) {
    f <- function(x) NULL
    body(f) <- parse(text = horner(p))[[1]]
    f
}


poly.orth <- function(x, degree = length(unique(x)) - 1, norm = TRUE) {
    at <- attr(poly(x, degree), "coefs")
    a <- at$alpha
    N <- at$norm2
    x <- polynomial()
    p <- list(polynomial(0), polynomial(1))
    for(j in 1:degree)
        p[[j + 2]] <- 
            (x - a[j]) * p[[j + 1]] - N[j + 1]/N[j] * p[[j]]
    p <- p[-1]
    if(norm) {
        sqrtN <- sqrt(N[-1])
        for(j in 1 + 0:degree) p[[j]] <- p[[j]]/sqrtN[j]
    }
    class(p) <- "polylist"
    p
}
polylist <- function(...) {
    P <- lapply(list(...), as.polynomial)
    structure(P, class = "polylist")
}

deriv.polylist <- function(p, ...) 
    structure(lapply(p, deriv), class = class(p))

integral.polylist <- function(p, ...) {
    result <- lapply(p, integral, ...)
    if (length(result) > 0 && is.polynomial(result[[1]]))
        class(result) <- class(p)
    result
}

plot.polylist <- function(p, xlim = 0:1, ylim = range(Px), type = "l",
                          len = 100, ...) {
    if(missing(xlim)) {
        ## try to cover the "interesting" region
        xlim <- range(Re(unlist(lapply(p, summary.polynomial))))
    }
    if(any(is.na(xlim))) {
        warning("summary of polynomial fails. Using nominal xlim")
        xlim <- 0:1
    }
    if(diff(xlim) == 0)
        xlim <- xlim + c(-1, 1)/2
    if(length(xlim) > 2)
        x <- xlim
    else {
        eps <- diff(xlim)/100
        xlim <- xlim + c( - eps, eps)
        x <- seq(xlim[1], xlim[2], len = len)
    }
    Px <- unlist(lapply(p, predict.polynomial, x))
    if(!missing(ylim))
        Px[Px < ylim[1]] <- Px[Px > ylim[2]] <- NA
    plot(cbind(x, Px), xlab = "x", ylab = "P(x)", type = "n",
         xlim = xlim, ylim = ylim, ...)
    for(i in seq(along = p))
        lines(p[[i]], lty = i)
    invisible()
}

print.polylist <- function(x, ...) {
    cat("List of polynomials:\n")
    y <- x
    x <- unclass(x)
    NextMethod()
    invisible(y)
}
change.origin <- function(p, o) {
    if(!is.polynomial(p))
        stop(paste("\"", deparse(substitute(p)), "\"", 
                   " is not a polynomial"))
    o <- unclass(o[1])
    r <- predict(p, o)
    m <- 1
    p <- deriv(p)
    while(p != 0) {
        r <- c(r, predict(p, o))
        m <- m + 1
        p <- polynomial(unclass(deriv(p))/m)
    }
    polynomial(r)
}

coef.polynomial <- function(object,...)
    as.vector(object)

deriv.polynomial <- function(expr, ...) {
    expr <- unclass(expr)
    if(length(expr) == 1)
        return(polynomial(0))
    expr <- expr[-1]
    polynomial(expr * seq(along = expr))
}

integral <- function(expr, ...) UseMethod("integral")

integral.polynomial <- function(expr, limits = NULL, ...) {
    expr <- unclass(expr)
    p <- polynomial(c(0, expr/seq(along = expr)))
    if(is.null(limits))
        p
    else
        diff(predict(p, limits))
}

lines.polynomial <- function(p, len = 100, ...) {
    pu <- par("usr")
    x <- seq(pu[1], pu[2], len = len)
    y <- predict(p, x)
    y[y <= pu[3] | y >= pu[4]] <- NA
    lines(x, y, ...)
}

monic <- function(p) {
    p <- unclass(p)
    if(all(p == 0)) {
        warning("the zero polynomial has no monic form")
        return(polynomial(0))
    }
    polynomial(p/p[length(p)])
}

plot.polynomial <- function(p, xlim = 0:1, ylim = range(Px), 
			    type = "l", len = 100,...) {
    if(missing(xlim))
        xlim <- range(Re(unlist(summary(p))))
    if(any(is.na(xlim))) {
        warning("summary of polynomial fails. Using nominal xlim")
        xlim <- 0:1
    }
    if(diff(xlim) == 0)
        xlim <- xlim + c(-1, 1)/2
    if(length(xlim) > 2)
        x <- xlim
    else {
        eps <- diff(xlim)/100
        xlim <- xlim + c(- eps, eps)
        x <- seq(xlim[1], xlim[2], len = len)
    }
    Px <- predict(p, x)
    if(!missing(ylim))
        Px[Px < ylim[1]] <- Px[Px > ylim[2]] <- NA
    plot(x, Px, type = type, xlim = xlim, ylim = ylim, ...)
}

points.polynomial <- function(p, length = 100, ...) {
    pu <- par("usr")
    x <- seq(pu[1], pu[2], len = length)
    y <- predict(p, x)
    out <- y <= pu[3] | y >= pu[4]
    y[out] <- NA
    points(x, y, ...)
}

poly.calc <- function(x, y, tol = sqrt(.Machine$double.eps),
                      lab = dimnames(y)[[2]]) {
    if(missing(y)) {
        p <- 1
        for(xi in x)
            p <- c(0, p) - c(xi * p, 0)
        return(polynomial(p))
    }
    if(is.matrix(y)) {
        if(length(x) != nrow(y))
            stop("x and y are inconsistent in size")
        lis <- list()
        if(is.null(lab))
            lab <- paste("p", 1:(dim(y)[2]), sep = "")
        for(i in 1:dim(y)[2])
            lis[[lab[i]]] <- Recall(x, y[, i], tol)
        return(structure(lis, class = "polylist"))
    }
    if(any(toss <- duplicated(x))) {
        crit <- max(tapply(y, x, function(x) diff(range(x))))
        if(crit > tol)
            warning("some duplicated x-points have inconsistent y-values")
        keep <- !toss
        y <- y[keep]
        x <- x[keep]
    }
    if((m <- length(x)) != length(y))
        stop("x and y(x) do not match in length!")
    if(m <= 1)
        return(polynomial(y))
    r <- 0
    for(i in 1:m)
        r <- r + (y[i] * unclass(Recall(x[ - i])))/prod(x[i] - x[ - i])
    r[abs(r) < tol] <- 0
    polynomial(r)
}

poly.from.zeros <- function(...) poly.calc(unlist(list(...)))
poly.from.roots <- .Alias(poly.from.zeros)
poly.from.values <- .Alias(poly.calc)

predict.polynomial <- function(p, newdata, ...) {
    v <- 0
    p <- rev(unclass(p))
    for(pj in p)
        v <- newdata * v + pj
    v
}

print.summary.polynomial <- function(x, ...) {
    cat("\n Summary information for:\n")
    print(attr(x, "originalPolynomial"))
    cat("\n Zeros:\n")
    print(x$zeros)
    cat("\n Stationary points:\n")
    print(x$stationaryPoints)
    cat("\n Points of inflexion:\n")
    print(x$inflexionPoints)
    invisible(x)
}

solve.polynomial <- function(a, b, ...) {
    if(!missing(b)) 
        a <- a - b
    a <- unclass(a)
    if(a[1] == 0) {
        z <- rle(a)$lengths[1]
        a <- a[-(1:z)]
        r <- rep(0, z)
    }
    else
        r <- numeric(0)
    switch(as.character(length(a)),
           "0" =,
           "1" = r,
           "2" = sort(c(r,  - a[1]/a[2])),
       {
	   a <- rev(unclass(a))
	   a <- (a/a[1])[-1]
	   M <- rbind( - a, cbind(diag(length(a) - 1), 0))
	   sort(c(r, eigen(M, symmetric = F, only.values = T)$values))
       })
}

summary.polynomial <- function(object) {
    dp <- deriv(object)
    structure(list(zeros = solve(object),
                   stationaryPoints = solve(dp), 
                   inflexionPoints = solve(deriv(dp))), 
              class = "summary.polynomial",
              originalPolynomial = object)
}
