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 / gprocs / imsutils.icn < prev    next >
Text File  |  2001-05-02  |  12KB  |  608 lines
  1. ############################################################################
  2. #
  3. #    File:     imsutils.icn
  4. #
  5. #    Subject:  Procedures to manipulate image specifications
  6. #
  7. #    Author:   Ralph E. Griswold
  8. #
  9. #    Date:     May 2, 2001
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #  This file contains procedures that manipulate string representations for
  18. #  images.
  19. #
  20. #    patident(imx1, imx2)
  21. #    XDrawTile(win, xoff, yoff, pattern, magnif, mode)
  22. #    XDrawRows(win, xoff, yoff, imx, magnif, mode)
  23. #    bits2hex(s)
  24. #    decspec(pattern)
  25. #    getpatt(line)
  26. #    getpattnote(line)
  27. #    hex2bits(s)
  28. #    hexspec(pattern)
  29. #    legalpat(tile)
  30. #    legaltile(tile)
  31. #    pat2xbm(pattern, name)
  32. #    tilebits(imx)
  33. #    pdensity(pattern)
  34. #    pix2pat(window, x, y, cols, rows)
  35. #    readims(input)
  36. #    readimsline(input)
  37. #    rowbits(pattern)
  38. #    imstoimx(ims)
  39. #    imxtoims(imx)
  40. #    showbits(pattern)
  41. #    tiledim(pattern)
  42. #    pheight(pattern)
  43. #    pwidth(pattern)
  44. #    xbm2rows(input)
  45. #
  46. ############################################################################
  47. #
  48. #  Requires:  Version 8.11 graphics
  49. #
  50. ############################################################################
  51. #
  52. #  Links:  convert
  53. #
  54. ############################################################################
  55.  
  56. $include "xnames.icn"
  57.  
  58. link convert
  59.  
  60. record tdim(w, h)
  61.  
  62. #
  63. #  Test whether two image matrices are equivalent
  64.  
  65. procedure patident(imx1, imx2)
  66.    local i
  67.  
  68.    if *imx1 ~= *imx2 then fail
  69.    if **imx1 ~= **imx2 then fail
  70.  
  71.    every i := 1 to *imx1 do
  72.       if imx1[i] ~== imx2[1] then fail
  73.  
  74.    return imx2
  75.  
  76. end
  77. #
  78. #  Draw a tile at a given location.  If mode is nonnull, the
  79. #  area on which the tile is drawn is erased.
  80.  
  81. procedure XDrawTile(win, xoff, yoff, pattern, magnif, mode)
  82.    local x, y, row, pixel, dims, arglist
  83.  
  84.    if type(win) ~== "window" then {
  85.       win :=: xoff :=: yoff :=: pattern :=: mode
  86.       win := &window
  87.       }
  88.  
  89.    if magnif = 1 then XDrawImage(win, xoff, yoff, pattern, mode)
  90.    else {
  91.       if \mode then {
  92.          dims := tiledim(pattern)
  93.          XEraseArea(xoff, yoff, dims.w * magnif, dims.h * magnif)
  94.          }
  95.       y := yoff
  96.       every row := rowbits(pattern) do {        # draw a row
  97.          x := xoff
  98.          arglist := []
  99.          every pixel := !row do {
  100.             if pixel = "1" then put(arglist, x, y, magnif, magnif)
  101.             x +:= magnif
  102.             }
  103.          y +:= magnif
  104.          if *arglist = 0 then next
  105.          XFillRectangle ! arglist
  106.          }
  107.       }
  108.  
  109.    return
  110.  
  111. end
  112. #
  113. #  Draw image matrix at a given location.  If mode is nonnull, the
  114. #  area on which the tile is drawn is erased.
  115.  
  116. procedure XDrawRows(win, xoff, yoff, imx, magnif, mode)
  117.    local x, y, row, pixel, arglist
  118.  
  119.    if type(win) ~== "window" then {
  120.       win :=: xoff :=: yoff :=: imx :=: magnif :=: mode
  121.       win := &window
  122.       }
  123.  
  124.    /magnif := 1
  125.  
  126.    y := yoff
  127.  
  128.    if \mode then
  129.       XEraseArea(xoff, yoff, *imx[1] * magnif, *imx * magnif)
  130.  
  131.    every row := !imx do {        # draw a row
  132.       x := xoff
  133.       arglist := []
  134.  
  135.       if magnif = 1 then {
  136.          every pixel := !row do {
  137.             if pixel == "1" then put(arglist, x, y)
  138.             x +:= 1
  139.             }
  140.          y +:= 1
  141.          }
  142.       else {
  143.          every pixel := !row do {
  144.             if pixel = "1" then put(arglist, x, y, magnif, magnif)
  145.             x +:= magnif
  146.             }
  147.          y +:= magnif
  148.          }
  149.       if *arglist = 0 then next
  150.       if magnif = 1 then XDrawPoint ! arglist else XFillRectangle ! arglist
  151.       }
  152.  
  153.    return
  154.  
  155. end
  156.  
  157. #
  158. #  Convert bit string to hex pattern string
  159.  
  160. procedure bits2hex(s)
  161.    static bittab
  162.    local hex
  163.  
  164.    initial {
  165.       bittab := table()
  166.       bittab["0000"] := "0"
  167.       bittab["1000"] := "1"
  168.       bittab["0100"] := "2"
  169.       bittab["1100"] := "3"
  170.       bittab["0010"] := "4"
  171.       bittab["1010"] := "5"
  172.       bittab["0110"] := "6"
  173.       bittab["1110"] := "7"
  174.       bittab["0001"] := "8"
  175.       bittab["1001"] := "9"
  176.       bittab["0101"] := "a"
  177.       bittab["1101"] := "b"
  178.       bittab["0011"] := "c"
  179.       bittab["1011"] := "d"
  180.       bittab["0111"] := "e"
  181.       bittab["1111"] := "f"
  182.       }
  183.  
  184.    hex := ""
  185.  
  186.    s ? {
  187.        while hex := bittab[move(4)] || hex
  188.        if not pos(0) then hex := bittab[left(tab(0), 4, "0")] || hex
  189.        }
  190.  
  191.    return hex
  192.  
  193. end
  194.  
  195. #
  196. #  Convert pattern specification to decimal form
  197.  
  198. procedure decspec(pattern)
  199.    local cols, chunk, dec
  200.  
  201.    pattern ? {
  202.       if not upto("#") then return pattern
  203.       cols := tab(upto(','))
  204.       move(2)
  205.       chunk := (cols + 3) / 4
  206.       dec := cols || ","
  207.       while dec ||:= integer("16r" || move(chunk)) || ","
  208.       }
  209.  
  210.    return dec[1:-1]
  211.  
  212. end
  213.  
  214. #
  215. #  Get pattern from line.  It trims off leading and trailing whitespace
  216. #  and removes any annotation (beginning with a # after the first whitespace
  217.  
  218. procedure getpatt(line)
  219.  
  220.    line ? {
  221.       tab(many(' \t'))
  222.       return tab(upto(' \t') | 0)
  223.       }
  224.  
  225. end
  226.  
  227. #
  228. #  Get pattern annotation.  It returns an empty string if there is
  229. #  no annotation.
  230.  
  231. procedure getpattnote(line)
  232.  
  233.    line ? {
  234.       tab(many(' \t'))            # remove leading whitespace
  235.       tab(upto(' \t')) | return ""    # skip pattern
  236.       tab(upto('#')) | return ""    # get to annotation
  237.       tab(many('# \t'))            # get rid of leading junk
  238.       return tab(0)            # annotation
  239.       }
  240.  
  241. end
  242.  
  243. #  Convert hexadecimal string to bits
  244.  
  245. procedure hex2bits(s)
  246.    static hextab
  247.    local bits
  248.  
  249.    initial {
  250.       hextab := table()
  251.       hextab["0"] := "0000"
  252.       hextab["1"] := "0001"
  253.       hextab["2"] := "0010"
  254.       hextab["3"] := "0011"
  255.       hextab["4"] := "0100"
  256.       hextab["5"] := "0101"
  257.       hextab["6"] := "0110"
  258.       hextab["7"] := "0111"
  259.       hextab["8"] := "1000"
  260.       hextab["9"] := "1001"
  261.       hextab["a"] := "1010"
  262.       hextab["b"] := "1011"
  263.       hextab["c"] := "1100"
  264.       hextab["d"] := "1101"
  265.       hextab["e"] := "1110"
  266.       hextab["f"] := "1111"
  267.       }
  268.  
  269.    bits := ""
  270.  
  271.    map(s) ? {
  272.       while bits ||:= hextab[move(1)]
  273.       }
  274.  
  275.    return bits
  276.  
  277. end
  278.  
  279. #
  280. #  Convert pattern to hexadecimal form
  281.  
  282. procedure hexspec(pattern)
  283.    local cols, chunk, hex
  284.  
  285.    pattern ? {
  286.       if find("#") then return pattern
  287.       cols := tab(upto(','))
  288.       move(1)
  289.       chunk := (cols + 3) / 4
  290.       hex := cols || ",#"
  291.       while hex ||:= right(exbase10(tab(upto(',') | 0), 16), chunk, "0") do
  292.          move(1) | break
  293.       }
  294.  
  295.    return hex
  296.  
  297. end
  298.  
  299. #
  300. #  Succeed if tile is legal and small enough for (X) pattern.  Other
  301. #  windows systems may be more restrictive.
  302.  
  303. procedure legalpat(tile)
  304.  
  305.    if not legaltile(tile) then fail
  306.  
  307.    tile ? {
  308.       if 0 < integer(tab(upto(','))) <= 32 then return tile
  309.       else fail
  310.       }
  311.  
  312. end
  313.  
  314. #
  315. #  Succeed if tile is legal.  Accepts tiles that are too big for
  316. #  patterns.
  317.  
  318. procedure legaltile(tile)
  319.  
  320.    map(tile) ? {                # first check syntax
  321.       (tab(many(&digits)) & =",") | fail
  322.       if ="#" then (tab(many('0123456789abcdef')) & pos(0)) | fail
  323.       else {
  324.          while tab(many(&digits)) do {
  325.             if pos(0) then break    # okay; end of string
  326.             else ="," | fail
  327.             }
  328.          if not pos(0) then fail    # non-digit
  329.          }
  330.       }
  331.  
  332.    return hexspec(decspec(tile)) == tile
  333.  
  334. end
  335.  
  336. #
  337. #  Convert pattern specification to an XBM image file.
  338.  
  339. procedure pat2xbm(pattern, name)
  340.    local dims, chunk, row
  341.  
  342.    /name := "noname"
  343.  
  344.    dims := tiledim(pattern)
  345.  
  346.  
  347.    write("#define ", name, "_width ", dims.w)
  348.    write("#define ", name, "_height ", dims.h)
  349.    write("static char ", name, "_bits[] = {")
  350.  
  351.    chunk := (dims.w + 3) / 4
  352.  
  353.    pattern ? {
  354.       tab(upto('#') + 1)
  355.       while row := move(chunk) do {
  356.          if *row % 2 ~= 0 then row := "0" || row
  357.          row ? {
  358.             tab(0)
  359.             while writes("0x", move(-2), ",")
  360.             }
  361.          write()
  362.          }
  363.       }
  364.  
  365.    write("};")
  366.  
  367. end
  368.  
  369. #
  370. #  Count the number of bits set in a tile
  371.  
  372. procedure tilebits(imx)
  373.    local bits
  374.  
  375.    bits := 0
  376.  
  377.    every bits +:= !!imx
  378.  
  379.    return bits
  380.  
  381. end
  382.  
  383. #
  384. #  Compute density (percentage of black bits) of pattern
  385.  
  386. procedure pdensity(pattern)
  387.  
  388.    local dark, dims
  389.  
  390.    dims := tiledim(pattern)
  391.  
  392.    hexspec(pattern) ? {
  393.       dark := 0
  394.       every rowbits(pattern) ? {
  395.          every upto('1') do
  396.             dark +:= 1
  397.             }
  398.       return dark / real(dims.w * dims.h)
  399.       }
  400.  
  401. end
  402.  
  403. #
  404. #  Procedure to produce pattern specification from a section of a window.
  405.  
  406. procedure pix2pat(window, x, y, cols, rows)
  407.    local c, tile, pattern, pixels, y0
  408.  
  409.    pattern := ""
  410.  
  411.    every y0 := 0 to rows - 1 do {
  412.       pixels := ""
  413.       every c := Pixel(window, x, y0 + y, cols, 1) do
  414.          pixels ||:= (if c == "0,0,0" then "1" else "0")
  415.       pattern ||:= bits2hex(pixels)
  416.       }
  417.  
  418.    if *pattern = 0 then fail        # out of bounds specification
  419.    else return cols || ",#" || pattern
  420.  
  421. end
  422.  
  423. #
  424. #  Read pattern.  It skips lines starting with a #,
  425. #  empty lines, and trims off any trailing characters after the
  426. #  first whitespace of a pattern.
  427.  
  428. procedure readims(input)
  429.    local line
  430.  
  431.    while line := read(input) do
  432.       line ? {
  433.          if pos(0) | ="#" then next
  434.          return tab(upto(' \t') | 0)
  435.          }
  436.  
  437.    fail
  438.  
  439. end
  440.  
  441. #  
  442. #  Read pattern line.  It skips lines starting with a # and empty lines but
  443. #  does not trim off any trailing characters after the first whitespace of
  444. #  a pattern.
  445.  
  446. procedure readimsline(input)
  447.    local line
  448.  
  449.    while line := read(input) do
  450.       line ? {
  451.          if pos(0) | ="#" then next
  452.          return tab(0)
  453.          }
  454.  
  455.    fail
  456.  
  457. end
  458.  
  459. #
  460. #  Generate rows of bits in a pattern.  Doesn't work correctly for small
  461. #  patterns.  (Why?)
  462.  
  463. procedure rowbits(pattern)
  464.    local row, dims, chunk, hex
  465.  
  466.    dims := tiledim(pattern)
  467.  
  468.    hexspec(pattern) ? {
  469.       tab(upto(',') + 2)
  470.       hex := tab(0)
  471.       chunk := *hex / dims.h
  472.       hex ? {
  473.          while row := right(hex2bits(move(chunk)), dims.w, "0") do
  474.             suspend reverse(row)
  475.          }
  476.       }
  477.  
  478. end
  479.  
  480. #
  481. #  Produce an image matrix from a image string
  482.  
  483. procedure imstoimx(ims)
  484.    local imx
  485.  
  486.    imx := []
  487.  
  488.    every put(imx, rowbits(ims))
  489.  
  490.    return imx
  491.  
  492. end
  493.  
  494. #
  495. #  Convert row list to pattern specification
  496.  
  497. procedure imxtoims(imx)
  498.    local pattern
  499.  
  500.    pattern := *imx[1] || ",#"
  501.  
  502.    every pattern ||:= bits2hex(!imx)
  503.  
  504.    return pattern
  505.  
  506. end
  507.  
  508. #  Show bits of a pattern
  509.  
  510. procedure showbits(pattern)
  511.  
  512.    every write(rowbits(pattern))
  513.  
  514.    write()
  515.  
  516.    return
  517.  
  518. end
  519.  
  520.  
  521. #
  522. #  Produce dimensions of the tile for a pattern
  523.  
  524. procedure tiledim(pattern)
  525.    local cols
  526.  
  527.    hexspec(pattern) ? {
  528.       cols := integer(tab(upto(',')))
  529.       move(2)
  530.       return tdim(cols, *tab(0) / ((cols + 3) / 4))
  531.       }
  532.  
  533. end
  534.  
  535. #
  536. #  Produce height of a pattern specification
  537.  
  538. procedure pheight(pattern)
  539.    local cols
  540.  
  541.    hexspec(pattern) ? {
  542.       cols := integer(tab(upto(',')))
  543.       move(2)
  544.       return  *tab(0) / ((cols + 3) / 4)
  545.       }
  546.  
  547. end
  548.  
  549. #
  550. #  Produce width of a pattern specification
  551.  
  552. procedure pwidth(pattern)
  553.  
  554.    hexspec(pattern) ? {
  555.       return integer(tab(upto(',')))
  556.       }
  557.  
  558. end
  559.  
  560. #
  561. #  Generate rows of bits from an XBM file.  Note:  This apparently
  562. #  is not quite right if there are more than 2 hex digits per
  563. #  literal.
  564.  
  565. procedure xbm2rows(input)
  566.    local imagex, bits, row, hex, width, height, chunks
  567.    static hexdigit
  568.  
  569.    initial hexdigit := &digits ++ 'abcdef'
  570.  
  571.    imagex := ""
  572.  
  573.    read(input) ? {
  574.       tab(find("width") + 6)
  575.       tab(upto(&digits))
  576.       width := integer(tab(many(&digits)))
  577.       }
  578.  
  579.    read(input) ? {
  580.       tab(find("height") + 6)
  581.       tab(upto(&digits))
  582.       height := integer(tab(many(&digits)))
  583.       }
  584.  
  585.    chunks := (width / 8) + if (width % 8) > 0 then 1 else 0
  586.  
  587.    while imagex ||:= reads(input, 500000)    # Boo! -- can do better
  588.  
  589.    imagex ? {
  590.       every 1 to height do {
  591.          row := ""
  592.          every 1 to chunks do {
  593.             (hex := tab(any(hexdigit)) || tab(any(hexdigit))) | {
  594.                tab(find("0x") + 2)
  595.                hex := move(2)
  596.                }
  597.             row ||:= case hex of {
  598.               "00":    "00000000"
  599.               "ff":    "11111111"
  600.                default: reverse(right(hex2bits(hex), 8, "0"))
  601.                }
  602.             }
  603.          suspend left(row, width)
  604.          }
  605.       }
  606.  
  607. end
  608.