R/generic_support.r

Defines functions .write.generic .read.generic .rawToCharNull .hiNybble .loNybble .match.multi.factor.inv .match.multi.factor .bitwOrAll .match.factor.inv .match.factor .write.amigaData .read.amigaData print.AmigaTimeVal as.raw.AmigaTimeVal timeval .indexToBitmap .display.properties .amigaViewPortModes .inverseViewPort .is.colour deltaFibonacciDecompress deltaFibonacciCompress dither.matrix dither.raster index.colours rasterToBitmap bitmapToRaster unPackBitmap packBitmap amigaRawToColour colourToAmigaRaw dither

Documented in amigaRawToColour as.raw.AmigaTimeVal bitmapToRaster colourToAmigaRaw deltaFibonacciCompress deltaFibonacciDecompress dither dither.matrix dither.raster index.colours packBitmap rasterToBitmap timeval unPackBitmap

#' @rdname dither
#' @name dither
#' @export
dither <- function(x, method, ...) {
  ## I made this an S3 generic such that I could implement a dither function in the future
  ## for audio waves for downsampling audio...
  UseMethod("dither", x)
}

#' Convert colours to Amiga compatible raw data or vice versa
#'
#' Convert colours to Amiga compatible raw data or vice versa, such that
#' it can be used in graphical objects from the Commodore Amiga.
#'
#' On the original Commodore Amiga chipset, graphics used indexed palettes of
#' 12 bit colours. Colours are specified by their RGB (Red, Green and Blue)
#' values, each component requiring 4 bits (with corresponding values ranging
#' from 0 up to 15). Data structures on the Amiga were WORD (2 bytes) aligned.
#' Colours are therefore typically stored in either 2 bytes (skipping the
#' first four bits) or 3 bytes (one byte for each value).
#' 
#' These functions can be used to convert R colours into the closest matching
#' Amiga colour in a \code{raw} format, or vice versa. Note that later Amiga
#' models with the advanced (graphics) architecture (known as AA or AGA) allowed
#' for 24 bit colours.
#'
#' @param x In the case \code{amigaRawToColour} is called, \code{x} should
#' be a \code{vector} of \code{raw} data. The length of this vector should
#' be a multiple of 2 (when \code{n.bytes = "2"}) or 3 (when
#' \code{n.bytes = "3"}). When \code{colourToAmigaRaw} is called, \code{x}
#' should be a \code{character} strings representing a colour.
#' @param colour.depth A \code{character} string: \code{"12 bit"} (default) or
#' \code{"24 bit"}. The first should be used in most cases, as old Amigas
#' have a 12 bit colour depth.
#' @param n.bytes A \code{character} string: \code{"2"} or \code{"3"}. The
#' number of bytes that is used or should be used to store each colour.
#' @return In the case \code{amigaRawToColour} is called, a (vector of)
#' colour \code{character} string(s) is returned. When \code{colourToAmigaRaw}
#' is called, \code{raw} representing the colour(s) specified in \code{x} is
#' returned.
#' 
#' @rdname colourToAmigaRaw
#' @name colourToAmigaRaw
#' @examples
#' ## Let's create some Amiga palettes:
#' colourToAmigaRaw(c("red", "navy blue", "brown", "#34AC5A"))
#' 
#' ## let's do the reverse.
#' ## this is white:
#' amigaRawToColour(as.raw(c(0x0f, 0xff)))
#' 
#' ## this is white specified in 3 bytes:
#' amigaRawToColour(as.raw(c(0xf0, 0xf0, 0xf0)), n.bytes = "3")
#' 
#' ## lower nybbles are ignored, you will get a warning when it is not zero:
#' amigaRawToColour(as.raw(c(0xf0, 0xf0, 0x0f)), n.bytes = "3")
#' @family raw.operations
#' @author Pepijn de Vries
#' @export
colourToAmigaRaw <- function(x, colour.depth = c("12 bit", "24 bit"), n.bytes = c("2", "3")) {
  colour.depth <- match.arg(colour.depth, c("12 bit", "24 bit"))
  n.bytes <- match.arg(n.bytes, c("2", "3"))
  if (colour.depth == "24 bit" && n.bytes == "2") stop("3 bytes are required to store 24 bit colours!")
  col <- grDevices::col2rgb(x)
  if (colour.depth == "12 bit") {
    col <- floor((col + 4)/16.5)
  }
  if (colour.depth == "24 bit") col <- col/16
  if (n.bytes == "3") {
    as.vector(apply(col, 2, function(y) .amigaIntToRaw(16*y, 8, F)))
  } else {
    as.vector(apply(col, 2, function(y) as.raw(c(y[1], y[2]*16 + y[3]))))
  }
}

#' @rdname colourToAmigaRaw
#' @name amigaRawToColour
#' @export
amigaRawToColour <- function(x, colour.depth = c("12 bit", "24 bit"), n.bytes = c("2", "3")) {
  ## x = raw
  
  colour.depth <- match.arg(colour.depth, c("12 bit", "24 bit"))
  n.bytes <- match.arg(n.bytes, c("2", "3"))
  if (n.bytes == "2" && (length(x) %% 2) != 0) stop("x should be a vector of even length.")
  if (n.bytes == "3" && (length(x) %% 3) != 0) stop("x should be a vector with a multiple length of 3.")
  if (colour.depth == "24 bit" && n.bytes == "2") stop("3 bytes are required to store 24 bit colours!")
  hi <- .hiNybble(x)
  lo <- .loNybble(x)
  if (colour.depth == "24 bit" && n.bytes == "3") {
    sq <- seq(1, to = length(x), by = 3)
    x <- .rawToAmigaInt(x, 8, F)
    return(grDevices::rgb(x[sq]/255, x[sq + 1]/255, x[sq + 2]/255))
  } else if (colour.depth == "12 bit" && n.bytes == "3") {
    sq <- seq(1, to = length(x), by = 3)
    hi <- .hiNybble(x)
    if (any(lo != 0)) warning("The low nybble is not zero for all colours.")
    return(grDevices::rgb(hi[sq]/15, hi[sq + 1]/15, hi[sq + 2]/15))
  } else {
    x <- as.vector(rbind(hi, lo))
    sq <- seq(1, to = length(x), by = 4)
    if (any(x[sq] != 0)) warning("The low nybble is not zero for all colours.")
    x <- x[-sq]
    sq <- seq(1, to = length(x), by = 3)
    return(grDevices::rgb(x[sq]/15, x[sq + 1]/15, x[sq + 2]/15))
  }
}

#' A routine to (un)pack bitmap data
#'
#' A very simplistic lossless routine to (un)pack repetitive bitmap data. Often
#' used in InterLeaved BitMap (ILBM) images in IFF containers (\code{\link{IFFChunk}}).
#'
#' InterLeaved BitMap (ILBM) images on the Amiga often use a packing algorithm
#' referred to as `ByteRun1'. This routine was introduced first on
#' the Macintosh where it was called PackBits. It is a form of run-length encoding
#' and is very simple:
#' when a specific byte is repeated in a bitmap, it is replaced by
#' a (signed negative) byte telling how many times the following byte
#' should be repeated. When a series of bytes are not repetitive, it
#' is preceded by a (signed positive) byte telling how long the non
#' repetitive part is.
#' 
#' Not very complicated, but for most images some bytes can be shaved
#' off the file. This was very useful when everything had to be stored
#' on 880 kilobyte floppy disks with little CPU time to spare. Note
#' that the file size can also increase for (noisy) images.
#' 
#' This packing routine will pack the entire bitmap (\code{x})
#' at once. The IFF file format requires packing of bitmap data per
#' scanline. This is done automatically by the \code{\link{rasterToIFF}}
#' function, which calls this packing routine per scanline.
#'
#' @param x \code{raw} data, usually representing a (packed) bitmap.
#' @return Returns packed or unpacked \code{raw} data, depending on
#' whether \code{packBitmap} or \code{unPackBitmap} was called.
#' 
#' @rdname packBitmap
#' @name packBitmap
#' @examples
#' ## generate some random raw data:
#' dat.rnd <- as.raw(sample.int(10, 100, TRUE))
#' 
#' ## try to pack it:
#' pack.rnd <- packBitmap(dat.rnd)
#' 
#' ## due to the random nature of the source data
#' ## the data could not be packed efficiently.
#' ## The length of the packed data is close to
#' ## the length of the original data:
#' length(pack.rnd) - length(dat.rnd)
#' 
#' ## Now generate similar data but sort it
#' ## to generate more repetitive data:
#' dat.srt  <- as.raw(sort(sample.int(10, 100, TRUE)))
#' pack.srt <- packBitmap(dat.srt)
#' 
#' ## This time the packing routing is more successful:
#' length(pack.srt) - length(dat.srt)
#' 
#' ## The original data can always be obtained
#' ## from the packed data:
#' all(dat.rnd == unPackBitmap(pack.rnd))
#' all(dat.srt == unPackBitmap(pack.srt))
#' @references \url{http://amigadev.elowar.com/read/ADCD_2.1/Devices_Manual_guide/node01C0.html}
#' @references \url{https://en.wikipedia.org/wiki/PackBits}
#' @family raw.operations
#' @author Pepijn de Vries
#' @export
packBitmap <- function(x) {
  if (typeof(x) != "raw") stop("Argument 'x' should be raw data")
  n <- length(x)
  y <- x[-1L] != x[-length(x)]
  i <- c(which(y | is.na(y)), n)
  l <- diff(c(0L, i))
  while (any(l > 128)) {
    i <- sort(c(i, i[l > 128] - l[l > 128] + 128))
    l <- diff(c(0L, i))
  }
  ## Skip double repeats, as there is a large overhead from the packing byte:
  sel <- l > 1 & l < 4
  i <- c(i, rep(i[sel], l[sel] - 1))
  l <- c(l, rep(1, length(i) - length(l)))
  l[l > 1 & l < 4] <- 1
  l <- l[order(i)]
  i <- i[order(i)]
  while (any(duplicated(i))) {
    i[duplicated(i, fromLast = T)] <- i[duplicated(i, fromLast = T)] - 1
  }
  ## End skipping double repeats
  one.series.start <- which(diff(c(F, l == 1, F)) == 1)
  one.series.end <- which(diff(c(F, l == 1, F)) == -1) - 1
  if (length(one.series.start) != length(one.series.end)) stop("Unexpected error in packing the bitmap. Please report this error to the package author.")
  one.series <- mapply(function(start, end) {
    list(x[i[start[[1]]]:i[end[[1]]]])
  }, start = one.series.start,
  end   = one.series.end)
  one.series <- lapply(one.series, function(y) {
    yl <- length(y)
    result <- NULL
    while (yl > 128) {
      result <- c(result, .amigaIntToRaw(127, 8, T), y[1:128])
      yl <- yl - 128
      y <- y[-1:-128]
    }
    return(c(result, .amigaIntToRaw(yl - 1, 8, T), y))
  })
  result <- rep(list(raw(0)), length(l))
  result[one.series.start] <- one.series
  more.series <- mapply(function(y, dat, rep) {
    list(c(.amigaIntToRaw(-rep + 1, 8, T), dat))
  }, dat = x[i[l > 1]], rep = l[l > 1])
  result[l > 1] <- more.series
  result <- unlist(result)
  return (result)
}

#' @rdname packBitmap
#' @name unPackBitmap
#' @export
unPackBitmap <- function(x) {
  if (typeof(x) != "raw") stop("Argument 'x' should be raw data")
  ## Very simple packing routine for bitmap images
  ## TODO this routine is very slow due to the while loop. See if this routine can be implemented more efficiently
  result <- raw(0)
  offset <- 0
  while (offset < length(x)) {
    n <- .rawToAmigaInt(x[offset + 1], 8, T)
    if (n == -128) {
      offset <- offset + 1
    } else if (n < 0) {
      result <- c(result, rep(x[offset + 2], -n + 1))
      offset <- offset + 2
    } else {
      result <- c(result, x[offset + 2:(n + 2)])
      offset <- offset + 2 + n
    }
  }
  return(result)
}

#' Convert an Amiga bitmap image into a raster
#'
#' Amiga images are usually stored as bitmap images with indexed colours. This
#' function converts raw Amiga bitmap data into raster data
#' (\code{\link[grDevices]{as.raster}}).
#'
#' Bitmap images stored as raw data, representing palette index colours, can
#' be converted into raster data (\code{\link[grDevices]{as.raster}}). The latter
#' data can easily be plotted in R. It is usually not necessary to call this function
#' directly, as there are several more convenient wrappers for this function. Those
#' wrappers can convert specific file formats (such as IFF ILBM and Hardware Sprites,
#' see \code{\link[AmigaFFH]{as.raster}}) into raster objects. This function is
#' provided for completeness sake (or for when you want to search for images in an
#' amiga memory dump).
#'
#' @param x a \code{vector} of \code{raw} values, representing bitmap data.
#' @param w Width in pixels of the bitmap image. Can be any positive value. However,
#' bitmap data is `word' aligned on the amiga. This means that the width of the stored
#' bitmap data is a multiple of 16 pixels. The image is cropped to the width specified here.
#' @param h Height in pixels of the bitmap image.
#' @param depth The colour depth of the bitmap image (i.e., the number of bit planes).
#' The image will be composed of \code{2^depth} indexed colours.
#' @param palette A \code{vector} of \code{2^depth} colours, to be used for the indexed
#' colours of the bitmap image. By default, a grayscale palette is used.
#' When explicitly set to \code{NULL}, this function returns a matrix with palette index
#' values.
#' @param interleaved A \code{logical} value, indicating whether the bitmap is interleaved.
#' An interleaved bitmap image stores each consecutive bitmap layer per horizontal scanline.
#' @return Returns a raster object (\code{\link{as.raster}}) as specified in
#' the \code{\link{grDevices}} package. Unless, \code{palette} is set to \code{NULL},
#' in which case a \code{matrix} with \code{numeric} palette index values is returned.
#' 
#' @rdname bitmapToRaster
#' @name bitmapToRaster
#' @examples
#' \dontrun{
#' ## first load an example image:
#' example.iff <- read.iff(system.file("ilbm8lores.iff", package = "AmigaFFH"))
#' 
#' ## get the raw bitmap data, which is nested in the InterLeaved BitMap (ILBM)
#' ## IFF chunk as the BODY:
#' bitmap.data <- interpretIFFChunk(getIFFChunk(example.iff, c("ILBM", "BODY")))
#' 
#' ## In order to translate the bitmap data into a raster object we need
#' ## to know the image dimensions (width, height and colour depth). This
#' ## information can be obtained from the bitmap header (BMHD):
#' 
#' bitmap.header <- interpretIFFChunk(getIFFChunk(example.iff, c("ILBM", "BMHD")))
#' 
#' ## First the bitmap data needs to be unpacked as it was stored in a compresssed
#' ## form in the IFF file (see bitmap.header$Compression):
#' 
#' bitmap.data <- unPackBitmap(bitmap.data)
#' 
#' ## It would also be nice to use the correct colour palette. This can be obtained
#' ## from the CMAP chunk in the IFF file:
#' 
#' bitmap.palette <- interpretIFFChunk(getIFFChunk(example.iff, c("ILBM", "CMAP")))
#' 
#' example.raster <- bitmapToRaster(bitmap.data,
#'                                  bitmap.header$w,
#'                                  bitmap.header$h,
#'                                  bitmap.header$nPlanes,
#'                                  bitmap.palette)
#' 
#' ## We now have a raster object that can be plotted:
#' 
#' plot(example.raster, interpolate = FALSE)
#' }
#' @family raster.operations
#' @author Pepijn de Vries
#' @export
bitmapToRaster <- function(x, w, h, depth, palette = grDevices::gray(seq(0, 1, length.out = 2^depth)), interleaved = T) {
  if (!is.raw(x)) stop("x should be a vector of raw values.")
  w <- round(w)
  h <- round(h)
  if (w < 1 || h < 1) stop("Width and heigth should both be at least 1 pixel.")
  if (depth != round(depth) || depth < 1) stop("Depth should be a whole positive number.")
  if (!is.null(palette) && any(!.is.colour(palette))) stop("Palette should be composed of colours only.")
  if (!is.null(palette) && length(palette) != (2^depth)) stop("Palette should have a length of 2^depth.")
  if (length(interleaved) > 1) warning("More than 1 interleave value is given, only the first element of the vector is used.")
  interleaved <- as.logical(interleaved[[1]])
  ## invert bytes and longs is opposite to the defaults in adfExplorer.
  ## Does the user need to be able to change these values for bitmap images?
  x <- .rawToBitmap(x, invert.bytes = T, invert.longs = F)
  if (interleaved) {
    x <- array(x, c(16*ceiling(w/16), depth, h))
    x <- apply(x, c(1, 3), function(y) {
      sum(2^(0:(length(y) - 1)) * as.numeric(y))
    })
  } else {
    x <- array(x, c(16*ceiling(w/16), h, depth))
    x <- apply(x, c(1, 2), function(y) {
      sum(2^(0:(length(y) - 1)) * as.numeric(y))
    })
  }
  if (is.null(palette)) {
    x <- matrix(x, ncol = h, byrow = F)
    x <- t(x)[, 1:w, drop = F]
    return(x)
  } else {
    x <- matrix(palette[x + 1], ncol = h, byrow = F)
    x <- t(x)[, 1:w, drop = F]
    return(grDevices::as.raster(x))
  }
}

#' Convert a grDevices \code{raster} object into binary bitmap data
#'
#' Converts an image represented by a grDevices \code{raster} object into binary
#' (Amiga) bitmap data.
#'
#' Images represented by grDevices \code{raster} objects are virtually true colour (24 bit
#' colour depth) and an alpha layer (transparency). On the early Amiga's the chipset
#' (in combination with memory restrictions) only allowed images with indexed
#' palettes. The colour depth was 12 bit with the original chipset and the number
#' of colours allowed in a palette also depended on the chipset. This function
#' will allow you to convert a \code{raster} object into binary bitmap data with
#' an indexed palette. This means that the image is converted in a lossy way
#' (information will be lost). So don't expect the result to have the same quality as
#' the original image.
#'
#' With the \code{depth} argument, the raster can also be converted
#' to special mode bitmap images. One of these modes is the
#' \sQuote{hold and modify} (HAM). In this mode two of the bitplanes
#' are reserved as modifier switches. If the this switch equals
#' zero, the remainder of the bitplanes are used as an index for
#' colours in a fixed palette. If the switch equals 1, 2 or 3, the
#' red, green or blue component of the previous is modified, using the
#' number in the remainder of the bitplanes. So it holds the previous
#' colour but modifies one of the colour components (hence the term
#' \sQuote{hold and modify}.) Here only the HAM6 and
#' the HAM8 mode are implemented. HAM6 uses 6 bitplanes and a 12 bit
#' colour depth, HAM8 uses 8 bitplanes and a 24 bit colour depth.
#' 
#' The HAM mode was a special video modes supported by Amiga hardware.
#' Normal mode bitmap images with a 6 bit depth would allow for a
#' palette of 64 (2^6) colours, HAM6 can display 4096 colours with
#' the same bit depth.
#' 
#' In addition to HAM6 and HAM8, sliced HAM (or SHAM) was another
#' HAM variant. Using the coprocessor on the Amiga, it was possible
#' to change the palette at specific scanlines, increasing the number
#' of available colours even further. The SHAM mode is currently not
#' supported by this package.
#' @param x A raster object created with \code{\link[grDevices]{as.raster}} which
#' needs to be converted into bitmap data. It is also possible to let \code{x} be
#' a matrix of \code{character}s, representing colours.
#' @param depth The colour depth of the bitmap image. The image will be composed
#' of \code{2^depth} indexed colours.
#' 
#' \code{depth} can also be a \code{character} string "HAM6" or "HAM8"
#' representing special Amiga display modes (see details).
#' @param interleaved A \code{logical} value, indicating whether the bitmap needs to be
#' interleaved. An interleaved bitmap image stores each consecutive bitmap layer per
#' horizontal scanline.
#' @param indexing A function that accepts two arguments: \code{x} (a grDevices
#' \code{raster} object); \code{length.out}, a numeric value indicating the
#' desired size of the palette (i.e., the number of colours). It should return
#' a matrix with numeric palette indices (ranging from 1 up to the number of
#' colours in the palette). The result should have an attribute named `palette' that
#' contains the colours that correspond with the index numbers. The result should
#' also carry an attribute with the name `transparent', with a single numeric value
#' representing which colour in the palette should be treated as transparent (or
#' \code{NA} when no transparency is required). By default the
#' function \code{\link{index.colours}} is used. You are free to provide
#' a customised version of this function (see examples).
#' @return The bitmap is returned as a \code{vector} of \code{logical} values.
#' The \code{logical} values reflect the bits for each bitplane. The palette used
#' for the bitmap is returned as attribute to the \code{vector}. There will also be
#' an attribute called `transparent'. This will hold a numeric index corresponding
#' with the colour in the palette that will be treated as transparent. It will be
#' \code{NA} when transparency is not used.
#' 
#' @rdname rasterToBitmap
#' @name rasterToBitmap
#' @examples
#' \dontrun{
#' ## first: Let's make a raster out of the 'volcano' data, which we can use in the example:
#' volcano.raster <- as.raster(t(matrix(terrain.colors(1 + diff(range(volcano)))[volcano -
#'   min(volcano) + 1], nrow(volcano))))
#' 
#' ## convert the raster into binary (logical) bitmap data:
#' volcano.bm <- rasterToBitmap(volcano.raster)
#' 
#' ## The palette for the indexed colours of the generated bitmap is returned as
#' ## attribute. There is no transparency is the image:
#' attributes(volcano.bm)
#' 
#' ## We can also include a custom function for colour quantisation. Let's include
#' ## some dithering:
#' volcano.dither <- rasterToBitmap(volcano.raster,
#'                                  indexing = function(x, length.out) {
#'                                    index.colours(x, length.out,
#'                                                  dither = "floyd-steinberg")
#'                                  })
#'
#' ## You can also use a custom indexing function to force a specified palette,
#' ## in this case black and white:
#' volcano.bw <- rasterToBitmap(volcano.raster,
#'                              indexing = function(x, length.out) {
#'                                index.colours(x, length.out,
#'                                              palette = c("black", "white"),
#'                                              dither = "floyd-steinberg")
#'                              })
#' 
#' ## Make a bitmap using a special display mode (HAM6):
#' volcano.HAM <- rasterToBitmap(volcano.raster, "HAM6")
#' }
#' @family raster.operations
#' @author Pepijn de Vries
#' @export
rasterToBitmap <- function(x, depth = 3, interleaved = T, indexing = index.colours) {
  special.mode <- "none"
  if (depth %in% c("HAM6", "HAM8")) {
    special.mode <- depth
    depth <- ifelse(depth == "HAM6", 6, 8)
  }
  depth <- round(depth[[1]])
  if (depth < 1) stop("Bitmap depth should be at least 1.")
  interleaved <- interleaved[[1]]
  if (!is.logical(interleaved)) stop("Interleaved should be a logical value.")
  if (class(indexing) != "function") stop("'indexing' should be a function")
  if (!all(c("x", "length.out") %in% names(formals(indexing)))) stop("Function 'indexing' should require arguments 'x' and 'length.out'.")
  x <- as.matrix(x)
  x <- indexing(x = x, length.out = ifelse(special.mode %in% c("HAM6", "HAM8"),
                                           special.mode,
                                           2^depth))
  palette <- attributes(x)$palette
  transparent <- attributes(x)$transparent
  x <- .indexToBitmap(x, depth, interleaved)
  attributes(x) <- list(palette = palette, transparent = transparent)
  return (x)
}

#' Quantisation of colours and indexing a grDevices raster image
#'
#' Converts an image represented by a grDevices \code{raster} object into a
#' matrix containing numeric indices of a quantised colour palette.
#'
#' Determines the optimal limited palette by clustering colours in an image
#' with \code{\link[stats]{kmeans}}. The result of the optimisation routine
#' will depend on the randomly chosen cluster centres by this algorithm. This
#' means that the result may slightly differ for each call to this function. If
#' you want reproducible results, you may want to reset the random seed
#' (\code{\link{set.seed}}) before each call to this function.
#' 
#' @param x A raster object (\code{\link[grDevices]{as.raster}}), or a \code{matrix}
#' containing \code{character} strings representing colours. \code{x} can also
#' be a \code{list} of such matrices or rasters. All elements of this list should
#' have identical dimensions. An overall palette will be generated for elements in the
#' list.
#' @param length.out A \code{numeric} value indicating the number of desired
#' colours in the indexed palette.
#' 
#' It can also be a \code{character} string indicating which special
#' Amiga display mode should be used when indexing colours.
#' \sQuote{\code{HAM6}} and \sQuote{\code{HAM8}} are supported.
#' See \code{\link{rasterToBitmap}} for more details on these
#' special modes.
#' @param palette A vector of no more than \code{length.out} colours, to be used
#' for the bitmap image. When missing or set to \code{NULL}, a palette will be
#' generated based on the provided colours in raster \code{x}. In that case,
#' \code{\link[stats]{kmeans}} is used on the hue, saturation, brightness and
#' alpha values of the colours in \code{x} for clustering the colours. The cluster
#' centres will be used as palette colours.
#' @param background On the Amiga, indexed images could not be semi-transparent.
#' Only a single colour could be designated as being fully transparent. The
#' `\code{background}' argument should contain a background colour with which
#' semi-transparent colours should be mixed, before colour quantisation. It is
#' white by default.
#' @param dither Dither the output image using the algorithm specified here.
#' See the usage section for possible options. By default no dithering ("\code{none}")
#' is applied. See \code{\link{dither}} for more details.
#' @param colour.depth A \code{character} string indicating the colour depth to be used.
#' Can be either "\code{12 bit}" (default, standard on an Amiga with original chipset),
#' or "\code{24 bit}".
#' 
#' This argument is overruled when \code{length.out} is set to \dQuote{\code{HAM6}}
#' or \dQuote{\code{HAM8}}. In that case the colour depth linked to that special mode
#' is used (12 bit for HAM6, 24 bit for HAM8).
#' @param ... Arguments that are passed onto \code{\link[stats]{kmeans}} (see
#' \code{palette} argument).
#' @return Returns a \code{matrix} with the same dimensions as \code{x} containing
#' \code{numeric} index values. The corresponding palette is returned as attribute,
#' as well as the index value for the fully transparent colour in the palette.
#' When \code{x} is a \code{list} a \code{list} of matrices is returned.
#' 
#' @rdname index.colours
#' @name index.colours
#' @examples
#' \dontrun{
#' ## first: Let's make a raster out of the 'volcano' data, which we can use in the example:
#' volcano.raster <- as.raster(t(matrix(terrain.colors(1 + diff(range(volcano)))[volcano -
#'   min(volcano) + 1], nrow(volcano))))
#'
#' ## This will create an image of the original raster using an indexed palette:
#' volcano.index <- index.colours(volcano.raster)
#' 
#' ## The index values can be converted back into colours, using the palette:
#' volcano.index <- as.raster(apply(volcano.index, 2,
#'                                  function(x) attributes(volcano.index)$palette[x]))
#' 
#' ## Create an indexed image using dithering
#' volcano.dith <- index.colours(volcano.raster, dither = "floyd-steinberg")
#' volcano.dith <- as.raster(apply(volcano.dith, 2,
#'                                 function(x) attributes(volcano.dith)$palette[x]))
#' 
#' ## plot the images side by side for comparison
#' par(mfcol = c(1, 3))
#' plot(volcano.raster, interpolate = F)
#' plot(volcano.index, interpolate = F)
#' plot(volcano.dith, interpolate = F)
#' }
#' @family colour.quantisation.operations
#' @family raster.operations
#' @author Pepijn de Vries
#' @export
index.colours <- function(x, length.out = 8, palette = NULL, background = "#FFFFFF",
                          dither = c("none", "floyd-steinberg", "JJN", "stucki", "atkinson", "burkse", "sierra", "two-row-sierra", "sierra-lite"),
                          colour.depth = c("12 bit", "24 bit"), ...) {
  special.mode <- "none"
  x.is.list <- is.list(x)
  list.length <- 1
  if (x.is.list) list.length <- length(x)
  if (x.is.list) x <- lapply(x, as.matrix) else x <- as.matrix(x)
  if (!all(.is.colour(c(unlist(x))))) stop("x should be a matrix of colours or a grDevices raster object.")
  if (length.out %in% c("HAM6", "HAM8")) {
    special.mode <- length.out
    length.out <- ifelse(length.out == "HAM6", 16, 64)
    ## overrule the colour.depth argument when HAM6 or HAM8
    colour.depth <- ifelse(special.mode == "HAM6", "12 bit", "24 bit")
  } else {
    length.out <- round(length.out[[1]])
    if (length.out < 2) stop("length.out should be 2 or more.")
  }
  if (!is.null(palette) && !all(.is.colour(palette))) stop("palette should consist of colours.")
  if (!is.null(palette) && length(palette) < 2) stop("palette should consist of at least 2 colours.")
  background <- background[[1]]
  if (!.is.colour(background)) stop("background is not a valid colour.")
  
  colour.depth <- match.arg(colour.depth)
  if (colour.depth != "12 bit" && special.mode == "HAM6") stop("HAM6 required 12 bit colour depth")
  if (colour.depth != "24 bit" && special.mode == "HAM8") stop("HAM8 required 24 bit colour depth")
  dither <- match.arg(dither)

  background <- grDevices::col2rgb(background)

  if (x.is.list) {
    c.dim <- do.call(rbind, lapply(x, dim))
    if (any(!apply(c.dim, 2, function(y) all(y == y[[1]]))))
      stop("The dimensions of all elements in x should be equal")
    c.dim <- c.dim[1,]
    x <- unlist(x)
  } else {
    c.dim <- dim(x)
  }

  col.vals <- grDevices::col2rgb(x, T)
  if (special.mode %in% c("HAM6", "HAM8")) col.vals.rgb <- col.vals
  alpha <- col.vals[4,]
  col.vals <- col.vals[-4,]
  col.vals <- (col.vals*rbind(alpha, alpha, alpha) +
                 rep(background, ncol(col.vals))*(255 - rbind(alpha, alpha, alpha)))/255
  col.vals <- grDevices::rgb2hsv(col.vals)
  col.vals[,alpha == 0] <- grDevices::rgb2hsv(background)
  alpha[alpha > 0] <- 255
  x <- apply(rbind(col.vals, alpha/255), 2,
             function(y) grDevices::hsv(y[1], y[2], y[3], y[4]))

  x <- array(x, c(c.dim, list.length))
  x <- lapply(1:list.length, function(y) as.raster(x[,,y]))
  col.vals <- rbind(col.vals, 1 - as.numeric(alpha == 0))
  current.unique.length <- length(unique(c(unlist(x))))
  current.total.length <- length(unlist(x))
  result <- NULL
  transparent <- NA
  if (is.null(palette)) {
    if (current.total.length <= length.out || current.unique.length < length.out) {
      palette <- rep("#000000", length.out)
      palette[1:current.unique.length] <- unique(c(unlist(x)))
      transparent <- which(substr(palette, 8, 9) == "00")[1]
      result <- lapply(x, function(y) apply(y, 2, match, table = palette))
    } else {
      if (special.mode %in% c("HAM6", "HAM8")) {
        col.diff <- array(col.vals.rgb[-4,], c(3, c.dim, list.length))
        col.diff <- c(apply(col.diff, 4, function(z) {
          z <- (z[,,-1] - z[,,-dim(z)[3]])^2
          z <- apply(z, c(2, 3), function(z2) {
            z2[which(z2 == max(z2))[[1]]] <- 0
            prod(1 + z2)/(256*256)
          })
          z <- cbind(rep(0, nrow(z)), z)
          z
        }))
        ## include information on where the image changes a lot in R, G and B value
        col.vals <- rbind(col.vals, col.diff)
        palette <- stats::kmeans(as.matrix(t(col.vals)), length.out, ...)
      } else {
        palette <- stats::kmeans(as.matrix(t(col.vals)), length.out, ...)
        result <- palette$cluster
        result <- array(palette$cluster, c(c.dim, list.length))
        result <- lapply(1:list.length, function(y) result[,,y])
      }
      transparent <- which(palette$centers[,4] == 0)[1]
      palette <- apply(palette$centers, 1, function(x) grDevices::hsv(x[1], x[2], x[3], x[4]))
    }
    # sort colours such that the most frequently occuring colours are listed first
    freqs   <- table(factor(unlist(result), as.character(1:length.out)))
    ord     <- order(-freqs)
    rnk     <- rank(-freqs, ties.method = "first")
    palette <- as.vector(palette[ord])
    transparent <- as.vector(rnk[transparent])
    if (!is.null(result)) {
      result <- lapply(result, function(y) as.vector(rnk)[y])
      result <- lapply(result, matrix, nrow = c.dim)
    }
  } else {
    palette <- grDevices::col2rgb(palette, T)
    transparent <- which(palette[4,] == 0)[1]
    palette[4,palette[4,] > 0] <- 255
    palette <- grDevices::rgb(palette[1,], palette[2,], palette[3,], palette[4,], maxColorValue = 255)
    result <- lapply(x, function(y) apply(y, 2, match, table = palette))
  }

  if (dither != "none" || special.mode %in% c("HAM6", "HAM8")) { ## dithering should also be called in case of HAM modes
    if (x.is.list) {
      result <- lapply(x, function(y) dither(y, method = dither, palette = palette, mode = special.mode))
    } else {
      result <- dither(x[[1]], method = dither, palette = palette, mode = special.mode)
    }
  } else if (!x.is.list) {
    result <- result[[1]]
  }
  palette <- suppressWarnings(amigaRawToColour(colourToAmigaRaw(palette, "24 bit", "3"), colour.depth, "3"))
  attributes(result)[["palette"]] <- as.vector(palette)
  attributes(result)[["transparent"]] <- transparent
  return(result)
}

#' Image dithering
#'
#' Dither is an intentional form of noise applied to an image to avoid colour
#' banding when reducing the amount of colours in that image. This function
#' applies dithering to a grDevices \code{raster} image.
#'
#' The approaches implemented here all use error diffusion to achieve dithering.
#' Each pixel is scanned (from top to bottom, from left to right), where the actual
#' colour is sampled and compared with the closest matching colour in the palette.
#' The error (the differences between the actual and used colour) is distributed over
#' the surrounding pixels. The only difference between the methods implemented here
#' is the way the error is distributed. The algorithm itself is identical. For more
#' details consult the listed references.
#'
#' Which method results in the best quality image will depend on the original image
#' and the palette colours used for dithering, but is also a matter of taste. Note
#' that the dithering algorithm is relatively slow and is provided in this package
#' for your convenience. As it is not in the main scope of this package you should
#' use dedicated software for faster/better results.
#' @param x Original image data that needs to be dithered. Should be a raster object
#' (\code{\link[grDevices]{as.raster}}), or a matrix of \code{character} string
#' representing colours.
#' @param method A \code{character} string indicating which dithering method should
#' be applied. See usage section for all possible options (Note that the "JJN" is
#' the Jarvis, Judice, and Ninke algorithm). Default is "\code{none}", meaning that
#' no dithering is applied.
#' @param palette A palette to which the image should be dithered. It should be a
#' \code{vector} of \code{character} strings representing colours.
#' @param mode A \code{character} string indicating whether a special
#' Amiga display mode should be used when dithering. By default
#' \sQuote{\code{none}} is used (no special mode). In addition,
#' \sQuote{\code{HAM6}} and \sQuote{\code{HAM8}} are supported.
#' See \code{\link{rasterToBitmap}} for more details.
#' @param ... Currently ignored.
#' @return Returns a \code{matrix} with the same dimensions as \code{x} containing
#' \code{numeric} index values. The corresponding palette is returned as attribute,
#' as well as the index value for the fully transparent colour in the palette.
#' 
#' @rdname dither
#' @name dither
#' @aliases dither.raster
#' @examples
#' \dontrun{
#' ## first: Let's make a raster out of the 'volcano' data, which we can use in the example:
#' volcano.raster <- as.raster(t(matrix(terrain.colors(1 + diff(range(volcano)))[volcano -
#'   min(volcano) + 1], nrow(volcano))))
#'
#' ## let's dither the image, using a predefined two colour palette:
#' volcano.dither <- dither(volcano.raster,
#'                          method = "floyd-steinberg",
#'                          palette = c("yellow", "green"))
#' 
#' ## Convert the indices back into a raster object, such that we can plot it:
#' volcano.dither <- as.raster(apply(volcano.dither, 2, function(x) c("yellow", "green")[x]))
#' par(mfcol = c(1, 2))
#' plot(volcano.raster, interpolate = F)
#' plot(volcano.dither, interpolate = F)
#' 
#' ## results will get better when a better matching colour palette is used.
#' ## for that purpose use the function 'index.colours'.
#' }
#' @references R.W. Floyd, L. Steinberg, \emph{An adaptive algorithm for spatial grey scale}. Proceedings of the Society of Information Display 17, 75-77 (1976).
#' @references J. F. Jarvis, C. N. Judice, and W. H. Ninke, \emph{A survey of techniques for the display of continuous tone pictures on bilevel displays}. Computer Graphics and Image Processing, 5:1:13-40 (1976).
#' @references \url{https://en.wikipedia.org/wiki/Floyd-Steinberg_dithering}
#' @references \url{https://tannerhelland.com/4660/dithering-eleven-algorithms-source-code/}
#' @family colour.quantisation.operations
#' @family raster.operations
#' @author Pepijn de Vries
#' @export
dither.raster <- function(x, method = c("none", "floyd-steinberg", "JJN", "stucki", "atkinson", "burkse", "sierra", "two-row-sierra", "sierra-lite"), palette, mode = c("none", "HAM6", "HAM8"), ...) {
  mode <- match.arg(mode)
  if (!all(.is.colour(c(x)))) stop("x should be a matrix of colours or a grDevices raster object.")
  if (!is.null(palette) && !all(.is.colour(palette))) stop("palette should consist of colours.")
  if (!is.null(palette) && length(palette) < 2) stop("palette should consist of at least 2 colours.")

  x <- matrix(x, nrow = dim(x))
  method <- match.arg(method)
  c.dim <- dim(x)
  
  ## create an array with width, height, r, g, b and alpha as separate dimensions
  x <- grDevices::col2rgb(x, T)
  x <- lapply(split(x, row(x)), matrix, nrow = c.dim)
  x <- array(c(x[[1]], x[[2]], x[[3]], x[[4]]), dim = c(rev(c.dim), 4))
  
  pal.rgb <- col2rgb(palette, T)

  result <- matrix(rep(NA, prod(c.dim)), nrow = c.dim)
  if (method == "floyd-steinberg") {
    e2 <- matrix(c(0, 3, -16, 5, 7, 1), nrow = c(2, 3))/16
    ir2 <- 0:1
    jr2 <- -1:1
  } else if (method == "JJN") {
    e2 <- matrix(c(0, 3, 1, 0, 5, 3, -48, 7, 5, 7, 5, 3, 5, 3, 1), nrow = c(3, 5))/48
    ir2 <- 0:2
    jr2 <- -2:2
  } else if (method == "stucki") {
    e2 <- matrix(c(0, 2, 1, 0, 4, 2, -42, 8, 4, 8, 4, 2, 4, 2, 1), nrow = c(3, 5))/42
    ir2 <- 0:2
    jr2 <- -2:2
  } else if (method == "atkinson") {
    e2 <- matrix(c(0, 1, 0, -8, 1, 1, 1, 1, 0, 1, 0, 0), nrow = c(3, 4))/8
    ir2 <- 0:2
    jr2 <- -1:2
  } else if (method == "burkse") {
    e2 <- matrix(c(0, 2, 0, 4, -32, 8, 8, 4, 4, 2), nrow = c(2, 5))/32
    ir2 <- 0:1
    jr2 <- -2:2
  } else if (method == "sierra") {
    e2 <- matrix(c(0, 2, 0, 0, 4, 2, -32, 5, 3, 5, 4, 2, 3, 2, 0), nrow = c(3, 5))/32
    ir2 <- 0:2
    jr2 <- -2:2
  } else if (method == "two-row-sierra") {
    e2 <- matrix(c(0, 1, 0, 2, -16, 3, 4, 2, 3, 1), nrow = c(2, 5))/16
    ir2 <- 0:1
    jr2 <- -2:2
  } else if (method == "sierra-lite") {
    e2 <- matrix(c(0, 1, -4, 1, 2, 0), nrow = c(2, 3))/4
    ir2 <- 0:1
    jr2 <- -1:1
  }
  if (method == "none" & !(mode %in% c("HAM6", "HAM8"))) {
    result <- apply(x, 2, function(a) {
      res <- apply(a, 1, function(b) {
        dst <- sqrt(colSums((pal.rgb - b)^2))
        which(dst == min(dst))[[1]]
      })
      res
    })
    result <- t(result)
  } else {
    color_multi   <- ifelse(mode == "HAM8", 255/63, 17)
    for(j in 1:dim(x)[2]) {
      if (mode %in% c("HAM6", "HAM8")) prev <- c(grDevices::col2rgb(palette[1]))
      for(i in 1:dim(x)[1]) {
        ## find the closest matching colour in the palette compared to the
        ## current pixel. This is the colour where the Euclidean distance
        ## in RGBA space is smallest compared to the actual colour:
        if (mode %in% c("HAM6", "HAM8")) {
          dst <- apply(pal.rgb, 2, function(z) {
            dst <- abs(x[i, j, ] - z)
            sqrt(sum(dst^2))
          })
          dst.diff <- abs(x[i, j, 1:3] - prev)
          control.flag = which(dst.diff == max(dst.diff))[[1]]
          dst.diff[control.flag] <- 0
          dst.diff <- sqrt(sum(dst.diff^2))
          if (all(dst.diff < dst)) {
            idx <- round(x[i,j,][control.flag]/ifelse(mode == "HAM6", 17, (255/63)))
            prev[control.flag] <- color_multi*idx
            control.flag <- c(2, 3, 1)[control.flag]
          } else {
            control.flag <- 0
            ## Possible improvement for future versions:
            ## When multiple colours in the palette match best with the current
            ## pixel, now the first matching colour is selected.
            ## it is better to also look ahead to see if the pixel to the
            ## right matches best with this colour in the palette.
            idx <- which(dst == min(dst))[[1]] - 1
            prev <- c(grDevices::col2rgb(palette[[idx + 1]]))
          }
          result[j, i] <- idx + bitwShiftL(control.flag, ifelse(mode == "HAM6", 4, 6))
        } else {
          dst <- sqrt(colSums((pal.rgb - x[i, j, ])^2))
          result[j, i] <- which(dst == min(dst))[[1]]
        }
        if (method != "none" && !(j == dim(x)[[2]] && i == dim(x)[[1]])) {
          if (mode %in% c("HAM6", "HAM8")) {
            ## seems to create a slight horizontal stripes artifact in HAM modes.
            ## See if this can be avoided
            P            <- c(prev, 255)
          } else {
            P            <- pal.rgb[,result[j, i]]
          }
          
          ## calculate the error (difference) between the actual colour and the colour
          ## from the palette:
          e            <- x[i, j, ] - P
          
          ## get the proper row and column indices for the error distribution matrix.
          ## This is necessary when we are close to the edge of the image:
          sel.i        <- i + ir2
          ir           <- ir2[sel.i %in% 1:dim(x)[1]]
          sel.j        <- j + jr2
          jr           <- jr2[sel.j %in% 1:dim(x)[2]]
          
          ## Distribute the error (e) over the surrounding pixels using the error
          ## distribution matrix (e2) for the selected method:
          repl <- x[i + ir, j + jr, ]
          repl <- repl + (e2 %o% e)[ir - min(ir2) + 1, jr -min(jr2) + 1,]
          ## Put some constrains on the error:
          repl[repl < 0] <- 0
          repl[repl > 255] <- 255
          x[i + ir, j + jr, ] <- repl
        }
      }
    }
    if (mode %in% c("HAM6", "HAM8")) result <- result + 1
  }
  return(result)
}

#' @rdname dither
#' @name dither
#' @aliases dither.matrix
#' @export
dither.matrix <- function(x, method = c("none", "floyd-steinberg", "JJN", "stucki", "atkinson", "burkse", "sierra", "two-row-sierra", "sierra-lite"), palette, mode = c("none", "HAM6", "HAM8"), ...) {
  dither.raster(grDevices::as.raster(x), method, palette, mode, ...)
}

#' (De)compress 8-bit continuous signals.
#'
#' Use a lossy delta-Fibonacci (de)compression to continuous 8-bit signals.
#' This algorithm was used to compress 8-bit audio wave data on the Amiga.
#'
#' This form of compression is lossy, meaning that information and quality will get lost.
#' 8-bit audio is normally stored as an 8-bit signed value representing the amplitude
#' at specific time intervals. The delta-Fibonacci compression instead stores the
#' difference between two time intervals (delta) as a 4-bit index. This index in turn
#' represents a value from the Fibonacci series (hence the algorithm name). The compression
#' stores small delta values accurately, but large delta values less accurately.
#' As each sample is stored as a 4-bit value instead of an 8-bit value, the amount of
#' data is reduced with almost 50\% (the exact compression ratio is (4 + n)/(2n)).
#' 
#' The algorithm was first described by Steve Hayes and was used in 8SVX audio stored in
#' the Interchange File Format (IFF). The quality loss is considerable (especially
#' when the audio contained many large deltas) and was even in
#' the time it was developed (1985) not used much. The function is provided here for
#' the sake of completeness. The implementation here only compresses 8-bit data, as
#' for 16-bit data the quality loss will be more considerable.
#' @param x A \code{vector} of \code{raw} data that needs to be (de)compressed.
#' @param ... Currently ignored.
#' @return Returns a \code{vector} of the resulting (de)compressed \code{raw} data.
#' @rdname deltaFibonacciCompress
#' @name deltaFibonacciCompress
#' @examples
#' \dontrun{
#' ## Let's get an audio wave from the ProTrackR package, which we
#' ## can use in this example:
#' buzz     <- ProTrackR::PTSample(ProTrackR::mod.intro, 1)
#' 
#' ## Let's convert it into raw data, such that we can compress it:
#' buzz.raw <- adfExplorer::amigaIntToRaw(ProTrackR::waveform(buzz) - 128, 8, T)
#' 
#' ## Let's compress it:
#' buzz.compress <- deltaFibonacciCompress(buzz.raw)
#' 
#' ## Look the new data uses less memory:
#' length(buzz.compress)/length(buzz.raw)
#' 
#' ## The compression was lossy, which we can examine by decompressing the
#' ## sample again:
#' buzz.decompress <- deltaFibonacciDecompress(buzz.compress)
#' 
#' ## And turn the raw data into numeric data:
#' buzz.decompress <- adfExplorer::rawToAmigaInt(buzz.decompress, 8, T)
#' 
#' ## Plot the original wave in black, the decompressed wave in blue
#' ## and the error in red (difference between the original and decompressed
#' ## wave). The error is actually very small here.
#' plot(ProTrackR::waveform(buzz) - 128, type = "l")
#' lines(buzz.decompress, col = "blue")
#' buzz.error <- ProTrackR::waveform(buzz) - 128 - buzz.decompress
#' lines(buzz.error, col = "red")
#' 
#' ## this can also be visualised by plotting the orignal wave data against
#' ## the decompressed data (and observe a very good correlation):
#' plot(ProTrackR::waveform(buzz) - 128, buzz.decompress)
#' 
#' ## Let's do the same with a sample of a snare drum, which has larger
#' ## delta values:
#' snare.drum <- ProTrackR::PTSample(ProTrackR::mod.intro, 2)
#' 
#' ## Let's convert it into raw data, such that we can compress it:
#' snare.raw <- adfExplorer::amigaIntToRaw(ProTrackR::waveform(snare.drum) - 128, 8, T)
#' 
#' ## Let's compress it:
#' snare.compress <- deltaFibonacciCompress(snare.raw)
#' 
#' ## Decompress the sample:
#' snare.decompress <- deltaFibonacciDecompress(snare.compress)
#' 
#' ## And turn the raw data into numeric data:
#' snare.decompress <- adfExplorer::rawToAmigaInt(snare.decompress, 8, T)
#' 
#' ## Now if we make the same comparison as before, we note that the
#' ## error in the decompressed wave is much larger than in the previous
#' ## case (red line):
#' plot(ProTrackR::waveform(snare.drum) - 128, type = "l")
#' lines(snare.decompress, col = "blue")
#' snare.error <- ProTrackR::waveform(snare.drum) - 128 - snare.decompress
#' lines(snare.error, col = "red")
#' 
#' ## this can also be visualised by plotting the orignal wave data against
#' ## the decompressed data (and observe a nice but not perfect correlation):
#' plot(ProTrackR::waveform(snare.drum) - 128, snare.decompress)
#' }
#' @references \url{https://en.wikipedia.org/wiki/Delta_encoding}
#' @references \url{http://amigadev.elowar.com/read/ADCD_2.1/Devices_Manual_guide/node02D6.html}
#' @author Pepijn de Vries
#' @export
deltaFibonacciCompress <- function(x, ...) {
  ## Steve Hayes' Fibonacci Delta sound compression technique
  ## algorithm results in slightly different compression than
  ## achieved with Audiomaster IV. But the total error is smaller
  ## in this implementation
  result <- c(raw(1), x[1])
  x <- .rawToAmigaInt(x, 8, T)
  fibonacci <- rev(c(-34,-21,-13,-8,-5,-3,-2,-1,0,1,2,3,5,8,13,21))
  fib.deltas <- rep(NA, length(x))
  new.wave <- fib.deltas
  new.wave[1] <- x[1]
  for (i in 1:length(x)) {
    target.value <- x[i] + 128
    achieved.value <- (c(x[1], new.wave)[i] + fibonacci + 128) %% 256
    value.dif <- target.value - achieved.value
    fib.deltas[i] <- 16 - (which(abs(value.dif) == min(abs(value.dif)))[[1]])
    
    new.wave[i] <- c(x[1], new.wave)[i] + fibonacci[16 - fib.deltas[i]]
  }
  fib.even <- as.raw(fib.deltas)
  fib.odd <- fib.even[seq(1, length(fib.even), by = 2)]
  if (length(fib.even) == 1)
    fib.even <- as.raw(8)
  else
    fib.even <- fib.even[seq(2, length(fib.even), by = 2)]
  if (length(fib.odd) < length(fib.even)) fib.odd <- c(fib.odd, as.raw(8))
  if (length(fib.odd) > length(fib.even)) fib.even <- c(fib.even, as.raw(8))
  result <- c(result,
              .amigaIntToRaw(.rawToAmigaInt(fib.odd)*0x10) | fib.even)
  return(result)
}

#' @rdname deltaFibonacciCompress
#' @name deltaFibonacciDecompress
#' @export
deltaFibonacciDecompress <- function(x, ...) {
  ## from http://amigadev.elowar.com/read/ADCD_2.1/Devices_Manual_guide/node02D6.html
  ## Unpack Fibonacci-delta encoded data from n byte source buffer into
  ## 2*(n-2) byte dest buffer. Source buffer has a pad byte, an 8-bit
  ## initial value, followed by n-2 bytes comprising 2*(n-2) 4-bit
  ## encoded samples.
  ## second byte indicates the base value:
  base.val <- x[2]
  ## first byte is a padding byte; second is already stored; skip them:
  x <- x[-1:-2]
  fibonacci <- c(-34,-21,-13,-8,-5,-3,-2,-1,0,1,2,3,5,8,13,21)
  result <- c(rbind(.hiNybble(x), .loNybble(x)))
  result <- fibonacci[result + 1]
  result <- .rawToAmigaInt(base.val, 8, T) + cumsum(result)
  result <- ((result + 128) %% 256) - 128
  return(.amigaIntToRaw(result, 8, T))
}

.is.colour <- function(x)
{
  unlist(lapply(x, function(y) {
    res <- try(col2rgb(y), silent = TRUE)
    return(!"try-error" %in% class(res))
  }))
}

.inverseViewPort <- function(display.mode, monitor) {
  adm <- AmigaFFH::amiga_display_modes
  camg <- adm$DISPLAY_MODE_ID[adm$DISPLAY_MODE == display.mode][[1]] |
    AmigaFFH::amiga_monitors$CODE[AmigaFFH::amiga_monitors$MONITOR_ID == monitor][[1]]
  new("IFFChunk", chunk.type = "CAMG", chunk.data = list(camg))
}

.amigaViewPortModes <- function(x) {
  MONITOR_ID_MASK <- as.raw(c(0xff, 0xff, 0x10, 0x00))
  UPPER_MASK      <- as.raw(c(0xff, 0xff, 0x00, 0x00))
  EXTENDED_MODE   <- as.raw(c(0x00, 0x00, 0x10, 0x00))
  SPRITES	        <- as.raw(c(0x00, 0x00, 0x40, 0x00))
  GENLOCK_AUDIO   <- as.raw(c(0x00, 0x00, 0x01, 0x00))
  GENLOCK_VIDEO   <- as.raw(c(0x00, 0x00, 0x00, 0x02))
  VP_HIDE         <- as.raw(c(0x00, 0x00, 0x20, 0x00))
  
  # Knock bad bits out of old-style CAMGs modes before checking
  # availability. (some ILBM CAMG's have these bits set in old 1.3 modes,
  # and should not) If not an extended monitor ID, or if marked as
  # extended but missing upper 16 bits, screen out inappropriate bits now.
  ## see: http://amigadev.elowar.com/read/ADCD_2.1/AmigaMail_Vol2_guide/node00FD.html
  
  if (!any(as.logical(x & MONITOR_ID_MASK)) ||
      (any(as.logical(x & EXTENDED_MODE)) && !any(as.logical(x & UPPER_MASK)))) {
    if (any(as.logical(x & (EXTENDED_MODE|SPRITES|GENLOCK_AUDIO|GENLOCK_VIDEO|VP_HIDE)))) {
      warning("CAMG / display mode contains old style bad bits, I will knock them out...")
      x <- x & !(EXTENDED_MODE|SPRITES|GENLOCK_AUDIO|GENLOCK_VIDEO|VP_HIDE)
    }
  }
  
  # Check for bogus CAMG like some brushes have, with junk in
  # upper word and extended bit NOT set not set in lower word.
  if (any(as.logical(x & UPPER_MASK)) && !(any(as.logical(x & EXTENDED_MODE)))) {
    warning("CAMG / display mode contains bogus bits, I will use the simplest display mode possible...")
    x <- as.raw(c(0x00, 0x00, 0x00, 0x00))
  }
  
  monitors <- AmigaFFH::amiga_monitors
  display_modes <- AmigaFFH::amiga_display_modes
  display_modes <- AmigaFFH::amiga_display_modes
  mon <- unlist(lapply(monitors$CODE, function(y) all(y == (x & MONITOR_ID_MASK))))
  mon <- monitors$MONITOR_ID[mon]
  if (length(mon) > 0 && mon %in% c("STANDARD", "DEFAULT_MONITOR_ID", "NTSC_MONITOR_ID", "PAL_MONITOR_ID")) {
    x <- x & !MONITOR_ID_MASK
  }
  disp <- unlist(lapply(display_modes$DISPLAY_MODE_ID, function(y) all(y == x)))
  disp <- display_modes$DISPLAY_MODE[disp]
  
  if (length(mon) > 0 && length(disp) == 0 && mon %in% c("EURO36_MONITOR_ID", "SUPER72_MONITOR_ID")) {
    x <- x & !MONITOR_ID_MASK
    disp <- unlist(lapply(display_modes$DISPLAY_MODE_ID, function(y) all(y == x)))
    disp <- display_modes$DISPLAY_MODE[disp]
  }
  
  return(list(monitor = mon, display.mode = disp))
}

.display.properties <- function(display.mode, monitor) {
  attribs <- list(
    is.lace         = grepl("LACE", display.mode),
    is.super        = grepl("SUPER", display.mode),
    is.hires        = grepl("HIRES", display.mode),
    is.HAM          = grepl("HAM", display.mode),
    is.extralores   = grepl("EXTRALORES", display.mode),
    is.noflicker    = grepl("FF", display.mode),
    is.scan.doubled = grepl("DBL", display.mode),
    is.productivity = grepl("PRODUCT", display.mode),
    is.halfbright   = grepl("HB|HALFBRITE", display.mode)
  )
  
  aspect.x <- ifelse(monitor == "A2024_MONITOR_ID", 14,
                     ifelse(monitor == "SUPER72_MONITOR_ID", 34, 44))
  width <- ifelse(monitor == "A2024_MONITOR_ID", 1024,
                  ifelse(monitor == "SUPER72_MONITOR_ID", 200, 320))
  if (length(attribs$is.extralores) > 0 && attribs$is.extralores) {
    width <- width/2
    aspect.x <- aspect.x*2
  }
  if (length(attribs$is.hires) > 0 && attribs$is.hires) {
    width <- width*2
    aspect.x <- aspect.x/2
  }
  if (length(attribs$is.super) > 0 && attribs$is.super) {
    width <- width*4
    aspect.x <- aspect.x/4
  }
  if (length(attribs$is.productivity) > 0 && attribs$is.productivity) {
    width <- width*2
    aspect.x <- aspect.x/2
  }
  
  height <- ifelse(monitor == "A2024_MONITOR_ID", 800,
                   ifelse(monitor == "SUPER72_MONITOR_ID", 300,
                          ifelse(monitor == "VGA_MONITOR_ID", 480,
                                 ifelse(monitor == "EURO72_MONITOR_ID", 400,
                                        ifelse(grepl("PAL", monitor), 256, 200)))))
  aspect.y <- ifelse(monitor == "A2024_MONITOR_ID", 11,
                     ifelse(monitor == "SUPER72_MONITOR_ID", 40,
                            ifelse(monitor == "VGA_MONITOR_ID", 22,
                                   ifelse(monitor == "EURO72_MONITOR_ID", 22,
                                          ifelse(grepl("NTSC", monitor), 52, 44)))))
  
  if (length(attribs$is.lace) > 0 && attribs$is.lace) {
    height <- height*2
    aspect.y <- aspect.y/2
  }
  if (length(attribs$is.scan.doubled) > 0 && attribs$is.scan.doubled) {
    height <- height*2
    aspect.y <- aspect.y/2
  }
  if (length(attribs$is.no.flicker) > 0 && attribs$is.no.flicker) {
    height <- height/2
    aspect.y <- aspect.y*2
  }
  attribs[["screenwidth"]] <- width
  attribs[["screenheight"]] <- height
  attribs[["aspect.x"]] <- aspect.x
  attribs[["aspect.y"]] <- aspect.y
  return(attribs)
}

.indexToBitmap <- function(x, depth, interleaved) {
  ## x should be a matrix of palette indices
  x <- cbind(x, matrix(1, ncol = -ncol(x)%%16, nrow = nrow(x)))
  x.dim <- dim(x)
  x <- .rawToBitmap(.amigaIntToRaw(c(x) - 1, 32, F), T, F)
  sq <- c(outer(31:(32 - depth), seq(1, length(x), by = 32), "+"))
  x <- as.logical(x[sq])
  rm(sq)
  # dimensions are bitplane, height, width
  x <- array(x, dim = c(depth, x.dim))
  if (interleaved == T) {
    ## rearrange dimensions to height, bitplane, width (non-interleaved.)
    x <- c(aperm(x, c(3, 1, 2)))
  } else {
    ## rearrange dimensions to bitplane, height, width (interleaved.)
    x <- c(aperm(x, c(3, 2, 1)))
  }
}

#' Get an Amiga timeval struct value from raw data
#'
#' Some Amiga applications use a timeval struct (see references) to represent a
#' time span in seconds. This function coerces raw data to such a numeric time span.
#'
#' Timeval is a structure (struct) as specified in device/timer.h on the Amiga (see
#' references). It represents a timespan in seconds. This function retrieves the
#' numeric value from \code{raw} data. Amongst others, the timeval struct was used
#' in the system-configuration file (see \link{SysConfig}) to specify key repeat speed,
#' key repeat delay and mouse double click speed. Use \code{as.raw} for the inverse
#' of this function and get the original raw data.
#' @rdname timeval
#' @name timeval
#' @param x a \code{vector} of \code{raw} data that need to be converted into
#' Amiga timeval structs.
#' @return Returns a \code{numeric} \code{vector} of a timespan in seconds. It is
#' represented as an S3 AmigaTimeVal class.
#' @examples
#' ## First four raw values represent seconds, the latter four microseconds:
#' temp <- timeval(as.raw(c(0, 0, 0, 1, 0, 0, 0, 1)))
#' print(temp)
#' 
#' ## You can use 'as.raw' to get the original raw data again:
#' as.raw(temp)
#' @author Pepijn de Vries
#' @references \url{http://amigadev.elowar.com/read/ADCD_2.1/Includes_and_Autodocs_2._guide/node0053.html}
#' @export
timeval <- function(x) {
  ## get timeval struct from raw data
  if ((length(x) %% 8) != 0) stop("The length of x should be a multiple of 8.")
  if (typeof(x) != "raw") stop("x should be of type 'raw'.")
  x <- matrix(.rawToAmigaInt(x, 32, F), ncol = 2, byrow = T)
  result <- apply(x, 1, function(y) y[[1]] + y[[2]]/1e6)
  class(result) <- "AmigaTimeVal"
  return(result)
}

#' @name as.raw
#' @rdname as.raw
#' @export
as.raw.AmigaTimeVal <- function(x, ...) {
  ## convert a timval (time interval in seconds) to raw timeval struct
  if (class(x) != "AmigaTimeVal") stop("x should be of S3 class AmigaTimeVal.")
  secs   <- floor(x)
  micros <- round((x - secs)*1e6)
  secs[secs >= 2^32] <-  (2^32) - 1
  micros[micros >= 2^32] <-  (2^32) - 1
  .amigaIntToRaw(c(rbind(secs, micros)), 32, F)
}

#' @export
print.AmigaTimeVal <- function(x, ...) {
  invisible(lapply(x, function(y) cat(sprintf("%f [s] Amiga timeval struct\n", y, ...))))
}

.read.amigaData <- function(dat, n.bytes, signed, par.names) {
  ## read numeric and raw data from amiga raw input
  ## dat = vector of raw data
  ## n.bytes = vector of lengths of bytes to be read from input data. Negative values are negated and indicate that raw data should be read as is
  ## signed = vector of logicals. Indicate whether the values read from data are signed (T) or unsigned (F)
  ## par.names = parameter names for the data read from the input data
  n.bytes <- round(n.bytes)
  offset <- 0
  result <- mapply(function(n.b, sgnd) {
    res <- NULL
    if (n.b > 0) {
      res <- .rawToAmigaInt(dat[offset + (1:n.b)], n.b*8, sgnd)
    } else if (n.b < 0){
      n.b <- -n.b
      res <- dat[offset + (1:n.b)]
    }
    offset <<- offset + n.b
    return(res)
  }, n.b = n.bytes, sgnd = signed, SIMPLIFY = F)
  names(result) <- par.names
  result
}

.write.amigaData <- function(lst, n.bytes, signed, par.names) {
  ## inverse function for .read.amigaData
  ## first make sure list is in correct order:
  lst <- lst[par.names]
  if (any(n.bytes > 0)) {
    lst[n.bytes > 0] <- lapply(1:sum(n.bytes > 0), function(y) {
      .amigaIntToRaw(lst[n.bytes > 0][[y]],
                                 8*n.bytes[n.bytes > 0][y],
                                 signed[n.bytes > 0][y])
    })
  }
  lst <- unlist(lst)
  names(lst) <- NULL
  return(lst)
}

.match.factor <- function(lst, element.name, vals, levs) {
  result <- match(lst[[element.name]], vals)
  if (is.na(result)) stop(sprintf("Unknown %s.", element.name))
  result <- factor(levs[result], levs)
  return(result)
}

.match.factor.inv <- function(lst, element.name, vals, levs) {
  result <- vals[which(levs %in% lst[[element.name]])]
  if (length(result) == 0) stop(sprintf("Unknown level for %s.", element.name))
  if (length(result) > 1) stop(sprintf("Only a single value for %s is allowed.", element.name))
  return(result)
}

.bitwOrAll <- function(x) {
  while (length(x) > 1) {
    x <- c(bitwOr(x[1], x[2]), x[-1:-2])
  }
  return(x)
}

.match.multi.factor <- function(lst, element.name, vals, levs) {
  result <- levs[bitwAnd(lst[[element.name]], vals) == vals]
  result <- factor(result, levs)
}

.match.multi.factor.inv <- function(lst, element.name, vals, levs) {
  result <- vals[which(levs %in% lst[[element.name]])]
  while (length(result) > 1) {
    result <- c(bitwOr(result[1], result[2]), result[-1:-2])
  }
  return(result)
}

.loNybble <-
  function(raw_dat)
    ## function that gets the value [0,16] of the 4 low bits of a raw byte
  {
    if (class(raw_dat) != "raw") stop ("Only raw data is accepted as input")
    return(as.integer(raw_dat)%%16)
  }

.hiNybble <-
  function(raw_dat)
    ## function that gets the value [0,16] of the 4 high bits of a raw byte
  {
    if (class(raw_dat) != "raw") stop ("Only raw data is accepted as input")
    return(as.integer(as.integer(raw_dat)/16))
  }

.rawToCharNull <- function(raw_dat) {
  result <- ""
  if (length(raw_dat) < 3) try(result <- (rawToChar(raw_dat)), silent = T) else
  {
    result    <- raw_dat
    runlength <- rle(result)$lengths
    if (length(runlength) > 2)
    {
      rel_range <- (runlength[1] + 1):(length(result) - runlength[length(runlength)])
      if (result[[1]] != raw(1)) rel_range <- 1:rel_range[length(rel_range)]
      if (result[[length(result)]] != raw(1)) rel_range <- rel_range[1]:length(result)
      result[rel_range][result[rel_range] == as.raw(0x00)] <- as.raw(0x20)
      result <- result[result != raw(1)]
    }
    try(result <- rawToChar(result), silent = T)
    if (class(result) == "raw") result <- ""
  }
  return(result)
}

.read.generic <- function(file, disk = NULL) {
  ## If the file size can be determined from 'file', that size
  ## will be read. Other wise, the file will be read in 5 kB chunks.
  size <- 5*1024
  if (!is.null(disk)) {
    if ("adfExplorer" %in% rownames(utils::installed.packages())) {
      dat <- adfExplorer::get.adf.file(disk, file)
      size <- length(dat)
      file <- rawConnection(dat, "rb")
    } else {
      stop("When specifying 'disk', the 'adfExplorer' package needs to be installed.")
    }
  }
  if ("character" %in% class(file)) {
    size <- file.size(file)
    file <- file(file, "rb")
  }
  if ("connection" %in% class(file)) {
    con_info <- summary(file)
    if (con_info$`can read` != "yes" || con_info$text != "binary") stop("file is not a connection from which binary data can be read...")
  }
  result <- NULL
  repeat {
    l1 <- length(result)
    result <- c(result, readBin(file, "raw", size))
    l2 <- length(result)
    if ((l2 - l1) < size) break
  }
  close(file)
  return(result)
}

.write.generic <- function(x, file, disk = NULL, ...) {
  raw.dat <- as.raw(x, ...)
  if (is.null(disk)) {
    if (class(file) == "character") con <- file(file, "wb")
    if ("connection" %in% class(file)) {
      con_info <- summary(con)
      if (con_info$`can write` != "yes" || con_info$text != "binary") stop("file is not a connection to which binary data can be written...")
      con <- file
    }
    writeBin(raw.dat, con, endian = "big")
    if (class(file) == "character") return(close(con))
  } else {
    if ("adfExplorer" %in% rownames(utils::installed.packages())) {
      return(adfExplorer::put.adf.file(disk, raw.dat, file))
    } else {
      stop("When specifying 'disk', the 'adfExplorer' package needs to be installed.")
    }
  }
}

Try the AmigaFFH package in your browser

Any scripts or data that you put into this service are public.

AmigaFFH documentation built on Sept. 5, 2021, 5:22 p.m.