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 / bevel.icn < prev    next >
Text File  |  2000-07-29  |  15KB  |  535 lines
  1. ############################################################################
  2. #
  3. #    File:     bevel.icn
  4. #
  5. #    Subject:  Procedures for drawing beveled objects
  6. #
  7. #    Author:   Gregg M. Townsend
  8. #
  9. #    Date:     April 1, 1997
  10. #
  11. ############################################################################
  12. #
  13. #   This file is in the public domain.
  14. #
  15. ############################################################################
  16. #
  17. #    These procedures draw objects having a raised or sunken appearance.
  18. #
  19. #    BevelReset(win)                sets/resets shading colors.
  20. #
  21. #    BevelCircle(win, x, y, r, bw)        draws a beveled circle.
  22. #
  23. #    BevelDiamond(win, x, y, r, bw)        draws a beveled diamond.
  24. #
  25. #    BevelTriangle(win, x, y, r, o, bw)    draws a beveled triangle.
  26. #
  27. #    BevelSquare(win, x, y, r, bw)        draws a beveled square.
  28. #
  29. #    FillSquare(win, x, y, r)        fills a square.
  30. #
  31. #    FillDiamond(win, x, y, r)        fills a diamond.
  32. #
  33. #    FillTriangle(win, x, y, r, o)        fills a triangle.
  34. #
  35. #    RidgeRectangle(win, x, y, w, h, bw)    draws a ridged rectangle.
  36. #
  37. #    GrooveRectangle(win, x, y, w, h, bw)    draws a grooved rectangle.
  38. #
  39. #    BevelRectangle(win, x, y, w, h, bw)    draws a beveled rectangle.
  40. #
  41. #    DrawRidge(win, x1, y1, x2, y2, w)    draws a ridged line.
  42. #
  43. #    DrawGroove(win, x1, y1, x2, y2, w)    draws a grooved line.
  44. #
  45. ############################################################################
  46. #
  47. #  These procedures allow the drawing of buttons and other objects
  48. #  with a three-dimensional appearance.  They are intended to be
  49. #  used like other graphics primitives (DrawRectangle() etc.).
  50. #  However, this abstraction fails if the background color changes
  51. #  or if clipping is set, due to the use of cached graphics contexts.
  52. #
  53. #  BevelReset(win) -- set/reset colors for beveling
  54. #    This procedure is called automatically by the others.
  55. #    It can be called explicitly if the background color is changed.
  56. #
  57. #  BevelCircle(win, x, y, r, bw) -- draw beveled circle
  58. #  BevelDiamond(win, x, y, r, bw) -- draw beveled diamond
  59. #  BevelTriangle(win, x, y, r, o, bw) -- draw beveled triangle
  60. #  BevelSquare(win, x, y, r, bw) -- draw beveled square
  61. #    These procedures draw a figure centered at (x,y) and having
  62. #    a "radius" of r.  bw is the bevel width, in pixels.
  63. #       o is the triangle orientation: "n", "s", "e", or "w".
  64. #
  65. #  FillSquare(win, x, y, r) -- fill square centered at (x,y)
  66. #  FillDiamond(win, x, y, r) -- fill diamond centered at (x,y)
  67. #  FillTriangle(win, x, y, r, o) -- fill triangle centered at (x,y)
  68. #    These procedures complement the beveled outline procedures
  69. #    by filling a figure centered at (x,y).  Fillcircle is already
  70. #    an Icon function and so is not included here.
  71. #
  72. #  RidgeRectangle(win, x, y, w, h, bw) -- draw ridged rectangle
  73. #  GrooveRectangle(win, x, y, w, h, bw) -- draw grooved rectangle
  74. #  BevelRectangle(win, x, y, w, h, bw) -- draw beveled rectangle
  75. #    These procedures draw a rectangle with the given external
  76. #    dimensions and border width.  Beveled rectangles are raised
  77. #    if bw > 0 or sunken if bw < 0.
  78. #
  79. #  DrawRidge(win, x1, y1, x2, y2, w) -- draw a ridged line
  80. #  DrawGroove(win, x1, y1, x2, y2, w) -- draw a grooved line
  81. #    These procedures draw a groove or ridge of width 2 at any angle.
  82. #    If w = 0, a groove or ridge is erased to the background color.
  83. #
  84. #  For BevelSquare() and FillSquare(), the width drawn is 2 * r + 1,
  85. #  not just 2 * r.  This is necessary to keep the visual center at the
  86. #  specified (x, y) and is consistent with the other centered procedures
  87. #  and the built-in function FillCircle.
  88. #
  89. ############################################################################
  90. #
  91. #  Includes:  vdefns
  92. #
  93. ############################################################################
  94. #
  95. #  Links:  graphics
  96. #
  97. ############################################################################
  98. #
  99. #  Requires:  Version 9 graphics
  100. #
  101. ############################################################################
  102.  
  103.  
  104. $include "vdefns.icn"
  105.  
  106. link graphics
  107.  
  108.  
  109. global bev_table
  110. record bev_record(shadow, hilite)
  111.  
  112.  
  113. #  BevelReset(win) -- set/reset colors for beveling
  114. #
  115. #  Called automatically the first time a beveling procedure is called;
  116. #  must also be called explicitly if the background color is changed.
  117. #  (Pale, weak background colors work best with beveling.)
  118.  
  119. procedure BevelReset(win)    #: set colors for beveled drawing
  120.    local b, h, l, s, hilite, shadow, lhilite, lshadow
  121.  
  122.    /win := &window
  123.    /bev_table := table()
  124.  
  125.    if b := \bev_table[win] then {
  126.       Uncouple(b.hilite)
  127.       Uncouple(b.shadow)
  128.       b := &null
  129.       }
  130.  
  131.    if WAttrib(win, "depth") >= 4 then {
  132.  
  133.       HLS(ColorValue(Bg(win))) ? {
  134.          h := tab(many(&digits))
  135.          move(1)
  136.          l := tab(many(&digits))
  137.          move(1)
  138.          s := tab(0)
  139.          }
  140.    
  141.       case l of {
  142.           0 <= l < 10 & l:      { lshadow := 25;    lhilite := 50 }
  143.          10 <= l < 25 & l:      { lshadow := 0;    lhilite := l + 25 }
  144.          25 <= l < 75 & l:      { lshadow := l - 25;    lhilite := l + 25 }
  145.          75 <= l < 90 & l:      { lshadow := l - 25;    lhilite := 100 }
  146.          default:          { lshadow := 50;    lhilite := 75 }
  147.          }
  148.       s /:= 2
  149.    
  150.       shadow := Clone(win, "fg=" || HLSValue(h || ":" || lshadow || ":" || s),
  151.          "linewidth=1", "linestyle=solid", "fillstyle=solid", "drawop=copy")
  152.       hilite := Clone(shadow,
  153.          "fg=" || HLSValue(h || ":" || lhilite || ":" || s))
  154.       b := bev_record(\shadow, \hilite)
  155.       }
  156.  
  157.    if /b then {
  158.       shadow := Clone(win,
  159.          "linewidth=1", "linestyle=solid", "fillstyle=solid", "drawop=copy")
  160.       hilite := Clone(shadow, "fillstyle=textured", "pattern=gray")
  161.       b := bev_record(shadow, hilite)
  162.       }
  163.  
  164.    bev_table[win] := bev_record(shadow, hilite)
  165.    return win
  166. end
  167.  
  168.  
  169. #  bev_lookup(win) -- look up and return bev_record for a window.
  170. #
  171. #  (Internal procedure)
  172.  
  173. procedure bev_lookup(win)
  174.    local b, dx, dy
  175.    b := \(\bev_table)[win] | bev_table[BevelReset(win)]
  176.    dx := "dx=" || WAttrib(win, "dx")
  177.    dy := "dy=" || WAttrib(win, "dy")
  178.    every WAttrib(b.shadow | b.hilite, dx, dy)
  179.    return b
  180. end
  181.  
  182.  
  183. #  BevelCircle(win, x, y, r, bw) -- draw beveled circle
  184.  
  185. procedure BevelCircle(win, x, y, r, bw)        #: draw beveled circle
  186.    local b, upper, lower, a
  187.    static type
  188.  
  189.    initial type := proc("type", 0)    # protect attractive name
  190.  
  191.    if type(win) ~== "window" then
  192.       return BevelCircle((\&window | runerr(140)), win, x, y, r)
  193.    b := bev_lookup(win)
  194.  
  195.    /r := 6
  196.    /bw := 2
  197.    if bw >= 0 then {
  198.       upper := b.hilite
  199.       lower := b.shadow
  200.       }
  201.    else {
  202.       upper := b.shadow
  203.       lower := b.hilite
  204.       bw := -bw
  205.       }
  206.  
  207.    a := -&pi / 8
  208.    while (bw -:= 1) >= 0 do {
  209.       DrawCircle(lower, x, y, r, a, &pi)
  210.       DrawCircle(upper, x, y, r, a + &pi, &pi)
  211.       r -:= 1
  212.       }
  213.    return win
  214. end
  215.  
  216.  
  217. #  BevelDiamond(win, x, y, r, bw) -- draw beveled diamond
  218.  
  219. procedure BevelDiamond(win, x, y, r, bw)    #: draw beveled diamond
  220.    local b, upper, lower
  221.    static type
  222.  
  223.    initial type := proc("type", 0)    # protect attractive name
  224.  
  225.    if type(win) ~== "window" then
  226.       return BevelDiamond((\&window | runerr(140)), win, x, y, r)
  227.    b := bev_lookup(win)
  228.  
  229.    /r := 6
  230.    /bw := 3
  231.    if bw >= 0 then {
  232.       upper := b.hilite
  233.       lower := b.shadow
  234.       }
  235.    else {
  236.       upper := b.shadow
  237.       lower := b.hilite
  238.       bw := -bw
  239.       }
  240.  
  241.    while (bw -:= 1) >= 0 do {
  242.       DrawLine(lower, x - r, y, x, y + r, x + r, y)
  243.       DrawLine(upper, x - r, y, x, y - r, x + r, y)
  244.       r -:= 1
  245.       }
  246.    return win
  247. end
  248.  
  249.  
  250. #  BevelTriangle(win, x, y, r, o, bw) -- draw beveled triangle
  251.  
  252. procedure BevelTriangle(win, x, y, r, o, bw)
  253.    local b, upper, lower
  254.    static type
  255.  
  256.    initial type := proc("type", 0)    # protect attractive name
  257.  
  258.    if type(win) ~== "window" then
  259.       return BevelTriangle((\&window | runerr(140)), win, x, y, r, o)
  260.    b := bev_lookup(win)
  261.  
  262.    /r := 6
  263.    /bw := 2
  264.    if bw >= 0 then {
  265.       upper := b.hilite
  266.       lower := b.shadow
  267.       }
  268.    else {
  269.       upper := b.shadow
  270.       lower := b.hilite
  271.       bw := -bw
  272.       }
  273.  
  274.    while (bw -:= 1) >= 0 do {
  275.       case o of {
  276.          default: {  #"n"
  277.             DrawLine(lower, x - r, y + r, x + r, y + r, x, y - r)
  278.             DrawLine(upper, x - r, y + r, x, y - r)
  279.             }
  280.          "s": {
  281.             DrawLine(lower, x, y + r, x + r, y - r)
  282.             DrawLine(upper, x, y + r, x - r, y - r, x + r, y - r)
  283.             }
  284.          "e": {
  285.             DrawLine(lower, x - r, y + r, x + r, y)
  286.             DrawLine(upper, x - r, y + r, x - r, y - r, x + r, y)
  287.             }
  288.          "w": {
  289.             DrawSegment(lower, x - r, y, x + r, y + r, x + r, y + r, x + r, y-r)
  290.             DrawLine(upper, x - r, y, x + r, y - r)
  291.             }
  292.          }
  293.       r -:= 1
  294.       }
  295.    return win
  296. end
  297.  
  298.  
  299. #  BevelSquare(win, x, y, r, bw) -- draw beveled square
  300.  
  301. procedure BevelSquare(win, x, y, r, bw)        #: draw beveled square
  302.    static type
  303.  
  304.    initial type := proc("type", 0)    # protect attractive name
  305.  
  306.    if type(win) ~== "window" then
  307.       return BevelSquare((\&window | runerr(140)), win, x, y, r)
  308.    /r := 6
  309.    return BevelRectangle(win, x - r, y - r, 2 * r + 1, 2 * r + 1, bw)
  310. end
  311.  
  312.  
  313. #  RidgeRectangle(win, x, y, w, h, bw) -- draw ridged rectangle
  314.  
  315. procedure RidgeRectangle(win, x, y, w, h, bw)    #: draw ridged rectangle
  316.    static type
  317.  
  318.    initial type := proc("type", 0)    # protect attractive name
  319.  
  320.    if type(win) ~== "window" then
  321.       return RidgeRectangle((\&window | runerr(140)), win, x, y, w, h)
  322.    /bw := 2
  323.    return GrooveRectangle(win, x, y, w, h, -bw)
  324. end
  325.  
  326.  
  327. #  GrooveRectangle(win, x, y, w, h, bw) -- draw grooved rectangle
  328.  
  329. procedure GrooveRectangle(win, x, y, w, h, bw)    #: draw grooved rectangle
  330.    local abw
  331.    static type
  332.  
  333.    initial type := proc("type", 0)    # protect attractive name
  334.  
  335.    if type(win) ~== "window" then
  336.       return GrooveRectangle((\&window | runerr(140)), win, x, y, w, h)
  337.  
  338.    /x := -WAttrib(win, "dx")
  339.    /y := -WAttrib(win, "dy")
  340.    /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
  341.    /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))
  342.  
  343.    if w < 0 then
  344.       x -:= (w := -w)
  345.    if h < 0 then
  346.       y -:= (h := -h)
  347.  
  348.    /bw := 2
  349.    if bw >= 0 then
  350.       bw := (bw + 1) / 2
  351.    else
  352.       bw := -((-bw + 1) / 2)
  353.    abw := abs(bw)
  354.  
  355.    BevelRectangle(win, x, y, w, h, -bw)
  356.    BevelRectangle(win, x + abw, y + abw, w - 2 * abw, h - 2 * abw, bw)
  357.    return win
  358. end
  359.  
  360.  
  361. #  BevelRectangle(win, x, y, w, h, bw) -- draw beveled rectangle
  362. #
  363. #  bw is the border width (>0 for raised bevel, <0 for sunken bevel).
  364. #  (x,y,w,h) bounds the entire beveled rectangle, not the usable area inside.
  365.  
  366. procedure BevelRectangle(win, x, y, w, h, bw)    #: draw beveled rectangle
  367.    local b, upper, lower, xx, yy
  368.    static type
  369.  
  370.    initial type := proc("type", 0)    # protect attractive name
  371.  
  372.    if type(win) ~== "window" then
  373.       return BevelRectangle((\&window | runerr(140)), win, x, y, w, h)
  374.    b := bev_lookup(win)
  375.  
  376.    /x := -WAttrib(win, "dx")
  377.    /y := -WAttrib(win, "dy")
  378.    /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
  379.    /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))
  380.  
  381.    if w < 0 then
  382.       x -:= (w := -w)
  383.    if h < 0 then
  384.       y -:= (h := -h)
  385.  
  386.    /bw := 2
  387.    if bw >= 0 then {
  388.       upper := b.hilite
  389.       lower := b.shadow
  390.       }
  391.    else {
  392.       upper := b.shadow
  393.       lower := b.hilite
  394.       bw := -bw
  395.       }
  396.  
  397.    xx := x + w
  398.    yy := y + h
  399.    FillRectangle(lower, x, yy, w, -bw, xx, y, -bw, h)
  400.  
  401.    while (bw -:= 1) >= 0 do {
  402.       DrawLine(upper, x, yy -:= 1, x, y, xx -:= 1, y)
  403.       x +:= 1
  404.       y +:= 1
  405.       }
  406.  
  407.    return win
  408. end
  409.  
  410.  
  411. #  DrawRidge(win, x1, y1, x2, y2, w) -- draw a ridged line
  412. #
  413. #  If w is negative, a groove is drawn instead.
  414.  
  415. procedure DrawRidge(win, x1, y1, x2, y2, w)    #: draw ridged line
  416.    static type
  417.  
  418.    initial type := proc("type", 0)    # protect attractive name
  419.  
  420.    if type(win) ~== "window" then
  421.       return DrawRidge((\&window | runerr(140)), win, x1, y1, x2, y2)
  422.    /w := 2
  423.  
  424.    DrawGroove(win, x1, y1, x2, y2, -w)
  425.    return win
  426. end
  427.  
  428.  
  429. #  DrawGroove(win, x1, y1, x2, y2, w) -- draw a grooved line
  430. #
  431. #  If w > 0, draw groove of width 2.
  432. #  If w = 0, erase groove/ridge of width 2.
  433. #  If w < 0, draw ridge of width 2.
  434. #
  435. #  Horizontal and vertical grooves fill the same pixels as lines drawn
  436. #  linewidth=2.  Angled grooves are not necessarily the same, though.
  437.  
  438. procedure DrawGroove(win, x1, y1, x2, y2, w)    #: draw grooved line
  439.    local a, n, b, upper, lower, fg
  440.    static type
  441.  
  442.    initial type := proc("type", 0)    # protect attractive name
  443.  
  444.    if type(win) ~== "window" then
  445.       return DrawGroove((\&window | runerr(140)), win, x1, y1, x2, y2)
  446.  
  447.    /w := 2
  448.    x1 := integer(x1)
  449.    y1 := integer(y1)
  450.    x2 := integer(x2)
  451.    y2 := integer(y2)
  452.  
  453.    if w ~= 0 then {            # if really drawing
  454.       b := bev_lookup(win)
  455.       upper := b.shadow
  456.       lower := b.hilite
  457.       }
  458.    else {
  459.       fg := Fg(win)            # if erasing, draw in bg color
  460.       Fg(win, Bg(win))
  461.       upper := lower := win
  462.       }
  463.  
  464.    a := atan(y2 - y1, x2 - x1)
  465.    if a < 0 then
  466.       a +:= &pi
  467.    n := integer(8 * a / &pi)
  468.  
  469.    if w < 0 then            # if groove/ridge swap
  470.       upper :=: lower
  471.    if n = 2 then            # if tricky illumination angle
  472.       upper :=: lower
  473.  
  474.    if 2 <= n <= 5 then {        # approximately vertical
  475.       DrawLine(upper, x1 - 1, y1, x2 - 1, y2)
  476.       DrawLine(lower, x1, y1, x2, y2)
  477.       }
  478.    else {                # approximately horizontal
  479.       DrawLine(upper, x1, y1 - 1, x2, y2 - 1)
  480.       DrawLine(lower, x1, y1, x2, y2)
  481.       }
  482.  
  483.    Fg(win, \fg)                # restore foreground if changed
  484.    return win
  485. end
  486.  
  487.  
  488. #  FillSquare(win, x, y, r) -- fill square centered at (x,y)
  489.  
  490. procedure FillSquare(win, x, y, r)        #: draw filled square
  491.    static type
  492.  
  493.    initial type := proc("type", 0)    # protect attractive name
  494.    if type(win) ~== "window" then
  495.       return FillSquare((\&window | runerr(140)), win, x, y)
  496.    return FillRectangle(win, x - r, y - r, 2 * r + 1, 2 * r + 1)
  497. end
  498.  
  499.  
  500. #  FillDiamond(win, x, y, r) -- fill diamond centered at (x,y)
  501.  
  502. procedure FillDiamond(win, x, y, r)        #: draw filled diamond
  503.    static type
  504.  
  505.    initial type := proc("type", 0)    # protect attractive name
  506.    if type(win) ~== "window" then
  507.       return FillDiamond((\&window | runerr(140)), win, x, y)
  508.    return FillPolygon(win, x - r, y, x, y + r + 1, x + r + 1, y, x, y - r - 1)
  509. end
  510.  
  511.  
  512. #  FillTriangle(win, x, y, r, o) -- fill triangle centered at (x,y)
  513. #
  514. #  r is "radius" (1/2 of side of enclosing square)
  515. #  o is orientation ("n", "s", "e", "w")
  516.  
  517. procedure FillTriangle(win, x, y, r, o)        #: draw filled triangle
  518.    static type
  519.  
  520.    initial type := proc("type", 0)    # protect attractive name
  521.    if type(win) ~== "window" then
  522.       return FillTriangle((\&window | runerr(140)), win, x, y, r)
  523.    return case o of {
  524.       default:  #"n"
  525.          FillPolygon(win, x - r - 1, y + r + 1, x, y - r, x + r + 1, y + r + 1)
  526.       "s":
  527.          FillPolygon(win, x - r, y - r, x, y + r, x + r, y - r)
  528.       "e":
  529.          FillPolygon(win, x - r, y - r, x + r, y, x - r, y + r)
  530.       "w":
  531.          FillPolygon(win, x + r + 1, y - r - 1, x - r, y, x + r + 1, y + r + 1)
  532.       }
  533. end
  534.  
  535.