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