path: root/ipl/gprogs/gallery.icn

############################################################################
#
#	File:     gallery.icn
#
#	Subject:  Program to display many images at once
#
#	Author:   Gregg M. Townsend
#
#	Date:     August 3, 2005
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#  Usage:  gallery [-{whs}nnn] [-{rmtud}] file...
#
#  Gallery displays multiple images in a single window.  The images
#  are shrunken by resampling and tiled in columns or rows.
#
#  GIF and XPM format images are always supported.  JPEG format is
#  supported when built by Jcon.  JPEG, PPM, TIFF, PNG, and RLE formats
#  are also available under Unix if the necessary conversion utilities
#  are available in the shell search path.
#
#  When the window fills, diagonal lines in the extreme corners of the
#  window indicate that you can press Enter for the next screenful.
#  Solid triangles appear when there are no more images; press Q to exit.
#
#  At either of those pauses, pressing 'S' brings up a dialog for saving
#  a snapshot of the window.  Clicking the left mouse button on an
#  image displays a popup window with information about the image.  A
#  second click dismisses the popup, as does the space bar or Enter key.
#  The right mouse button activates the same popup momentarily until
#  the button is released.
#
#  -wnnn sets the maximum width for displaying an image;
#  -hnnn sets the maximum height.  -snnn sets both.
#  By default, sizes are chosen automatically, subject to a minimum
#  size of 32x32, to allow all images to fit in a single window.
#
#  -r arranges images in rows instead of columns.
#  -m maximizes the window size before displaying images.
#  -t trims file names of leading path components and extensions.
#  -u shows images completely unlabeled.
#  -d prints some debugging information.
#
#  The standard Window() options are accepted and can be used to
#  set the window size and other parameters.  A default gamma value
#  of 1.0 can be changed by using (e.g.) "-A gamma=1.6".
#
#  -cn and -gn options, which formerly selected a color palette,
#  are now ignored.
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links: graphics, imscolor, interact, options, io, random, cfunc
#
############################################################################


#  TO DO:
#
#  improve prompts -- something more obvious & intuitive


link graphics
link imscolor
link interact
link options
link io
link random


$define Gap 4			# gap between images
$define MinWidth 32		# minimum width if auto-scaled
$define MinHeight 32		# minimum height if auto-scaled


record imrec(win, fullw, fullh)
record area(fname, x, y, w, h, iw, ih)

global opts			# command options
global tempname			# temporary file name

global ww, wh, fh, fw		# window dimensions
global maxw, maxh		# maximum size of displayed image

global areas			# areas used for display



procedure main(args)
   local cw, ch, bigh, bigw, x, y, w, h, gg, aspr, aspmax, horz
   local fname, label, f, tw, s, nchars, nlines, img, imwin, e

   # generate a random name for the temporary file
   randomize()
   tempname := "/tmp/gal" || right(?99999, 5, "0") || ".tmp"

   # open the window and process options
   Window("size=800,500", "bg=pale gray", "font=sans,8", "gamma=1.0", args)
   opts := options(args, "g+c+w+h+s+rmtud")
   if \opts["m"] then
      WAttrib("canvas=maximal")
   if *args = 0 then
      stop("usage: ", &progname, " [-{gc}n] [-{whd}nnn] [-{mtv}] file...")

   # allow user resizing of window
   &error := 1
   WAttrib("resize=on")
   &error := 0

   # record window dimensions
   ww := WAttrib("width")
   wh := WAttrib("height")
   if \opts["u"] then
      fh := 0
   else
      fh := WAttrib("fheight")
   fw := WAttrib("fwidth")
   maxw := \opts["w"] | \opts["s"] | 2 * \opts["h"]
   maxh := \opts["h"] | \opts["s"] | 2 * \opts["w"]

   # If no image size specified, try to guess to fill the window
   if /maxw then
      layout(*args)

   aspmax := real(maxw) / real(maxh)

   # Display the files.
   x := y := Gap
   bigw := bigh := 0
   areas := list()
   every fname := !args do {

      close(\f)
      close(\imwin)
      f := imwin := &null

      # Check for an interrupt
      while *Pending() > 0 do
         if Event() === QuitEvents() then
            return

      # Get the next file and translate its image.
      f := open(fname) |
         { write(&errout, fname, ": can't open"); next }

      # Read the image, full sized, into a scratch canvas
      if not (img := rdimage(fname, f, maxw, maxh)) then
         { write(&errout, fname, ": can't decode"); next }
      imwin := img.win

      # Scale the image to the desired size
      w := WAttrib(imwin, "width")
      h := WAttrib(imwin, "height")
      aspr := real(w) / real(h)
      if w > maxw | h > maxh then {
         if aspr > aspmax then {
            w := maxw
            h := maxw / aspr
            }
         else {
            w := maxh * aspr
            h := maxh
            }
         w <:= 1
         h <:= 1
         Zoom(imwin, , , , , , , w, h)
         }

      # Trim the file name if so requested.
      if \opts["t"] then
         fname ? {
            while tab(upto('/') + 1)
            ="cache"
            label := tab(upto('.') | 0)
            }
      else
         label := fname

      # Calculate the area needed for display
      cw := w					# cell width
      if /opts["u"] then
         cw <:= TextWidth(label)		# ensure room for label
      ch := h + fh				# cell height

      # Place the new image on a new row or new window if needed.
      if x + cw > ww | y + ch > wh then {	# if row or column is full

         if /opts["r"] then {
            x +:= bigw + Gap			# start new column
            y := Gap
            bigw := 0
            }
         else {
            x := Gap				# start new row
            y +:= bigh + Gap
            bigh := 0
            }

         if x + cw > ww | y + ch > wh then {
            # no room for new row or column
            pause()				# wait for OK
            EraseArea()				# clear the window
            ww := WAttrib("width")
            wh := WAttrib("height")
            x := y := Gap
            bigw := bigh := 0
            areas := list()
            }
         }

      # Draw the image and its label.
      CopyArea(imwin, &window, 0, 0, w, h, x, y)
      if /opts["u"] then
         DrawString(x, y + h + fh - WAttrib("descent"), label)

      # Record the space it occupies
      put(areas, area(fname, x - Gap / 2, y - Gap / 2, w + Gap, h + fh + Gap,
         img.fullw, img.fullh))

      # Move on to next position.
      if /opts["r"] then
         y +:= ch + Gap
      else
         x +:= cw + Gap
      bigh <:= ch
      bigw <:= cw
      }

   # All images have been displayed.  Wait for "q" before exiting.
   close(\f)
   close(\imwin)

   w := WAttrib("width")
   h := WAttrib("height")
   gg := 2 * Gap - 1
   FillPolygon(0, 0, 0, gg - 1, gg - 1, 0)
   FillPolygon(0, h, 0, h - gg, gg - 1, h - 1)
   FillPolygon(w, 0, w - gg, 0, w - 1, gg - 1)
   FillPolygon(w, h, w - gg, h - 1, w - 1, h - gg)

   while e := Event() do case e of {		# wait for event
      QuitEvents():		exit()		# quit on "q" etc
      !"sS":			snapshot()	# save window shapshot
      &lpress | &rpress:	info(e)		# display info about image
      }
end



#  layout(n) -- calculate layout for n images

$define GuessAspect 1.5		# aspect ratio guess used for layout

procedure layout(n)
   local aspf, nhigh, nwide

   aspf := real(ww) / real(wh) / GuessAspect
   nhigh := integer(sqrt(n / aspf) + 0.5)
   nhigh <:= 1
   nwide := (n + nhigh - 1) / nhigh
   maxw := ((ww - Gap) / nwide) - Gap
   maxh := ((wh - Gap) / nhigh) - Gap - fh
   maxw <:= MinWidth
   maxh <:= MinHeight

   if \opts["d"] then
      write(&errout, "npix=", n, " aspf=", aspf, " nhigh=", nhigh,
         " nwide=", nwide, " maxh=", maxh, " maxw=", maxw)
   return
end



## pause() -- wait for clearance to start a new window

procedure pause()
   local w, h, gg, e

   while *Pending() > 0 do		# consume and ignore older events
      Event()

   w := WAttrib("width")
   h := WAttrib("height")
   gg := 2 * Gap - 1
   DrawLine(0, gg - 1, gg - 1, 0)	# draw diagonals to indicate pause
   DrawLine(0, h - gg, gg - 1, h - 1)
   DrawLine(w - gg, 0, w - 1, gg - 1)
   DrawLine(w - gg, h - 1, w - 1, h - gg)

   while e := Event() do case e of {		# wait for event
      QuitEvents():		exit()		# quit on "q" etc
      !" \t\r\n":		break		# continue on "\r" etc
      !"sS":			snapshot()	# save window shapshot
      &lpress | &rpress:	info(e)		# display info about image
      }
   return
end



## info(event) -- display info about image under the mouse

$define InfoMargin 10	# margin around image
$define InfoHeight 80	# text area height
$define InfoWidth 300	# text area width

procedure info(e)
   local a, w, h, wmin, wmax, hmax

   wmin := InfoWidth + 2 * InfoMargin
   wmax := WAttrib("width") - 4 * InfoMargin
   hmax := WAttrib("height") - 5 * InfoMargin - InfoHeight

   every a := !areas do
      if InBounds(a.x, a.y, a.w, a.h) then {
         w := a.iw
         h := a.ih
         if w >:= wmax then
            h := a.ih * w / a.iw
         if h >:= hmax then
            w := a.iw * h / a.ih
         wmin <:= w + 2 * InfoMargin
         Popup(, , wmin, h + InfoHeight + 3 * InfoMargin, popinfo, a, e, w, h)
         break
         }
   return
end



##  popinfo(area, event, w, h) -- display info in the popup
#
#   if event was &rpress, wait for &rrelease
#   otherwise wait for &lpress, Enter, or space to dismiss

procedure popinfo(a, e, w, h)
   local f, i, n, x, y

   f := open(a.fname)
   seek(f, 0)
   n := where(f)
   seek(f, 1)
   i := rdimage(a.fname, f, w, h) | fail

   x := (WAttrib("clipw") - w) / 2
   y := InfoMargin
   Zoom(i.win, &window, , , , , x, y, w, h)

   Font("sans,bold,12")
   WAttrib("leading=16")
   GotoXY(0, InfoMargin + h + InfoMargin + WAttrib("ascent"))
   WWrite("    ", a.fname)
   WWrite("    ", a.iw, " x ", a.ih, " pixels")
   WWrite("    ", n, " bytes")
   WWrite("    ", iformat(f), " format")

   if e === &rpress then
      until Event() === &rrelease		# dismiss upon button release
   else {
      until Event() === &lrelease		# consume matching release
      until Event() === &lrelease | !" \n\r"	# wait for dismissal
   }

   WClose(i.win)
   return
end



## iformat(f) -- return image format of file f

procedure iformat(f)
   local s

   seek(f, 1)
   s := reads(f, 1024) | fail
   seek(f, 1)
   s ? {
      if ="GIF8"		then return "GIF"
      if ="\x89PNG"		then return "PNG"
      if ="\xFF\xD8\xFF"	then return "JPEG"
      if ="MM\x00\x2A"		then return "TIFF"
      if ="II\x2A\x00"		then return "TIFF"
      if =("P1" | "P4")		then return "PBM"
      if =("P2" | "P5")		then return "PGM"
      if =("P3" | "P6")		then return "PPM"
      if ="\x52\xCC"		then return "RLE"
      if ="BM"			then return "BMP"
      if find("XPM")		then return "XPM"
      fail
      }
end



## rdimage(fname, f, maxw, maxh) -- read image into scratch window

procedure rdimage(fname, f, maxw, maxh)
   local iwin

   case iformat(f) of {
      "GIF" | "XPM":		iwin := load(fname)
      "PNG":			iwin := convert(fname, "pngtopnm")
      "TIFF":			iwin := convert(fname, "tifftopnm")
      "PBM" | "PGM" | "PPM":	iwin := convert(fname, "cat")
      "RLE":			iwin := convert(fname, "rletopnm")
      "BMP":			iwin := convert(fname, "bmptoppm")
      "JPEG":			return jpegread(fname, maxw, maxh)
      }

   return imrec(\iwin, WAttrib(iwin, "width"), WAttrib(iwin, "height"))
end



## convert(fname, utilname) -- read image by converting through PPM to GIF

procedure convert(fname, utilname)
   needprog(utilname) | fail
   needprog("ppmquant") | fail
   needprog("ppmtogif") | fail
   return mkgif(utilname ||
      " 2>/dev/null | ppmquant 256 2>/dev/null | ppmtogif 2>/dev/null",
      fname)
end



## mkgif(cmd, fname) -- run filter to produce GIF file

procedure mkgif(cmd, fname)
   local win, f

   remove(tempname)
   cmd := "<\"" || fname || "\" " || cmd || " >" || tempname
   if \opts["d"] then
      write(&errout, "+ ", cmd)
   system(cmd)
   f := open(tempname) | fail
   win := load(tempname)
   close(f)
   remove(tempname)
   return \win
end



## jpegread(fname, maxw, maxh) -- read JPEG image

procedure jpegread(fname, maxw, maxh)
   local scale, iwin, irec

   $ifdef _JAVA
      iwin := load(fname)
      return imrec(\iwin, WAttrib(iwin, "width"), WAttrib(iwin, "height"))
   $else
      needprog("djpeg") | fail
      irec := imrec()
      if jsize(irec, fname) then
         scale := jscale(irec, \maxw, \maxh) | ""
      else
         scale := ""
      irec.win := mkgif("djpeg " || scale || " -g 2>/dev/null", fname) | fail
      /irec.fullw := WAttrib(iwin, "width")
      /irec.fullh := WAttrib(iwin, "height")
      return irec
   $endif


end



## jsize(irec, fname) -- set fullw and fullh fields for JPEG image

procedure jsize(irec, fname)
   local s, p, line, w, h

   s := ""
   p := open("rdjpgcom -verbose " || fname, "p") | fail
   while line := read(p) do line ? {
      ="JPEG image is "				| next
      w := tab(many(&digits))			| next
      ="w * "					| next
      h := tab(many(&digits))			| next
      ="h, "					| next
      close(p)
      irec.fullw := integer(w)
      irec.fullh := integer(h)
      return
      }
   close(p)
   fail
end



## jscale(irec, maxw, maxh) -- determine scaling for faster JPEG reading

procedure jscale(irec, maxw, maxh)
   local m

   m := irec.fullw / maxw
   m <:= irec.fullh / maxh
   if m >= 8 then return "-scale 1/8"
   if m >= 4 then return "-scale 1/4"
   if m >= 2 then return "-scale 1/2"
   return ""
end





## load(fname) -- read image using WOpen

procedure load(fname)
   return WOpen("canvas=hidden", "bg=" || WAttrib("bg"),
      "gamma=" || WAttrib("gamma"), "image=" || fname)
end



## needprog(s) -- check for presence of program s in $PATH
#
#  Fails if the program is not available.
#  Issues a diagnostic only once per program.

procedure needprog(s)
   static ptable
   initial ptable := table()

   /ptable[s] := pathfind(s, map(getenv("PATH"), ":", " ")) |
      (write(&errout, "can't find program \"", s, "\" in $PATH") & "")
   return "" ~=== ptable[s]
end