# Linearised transformation matrices
.bradfordXYZtoLMS <- matrix(c(0.8951, -0.7502, 0.0389, 0.2664, 1.7135, -0.0685, -0.1614, 0.0367, 1.0296), 3, 3)
.bradfordLMStoXYZ <- solve(.bradfordXYZtoLMS)

# Oklab reference https://bottosson.github.io/posts/oklab/
.XYZtoOklabM1 <- matrix(c(0.8189330101, 0.0329845436, 0.0482003018, 0.3618667424, 0.9293118715, 0.2643662691, -0.1288597137, 0.0361456387, 0.6338517070), 3, 3)
.XYZtoOklabM2 <- matrix(c(0.2104542553, 1.9779984951, 0.0259040371, 0.7936177850, -2.4285922050, 0.7827717662, -0.0040720468, 0.4505937099, -0.8086757660), 3, 3)
.OklabtoXYZM1 <- solve(.XYZtoOklabM1)
.OklabtoXYZM2 <- solve(.XYZtoOklabM2)

# Standard and additional colour space converters
.converters <- list(rgb="sRGB", srgb="sRGB", xyz="XYZ", "apple rgb"="Apple RGB", "cie rgb"="CIE RGB", lab="Lab", luv="Luv")

# Since R 3.6.0, colorConverter() has a "vectorized" argument that allows converters to indicate that they can handle multiple colours at once. For now we don't use that, for backwards compatibility
.converters$hsv <- colorConverter(
    toXYZ = function (hsv, ...) {
        c <- hsv[2] * hsv[3]            # chroma
        base <- (1 - hsv[2]) * hsv[3]
        sextile <- (hsv[1] %% 360) / 60 + 1
        f <- sextile - floor(sextile)
        rgb <- base + switch(as.integer(sextile), c(c,f*c,0), c((1-f)*c,c,0), c(0,c,f*c), c(0,(1-f)*c,c), c(f*c,0,c), c(c,0,(1-f)*c))
        colorspaces$sRGB$toXYZ(rgb, ...)
    },
    fromXYZ = function (xyz, ...) {
        # This rounding operation mirrors convertColor(), and avoids numerical variability between platforms
        rgb <- round(colorspaces$sRGB$fromXYZ(xyz, ...), 5)
        rgb[rgb < 0] <- 0
        rgb[rgb > 1] <- 1
        rgb <- (if (is.matrix(rgb)) t(rgb) else matrix(rgb,ncol=1L))
        hsv <- drop(rgb2hsv(rgb, maxColorValue=1))
        hsv[1] <- (hsv[1] * 360) %% 360
        structure(hsv, names=c("H","S","V"))
    },
    name = "HSV")

.converters$lms <- colorConverter(
    toXYZ = function (lms, ...) { .bradfordLMStoXYZ %*% lms },
    fromXYZ = function (xyz, ...) { structure(.bradfordXYZtoLMS %*% xyz, names=c("L","M","S")) },
    name = "LMS")

.converters$lch <- colorConverter(
    toXYZ = function (lch, ...) {
        angle <- lch[3] / 180 * pi
        lab <- c(lch[1], lch[2] * cos(angle), lch[2] * sin(angle))
        colorspaces$Lab$toXYZ(lab, ...)
    },
    fromXYZ = function (xyz, ...) {
        lab <- colorspaces$Lab$fromXYZ(xyz, ...)
        lch <- c(lab[1], sqrt(lab[2]^2 + lab[3]^2), atan2(lab[3],lab[2]) / pi * 180)
        lch[3] <- lch[3] %% 360
        structure(lch, names=c("L","C","h"))
    },
    name = "LCh")

.converters$oklab <- colorConverter(
    toXYZ = function (oklab, ...) {
        .OklabtoXYZM1 %*% (.OklabtoXYZM2 %*% oklab)^3
    },
    fromXYZ = function (xyz, ...) {
        # x^(1/3) returns NaN for negative numbers, so a bit more care is needed
        lab <- .XYZtoOklabM1 %*% xyz
        labPrime <- sign(lab) * abs(lab)^(1/3)
        structure(.XYZtoOklabM2 %*% labPrime, names=c("L","a","b"))
    },
    white = "D65",
    name = "Oklab")

.toHex <- function (coords, space, alpha = NULL)
{
    space <- tolower(space)
    missing <- apply(coords, 1, anyNA)
    
    if (any(!missing) && !identical(.converters[[space]], "sRGB"))
        coords[!missing,] <- convertColor(coords[!missing,,drop=FALSE], .converters[[space]], "sRGB")
    
    result <- rep(NA_character_, nrow(coords))
    if (is.null(alpha) || all(alpha == 1))
        result[!missing] <- rgb(coords[!missing,1], coords[!missing,2], coords[!missing,3], maxColorValue=1)
    else
        result[!missing] <- rgb(coords[!missing,1], coords[!missing,2], coords[!missing,3], pmax(0,pmin(1,alpha[!missing])), maxColorValue=1)
    return (result)
}

.clip <- function (coords, space)
{
    if (grepl("rgb$", tolower(space)))
    {
        coords[coords < 0] <- 0
        coords[coords > 1] <- 1
    }
    else if (tolower(space) == "hsv")
    {
        temp <- coords[,1] %% 360
        coords[coords < 0] <- 0
        coords[coords > 1] <- 1
        coords[,1] <- temp
    }
    
    return (coords)
}

.dims <- function (x, collapse = FALSE)
{
    if (is.null(dim(x)))
        return (length(x))
    else if (length(dim(x)) > 2 && collapse)
        return (c(dim(x)[1], prod(dim(x)[-1])))
    else
        return (dim(x))
}

.hasNames <- function (x) !is.null(names(x)) && any(nchar(names(x)) > 0)

.names <- function (x, ..., allowNull = TRUE)
{
    if (!missing(..1))
    {
        elements <- lapply(list(x,...), .names, allowNull=FALSE)
        result <- do.call("c", elements)
    }
    else if (!is.null(names(x)))
        result <- names(x)
    else
        result <- rep("", length(x))

    if (allowNull && (is.null(result) || all(result == "")))
        return (NULL)
    else
        return (result)
}

.alpha <- function (x, ..., allowNull = TRUE)
{
    if (!missing(..1))
    {
        elements <- lapply(list(x,...), .alpha, allowNull=FALSE)
        result <- do.call("c", elements)
    }
    else
    {
        if (!is.null(attr(x, "alpha")))
            result <- pmax(0, pmin(1, attr(x,"alpha")))
        else if (any(grepl("#[0-9A-Fa-f]{8}", as.character(x), perl=TRUE)))
            result <- unname(col2rgb(as.character(x), alpha=TRUE)["alpha",] / 255)
        else
            result <- rep(1, length(x))
    }
    
    if (allowNull && all(result == 1))
        return (NULL)
    else
        return (result)
}

#' The shade class
#' 
#' Objects of class `"shade"` are simply standard R character vectors
#' representing one or more 8-bit (s)RGB colours in CSS-like hex format, but
#' with extra attributes giving the current colour space and coordinates.
#' Opacity values are also supported.
#'
#' The `shade()` function creates a colour vector from a single main argument
#' plus method-specific arguments where appropriate. The `shades()` function
#' provides an alternative interface that converts each of its arguments to
#' shades, with direct inline naming, and then concatenates them.
#' 
#' Comparison between `"shade"` objects `x` and `y` is achieved by converting
#' `y` (the second argument) into the colour space of `x` and then comparing
#' coordinates, after any clipping.
#' 
#' @param x,y R objects, or `"shade"` objects for methods.
#' @param space For a matrix, the space in which coordinates are being
#'   provided.
#' @param alpha For a matrix, an associated vector of opacity values between 0
#'   and 1, if required.
#' @param target,current Shade vectors to compare.
#' @param i An index vector.
#' @param value A vector of replacement colours.
#' @param hexonly If `TRUE`, compare only on the basis of the hex strings.
#'   Otherwise test for equal coordinates.
#' @param ... For `shade()`, additional parameters to methods. For `shades()`
#'   and `c()`, any number of colours in any acceptable form.
#' @return A character vector of class `"shade"`, with additional attributes
#'   as follows.
#'     \item{space}{A string naming a colour space.}
#'     \item{coords}{A matrix giving colour coordinates in the relevant space,
#'       one colour per row.}
#'     \item{alpha}{A numeric vector of alpha (opacity) values between 0 and 1,
#'       one value per element of the vector. If not present then full opacity
#'       is assumed for every element.}
#'     \item{names}{A character vector of element names, in the usual R
#'       convention. If not present then the object is unnamed.}
#' 
#' @note When concatenating, shades that are all from the same space will
#'   remain in that space, but shades from different spaces will be warped to
#'   "XYZ" space.
#' 
#' @examples
#' s <- shade(c("red", "green", "blue"))
#' s[1]
#' s[1] <- "pink"
#' @author Jon Clayden <code@@clayden.org>
#' @export
shade <- function (x, ...)
{
    # Zero-length special case - nothing to dispatch on
    if (nargs() == 0)
        return (structure(character(0), space="sRGB", coords=matrix(NA,0,3), class="shade"))
    
    UseMethod("shade")
}

#' @rdname shade
#' @export
shade.shade <- function (x, ...)
{
    return (x)
}

#' @rdname shade
#' @export
shade.color <- function (x, ...)
{
    hex <- colorspace::hex(x, fixup=TRUE)
    coords <- colorspace::coords(x)
    structure(hex, names=rownames(coords), space=class(x), coords=coords, alpha=.alpha(hex), class="shade")
}

#' @rdname shade
#' @export
shade.matrix <- function (x, space = "sRGB", alpha = NULL, ...)
{
    hex <- .toHex(x, space, alpha)
    structure(hex, names=rownames(x), space=space, coords=x, alpha=.alpha(hex), class="shade")
}

#' @rdname shade
#' @export
shade.character <- function (x, ...)
{
    if (length(x) == 0)
        return (shade())
    
    coords <- structure(t(col2rgb(x)/255), dimnames=list(NULL,c("R","G","B")))
    coords[is.na(x),] <- NA
    alpha <- .alpha(x)
    
    nonHex <- !is.na(x) & !grepl("^\\s*#", x, perl=TRUE)
    if (!.hasNames(x) && any(nonHex))
        names(x) <- ifelse(nonHex, x, "")
    
    structure(.toHex(coords,"sRGB",alpha), names=names(x), space="sRGB", coords=coords, alpha=alpha, class="shade")
}

#' @rdname shade
#' @export
shade.default <- function (x, ...)
{
    shade.character(as.character(x), ...)
}

#' @rdname shade
#' @export
shades <- function (...)
{
    args <- list(...)
    elements <- lapply(unname(args), shade)
    result <- do.call(c, elements)
    
    if (.hasNames(args))
    {
        resultNames <- .names(result, allowNull=FALSE)
        lengths <- vapply(elements, length, integer(1L))
        argNames <- rep(.names(args, allowNull=FALSE), lengths)
        indices <- which(argNames != "")
        names(result) <- replace(resultNames, indices, argNames[indices])
    }
    
    return (result)
}

#' @rdname shade
#' @export
print.shade <- function (x, ...)
{
    len <- length(x)
    hasAlpha <- !is.null(attr(x, "alpha"))
    cat(paste0(" ", len, ifelse(.hasNames(x)," named",""), ifelse(len==1," shade"," shades"), " in ", space(x), " space, ", ifelse(hasAlpha,"with","without"), " transparency\n"))
    print(structure(x, space=NULL, coords=NULL, alpha=NULL, class=NULL), quote=FALSE)
}

#' @rdname shade
#' @export
"[.shade" <- function (x, i)
{
    structure(as.character(x)[i], space=attr(x,"space"), coords=attr(x,"coords")[i,,drop=FALSE], alpha=attr(x,"alpha")[i], class="shade")
}

#' @rdname shade
#' @export
"[<-.shade" <- function (x, i, value)
{
    space <- attr(x, "space")
    replacement <- warp(value, space)
    coords <- attr(x, "coords")
    coords[i,] <- attr(replacement, "coords")
    
    alpha <- .alpha(x, allowNull=FALSE)
    alpha[i] <- .alpha(replacement, allowNull=FALSE)
    if (all(alpha == 1))
        alpha <- NULL
    
    names <- .names(x, allowNull=FALSE)
    names[i] <- .names(replacement, allowNull=FALSE)
    if (all(names == ""))
        names <- NULL
    
    structure(.toHex(coords,space,alpha), space=space, coords=coords, alpha=alpha, names=names, class="shade")
}

#' @rdname shade
#' @export
c.shade <- function (...)
{
    shades <- lapply(list(...), shade)
    spaces <- sapply(shades, space)
    
    if (all(spaces == spaces[1]))
        space <- spaces[1]
    else
    {
        space <- "XYZ"
        shades <- lapply(shades, warp, "XYZ")
    }
    
    structure(do.call("c",lapply(shades,as.character)), space=space, coords=do.call("rbind",lapply(shades,coords)), alpha=do.call(".alpha",shades), names=do.call(".names",shades), class="shade")
}

#' @rdname shade
#' @export
rep.shade <- function (x, ...)
{
    indices <- rep(seq_along(x), ...)
    structure(as.character(x)[indices], space=attr(x,"space"), coords=attr(x,"coords")[indices,,drop=FALSE], alpha=attr(x,"alpha")[indices], names=.names(x)[indices], class="shade")
}

#' @rdname shade
#' @export
rev.shade <- function (x)
{
    indices <- rev(seq_along(x))
    structure(as.character(x)[indices], space=attr(x,"space"), coords=attr(x,"coords")[indices,,drop=FALSE], alpha=attr(x,"alpha")[indices], names=.names(x)[indices], class="shade")
}

#' @rdname shade
#' @export
"==.shade" <- function (x, y)
{
    y <- rep(warp(y,attr(x,"space")), length.out=length(x))
    xCoords <- coords(x)
    yCoords <- coords(y)
    coordsAgree <- sapply(seq_along(x), function(i) all(xCoords[i,] == yCoords[i,]))
    alphaAgrees <- .alpha(x, allowNull=FALSE) == .alpha(y, allowNull=FALSE)
    return (coordsAgree & alphaAgrees)
}

#' @rdname shade
#' @export
"!=.shade" <- function (x, y)
{
    return (!`==.shade`(x,y))
}

#' @rdname shade
#' @method all.equal shade
#' @exportS3Method all.equal shade
all.equal.shade <- function (target, current, hexonly = FALSE, ...)
{
    if (hexonly)
        all.equal(as.character(target), as.character(current), ...)
    else if (length(target) != length(current))
        paste0("Lengths do not match (", length(target), " and ", length(current), ")")
    else if (!all(.alpha(target,allowNull=FALSE) == .alpha(current,allowNull=FALSE)))
        paste0("Alpha values do not match (mean absolute difference is ", signif(mean(abs(.alpha(target,allowNull=FALSE) - .alpha(current,allowNull=FALSE))),4), ")")
    else
    {
        target <- warp(target, space(current))
        result <- all.equal(coords(target), coords(current), ...)
        if (isTRUE(result))
            return (TRUE)
        else
        {
            distances <- sapply(seq_along(target), function(i) distance(target[i],current[i]))
            paste0("Mean colour distance is ", signif(mean(distances,4)))
        }
    }
}

#' Retrieve the space of a colour vector
#' 
#' This function retrieves the colour space in which its argument is currently
#' defined.
#' 
#' @param x An R object.
#' @param ... Additional arguments to methods.
#' @return A string naming a colour space.
#'
#' @examples
#' space("red")
#' @author Jon Clayden <code@@clayden.org>
#' @export
space <- function (x, ...)
{
    UseMethod("space")
}

#' @export
space.shade <- function (x, ...)
{
    attr(x, "space")
}

#' @export
space.default <- function (x, ...)
{
    space.shade(shade(x, ...))
}

#' Retrieve the coordinates of a colour vector
#' 
#' This function retrieves the coordinates of a colour vector's elements,
#' within whatever space it is currently defined.
#' 
#' @param x An R object.
#' @param ... Additional arguments to methods.
#' @return A matrix giving colour coordinates in the relevant space, one colour
#'   per row. Columns are typically named.
#'
#' @examples
#' coords("red")
#' @author Jon Clayden <code@@clayden.org>
#' @export
coords <- function (x, ...)
{
    UseMethod("coords")
}

#' @export
coords.shade <- function (x, ...)
{
    attr(x, "coords")
}

#' @export
coords.default <- function (x, ...)
{
    coords.shade(shade(x, ...))
}

#' Shift colours between spaces
#' 
#' This function shifts the current colour space of its arguments to the
#' specified space, returning a new object of class \code{"shade"}.
#' 
#' Valid names for spaces are currently those supported by the
#' \code{\link{convertColor}} function, namely "sRGB", "Apple RGB", "CIE
#' RGB", "XYZ", "Lab" and "Luv"; plus "RGB" (which is treated as an
#' alias for "sRGB"), "HSV", "LCh", "LMS" and "Oklab". Case is not significant.
#' 
#' @param x An R object which can be coerced to class \code{"shade"}.
#' @param space A string naming the new space.
#' @return A new object of class \code{"shade"}.
#' 
#' @note LMS space, used for chromatic adaptation and simulating colour
#'   blindness, is not uniquely defined. Here we use the (linearised) Bradford
#'   transform, obtained by Lam (1985) and used widely in ICC colour profiles
#'   and elsewhere, to transform to and from CIE XYZ space.
#'   
#'   R uses the D65 standard illuminant as the reference white for the "Lab"
#'   and "Luv" spaces.
#' 
#' @examples
#' warp("red", "HSV")
#' @references
#' The Oklab colour space is explained at \url{https://bottosson.github.io/posts/oklab/}.
#' 
#' Lam, K.M. (1985). Metamerism and colour constancy. PhD thesis, University of
#' Bradford.
#' @seealso \code{\link{convertColor}}
#' @author Jon Clayden <code@@clayden.org>
#' @export
warp <- function (x, space)
{
    x <- shade(x)
    sourceSpace <- tolower(attr(x, "space"))
    targetSpace <- tolower(space)
    
    if (sourceSpace == targetSpace)
        return (x)
    
    coords <- attr(x, "coords")
    missing <- apply(coords, 1, anyNA)
    if (any(!missing))
        coords[!missing,] <- convertColor(coords[!missing,,drop=FALSE], .converters[[sourceSpace]], .converters[[targetSpace]])
    alpha <- .alpha(x)
    
    return (structure(.toHex(coords,targetSpace,alpha), names=names(x), dim=dim(x), space=space, coords=coords, alpha=alpha, class="shade"))
}
