RSurvey: Geographic Information System Application

#' Create Icon Bitmap Image
#'
#' Create a small \acronym{Tk} bitmap image.
#'
#' @param type character.
#'   Icon image type, see \sQuote{Details}
#'
#' @details Icon image types include:
#'   \code{left}, \code{right}, \code{up}, \code{down}, \code{top}, \code{bottom},
#'   \code{upleft}, \code{upright}, \code{downleft}, \code{downright}, \code{next},
#'   \code{previous}, \code{copy}, \code{paste}, \code{find}, \code{delete},
#'   \code{view}, \code{info}, \code{plus}, \code{minus}, \code{print}, and \code{histogram}.
#'   A recommended editor for bitmap design is Paul Obermeier's
#'   \href{http://www.posoft.de/html/poBitmapMain.html}{poBitmap} tool;
#'   specify a square icon 11 pixels on each side.
#'
#' @return An image of class tclObj.
#'
#' @author J.C. Fisher, U.S. Geological Survey, Idaho Water Science Center
#'
#' @seealso \code{\link[tcltk:TkCommands]{tkimage.create}}
#'
#' @keywords misc
#'
#' @export
#'
#' @examples
#' \dontrun{
#'   types <- c("left", "right", "up", "down", "top", "bottom", "upleft", "upright",
#'              "downleft", "downright", "next", "previous", "copy", "paste", "find",
#'              "delete", "view", "info", "plus", "minus", "print", "histogram")
#'   Fun <- function(k) print(types[k])
#'   tt <- tcltk::tktoplevel(padx = 50, pady = 50)
#'   i <- 0
#'   j <- 0
#'   d <- 5
#'   for (k in seq_along(types)) {
#'     img <- paste("img", k, sep = ".")
#'     but <- paste("but", k, sep = ".")
#'     assign(img, GetBitmapImage(types[k]))
#'     assign(but, tcltk::ttkbutton(tt, width = 2, image = get(img),
#'                                  command = local({k <- k; function() Fun(k)})))
#'     tcltk::tkgrid(get(but), row = i, column = j, padx = 5, pady = 5)
#'     i <- k %/% d
#'     j <- ifelse(j < d - 1, j + 1, 0)
#'   }
#' }
#'

GetBitmapImage <- function(type) {

  bits <- list()

  bits[["left"]]      <- c("0x00", "0x00", "0x20", "0x00", "0x30", "0x00",
                           "0x38", "0x00", "0xfc", "0x01", "0xfe", "0x01",
                           "0xfc", "0x01", "0x38", "0x00", "0x30", "0x00",
                           "0x20", "0x00", "0x00", "0x00")
  bits[["right"]]     <- c("0x00", "0x00", "0x20", "0x00", "0x60", "0x00",
                           "0xe0", "0x00", "0xfc", "0x01", "0xfc", "0x03",
                           "0xfc", "0x01", "0xe0", "0x00", "0x60", "0x00",
                           "0x20", "0x00", "0x00", "0x00")
  bits[["up"]]        <- c("0x00", "0x00", "0x20", "0x00", "0x70", "0x00",
                           "0xf8", "0x00", "0xfc", "0x01", "0xfe", "0x03",
                           "0x70", "0x00", "0x70", "0x00", "0x70", "0x00",
                           "0x00", "0x00", "0x00", "0x00")
  bits[["down"]]      <- c("0x00", "0x00", "0x00", "0x00", "0x70", "0x00",
                           "0x70", "0x00", "0x70", "0x00", "0xfe", "0x03",
                           "0xfc", "0x01", "0xf8", "0x00", "0x70", "0x00",
                           "0x20", "0x00", "0x00", "0x00")
  bits[["top"]]       <- c("0x00", "0x00", "0xfe", "0x03", "0xfe", "0x03",
                           "0x20", "0x00", "0x70", "0x00", "0xf8", "0x00",
                           "0xfc", "0x01", "0xfe", "0x03", "0x70", "0x00",
                           "0x70", "0x00", "0x70", "0x00")
  bits[["bottom"]]    <- c("0x70", "0x00", "0x70", "0x00", "0x70", "0x00",
                           "0xfe", "0x03", "0xfc", "0x01", "0xf8", "0x00",
                           "0x70", "0x00", "0x20", "0x00", "0xfe", "0x03",
                           "0xfe", "0x03", "0x00", "0x00")
  bits[["upleft"]]    <- c("0x00", "0x00", "0x7e", "0x00", "0x3e", "0x00",
                           "0x3e", "0x00", "0x7e", "0x00", "0xfe", "0x00",
                           "0xf2", "0x01", "0xe0", "0x00", "0x40", "0x00",
                           "0x00", "0x00", "0x00", "0x00")
  bits[["upright"]]   <- c("0x00", "0x00", "0xf0", "0x03", "0xe0", "0x03",
                           "0xe0", "0x03", "0xf0", "0x03", "0xf8", "0x03",
                           "0x7c", "0x02", "0x38", "0x00", "0x10", "0x00",
                           "0x00", "0x00", "0x00", "0x00")
  bits[["downleft"]]  <- c("0x00", "0x00", "0x00", "0x00", "0x40", "0x00",
                           "0xe0", "0x00", "0xf2", "0x01", "0xfe", "0x00",
                           "0x7e", "0x00", "0x3e", "0x00", "0x3e", "0x00",
                           "0x7e", "0x00", "0x00", "0x00")
  bits[["downright"]] <- c("0x00", "0x00", "0x00", "0x00", "0x10", "0x00",
                           "0x38", "0x00", "0x7c", "0x02", "0xf8", "0x03",
                           "0xf0", "0x03", "0xe0", "0x03", "0xe0", "0x03",
                           "0xf0", "0x03", "0x00", "0x00")
  bits[["next"]]      <- c("0x08", "0x00", "0x18", "0x00", "0x38", "0x00",
                           "0x78", "0x00", "0xf8", "0x00", "0xf8", "0x01",
                           "0xf8", "0x00", "0x78", "0x00", "0x38", "0x00",
                           "0x18", "0x00", "0x08", "0x00")
  bits[["previous"]]  <- c("0x80", "0x00", "0xc0", "0x00", "0xe0", "0x00",
                           "0xf0", "0x00", "0xf8", "0x00", "0xfc", "0x00",
                           "0xf8", "0x00", "0xf0", "0x00", "0xe0", "0x00",
                           "0xc0", "0x00", "0x80", "0x00")
  bits[["copy"]]      <- c("0x00", "0x00", "0x7e", "0x00", "0x42", "0x00",
                           "0xf2", "0x03", "0x12", "0x02", "0x12", "0x02",
                           "0x12", "0x02", "0x1e", "0x02", "0x10", "0x02",
                           "0xf0", "0x03", "0x00", "0x00")
  bits[["paste"]]     <- c("0x10", "0x00", "0xfe", "0x00", "0xba", "0x00",
                           "0x82", "0x00", "0xe2", "0x07", "0xe2", "0x07",
                           "0xe2", "0x07", "0xe2", "0x07", "0xfe", "0x07",
                           "0xe0", "0x07", "0xe0", "0x07")
  bits[["find"]]      <- c("0x3c", "0x00", "0x42", "0x00", "0x81", "0x00",
                           "0x81", "0x00", "0x81", "0x00", "0x81", "0x00",
                           "0x42", "0x00", "0xbc", "0x01", "0x80", "0x03",
                           "0x00", "0x07", "0x00", "0x06")
  bits[["delete"]]    <- c("0x00", "0x00", "0x06", "0x03", "0x8e", "0x03",
                           "0xdc", "0x01", "0xf8", "0x00", "0x70", "0x00",
                           "0xf8", "0x00", "0xdc", "0x01", "0x8e", "0x03",
                           "0x06", "0x03", "0x00", "0x00")
  bits[["view"]]      <- c("0xff", "0x07", "0xff", "0x07", "0x00", "0x00",
                           "0xff", "0x07", "0xff", "0x07", "0x00", "0x00",
                           "0xff", "0x07", "0xff", "0x07", "0x00", "0x00",
                           "0xff", "0x07", "0xff", "0x07")
  bits[["info"]]      <- c("0x30", "0x00", "0x30", "0x00", "0x00", "0x00",
                           "0x78", "0x00", "0x30", "0x00", "0x30", "0x00",
                           "0x30", "0x00", "0x30", "0x00", "0x30", "0x00",
                           "0x30", "0x00", "0xfc", "0x00")
  bits[["plus"]]      <- c("0x70", "0x00", "0x70", "0x00", "0x70", "0x00",
                           "0x70", "0x00", "0xff", "0x07", "0xff", "0x07",
                           "0xff", "0x07", "0x70", "0x00", "0x70", "0x00",
                           "0x70", "0x00", "0x70", "0x00")
  bits[["minus"]]     <- c("0x00", "0x00", "0x00", "0x00", "0x00", "0x00",
                           "0x00", "0x00", "0xff", "0x07", "0xff", "0x07",
                           "0xff", "0x07", "0x00", "0x00", "0x00", "0x00",
                           "0x00", "0x00", "0x00", "0x00")
  bits[["print"]]     <- c("0xfc", "0x01", "0xfc", "0x01", "0x00", "0x00",
                           "0xff", "0x07", "0xff", "0x07", "0xff", "0x07",
                           "0xff", "0x07", "0x07", "0x07", "0x07", "0x07",
                           "0x04", "0x01", "0xfc", "0x01")
  bits[["histogram"]] <- c("0x00", "0x07", "0x00", "0x07", "0x00", "0x07",
                           "0x70", "0x07", "0x77", "0x07", "0x77", "0x07",
                           "0x77", "0x07", "0x77", "0x07", "0x00", "0x00",
                           "0xff", "0x07", "0xff", "0x07")

  if (!is.character(type) || !type %in% names(bits))
    stop("Requested bitmap image does not exist")

  n <- length(bits[[type]]) / 2L
  bits.str <- paste("#define v_width ", n, "\n#define v_height ", n, "\n",
                    "static unsigned char v_bits[] = { ",
                    paste0(bits[[type]], collapse=", "), " }; ")

  return(tcltk::tkimage.create("bitmap", data=tcltk::as.tclObj(bits.str)))
}