R/generic_support.r

In AmigaFFH: Commodore Amiga File Format Handler

#' @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.
#' @returns 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.
#' @returns 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.
#' @returns 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).
#' @returns 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 (!"function" %in% class(indexing)) 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).
#' @returns 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.
#' @returns 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.
#' @returns 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.
#' @returns 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 (!"AmigaTimeVal" %in% class(x)) 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 (!"raw" %in% class(raw_dat)) 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 (!"raw" %in% class(raw_dat)) 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 ("raw" %in% class(result)) 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 ("character" %in% class(file)) 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 ("character" %in% class(file)) 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.")
    }
  }
}