############################################################################
#
#	File:     imscolor.icn
#
#	Subject:  Procedures for manipulating images
#
#	Author:   Gregg M. Townsend
#
#	Date:     December 25, 1999
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#	These procedures manipulate image strings.
#
#	imswidth(im)		returns the width of an image.
#	imsheight(im)		returns the height of an image.
#	imspalette(im)		returns the palette used by an image.
#
#	imsmap(s1, s2, s3)	applies map() to the image data.
#
#	imswrite(f, s, n)	writes an image string to a file.
#
#	drawpalette(W, p, x, y, w, h, f, n)	draws the color palette p.
#
#	pickpalette(W, p, dx, dy, w, h, n)      maps window coordinates
#				to a palette drawn by drawpalette().
#
#	XPMImage(W, f, p)	reads an XPM file, returning an image string.
#
############################################################################
#
#  imswidth(im) returns the width of an image.
#  imsheight(im) returns the height of an image.
#  imspalette(im) returns the palette used by an image.
#
#  imsmap(s1, s2, s3) returns an image produced by mapping the data (only)
#  of image s1 and replacing characters found in s2 with corresponding
#  characters from s3.
#
#  imswrite(f, s, n) writes image string s to file f, limiting the line
#  length to n characters.  Defaults are f = &output, n = 79.  Extra
#  punctuation in s makes the lines break at nonsensical places, but
#  the output is still legal.
#
#  drawpalette([win,] p, x, y, w, h, f, n) draws the colors of palette
#  p in the given rectangular region.  n columns are used;  if n is
#  omitted, a layout is chosen based on the palette name and size. The
#  layout algorithm works best when the height is two to four times
#  the width.  Characters in the flag string f have these meanings:
#	l	label each color with its key
#	o	outline each color in black
#	u	unframed use: don't hash unused cells at end
#
#  pickpalette([win,] p, dx, dy, w, h, n) returns the character at (dx,dy)
#  within a region drawn by drawpalette(win, p, x, y, w, h, f, n).
#
#  XPMImage([win,] f, palette) reads an XPM (X Pixmap) format image from
#  the open file f and returns an Icon image specification that uses the
#  specified palette.  XPMImage() fails if it cannot decode the file.
#  If f is omitted, &input is used; if palette is omitted, "c1" is used.
#  Not all variants of XPM format are handled; in particular, images that
#  use more than one significant input character per pixel, or that use
#  the old XPM Version 1 format, cause XPMImage() to fail.  No window
#  is required, but X-specific color names like "papayawhip" will not
#  be recognized without a window.
#
############################################################################
#
#  Links: graphics
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################

link graphics


#  imspalette(im) -- return palette used by image

procedure imspalette(im)			#: palette for image
   im ? {tab(upto(',') + 1) & return ((="#" & &null) | tab(upto(',')))}
end


#  imswidth(im) -- return width of image

procedure imswidth(im)				#: width of image
   im ? return integer(tab(upto(',')))
end


#  imsheight(im) -- return height of image

procedure imsheight(im)				#: height of image
   local pal, w, n, d, c

   im ? {
      w := integer(tab(upto(','))) | fail
      move(1)
      if ="#" then {
         n := IMH_Count('0123456789ABCDEFabcdef')
         d := (w + 3) / 4
         return (n + d - 1) / d
         }
      pal := tab(upto(',')) | fail
      move(1)
      c := cset(PaletteChars(pal)) | fail
      n := IMH_Count(c ++ '~\xFF')
      return (n + w - 1) / w
      }
end

procedure IMH_Count(c)		# count remaining chars that are in cset c
   local n

   n := 0
   while tab(upto(c)) do
      n +:= *tab(many(c))
   return n
end


#  imsmap(s1, s2, s3) -- map the data (only) of an image string

procedure imsmap(s1, s2, s3)			#: map data of image string
   s1 ? return tab(upto(',')+1) || tab(upto(',')+1) || map(tab(0), s2, s3)
end


#  imswrite(f, s, n) -- write image string s to file f, max linelength of n.

procedure imswrite(f, s, n)			#: write image string
   local w, h, p, d, ll

   w := imswidth(s) | fail
   h := imsheight(s) | fail
   p := imspalette(s) | fail

   if /p then				# if bilevel image
      d := (w + 3) / 4			# number of digits per row
   else
      d := w

   /f := &output
   /n := 79

   # Figure out a reasonable line length for output, with n as maximum
   n -:= 1				# allow for underscore
   if upto('\0', PaletteChars(\p)) then
      n /:= 4				# allow for escapes
   ll := 1 + (n > (d - 1) / seq(1))	# divide line as equally as possible

   # Write the image as a multiline string constant.
   s ? {
      tab(upto(',') + 1)
      ="#" | tab(upto(',') + 1)
      write(f, "\"", w, ",", (\p || ",") | "#", "_")
      while not pos(0) do IWR_Row(f, move(d) | tab(0), ll)
      write(f, "\"")
      }
   return
end

procedure IWR_Row(f, s, n)	# write one row, max n bytes per line
   s ? while not pos(0) do
      write(f, image(move(n) | tab(0)) [2:-1], "_")
   return
end


#  drawpalette(win, p, x, y, w, h, f, n) -- draw palette in region

procedure drawpalette(win, p, x, y, w, h, f, n)	#: draw palette
   local nh, c, s, colr, x1, x2, y1, y2, i, j, ret
   static cs
   initial cs := &ascii[33+:95] -- '\\'

   if type(win) ~== "window" then {
      win :=: p :=: x :=: y :=: w :=: h :=: f :=: n
      win := \&window | runerr(140, &window)
      }
   win := Clone(win, "fg=black")
   ret := win

   /p := "c1"
   /f := ""

   /x := -WAttrib(win, "dx")
   /y := -WAttrib(win, "dy")
   /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
   /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))

   if w < 0 then
      x -:= (w := -w)
   if h < 0 then
      y -:= (h := -h)

   s := PAL_Order(p) | fail
   /n := PAL_Columns(p, s, w, h)
   nh := (*s + n - 1) / n

   EraseArea(win, x, y, w, h)
   if f ? upto('o') then {
      w -:= 1
      h -:= 1
      }

   i := j := 0
   every c := !s do {
      x1 := x + j * w / n
      x2 := x + (j + 1) * w / n
      y1 := y + i * h / nh
      y2 := y + (i + 1) * h / nh
      Fg(win, colr := PaletteColor(p, c)) | (ret := &null)
      FillRectangle(win, x1, y1, x2 - x1, y2 - y1)
      if upto('l', f) then {
         Fg(win, Contrast(win, colr))
         if not upto(cs, c) then
            c := image(c)[-3:-1]
         CenterString(win, (x1 + x2) / 2, (y1 + y2) / 2, c)
         }
      if upto('o', f) then {
         Fg(win, "black")
         DrawRectangle(win, x1, y1, x2 - x1, y2 - y1)
         }
      if (j +:= 1) >= n then {
         j := 0
         i +:= 1
         }
      }

   # if some cells are unfilled, and the 'u' flag is not given,
   # hash the unfilled cells with a diagonal pattern.
   if j > 0 & not upto('u', f) then {
      x1 := x + j * w / n
      y1 := y + i * h / nh
      x2 := x + w
      y2 := y + h
      WAttrib(win, "fg=black", "pattern=diagonal", "fillstyle=textured")
      FillRectangle(win, x1, y1, x2 - x1, y2 - y1)
      if upto('o', f) then {
         WAttrib(win, "fillstyle=solid")
         DrawRectangle(win, x1, y1, x2 - x1, y2 - y1)
         }
      }

   Uncouple(win)
   return \ret
end


#  pickpalette(win, p, dx, dy, w, h, n) -- return key picked from drawn palette

procedure pickpalette(win, p, dx, dy, w, h, n)	#: key from drawn palette
   local s, nw, nh

   if type(win) ~== "window" then {
      win :=: p :=: dx :=: dy :=: w :=: h :=: n
      win := \&window | runerr(140, &window)
      }
   /w := WAttrib(win, "width")
   /h := WAttrib(win, "height")
   if dx < 0 | dy < 0 | dx >= w | dy >= h then
      fail

   s := PAL_Order(p) | fail
   /n := PAL_Columns(p, s, w, h)
   nh := (*s + n - 1) / n

   dx := ((dx + 1) * n - 1) / w
   dy := ((dy + 1) * nh - 1) / h
   return s[1 + n * dy + dx]
end


#  PAL_Columns(p, s, w, h) -- calc columns for auto-layout (internal routine)
#
#  p is palette name; s is character string; w,h are available dimensions

procedure PAL_Columns(p, s, w, h)
   local nw, nh

   return case p of {
      "c1":	return 6
      "c2":	return 2
      "c3":	return 3
      "c4":	return 4
      "c5":	return 5
      "c6":	return 6
      default: {
	 nw := integer(w / sqrt(w * h / *s))
         nw <:= 1
         nh := (*s + nw - 1) / nw
         nh <:= 1
         return (*s + nh - 1) / nh
	 }
      }
end


#  PAL_Order(p) -- return reordered palette chars (internal routine)
#
#  Normal order for color cube is sorted r/g/b, then extra grays.
#  Reorder by g/r/b followed by full set of grays, including duplicates,
#  back to black.  Returns unmodified list of characters for c1 and
#  grayscale palettes.

procedure PAL_Order(p)
   local palchars, s, t, n, n3, i, l

   palchars := PaletteChars(p) | fail

   p ? {
      if not (="c" & any('23456')) then return palchars
      n := integer(move(1))
      }

   palchars ? {

      l := list(n, "")
      n3 := n * n * n
      while &pos <= n3 do
         every !l ||:= (move(n) \ 1)
      s := ""
      every s ||:= !l		# build g/r/b cube portion

      t := ""
      every i := 1 to (n3 - 1) by (n * (n + 1) + 1) do
         t ||:= palchars[i] || move(n - 1)
      }

   return s || reverse(t)
end


#  XPMImage(win, f, palette) -- read XPM file and return Icon image spec

procedure XPMImage(win, f, pal)			#: image string for XPM file
   local w, h, nc, cpp, i, im, c, k, s1, s2

   if type(win) ~== "window" then {
      win :=: f :=: pal
      win := &window		# okay if null
      }
   /f := &input
   /pal := "c1"
   type(f) == "file" | runerr(105, f)
   PaletteChars(pal) | runerr(205, f)

   (read(f) ? find("XPM")) | fail
   (XPM_RdStr(f) | fail) ? {
      tab(many(' \t'));  w := tab(many(&digits)) | fail
      tab(many(' \t'));  h := tab(many(&digits)) | fail
      tab(many(' \t'));  nc := tab(many(&digits)) | fail
      tab(many(' \t'));  cpp := tab(many(&digits)) | fail
   }
   if w = 0 | h = 0 then
      fail

   # read colors and figure out translation
   s1 := s2 := ""
   every i := 1 to nc do (XPM_RdStr(f) | fail) ? {
      s1 ||:= move(1)
      if cpp > 1 then
         =" " | fail			# if not blank, we can't handle it
      k := &null
      # find a color key we can decipher; try color, then grayscale, then mono
      (c := !"cgm") & tab(upto(' \t') + 1) & =c & tab(many(' \t')) &
         (k := XPM_Key(win, pal, (tab(upto(' \t') | 0))))
      # use first color found, or default if none
      s2 ||:= \k | PaletteKey(pal, "gray")
      }

   # construct image
   im := w || "," || pal || ","
   if cpp = 1 then
      while im ||:= map(XPM_RdStr(f), s1, s2)
   else
      while im ||:= map(XPM_Nth(XPM_RdStr(f), cpp), s1, s2)
   return im
end

procedure XPM_Key(win, pal, s)	#  return key corresponding to color s

   if s == "None" then {		# if transparent
      if PaletteColor(pal, "~") then	# if "~" is in palette
         return "\xFF"			# then use "\xFF" for transparent
      else
         return "~"			# but use "~" if possible
      }

   if \win then
      return PaletteKey(win, pal, s)	# return key from palette, or fail
   else
      return PaletteKey(pal, s)		# return key from palette, or fail
end

procedure XPM_RdStr(f)		# read next C string from file f
   local line, s

   while line := read(f) do line ? {
      tab(many(' \t'))
      ="\"" | next
      if s := tab(upto('"')) then
         return s
      }
   fail
end

procedure XPM_Nth(s, n)		#  concatenate every nth character from s
   local t
   n -:= 1
   t := ""
   s ? while t ||:= move(1) do
      move(n)
   return t
end