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 / gpxop.icn < prev    next >
Text File  |  2000-07-29  |  10KB  |  315 lines
  1. ############################################################################
  2. #
  3. #    File:     gpxop.icn
  4. #
  5. #    Subject:  Procedures for graphics operations
  6. #
  7. #    Author:   Gregg M. Townsend
  8. #
  9. #    Date:     May 26, 1999
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #    This file contains some graphics procedures.
  18. #
  19. #    LeftString(x, y, s)      draws a string left-aligned at (x, y).
  20. #
  21. #    CenterString(x, y, s)      draws a string centered at (x, y).
  22. #
  23. #    RightString(x, y, s)      draws a string right-aligned at (x, y).
  24. #
  25. #    ClearOutline(x, y, w, h)  draws a rectangle, erasing its interior.
  26. #
  27. #    Translate(dx, dy, w, h)      moves the window origin and optionally
  28. #                  sets the clipping region.
  29. #
  30. #    Zoom(x1, y1, w1, h1, x2, y2, w2, h2)
  31. #                  copies and distorts a rectangle.
  32. #
  33. #    Capture(p, x, y, w, h)      converts a window area to an image string.
  34. #
  35. #    Sweep()              lets the user select a rectangular area.
  36. #
  37. ############################################################################
  38. #
  39. #  LeftString(x, y, s), CenterString(x, y, s), and RightString(x, y, s)
  40. #  draw a string centered vertically about y and left-justified,
  41. #  centered, or right-justified about x.
  42. #
  43. #  ClearOutline(x, y, w, h) draws a rectangle in the foreground color
  44. #  and fills it with the background color.
  45. #
  46. #  Translate(dx, dy, w, h) adjusts a window's dx and dy attributes by
  47. #  the values given.  Note that the resulting attribute values are the
  48. #  sums of the existing values with the parameters, so that successive
  49. #  translations accumulate.  If w and h are supplied, the clipping
  50. #  region is set to a rectangle of size (w, h) at the new origin.
  51. #
  52. #  Zoom(x1, y1, w1, h1, x2, y2, w2, h2) is a distorting variation of
  53. #  CopyArea that can be used to shrink or enlarge a rectangular area.
  54. #  Zero, one, or two window arguments can be supplied.  Rectangle 1 is
  55. #  copied to fill rectangle 2 using simple pixel sampling and replication.
  56. #  The rectangles can overlap.  The usual defaults apply for both rectangles.
  57. #
  58. #  Sweep() lets the user select a rectangular area using the mouse.
  59. #  Called when a mouse button is pressed, Sweep handles all subsequent
  60. #  events until a mouse button is released.  As the mouse moves, a
  61. #  reverse-mode outline rectangle indicates the selected area.  The
  62. #  pixels underneath the rectangle outline are considered part of this
  63. #  rectangle, implying a minimum width/height of 1, and the rectangle
  64. #  is clipped to the window  boundary.  Sweep returns a list of four
  65. #  integers [x,y,w,h] giving the rectangle bounds in canonical form
  66. #  (w and h always positive).  Note that w and h give the width as
  67. #  measured in FillRectangle terms (number of pixels included) rather
  68. #  than DrawRectangle terms (coordinate difference).
  69. #
  70. #  Capture(palette, x, y, w, h) converts a window region into an
  71. #  image string using the specified palette, and returns the string.
  72. #
  73. #  These procedures all accept an optional initial window argument.
  74. #
  75. ############################################################################
  76. #
  77. #  Links: gpxlib
  78. #
  79. ############################################################################
  80. #
  81. #  Requires:  Version 9 graphics
  82. #
  83. ############################################################################
  84.  
  85. link gpxlib
  86.  
  87.  
  88. #   LeftString(x, y, s) -- draw string left-justified at (x,y).
  89.  
  90. procedure LeftString(win, x, y, s)        #: draw left-justified string
  91.    static type
  92.  
  93.    initial type := proc("type", 0)    # protect attractive name
  94.    if type(win) ~== "window" then {
  95.       win :=: x :=: y :=: s
  96.       win := &window
  97.       }
  98.    y +:= (WAttrib(win, "ascent") - WAttrib(win, "descent")) / 2 + 1
  99.    return DrawString(win, x, y, s)
  100. end
  101.  
  102.  
  103. #   CenterString(x, y, s) -- draw string centered about (x,y).
  104.  
  105. procedure CenterString(win, x, y, s)        #: draw centered string
  106.    static type
  107.  
  108.    initial type := proc("type", 0)    # protect attractive name
  109.    if type(win) ~== "window" then {
  110.       win :=: x :=: y :=: s
  111.       win := &window
  112.       }
  113.    x -:= TextWidth(win, s) / 2
  114.    y +:= (WAttrib(win, "ascent") - WAttrib(win, "descent")) / 2 + 1
  115.    return DrawString(win, x, y, s)
  116. end
  117.  
  118.  
  119. #   RightString(x, y, s) -- draw string right-justified at (x,y).
  120.  
  121. procedure RightString(win, x, y, s)        #: draw right-justified string
  122.    static type
  123.  
  124.    initial type := proc("type", 0)    # protect attractive name
  125.    if type(win) ~== "window" then {
  126.       win :=: x :=: y :=: s
  127.       win := &window
  128.       }
  129.    x -:= TextWidth(win, s)
  130.    y +:= (WAttrib(win, "ascent") - WAttrib(win, "descent")) / 2 + 1
  131.    return DrawString(win, x, y, s)
  132. end
  133.  
  134.  
  135. #   ClearOutline(x, y, w, h) -- draw rectangle and fill background.
  136.  
  137. procedure ClearOutline(win, x, y, w, h)        #: draw and clear rectangle
  138.    static type
  139.  
  140.    initial type := proc("type", 0)    # protect attractive name
  141.    if type(win) ~== "window" then {
  142.       win :=: x :=: y :=: w :=: h
  143.       win := &window
  144.       }
  145.  
  146.    /x := -WAttrib(win, "dx")
  147.    /y := -WAttrib(win, "dy")
  148.    /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
  149.    /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))
  150.  
  151.    if w < 0 then
  152.       x -:= (w := -w)
  153.    if h < 0 then
  154.       y -:= (h := -h)
  155.  
  156.    DrawRectangle(win, x, y, w, h)
  157.    EraseArea(win, x+1, y+1, w-1, h-1)
  158.    return win
  159. end
  160.  
  161.  
  162. #   Translate(dx, dy, w, h) -- add translation and possibly clipping.
  163.  
  164. procedure Translate(win, dx, dy, w, h)        #: add translation
  165.    static type
  166.  
  167.    initial type := proc("type", 0)    # protect attractive name
  168.    if type(win) ~== "window" then {
  169.       win :=: dx :=: dy :=: w :=: h
  170.       win := &window
  171.       }
  172.    WAttrib(win, "dx=" || WAttrib(win,"dx")+dx, "dy=" || WAttrib(win,"dy")+dy)
  173.    Clip(win, 0, 0, \w, \h)
  174.    return win
  175. end
  176.  
  177.  
  178. #  Sweep() -- sweep out area with mouse, return bounds
  179.  
  180. procedure Sweep(win)                #: sweep area with mouse
  181.    local x, y, w, h, wmin, wmax, hmin, hmax
  182.  
  183.    /win := &window
  184.    win := Clone(win, "drawop=reverse")
  185.  
  186.    x := &x                    # set initial rect bounds
  187.    y := &y
  188.    w := h := 0
  189.  
  190.    wmin := -WAttrib(win, "dx") - x        # calc coordinate limits
  191.    hmin := -WAttrib(win, "dy") - y
  192.    wmax := wmin + WAttrib(win, "width") - 1
  193.    hmax := hmin + WAttrib(win, "height") - 1
  194.  
  195.    DrawRectangle(win, x, y, w, h)        # draw initial bounding rect
  196.    until Event(win) === (&lrelease | &mrelease | &rrelease) do {
  197.       DrawRectangle(win, x, y, w, h)        # erase old bounds
  198.       w := &x - x                # calc new width & height
  199.       h := &y - y
  200.       w <:= wmin                # clip to stay on window
  201.       w >:= wmax
  202.       h <:= hmin
  203.       h >:= hmax
  204.       DrawRectangle(win, x, y, w, h)        # draw new bounds
  205.       }
  206.    DrawRectangle(win, x, y, w, h)        # erase bounding rectangle
  207.  
  208.    if w < 0 then x -:= (w := -w)        # ensure nonnegative sizes
  209.    if h < 0 then y -:= (h := -h)
  210.  
  211.    Uncouple(win)
  212.    return [x, y, w + 1, h + 1]            # return FillRectangle bounds
  213. end
  214.  
  215.  
  216. #  Zoom(win1, win2, x1, y1, w1, h1, x2, y2, w2, h2) -- copy and distort.
  217.  
  218. procedure Zoom(args[])                #: zoom image
  219.    local win1, x1, y1, w1, h1
  220.    local win2, x2, y2, w2, h2
  221.    local x, y, scr
  222.    static type
  223.  
  224.    initial type := proc("type", 0)    # protect attractive name
  225.  
  226.    if type(args[1]) == "window" then
  227.       win1 := get(args)
  228.    else
  229.       win1 := \&window | runerr(140, &window)
  230.    if type(args[1]) == "window" then
  231.       win2 := get(args)
  232.    else
  233.       win2 := win1
  234.  
  235.    x1 := \get(args) | -WAttrib(win1, "dx")
  236.    y1 := \get(args) | -WAttrib(win1, "dy")
  237.    w1 := \get(args) | WAttrib(win1, "width") - (x1 + WAttrib(win1, "dx"))
  238.    h1 := \get(args) | WAttrib(win1, "height") - (y1 + WAttrib(win1, "dy"))
  239.    if w1 < 0 then
  240.       x1 -:= (w1 := -w1)
  241.    if h1 < 0 then
  242.       y1 -:= (h1 := -h1)
  243.  
  244.    x2 := \get(args) | -WAttrib(win2, "dx")
  245.    y2 := \get(args) | -WAttrib(win2, "dy")
  246.    w2 := \get(args) | WAttrib(win2, "width") - (x2 + WAttrib(win2, "dx"))
  247.    h2 := \get(args) | WAttrib(win2, "height") - (y2 + WAttrib(win2, "dy"))
  248.    if w2 < 0 then
  249.       x2 -:= (w2 := -w2)
  250.    if h2 < 0 then
  251.       y2 -:= (h2 := -h2)
  252.  
  253.    if w1 = 0 | w2 = 0 | h1 = 0 | h2 = 0 then
  254.       return
  255.  
  256.    scr := ScratchCanvas(win2, w2, h1, "__Zoom__") | fail
  257.    every x := 0 to w2 - 1 do
  258.       CopyArea(win1, scr, x1 + w1 * ((x + 0.5) / w2), y1, 1, h1, x, 0)
  259.    every y := 0 to h2 - 1 do
  260.       CopyArea(scr, win2, 0, h1 * ((y + 0.5) / h2), w2, 1, x2, y2 + y)
  261.  
  262.    EraseArea(scr)        # release colors
  263.    return win1
  264. end
  265.  
  266.  
  267. #  Capture(win, pal, x, y, w, h) -- capture screen region as image string
  268.  
  269. $define CaptureChunk 100
  270.  
  271. procedure Capture(win, pal, x, y, w, h)        #: capture image as string
  272.    local a, c, k, s, t, cmap
  273.    static type
  274.  
  275.    initial type := proc("type", 0)    # protect attractive name
  276.  
  277.    if type(win) ~== "window" then {
  278.       win :=: pal :=: x :=: y :=: w :=: h
  279.       win := \&window | runerr(140, &window)
  280.       }
  281.  
  282.    /pal := "c1"
  283.  
  284.    /x := -WAttrib(win, "dx")
  285.    /y := -WAttrib(win, "dy")
  286.    /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
  287.    /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))
  288.  
  289.    if w < 0 then
  290.       x -:= (w := -w)
  291.    if h < 0 then
  292.       y -:= (h := -h)
  293.  
  294.    PaletteChars(win, pal) | runerr(205, pal)
  295.  
  296.    cmap := table()
  297.  
  298.    # accumulate the image in chunks and then concatenate
  299.    # (much faster than concatenating single chars on a very long string)
  300.    s := ""
  301.    a := []
  302.    every k := Pixel(win, x, y, w, h) do {
  303.       c := \cmap[k] | (cmap[k] := PaletteKey(win, pal, k))
  304.       if *(s ||:= c) >= CaptureChunk then {
  305.          put(a, s)
  306.          s := ""
  307.          }
  308.       }
  309.    put(a, s)
  310.  
  311.    s := w || "," || pal || ","
  312.    while s ||:= get(a)
  313.    return s
  314. end
  315.