home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / gprogs / gallery.icn < prev    next >
Text File  |  2001-05-29  |  15KB  |  573 lines
  1. ############################################################################
  2. #
  3. #    File:     gallery.icn
  4. #
  5. #    Subject:  Program to display many images at once
  6. #
  7. #    Author:   Gregg M. Townsend
  8. #
  9. #    Date:     May 29, 2001
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #  Usage:  gallery [-{gc}n] [-{whs}nnn] [-{rmtud}] file...
  18. #
  19. #  Gallery displays multiple images in a single window.  The images
  20. #  are shrunken by resampling and tiled in columns or rows.
  21. #
  22. #  GIF and XPM format images are always supported.  JPEG format is
  23. #  supported when built by Jcon.  Raw-mode PPM files are supported
  24. #  if the v9 loadfunc() library is available.  JPEG, PPM, and RLE
  25. #  formats are also available under Unix if the necessary conversion
  26. #  utilities are available in the shell search path.
  27. #
  28. #  When the window fills, diagonal lines in the extreme corners of the
  29. #  window indicate that you can press Enter for the next screenful.
  30. #  Solid triangles appear when there are no more images; press Q to exit.
  31. #
  32. #  At either of those pauses, the clicking the left mouse button on an
  33. #  image displays a popup window with information about the image.  A
  34. #  second click dismisses the popup, as does the space bar or Enter key.
  35. #  The right mouse button activates the same popup momentarily until
  36. #  the button is released.
  37. #
  38. #  -cn or -gn selects the color palette used; -c6 is the default.
  39. #  (However, -g30 may look better even for color images.)
  40. #  The color palette is ignored when built by Jcon.
  41. #
  42. #  -wnnn sets the maximum width for displaying an image;
  43. #  -hnnn sets the maximum height.  -snnn sets both.
  44. #  By default, sizes are chosen automatically, subject to a minimum
  45. #  size of 32x32, to allow all images to fit in a single window.
  46. #
  47. #  -r arranges images in rows instead of columns.
  48. #  -m maximizes the window size before displaying images.
  49. #  -t trims file names of leading path components and extensions.
  50. #  -u shows images completely unlabeled.
  51. #  -d prints some debugging information.
  52. #
  53. ############################################################################
  54. #
  55. #  Requires:  Version 9 graphics
  56. #
  57. ############################################################################
  58. #
  59. #  Links: graphics, imscolor, options, io, random, cfunc
  60. #
  61. ############################################################################
  62.  
  63.  
  64. #  TO DO:
  65. #
  66. #  improve prompts -- something more obvious & intuitive
  67.  
  68.  
  69. link graphics
  70. link imscolor
  71. link options
  72. link io
  73. link random
  74.  
  75.  
  76. $undef _DYNAMIC_LOADING        # delete this to enable direct PPM reading
  77.  
  78. $ifdef _DYNAMIC_LOADING
  79. link cfunc
  80. $endif
  81.  
  82.  
  83. $define DefPalette "c6"        # default palette
  84. $define Gap 4            # gap between images
  85.  
  86. $define MinWidth 32        # minimum width if auto-scaled
  87. $define MinHeight 32        # minimum height if auto-scaled
  88.  
  89.  
  90. record area(fname, x, y, w, h, iw, ih)
  91.  
  92. global opts            # command options
  93. global tempname            # temporary file name
  94.  
  95. global pal            # selected palette (if any)
  96.  
  97. global ww, wh, fh, fw        # window dimensions
  98. global maxw, maxh        # maximum size of displayed image
  99.  
  100. global areas            # areas used for display
  101.  
  102.  
  103.  
  104. procedure main(args)
  105.    local cw, ch, bigh, bigw, x, y, w, h, gg, aspr, aspmax, horz
  106.    local fname, label, f, tw, s, nchars, nlines, imwin, e
  107.  
  108.    # generate a random name for the temporary file
  109.    randomize()
  110.    tempname := "/tmp/gal" || right(?99999, 5, "0") || ".tmp"
  111.  
  112.    # open the window and process options
  113.    Window("size=800,500", "bg=pale gray", "font=sans,8", args)
  114.    opts := options(args, "g+c+w+h+s+rmtud")
  115.    if \opts["m"] then
  116.       WAttrib("canvas=maximal")
  117.    if *args = 0 then
  118.       stop("usage: ", &progname, " [-{gc}n] [-{whd}nnn] [-{mtv}] file...")
  119.  
  120.    # allow user resizing of window
  121.    &error := 1
  122.    WAttrib("resize=on")
  123.    &error := 0
  124.  
  125.    # record window dimensions
  126.    ww := WAttrib("width")
  127.    wh := WAttrib("height")
  128.    if \opts["u"] then
  129.       fh := 0
  130.    else
  131.       fh := WAttrib("fheight")
  132.    fw := WAttrib("fwidth")
  133.    maxw := \opts["w"] | \opts["s"] | 2 * \opts["h"]
  134.    maxh := \opts["h"] | \opts["s"] | 2 * \opts["w"]
  135.  
  136.    # If no image size specified, try to guess to fill the window
  137.    if /maxw then
  138.       layout(*args)
  139.  
  140.    aspmax := real(maxw) / real(maxh)
  141.  
  142.    pal := ("c" || \opts["c"]) | ("g" || \opts["g"]) | DefPalette
  143.    PaletteChars(pal) | stop("invalid palette ", pal)
  144.  
  145.    # Display the files.
  146.    x := y := Gap
  147.    bigw := bigh := 0
  148.    areas := list()
  149.    every fname := !args do {
  150.  
  151.       close(\f)
  152.       close(\imwin)
  153.       f := imwin := &null
  154.  
  155.       # Check for an interrupt
  156.       while *Pending() > 0 do
  157.          if Event() === QuitEvents() then
  158.             return
  159.  
  160.       # Get the next file and translate its image.
  161.       f := open(fname) |
  162.          { write(&errout, fname, ": can't open"); next }
  163.  
  164.       # Read the image, full sized, into a scratch canvas
  165.       if not (imwin := rdimage(fname, f)) then
  166.          { write(&errout, fname, ": can't decode"); next }
  167.  
  168.       # Scale the image to the desired size
  169.       w := WAttrib(imwin, "width")
  170.       h := WAttrib(imwin, "height")
  171.       aspr := real(w) / real(h)
  172.       if w > maxw | h > maxh then {
  173.          if aspr > aspmax then {
  174.             w := maxw
  175.             h := maxw / aspr
  176.             }
  177.          else {
  178.             w := maxh * aspr
  179.             h := maxh
  180.             }
  181.          w <:= 1
  182.          h <:= 1
  183.          Zoom(imwin, , , , , , , w, h)
  184.          }
  185.  
  186.       # Trim the file name if so requested.
  187.       if \opts["t"] then
  188.          fname ? {
  189.             while tab(upto('/') + 1)
  190.             ="cache"
  191.             label := tab(upto('.') | 0)
  192.             }
  193.       else
  194.          label := fname
  195.  
  196.       # Calculate the area needed for display
  197.       cw := w                    # cell width
  198.       if /opts["u"] then
  199.          cw <:= TextWidth(label)        # ensure room for label
  200.       ch := h + fh                # cell height
  201.  
  202.       # Place the new image on a new row or new window if needed.
  203.       if x + cw > ww | y + ch > wh then {    # if row or column is full
  204.  
  205.          if /opts["r"] then {
  206.             x +:= bigw + Gap            # start new column
  207.             y := Gap
  208.             bigw := 0
  209.             }
  210.          else {
  211.             x := Gap                # start new row
  212.             y +:= bigh + Gap
  213.             bigh := 0
  214.             }
  215.  
  216.          if x + cw > ww | y + ch > wh then {
  217.             # no room for new row or column
  218.             pause()                # wait for OK
  219.             EraseArea()                # clear the window
  220.             ww := WAttrib("width")
  221.             wh := WAttrib("height")
  222.             x := y := Gap
  223.             bigw := bigh := 0
  224.             areas := list()
  225.             }
  226.          }
  227.  
  228.       # Draw the image and its label.
  229.       CopyArea(imwin, &window, 0, 0, w, h, x, y)
  230.       if /opts["u"] then
  231.          DrawString(x, y + h + fh - WAttrib("descent"), label)
  232.  
  233.       # Record the space it occupies
  234.       put(areas, area(fname, x - Gap / 2, y - Gap / 2, w + Gap, h + fh + Gap,
  235.          WAttrib(imwin, "width"), WAttrib(imwin, "height")))
  236.  
  237.       # Move on to next position.
  238.       if /opts["r"] then
  239.          y +:= ch + Gap
  240.       else
  241.          x +:= cw + Gap
  242.       bigh <:= ch
  243.       bigw <:= cw
  244.       }
  245.  
  246.    # All images have been displayed.  Wait for "q" before exiting.
  247.    close(\f)
  248.    close(\imwin)
  249.  
  250.    w := WAttrib("width")
  251.    h := WAttrib("height")
  252.    gg := 2 * Gap - 1
  253.    FillPolygon(0, 0, 0, gg - 1, gg - 1, 0)
  254.    FillPolygon(0, h, 0, h - gg, gg - 1, h - 1)
  255.    FillPolygon(w, 0, w - gg, 0, w - 1, gg - 1)
  256.    FillPolygon(w, h, w - gg, h - 1, w - 1, h - gg)
  257.  
  258.  
  259.    while e := Event() do case e of {        # wait for event
  260.       QuitEvents():        exit()        # quit on "q" etc
  261.       &lpress | &rpress:    info(e)        # display info about image
  262.       }
  263. end
  264.  
  265.  
  266.  
  267. #  layout(n) -- calculate layout for n images
  268.  
  269. $define GuessAspect 1.5        # aspect ratio guess used for layout
  270.  
  271. procedure layout(n)
  272.    local aspf, nhigh, nwide
  273.  
  274.    aspf := real(ww) / real(wh) / GuessAspect
  275.    nhigh := integer(sqrt(n / aspf) + 0.5)
  276.    nhigh <:= 1
  277.    nwide := (n + nhigh - 1) / nhigh
  278.    maxw := ((ww - Gap) / nwide) - Gap
  279.    maxh := ((wh - Gap) / nhigh) - Gap - fh
  280.    maxw <:= MinWidth
  281.    maxh <:= MinHeight
  282.  
  283.    if \opts["d"] then
  284.       write(&errout, "npix=", n, " aspf=", aspf, " nhigh=", nhigh,
  285.          " nwide=", nwide, " maxh=", maxh, " maxw=", maxw)
  286.    return
  287. end
  288.  
  289.  
  290.  
  291. ## pause() -- wait for clearance to start a new window
  292.  
  293. procedure pause()
  294.    local w, h, gg, e
  295.  
  296.    while *Pending() > 0 do        # consume and ignore older events
  297.       Event()
  298.  
  299.    w := WAttrib("width")
  300.    h := WAttrib("height")
  301.    gg := 2 * Gap - 1
  302.    DrawLine(0, gg - 1, gg - 1, 0)    # draw diagonals to indicate pause
  303.    DrawLine(0, h - gg, gg - 1, h - 1)
  304.    DrawLine(w - gg, 0, w - 1, gg - 1)
  305.    DrawLine(w - gg, h - 1, w - 1, h - gg)
  306.  
  307.    while e := Event() do case e of {        # wait for event
  308.       QuitEvents():        exit()        # quit on "q" etc
  309.       !" \t\r\n":        break        # continue on "\r" etc
  310.       &lpress | &rpress:    info(e)        # display info about image
  311.       }
  312.    return
  313. end
  314.  
  315.  
  316.  
  317. ## info(event) -- display info about image under the mouse
  318.  
  319. $define InfoMargin 10    # margin around image
  320. $define InfoHeight 80    # text area height
  321. $define InfoWidth 300    # text area width
  322.  
  323. procedure info(e)
  324.    local a, w, h, wmin, wmax, hmax
  325.  
  326.    wmin := InfoWidth + 2 * InfoMargin
  327.    wmax := WAttrib("width") - 4 * InfoMargin
  328.    hmax := WAttrib("height") - 5 * InfoMargin - InfoHeight
  329.  
  330.    every a := !areas do
  331.       if InBounds(a.x, a.y, a.w, a.h) then {
  332.          w := a.iw
  333.          h := a.ih
  334.          if w >:= wmax then
  335.             h := a.ih * w / a.iw
  336.          if h >:= hmax then
  337.             w := a.iw * h / a.ih
  338.          wmin <:= w + 2 * InfoMargin
  339.          Popup(, , wmin, h + InfoHeight + 3 * InfoMargin, popinfo, a, e, w, h)
  340.          break
  341.          }
  342.    return
  343. end
  344.  
  345.  
  346.  
  347. ##  popinfo(area, event, w, h) -- display info in the popup
  348. #
  349. #   if event was &rpress, wait for &rrelease
  350. #   otherwise wait for &lpress, Enter, or space to dismiss
  351.  
  352. procedure popinfo(a, e, w, h)
  353.    local f, i, n, x, y
  354.  
  355.    f := open(a.fname)
  356.    seek(f, 0)
  357.    n := where(f)
  358.    seek(f, 1)
  359.    i := rdimage(a.fname, f) | fail
  360.  
  361.    x := (WAttrib("clipw") - w) / 2
  362.    y := InfoMargin
  363.    Zoom(i, &window, , , , , x, y, w, h)
  364.  
  365.    Font("sans,bold,12")
  366.    WAttrib("leading=16")
  367.    GotoXY(0, InfoMargin + h + InfoMargin + WAttrib("ascent"))
  368.    WWrite("    ", a.fname)
  369.    WWrite("    ", a.iw, " x ", a.ih, " pixels")
  370.    WWrite("    ", n, " bytes")
  371.    WWrite("    ", iformat(f), " format")
  372.  
  373.    if e === &rpress then
  374.       until Event() === &rrelease        # dismiss upon button release
  375.    else {
  376.       until Event() === &lrelease        # consume matching release
  377.       until Event() === &lrelease | !" \n\r"    # wait for dismissal
  378.    }
  379.  
  380.    WClose(i)
  381.    return
  382. end
  383.  
  384.  
  385.  
  386. ## rdimage(fname, f) -- read image into scratch window
  387.  
  388. procedure rdimage(fname, f)
  389.    return case iformat(f) of {
  390.       "GIF":        gifread(f, fname, pal)
  391.       "JPEG":        jpegread(f, fname, pal)
  392.       "PBM" | "PGM":    pnmread(f, fname, pal)
  393.       "PPM":        ppmread(f, fname, pal)
  394.       "RLE":        rleread(f, fname, pal)
  395.       "XPM":        xpmread(f, fname, pal)
  396.       }
  397. end
  398.  
  399.  
  400.  
  401. ## iformat(f) -- return image format of file f
  402.  
  403. procedure iformat(f)
  404.    local s
  405.  
  406.    seek(f, 1)
  407.    s := reads(f, 1024) | fail
  408.    seek(f, 1)
  409.    s ? {
  410.       if ="GIF8"        then return "GIF"
  411.       if ="\xFF\xD8\xFF"    then return "JPEG"
  412.       if =("P1" | "P4")        then return "PBM"
  413.       if =("P2" | "P5")        then return "PGM"
  414.       if =("P3" | "P6")        then return "PPM"
  415.       if ="\x52\xCC"        then return "RLE"
  416.       if find("XPM")        then return "XPM"
  417.       fail
  418.       }
  419. end
  420.  
  421.  
  422.  
  423. ## xpmread(f, fname, pal) -- read XPM image from file f, named fname
  424.  
  425. procedure xpmread(f, fname, pal)
  426.    local s, w, h, win
  427.  
  428.    s := XPMImage(f, pal) | fail
  429.    w := imswidth(s)
  430.    h := imsheight(s)
  431.    win := WOpen("canvas=hidden", "bg=" || WAttrib("bg"),
  432.       "width=" || w, "height=" || h) | fail
  433.    DrawImage(win, 0, 0, s)
  434.    return win
  435. end
  436.  
  437.  
  438.  
  439. ## gifread(f, fname, pal) -- read GIF image from file f, named fname
  440. #
  441. #  WOpen("image=") is avoided because that consumes color palette entries.
  442. #  Instead, the image is read using ReadImage with a palette restriction.
  443. #
  444. #  gifread returns a window containing the image.
  445. #  It fails if for any reason the image cannot be read.
  446.  
  447. procedure gifread(f, fname, pal)
  448.    local w, h, win
  449.  
  450. $ifdef _JAVA        # no palettes, no problem
  451.    return WOpen("canvas=hidden", "bg=" || WAttrib("bg"), "image=" || fname)
  452. $else
  453.  
  454.    (reads(f, 10) | fail) ? {        # read header
  455.       ="GIF8" | fail
  456.       move(2)
  457.       w := ord(move(1)) + 256 * ord(move(1))    # width
  458.       h := ord(move(1)) + 256 * ord(move(1))    # height
  459.       }
  460.    win := WOpen("canvas=hidden", "bg=" || WAttrib("bg"),
  461.       "width=" || w, "height=" || h) | fail
  462.    if ReadImage(win, fname, 0, 0, pal) then
  463.       return win
  464.    close(win)
  465.    fail
  466.  
  467. $endif
  468. end
  469.  
  470.  
  471.  
  472. ## jpegread(f, fname, pal) -- read JPEG image
  473.  
  474. procedure jpegread(f, fname, pal)
  475.  
  476. $ifdef _JAVA
  477.    return WOpen("canvas=hidden", "bg=" || WAttrib("bg"), "image=" || fname)
  478. $else
  479.    needprog("djpeg") | fail
  480.    return filter("djpeg -g 2>/dev/null", fname, pal)
  481. $endif
  482.  
  483. end
  484.  
  485.  
  486.  
  487. ## ppmread(f, fname, pal) -- read PPM file
  488.  
  489. procedure ppmread(f, fname, pal)
  490.  
  491. $ifdef _DYNAMIC_LOADING
  492.    return rawppm(f, fname, pal) | pnmread(f, fname, pal)
  493. $else
  494.    return pnmread(f, fname, pal)
  495. $endif
  496.  
  497. end
  498.  
  499.  
  500.  
  501. ## pnmread(f, fname, pal) -- read PPM/PGM/PBM image by spawning converter
  502.  
  503. procedure pnmread(f, fname, pal)
  504.    needprog("ppmquant") | fail
  505.    needprog("ppmtogif") | fail
  506.    return filter("ppmquant 256 2>/dev/null | ppmtogif 2>/dev/null", fname, pal)
  507. end
  508.  
  509.  
  510.  
  511. $ifdef _DYNAMIC_LOADING
  512.  
  513. ## rawppm(f, fname, pal) -- read raw-mode PPM file f, named fname
  514.  
  515. procedure rawppm(f, fname, pal)
  516.    local w, h, s, win
  517.  
  518.    s := ""
  519.    while s ||:= reads(f, 200000)
  520.    w := ppmwidth(s) | fail
  521.    h := ppmheight(s)
  522.    win := WOpen("canvas=hidden", "width=" || w, "height=" || h) | fail
  523.    DrawImage(win, 0, 0, ppmimage(s, pal, ""))
  524.    return win
  525. end
  526.  
  527. $endif  # _DYNAMIC_LOADING
  528.  
  529.  
  530.  
  531. ## rleread(f, fname, pal) -- read Utah RLE image
  532.  
  533. procedure rleread(f, fname, pal)
  534.    needprog("rlequant") | fail
  535.    needprog("rletogif") | fail
  536.    return filter("rlequant | rletogif", fname, pal)
  537. end
  538.  
  539.  
  540.  
  541. ## filter(cmd, fname, pal) -- run filter to produce GIF file
  542.  
  543. procedure filter(cmd, fname, pal)
  544.    local win, f
  545.  
  546.    remove(tempname)
  547.    cmd := "<" || fname || " " || cmd || " >" || tempname
  548.    if \opts["d"] then
  549.       write(&errout, "+ ", cmd)
  550.    system(cmd)
  551.    f := open(tempname) | fail
  552.    win := gifread(f, tempname, pal)
  553.    close(f)
  554.    remove(tempname)
  555.    return \win
  556. end
  557.  
  558.  
  559.  
  560. ## needprog(s) -- check for presence of program s in $PATH
  561. #
  562. #  Fails if the program is not available.
  563. #  Issues a diagnostic only once per program.
  564.  
  565. procedure needprog(s)
  566.    static ptable
  567.    initial ptable := table()
  568.  
  569.    /ptable[s] := pathfind(s, map(getenv("PATH"), ":", " ")) |
  570.       (write(&errout, "can't find program \"", s, "\" in $PATH") & "")
  571.    return "" ~=== ptable[s]
  572. end
  573.