R/iff.ilbm.r

Defines functions .indexToHAMraster .bitmapToILBM .byteVerticalCompression .byteVerticalDecompression rasterToIFF plot.IFF.ANIM plot.IFF.ILBM as.raster.IFFChunk IFFChunk.IFF.DPAN IFFChunk.IFF.DLTA IFFChunk.IFF.ANHD IFFChunk.IFF.ANIM IFFChunk.IFF.CRNG IFFChunk.IFF.CAMG IFFChunk.IFF.BMHD IFFChunk.IFF.CMAP IFFChunk.IFF.ILBM

Documented in as.raster.IFFChunk IFFChunk.IFF.ANHD IFFChunk.IFF.ANIM IFFChunk.IFF.BMHD IFFChunk.IFF.CAMG IFFChunk.IFF.CMAP IFFChunk.IFF.CRNG IFFChunk.IFF.DLTA IFFChunk.IFF.DPAN IFFChunk.IFF.ILBM plot.IFF.ANIM plot.IFF.ILBM rasterToIFF

#' @rdname IFFChunk
#' @method IFFChunk IFF.ILBM
#' @export
IFFChunk.IFF.ILBM <- function(x, ...) {
  if (inherits(x, "matrix")) stop(paste("This IFF chunk interpretation is probably based on",
                                         "an ANIM DLTA chunk. It can't be converted back into an IFFChunk object."))
  rasterToIFF(x, ...)@chunk.data[[1]]
}

#' @rdname IFFChunk
#' @method IFFChunk IFF.CMAP
#' @export
IFFChunk.IFF.CMAP <- function(x, ...) {
  result <- colourToAmigaRaw(x, n.bytes = "3", ...)
  return(new("IFFChunk", chunk.type = "CMAP", chunk.data = list(result)))
}

#' @rdname IFFChunk
#' @export
IFFChunk.IFF.BMHD <- function(x, ...) {
  compr <- which(c("cmpNone", "cmpByteRun1") == x$Compression) - 1
  ## if the compression type is unknown, set to 0
  if (length(compr) == 0) compr <- 0
  mask <- which(c("mskNone", "mskHasMask", "mskHasTransparentColour", "mskLasso") == x$Masking) - 1
  ## if the masking type is unknown, set to 0
  if (length(mask) == 0) mask <- 0
  result <- c(.amigaIntToRaw(c(x$w, x$h), 16, F),
              .amigaIntToRaw(c(x$x, x$y), 16, T),
              .amigaIntToRaw(c(x$nPlanes, mask, compr), 8, F),
              as.raw(x$pad)[[1]],
              .amigaIntToRaw(x$transparentColour, 16, F),
              .amigaIntToRaw(c(x$xAspect, x$yAspect), 8, F),
              .amigaIntToRaw(c(x$pageWidth, x$pageHeight), 16, F))
  return(new("IFFChunk", chunk.type = "BMHD", chunk.data = list(result)))
}

#' @rdname IFFChunk
#' @export
IFFChunk.IFF.CAMG <- function(x, ...) {
  return(.inverseViewPort(x$display.mode, x$monitor))
}

#' @rdname IFFChunk
#' @export
IFFChunk.IFF.CRNG <- function(x, ...) {
  flag <- which(c("RNG_OFF", "RNG_ACTIVE", "RNG_REVERSE") == x$flags) - 1
  ## if the flag is unknown, set to 0
  if (length(flag) == 0) flag <- 0
  dat <- c(
    x$padding,
    .amigaIntToRaw(round(x$rate*(2^14)/60), 16, F),
    .amigaIntToRaw(flag, 16, F),
    .amigaIntToRaw(c(x$low, x$high), 8, F)
  )
  result <- new("IFFChunk", chunk.type = "CRNG", chunk.data = list(dat))
  return(result)
}

#' @rdname IFFChunk
#' @export
IFFChunk.IFF.ANIM <- function(x, ...) {
  rasterToIFF(x, ...)@chunk.data[[1]]
}

#' @rdname IFFChunk
#' @export
IFFChunk.IFF.ANHD <- function(x, ...) {
  oper <- which(x$operation == c("standard", "XOR", "LongDeltaMode", "ShortDeltaMode", "GeneralDeltamode", "ByteVerticalCompression", "StereoOp5", "ShortLongVerticalDeltaMode")) - 1
  ## if the flag is unknown, set to 0
  if (length(oper) == 0) oper <- 0
  result <- c(.amigaIntToRaw(oper, 8, F),
              .bitmapToRaw(x$mask, F, F),
              .amigaIntToRaw(c(x$w, x$h), 16, F),
              .amigaIntToRaw(c(x$x, x$y), 16, T),
              .amigaIntToRaw(c(x$abstime, x$reltime), 32, T),
              .amigaIntToRaw(x$interleave, 8, F),
              x$pad0,
              .bitmapToRaw(x$flags, T, T),
              x$pad1
  )
  result <- new("IFFChunk", chunk.type = "ANHD", chunk.data = list(result))
  return(result)
}

#' @rdname IFFChunk
#' @export
IFFChunk.IFF.DLTA <- function(x, ...) {
  return(new("IFFChunk", chunk.type = "DLTA", chunk.data = list(x)))
}

#' @rdname IFFChunk
#' @export
IFFChunk.IFF.DPAN <- function(x, ...) {
  result <- c(.amigaIntToRaw(c(x$version, x$nframes), 16, F),
              .bitmapToRaw(x$flags, T, T)
  )
  result <- new("IFFChunk", chunk.type = "DPAN", chunk.data = list(result))
  return(result)
}

#' Convert AmigaFFH objects into grDevices raster images
#'
#' Convert AmigaFFH objects that contain bitmap images into grDevices raster
#' images.
#'
#' Images on the Amiga were stored as bitmap images with indexed colour
#' palettes. This was mainly due to hardware and memory limitations.
#' Bitmap images could also be embedded in several file types. This method
#' can be used to convert AmigaFFH objects read from such files into
#' grDevices raster images ([grDevices::as.raster()]).
#'
#' @rdname as.raster
#' @name as.raster
#' @param x Object that needs to be converted into a `grDevices` raster. It
#' can be an [IFFChunk()] containing an interleaved bitmap image
#' (ILBM) or animation (ANIM), a [hardwareSprite()], an
#' [AmigaBitmapFont()] object or an [AmigaBitmapFontSet()] object.
#' @param background Use the argument `background` to
#' specify a background colour in case `x` is a [hardwareSprite()].
#' @param selected When `x` is an object of class [AmigaIcon()], `selected` can be
#' used to select a specific state. When set to `TRUE`, the raster of the [AmigaIcon()]
#' will be based on the `selected' state of the icon. Otherwise it will be based on the
#' deselected state (default).
#' 
#' When `x` is an [AmigaBasicShape()] class object, `selected` can be used to select a
#' specific layer of the shape to plot, which can be one of `"bitmap"` (default), `"shadow"` or `"collision"`.
#' @param ... Currently ignored.
#' @returns Returns a `grDevices` raster image ([grDevices::as.raster()])
#' based on `x`. If `x` is an animation ([IFFChunk()] of type ANIM),
#' a `list` of raster objects is returned.
#' @examples
#' \dontrun{
#' ## load an IFF file
#' example.iff <- read.iff(system.file("ilbm8lores.iff", package = "AmigaFFH"))
#' 
#' ## The file contains an interleaved bitmap image that can be
#' ## converted into a raster:
#' example.raster <- as.raster(example.iff)
#' 
#' ## the raster can be plotted:
#' plot(example.raster)
#' 
#' ## note that the IFFChunk can also be plotted directly:
#' plot(example.iff)
#' 
#' ## Hardware sprites can also be converted into raster images.
#' ## Let's generate a 16x16 sprite with a random bitmap:
#' spr <- new("hardwareSprite",
#'            VStop = 16,
#'            bitmap = as.raw(sample.int(255, 64, replace = TRUE)))
#' 
#' ## now convert it into a raster image.
#' ## as the background colour is not specified for hardware
#' ## sprite, we can optionally provide it here.
#' spr.raster <- as.raster(spr, background = "green")
#'
#' ## AmigaBasicShape objects can also be converted into rasters:
#' ball <- read.AmigaBasicShape(system.file("ball.shp", package = "AmigaFFH"))
#' ball.rst <- as.raster(ball)
#' }
#' @family iff.operations
#' @family raster.operations
#' @author Pepijn de Vries
#' @export
as.raster.IFFChunk <- function(x, ...) {
  if (x@chunk.type == "FORM") {
    result <- lapply(x@chunk.data, function(y){
      if (y@chunk.type == "ILBM") return(as.raster(y))
      if (y@chunk.type == "ANIM") return(interpretIFFChunk(y))
    })
    if (length(result) == 1) result <- result[[1]]
    return (result)
  } else if (x@chunk.type == "ILBM") {
    sub.chunks <- unlist(lapply(x@chunk.data, function(y) y@chunk.type))
    if (!("BMHD" %in% sub.chunks)) stop("No bitmap header present. Can't interpret bitmap.")
    if (!("BODY" %in% sub.chunks)) stop("No BODY chunk present. Can't convert the bitmap into a raster.")
    bm.header  <- interpretIFFChunk(getIFFChunk(x, "BMHD"))
    if (!("CAMG" %in% sub.chunks)) {
      bm.vp.mode <- NULL
      warning("No Amiga viewport available, interpretation possibly incorrect.")
    } else {
      bm.vp.mode <- interpretIFFChunk(getIFFChunk(x, "CAMG"))
      bm.vp.mode <- .display.properties(bm.vp.mode$display.mode, bm.vp.mode$monitor)
    }
    ## default palette in case 'CMAP' chunk is missing:
    bm.palette <- grDevices::gray(round(seq(0, 15, length.out = 2^bm.header$nPlanes))/15)
    ## Colours are interpreted as 12 bit when al low bits are 0, otherwise as 24 bit
    try(bm.palette <- interpretIFFChunk(getIFFChunk(x, "CMAP")), silent = T)
    ## extend the palette when the extra halfbright mode is used:
    if (!is.null(bm.vp.mode) && bm.vp.mode$is.halfbright) {
      bm.palette <- c(bm.palette,
                      substr(grDevices::adjustcolor(bm.palette, 1, 0.5, 0.5, 0.5), 1, 7))
    }
    if (bm.header$Compression == "cmpByteRun1") {
      bm <- unPackBitmap(interpretIFFChunk(getIFFChunk(x, "BODY")))
    } else if (bm.header$Compression == "cmpNone") {
      bm <- interpretIFFChunk(getIFFChunk(x, "BODY"))
    } else {
      stop("Bitmap data is compressed with unsupported algorithm.")
    }
    np <- bm.header$nPlanes
    if (length(bm.palette) < (2^np)) {
      if (bm.vp.mode$is.HAM) np <- ifelse(np == 8, 6, 5)
      bm.palette <- c(bm.palette, rep("#000000", (2^np) - length(bm.palette)))
    }
    rm(np)
    if (bm.header$Masking == "mskHasTransparentColour") {
      transparent <- bm.header$transparentColour + 1
      bm.palette[transparent] <- grDevices::adjustcolor(bm.palette[transparent],
                                                        alpha.f = 0)
    }
    attr.palette <- NULL
    if ("palette" %in% names(list(...)) && is.null(list(...)$palette)){
      attr.palette <- bm.palette
      bm.palette <- NULL
    }
    if (bm.vp.mode$is.HAM) {
      result <- bitmapToRaster(bm, bm.header$w, bm.header$h, bm.header$nPlanes, NULL)
      ## It is assumed that the image is HAM8 in case there are 8 bitplanes,
      ## HAM6 in all other cases...
      ## if bm.palette is null, we are dealing with an animation
      ## and we need to return the indices rather than the colours
      if (!is.null(bm.palette)) {
        result <- .indexToHAMraster(result, bm.header$nPlanes, bm.palette, bm.header$transparentColour)
      }
    } else {
      result <- bitmapToRaster(bm, bm.header$w, bm.header$h, bm.header$nPlanes, bm.palette)
    }
    if (bm.vp.mode$is.HAM) {
      attributes(result)[["mode"]] <- ifelse(bm.header$nPlanes == 8, "HAM8", "HAM6")
    }
    attributes(result)[["asp"]] <- bm.vp.mode$aspect.y/bm.vp.mode$aspect.x
    if (!is.null(attr.palette)) attributes(result)[["palette"]] <- attr.palette
    return(result)
  } else if (x@chunk.type == "ANIM") {
    return(interpretIFFChunk(x))
  } else {
    stop(sprintf("IFF chunk of type %s cannot be converted into a raster.", x@chunk.type))
  }
}

#' @rdname plot
#' @name plot
#' @export
plot.IFF.ILBM <- function(x, y, ...) {
  ## For ANIM frames, a matrix of palette indices is returned
  ## turn that into a raster object with a grayscale palette
  if (inherits(x, "matrix")) {
    pal <- grDevices::gray(seq(0, 1, length.out = max(round(abs(x)))))
    asp <- attributes(x)$asp
    x <- as.raster(apply(x, 2, function(z) pal[round(abs(z)) + 1]))
    attributes(x)$asp <- asp
  }
  class(x) <- "raster"
  if ("asp" %in% names(list(...)))
    graphics::plot(x, y, ...) else
      graphics::plot(x, y, asp = attributes(x)$asp, ...)
}

#' @rdname plot
#' @name plot
#' @export
plot.IFF.ANIM <- function(x, y, ...) {
  invisible(lapply(x, plot.IFF.ILBM, ...))
}

#' Convert a grDevices raster image into an IFF formated bitmap image
#'
#' Convert grDevices raster images ([grDevices::as.raster()])
#' into a formal [IFFChunk()] object, as an interleaved bitmap (ILBM)
#' image.
#'
#' Convert any modern image into a interleaved bitmap (image) conform
#' Interchange File Format (IFF) specifications. If your original image
#' is in true colour (i.e., a 24 bit colour depth) it will be converted
#' into a bitmap image with an indexed palette.
#'
#' @rdname rasterToIFF
#' @name rasterToIFF
#' @param x A raster object created with [grDevices::as.raster()] which
#' needs to be converted into an IFF formated bitmap image. It is also possible to let `x` be
#' a matrix of `character`s, representing colours.
#' @param display.mode Specify the Amiga display mode that should be used.
#' See [amiga_display_modes()] for all possible options.
#' "`LORES_KEY`" is used by default, this is the lowest resolution
#' possible on the Amiga.
#' @param monitor The Amiga monitor on which the needs to be displayed.
#' See [amiga_monitors()] for more details and posible options.
#' By default "`DEFAULT_MONITOR_ID`" is used.
#' @param anim.options Currently ignored. This argument will potentitally be implemented
#' in future versions of this package. Currently, animations are always encoded
#' with the "ByteVerticalCompression" in this package (when `x` is a list of
#' `raster` objects).
#' @param ... Arguments passed on to [rasterToBitmap()].
#' @returns Returns an [IFFChunk()] object holding an Interleaved
#' Bitmap (ILBM) image based on `x`.
#' @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))))
#' 
#' ## Turning the raster into an IFFChunk object is easy:
#' volcano.iff <- rasterToIFF(volcano.raster)
#' 
#' ## This object can be saved as an IFF file using write.iff
#' 
#' ## in special modes HAM6 and HAM 8 higher quality images
#' ## can be obtained. See 'rasterToBitmap' for more info on the
#' ## special HAM modes.
#' volcano.ham <- rasterToIFF(volcano.raster, "HAM_KEY", depth = "HAM8")
#' 
#' ## The result can be further improved by applying dithering
#' volcano.ham.dither <- rasterToIFF(volcano.raster, "HAM_KEY", depth = "HAM8",
#'   indexing = function(x, length.out) {
#'     index.colours(x, length.out, dither = "JJN", iter.max = 20)
#'   })
#' }
#' @family iff.operations
#' @family raster.operations
#' @author Pepijn de Vries
#' @export
rasterToIFF <- function(x,
                        display.mode = as.character(AmigaFFH::amiga_display_modes$DISPLAY_MODE),
                        monitor = as.character(AmigaFFH::amiga_monitors$MONITOR_ID),
                        anim.options,
                        ...) {
  display.mode <- match.arg(display.mode)
  monitor <- match.arg(monitor)
  pars <- list(...)
  if (is.null(pars$depth)) pars$depth <- 3
  if (is.null(pars$colour.depth)) pars$colour.depth <- "12 bit"
  if (grepl("EHB|EXTRAHALFBRITE", display.mode)) stop("Sorry, 'extra halfbrite' modes is currently not implemented")
  special.mode <- "none"
  if (pars$depth %in% c("HAM6", "HAM8")) {
    if (!grepl("HAM", display.mode)) warning("Display mode should be a HAM mode, when 'depth' is set to 'HAM6' or 'HAM8'. Display mode is corrected to 'HAM_KEY'.")
    display.mode <- "HAM_KEY"
  }
  if (grepl("HAM", display.mode)) {
    if (pars$depth %in% c("HAM6", "HAM8")) {
      special.mode <- pars$depth
      pars$colour.depth <- ifelse(special.mode == "HAM6", "12 bit", "24 bit")
      pars$depth <- ifelse(special.mode == "HAM6", 6, 8)
    } else {
      special.mode <- ifelse(pars$colour.depth == "24 bit", "HAM8", "HAM6")
    }
  }
  if (is.list(x)) {
    if (length(x) < 2) stop("When x is a list of rasters, it will be converted to an anim. x should have a length of at least 2.")
    if (any(unlist(lapply(x, function(y) !inherits(y, c("raster", "matrix")) || !all(.is.colour(y))))))
      stop("All elements of x should be a grDevices raster or a matrix of colours")
    if ("indexing" %in% names(list(...))) {
      x <- list(...)$indexing(x = x, length.out = ifelse(special.mode %in% c("HAM6", "HAM8"),
                                                         special.mode,
                                                         2^pars$depth))
    } else {
      x <- index.colours(x, length.out = ifelse(special.mode %in% c("HAM6", "HAM8"),
                                                special.mode,
                                                2^pars$depth))
    }
    pal <- attributes(x)$palette
    trans <- attributes(x)$transparent

    anhd <- lapply(1:(length(x) + 2), function(z) {
      anhdz <- list(
        operation       = "ByteVerticalCompression",
        mask            = rep(F, 8),
        w               = dim(x[[1]])[[2]],
        h               = dim(x[[1]])[[1]],
        x               = 0,
        y               = 0,
        abstime         = z*2,
        reltime         = 2,
        interleave      = 0,
        pad0            = raw(1),
        flags           = rep(F, 32),
        pad1            = raw(16)
      )
      class(anhdz) <- "IFF.ANHD"
      anhdz <- IFFChunk(anhdz)
      anhdz
    })
    
    frame1 <- .indexToBitmap(x[[1]], pars$depth, T)
    frame1 <- .bitmapToILBM(frame1, dim(x[[1]]), display.mode, monitor, pars$depth, pars$colour.depth, pal, trans)
    ## DPaint needs this class to set the correct number of frames:
    dpan <- list(version = 4, nframes = length(x), flags = rep(F, 32))
    class(dpan) <- "IFF.DPAN"
    frame1@chunk.data <- c(frame1@chunk.data[1],
                           anhd[[1]],
                           frame1@chunk.data[2],
                           IFFChunk(dpan),
                           frame1@chunk.data[3:4])
    frame1 <- new("IFFChunk", chunk.type = "FORM", chunk.data = list(frame1))

    ## .byteVerticalCompression returns a list of DLTA chunks, with the first frame missing (NULL)
    x <- .byteVerticalCompression(x, pars$depth)
    x[-1] <- lapply(2:length(x), function(y) {
      res <- new("IFFChunk", chunk.type = "ILBM", chunk.data = list(anhd[[y]], x[[y]]))
      res <- new("IFFChunk", chunk.type = "FORM", chunk.data = list(res))
      return(res)
    })
    x[[1]] <- frame1
    x <- new("IFFChunk", chunk.type = "ANIM", chunk.data = x)
    x <- new("IFFChunk", chunk.type = "FORM", chunk.data = list(x))
    return(x)
  }
  if (!inherits(x, c("raster", "matrix")) || !all(.is.colour(x))) stop("x should be a raster object or a matrix of colours.")
  if ("depth" %in% names(list(...))) {
    bm <- rasterToBitmap(x, ...)
  } else {
    bm <- rasterToBitmap(x, depth = ifelse(special.mode %in% c("HAM6", "HAM8"),
                                           special.mode,
                                           pars$depth), ...)
  }
  pal <- attributes(bm)$palette
  transparent <- attributes(bm)$transparent

  ## Create an ILBM chunk based on the bitmap data
  ilbm <- .bitmapToILBM(bm, dim(x), display.mode, monitor, pars$depth, pars$colour.depth, pal, transparent)
  ## Create a FORM chunk, encapsulating the bitmap info
  form <- new("IFFChunk", chunk.type = "FORM", chunk.data = list(ilbm))
  return(form)
}

## decompression for anim dlta frames
## dlta = raw data from dlta chunk
.byteVerticalDecompression <- function(dlta, w, h, interleave, use.xor, previous = NULL) {
  interleave[interleave == 0] <- 2
  pointers <- .rawToAmigaInt(dlta[1:(16*4)], 32, F)[1:8]
  if (all(pointers == 0)) {
    if (is.null(previous) || length(previous) == 0) {
      result <- matrix(0, h, w)
      class(result) <- c("IFF.ILBM", "IFF.ANY", class(result))
      return(result)
    } else {
      prev <- length(previous) - interleave + 1
      prev[prev < 1] <- 1
      return(previous[[prev]])
    }
  }
  bitmap.layers <- which(pointers > 1)
  bitmap.layers <- 1:bitmap.layers[bitmap.layers == max(bitmap.layers)]
  bitmap.layers <- pointers[bitmap.layers]
  ## loop the bitmap depth dimensions:
  result <- lapply(1:length(bitmap.layers), function(y) {
    offs <- bitmap.layers[[y]]
    prev <- NULL
    if (!is.null(previous)) {
      prev <- length(previous) - (interleave - 1)
      if (prev < 1) prev <- 1
      prev <- previous[[prev]]
      prev <- apply(prev, 2, function(z) {
        as.logical(floor(z/(2^(y - 1))) %% 2)
      })
      prev <- cbind(prev, matrix(F, h, w - ncol(prev)))
    }
    ## if the pointer is zero for a bitmap layer, there is no change. Just return previous frame
    if (offs == 0) {
      if (is.null(prev)) {
        return (matrix(0, h, w))
      } else return(prev)
    }
    ## loop columns:
    layer <- NULL
    for (i in 1:(w/8)) {
      op.count <- .rawToAmigaInt(dlta[1 + offs], 8, F)
      offs <- offs + 1
      row.result <- matrix(F, 0, 8)
      if (op.count > 0) {
        for (j in 1:op.count) {
          op <- .rawToAmigaInt(dlta[1 + offs], 8, F)
          offs <- offs + 1
          if (op == 0) { ## RUN operation; followed by number of repetitions and the repeating byte
            rep.count <- .rawToAmigaInt(dlta[1 + offs], 8, F)
            rep.dat <- matrix(rep(
              as.logical(.rawToBitmap(dlta[2 + offs], T, F)),
              rep.count
            ),
            ncol = 8, byrow = T)
            if (use.xor)
              rep.dat <- xor(prev[nrow(row.result) + 1:nrow(rep.dat), i*8 + (-7:0)], rep.dat)
            row.result <- rbind(row.result, rep.dat)
            offs <- offs + 2
          } else if (op < 0x80) { ## SKIP operation; move the cursor op bytes forward
            if (is.null(previous) || (is.list(previous) && length(previous) == 0)) {
              row.result <- rbind(row.result, matrix(F, nrow = op, ncol = 8))
            } else {
              nroff <- nrow(row.result) + 1
              if (length(nroff) == 0) nroff <- 1
              row.result <- rbind(row.result, prev[nroff + 0:(op - 1), i*8 + (-7:0)])
            }
          } else { ## DUMP operation; use op bytes literally
            op.cor <- op - 0x80
            temp <- as.logical(.rawToBitmap(dlta[(1 + offs):(offs + op.cor)], T, F))
            temp <- matrix(temp, ncol = 8, byrow = T)
            if (use.xor)
              temp <- xor(prev[nrow(row.result) + 1:nrow(temp), i*8 + (-7:0)], temp)
            row.result <- rbind(row.result, temp)
            offs <- offs + op.cor
          }
        }
      }
      if (nrow(row.result) == 0 || op.count == 0) {
        if (is.null(previous)) {
          row.result <- matrix(F, ncol = 8, nrow = h)
        } else {
          row.result <- prev[1:h, i*8 + (-7:0)]
        }
      }
      if (is.null(dim(row.result)) || !all(dim(row.result) == c(h, 8))) stop("Could not decode the bitmap correctly. If the bitmap was encoded with the AmigaFFH package, please contact the package author to get this fixed.")
      layer <- cbind(layer, row.result)
    }
    layer <- apply(layer, 2, function(z) (2^(y - 1))*as.numeric(z))
    return(layer)
  })
  result <- Reduce("+", result)
  class(result) <- c("IFF.ILBM", "IFF.ANY", class(result))
  return(result)
}

## vertical delta compression
## x should be a list of matrices with palette indices
## length of x should be > 1 (not checked here)
## the function returns a list of DLTA chunks, with the first element empty (NULL).
.byteVerticalCompression <- function(x, depth) {
  x <- c(x, x[1:2])
  h   <- dim(x[[1]])[[1]]
  w   <- dim(x[[1]])[[2]]
  x   <- lapply(x, function(y) cbind(y, matrix(0, nrow = h, ncol = (-w %% 16))))
  wbm <- w + (-w %%16)
  ## first frame should be ILBM with BMHD and BODY (constructed later and skipped here)
  result <- vector("list", length(x))
  for (i in 2:length(x)) {
    prev.id <- i - 2
    if (prev.id < 1) prev.id <- 1
    ## loop bitmap layers
    pointers <- NULL
    no.change <- rep(F, 16)
    for (j in 1:depth) {
      ## loop columns
      dep.data <- NULL
      for (k in 1:(wbm/8)) {
        previous.column <- floor((x[[prev.id]][,k*8 + (-7:0)] - 1)/(2^(j - 1))) %% 2
        curr.column     <- floor((x[[i]][,k*8 + (-7:0)] - 1)/(2^(j - 1))) %% 2
        row.similarity <- apply(previous.column == curr.column, 1, all)
        ## when there are only short fragments the same, classify them as different
        ## this is to avoid the large overhead of the operation bytes
        run.lengths <- rle(row.similarity)$lengths
        run.lengths <- rep(run.lengths, run.lengths)
        row.similarity[row.similarity & run.lengths < 3] <- F
        ## If the entire row is similar to the previous frame, add 0 as op.count to the result
        cursor <- 1
        op.count <- 0
        op.data <- NULL
        if (!all(row.similarity)) {
          while (cursor <= h) {
            if (row.similarity[[cursor]]) { ## when elements at the cursor are the same compared to the previous frame, the SKIP operation is in place
              skip <- which(diff(c(row.similarity[cursor:h], F)) != 0)[[1]]
              repskip <- floor(skip/127)
              ## note that the op.count needs to preceed each column of data
              ## it will be added after all ops of the column have been processed
              op.data <- c(op.data,
                           .amigaIntToRaw(c(
                             rep(127, repskip),
                             skip %% 127), 8, F))
              op.count <- op.count + repskip + 1
              cursor <- cursor + skip
            } else {
              dup <- c(T, duplicated(curr.column[cursor:h,, drop = F], fromLast = F)[-1]) & !row.similarity[cursor:h]
              dup.run.length <- rle(dup)$lengths
              dup.run1 <- dup.run.length[[1]]
              dup.run1[dup.run1 > 255] <- 255
              dup.run.length <- c(1, dup.run.length[1] - 1, dup.run.length[-1])
              dup.run.length <- rep(dup.run.length, dup.run.length)
              if (dup.run1 > 3 && length(dup) > 3 && dup[[2]]){ ## When elements at the cursor are not the same as the previous frame, and they are repetative, the RUN operation is in place
                op.data <- c(op.data,
                             .amigaIntToRaw(c(0, dup.run1), 8, F),
                             .bitmapToRaw(as.logical(t(curr.column[cursor,, drop = F])),
                                                      T, F))
                op.count <- op.count + 1
                cursor <- cursor + dup.run1
              } else { ## When elements at the cursor are not the same as the previous frame, and they are not repetative, the DUMP operation is in place
                skip <- which(diff(c(row.similarity[cursor:h] |
                                       c(dup.run.length[-1] > 2 & dup[-1], F), T)) != 0)[[1]]
                skip[skip > 127] <- 127
                dat <- .bitmapToRaw(as.logical(t(curr.column[cursor:(cursor + skip - 1),, drop = F])),
                                                T, F)
                op.data <- c(op.data,
                             .amigaIntToRaw(skip + 0x80, 8, F),
                             dat)
                cursor <- cursor + skip
                op.count <- op.count + 1
              }
            }
          }
        }
        ## After each column, bind the result to the previous column. Each column should start with the count of
        ## the total number of operations in the column, followed by the encoded data.
        dep.data <- c(dep.data,
                      .amigaIntToRaw(op.count, 8, F),
                      op.data)
      }
      if (all(dep.data == raw(1))) {
        no.change[[j]] <- T
        dep.data <- NULL
      }
      pointers <- c(pointers, length(dep.data))
      if (!is.null(dep.data)) result[[i]] <- c(result[[i]], dep.data) 
    }
    pointers <- cumsum(pointers)
    ptrs <- rep(0, 16)
    ptrs[1:length(pointers)] <- 64 + c(0 , pointers[0:(length(pointers) - 1)])
    ptrs[no.change] <- 0
    ## combine the op-data from all bitmap layers, starting with pointers to the start of the data for each layer
    ## if there was no change to a bitmap layer, there is no data. The pointer is set to 0 in that case.
    result[[i]] <- c(
      .amigaIntToRaw(ptrs, 32, F),
      result[[i]]
    )
    ## DLTA should be preceded by an ANHD chunk, this is not added by this function
    result[[i]] <- new("IFFChunk", chunk.type = "DLTA", chunk.data = list(result[[i]]))
  }
  return(result)
}

.bitmapToILBM <- function(bm, dim.x, display.mode, monitor, depth, colour.depth, pal, transparent) {
  bm <- .bitmapToRaw(bm, T, F)
  bm <- matrix(bm, nrow = 2*ceiling(dim.x[[2]]/16), byrow = F)
  bm <- c(unlist(apply(bm, 2, packBitmap)))
  
  ## Create a BODY chunk based on the bitmap data
  body <- new("IFFChunk", chunk.type = "BODY", chunk.data = list(bm))

  ## Create a CAMG chunk, specifying the displaymode
  camg <- .inverseViewPort(display.mode, monitor)
  disp <- .amigaViewPortModes(camg@chunk.data[[1]])
  disp.prop <- .display.properties(disp$display.mode, disp$monitor)
  ## Create BMHD chunk, with bitmap header information
  BMHD <- list(
    w                 = dim.x[2],
    h                 = dim.x[1],
    x                 = 0,
    y                 = 0,
    nPlanes           = depth,
    Masking           = ifelse(!is.null(transparent) && !is.na(transparent), "mskHasTransparentColour", "mskNone"),
    Compression       = "cmpByteRun1",
    pad               = raw(1),
    transparentColour = ifelse(!is.null(transparent) && !is.na(transparent), transparent - 1, 0),
    xAspect           = disp.prop$aspect.x,
    yAspect           = disp.prop$aspect.y,
    pageWidth         = disp.prop$screenwidth,
    pageHeight        = disp.prop$screenheight
  )
  class(BMHD) <- "IFF.BMHD"
  hdr <- IFFChunk(BMHD)
  ## Create a CMAP chunk with palette information
  class(pal) <- "IFF.CMAP"
  cmap <- IFFChunk(pal, colour.depth = colour.depth)
  # cmap <- new("IFFChunk", chunk.type = "CMAP", chunk.data = list(colourToAmigaRaw(pal, pars$colour.depth, "3")))
  ## Create a ILBM chunk, which hold all required bitmap information
  ilbm <- new("IFFChunk", chunk.type = "ILBM", chunk.data = list(
    hdr, cmap, camg, body
  ))
  return(ilbm)
}

.indexToHAMraster <- function(x, depth, palette, transparentColour) {
  control.mask  <- bitwShiftL(3, depth - 2)
  max_color     <- ifelse(depth == 8, 255, 15)
  color_divisor <- ifelse(depth == 8, 1, 17)
  color_multi   <- ifelse(depth == 8, 255/63, 1)
  x <- apply(x, 1, function(y) {
    control.flags <- 3*bitwAnd(y, control.mask)/control.mask
    y.shift <- (y - control.mask*control.flags/3)
    z             <- rep(NA, length(y))
    z[control.flags == 0] <- palette[y.shift[control.flags == 0] + 1]
    for (i in 1:length(y)) {
      if (is.na(z[i])) {
        z0   <- z[i - 1]
        if (length(z0) == 0) z0 <- palette[transparentColour + 1]
        cl   <- grDevices::col2rgb(z0)
        z[i] <- grDevices::rgb(
          ifelse(control.flags[i] == 2, color_multi*y.shift[i], cl["red",]/color_divisor),
          ifelse(control.flags[i] == 3, color_multi*y.shift[i], cl["green",]/color_divisor),
          ifelse(control.flags[i] == 1, color_multi*y.shift[i], cl["blue",]/color_divisor),
          maxColorValue = max_color
        )
      }
    }
    z
  })
  as.raster(t(x))
}

Try the AmigaFFH package in your browser

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

AmigaFFH documentation built on June 22, 2024, 11:03 a.m.