path: root/ipl/gprocs/bevel.icn

############################################################################
#
#	File:     bevel.icn
#
#	Subject:  Procedures for drawing beveled objects
#
#	Author:   Gregg M. Townsend
#
#	Date:     April 1, 1997
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#	These procedures draw objects having a raised or sunken appearance.
#
#	BevelReset(win)				sets/resets shading colors.
#
#	BevelCircle(win, x, y, r, bw)		draws a beveled circle.
#
#	BevelDiamond(win, x, y, r, bw)		draws a beveled diamond.
#
#	BevelTriangle(win, x, y, r, o, bw)	draws a beveled triangle.
#
#	BevelSquare(win, x, y, r, bw)		draws a beveled square.
#
#	FillSquare(win, x, y, r)		fills a square.
#
#	FillDiamond(win, x, y, r)		fills a diamond.
#
#	FillTriangle(win, x, y, r, o)		fills a triangle.
#
#	RidgeRectangle(win, x, y, w, h, bw)	draws a ridged rectangle.
#
#	GrooveRectangle(win, x, y, w, h, bw)	draws a grooved rectangle.
#
#	BevelRectangle(win, x, y, w, h, bw)	draws a beveled rectangle.
#
#	DrawRidge(win, x1, y1, x2, y2, w)	draws a ridged line.
#
#	DrawGroove(win, x1, y1, x2, y2, w)	draws a grooved line.
#
############################################################################
#
#  These procedures allow the drawing of buttons and other objects
#  with a three-dimensional appearance.  They are intended to be
#  used like other graphics primitives (DrawRectangle() etc.).
#  However, this abstraction fails if the background color changes
#  or if clipping is set, due to the use of cached graphics contexts.
#
#  BevelReset(win) -- set/reset colors for beveling
#	This procedure is called automatically by the others.
#	It can be called explicitly if the background color is changed.
#
#  BevelCircle(win, x, y, r, bw) -- draw beveled circle
#  BevelDiamond(win, x, y, r, bw) -- draw beveled diamond
#  BevelTriangle(win, x, y, r, o, bw) -- draw beveled triangle
#  BevelSquare(win, x, y, r, bw) -- draw beveled square
#	These procedures draw a figure centered at (x,y) and having
#	a "radius" of r.  bw is the bevel width, in pixels.
#       o is the triangle orientation: "n", "s", "e", or "w".
#
#  FillSquare(win, x, y, r) -- fill square centered at (x,y)
#  FillDiamond(win, x, y, r) -- fill diamond centered at (x,y)
#  FillTriangle(win, x, y, r, o) -- fill triangle centered at (x,y)
#	These procedures complement the beveled outline procedures
#	by filling a figure centered at (x,y).  Fillcircle is already
#	an Icon function and so is not included here.
#
#  RidgeRectangle(win, x, y, w, h, bw) -- draw ridged rectangle
#  GrooveRectangle(win, x, y, w, h, bw) -- draw grooved rectangle
#  BevelRectangle(win, x, y, w, h, bw) -- draw beveled rectangle
#	These procedures draw a rectangle with the given external
#	dimensions and border width.  Beveled rectangles are raised
#	if bw > 0 or sunken if bw < 0.
#
#  DrawRidge(win, x1, y1, x2, y2, w) -- draw a ridged line
#  DrawGroove(win, x1, y1, x2, y2, w) -- draw a grooved line
#	These procedures draw a groove or ridge of width 2 at any angle.
#	If w = 0, a groove or ridge is erased to the background color.
#
#  For BevelSquare() and FillSquare(), the width drawn is 2 * r + 1,
#  not just 2 * r.  This is necessary to keep the visual center at the
#  specified (x, y) and is consistent with the other centered procedures
#  and the built-in function FillCircle.
#
############################################################################
#
#  Includes:  vdefns
#
############################################################################
#
#  Links:  graphics
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################


$include "vdefns.icn"

link graphics


global bev_table
record bev_record(shadow, hilite)


#  BevelReset(win) -- set/reset colors for beveling
#
#  Called automatically the first time a beveling procedure is called;
#  must also be called explicitly if the background color is changed.
#  (Pale, weak background colors work best with beveling.)

procedure BevelReset(win)	#: set colors for beveled drawing
   local b, h, l, s, hilite, shadow, lhilite, lshadow

   /win := &window
   /bev_table := table()

   if b := \bev_table[win] then {
      Uncouple(b.hilite)
      Uncouple(b.shadow)
      b := &null
      }

   if WAttrib(win, "depth") >= 4 then {

      HLS(ColorValue(Bg(win))) ? {
         h := tab(many(&digits))
         move(1)
         l := tab(many(&digits))
         move(1)
         s := tab(0)
         }
   
      case l of {
          0 <= l < 10 & l:	  { lshadow := 25;	lhilite := 50 }
         10 <= l < 25 & l:	  { lshadow := 0;	lhilite := l + 25 }
         25 <= l < 75 & l:	  { lshadow := l - 25;	lhilite := l + 25 }
         75 <= l < 90 & l:	  { lshadow := l - 25;	lhilite := 100 }
         default:		  { lshadow := 50;	lhilite := 75 }
         }
      s /:= 2
   
      shadow := Clone(win, "fg=" || HLSValue(h || ":" || lshadow || ":" || s),
         "linewidth=1", "linestyle=solid", "fillstyle=solid", "drawop=copy")
      hilite := Clone(shadow,
         "fg=" || HLSValue(h || ":" || lhilite || ":" || s))
      b := bev_record(\shadow, \hilite)
      }

   if /b then {
      shadow := Clone(win,
         "linewidth=1", "linestyle=solid", "fillstyle=solid", "drawop=copy")
      hilite := Clone(shadow, "fillstyle=textured", "pattern=gray")
      b := bev_record(shadow, hilite)
      }

   bev_table[win] := bev_record(shadow, hilite)
   return win
end


#  bev_lookup(win) -- look up and return bev_record for a window.
#
#  (Internal procedure)

procedure bev_lookup(win)
   local b, dx, dy
   b := \(\bev_table)[win] | bev_table[BevelReset(win)]
   dx := "dx=" || WAttrib(win, "dx")
   dy := "dy=" || WAttrib(win, "dy")
   every WAttrib(b.shadow | b.hilite, dx, dy)
   return b
end


#  BevelCircle(win, x, y, r, bw) -- draw beveled circle

procedure BevelCircle(win, x, y, r, bw)		#: draw beveled circle
   local b, upper, lower, a
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then
      return BevelCircle((\&window | runerr(140)), win, x, y, r)
   b := bev_lookup(win)

   /r := 6
   /bw := 2
   if bw >= 0 then {
      upper := b.hilite
      lower := b.shadow
      }
   else {
      upper := b.shadow
      lower := b.hilite
      bw := -bw
      }

   a := -&pi / 8
   while (bw -:= 1) >= 0 do {
      DrawCircle(lower, x, y, r, a, &pi)
      DrawCircle(upper, x, y, r, a + &pi, &pi)
      r -:= 1
      }
   return win
end


#  BevelDiamond(win, x, y, r, bw) -- draw beveled diamond

procedure BevelDiamond(win, x, y, r, bw)	#: draw beveled diamond
   local b, upper, lower
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then
      return BevelDiamond((\&window | runerr(140)), win, x, y, r)
   b := bev_lookup(win)

   /r := 6
   /bw := 3
   if bw >= 0 then {
      upper := b.hilite
      lower := b.shadow
      }
   else {
      upper := b.shadow
      lower := b.hilite
      bw := -bw
      }

   while (bw -:= 1) >= 0 do {
      DrawLine(lower, x - r, y, x, y + r, x + r, y)
      DrawLine(upper, x - r, y, x, y - r, x + r, y)
      r -:= 1
      }
   return win
end


#  BevelTriangle(win, x, y, r, o, bw) -- draw beveled triangle

procedure BevelTriangle(win, x, y, r, o, bw)
   local b, upper, lower
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then
      return BevelTriangle((\&window | runerr(140)), win, x, y, r, o)
   b := bev_lookup(win)

   /r := 6
   /bw := 2
   if bw >= 0 then {
      upper := b.hilite
      lower := b.shadow
      }
   else {
      upper := b.shadow
      lower := b.hilite
      bw := -bw
      }

   while (bw -:= 1) >= 0 do {
      case o of {
         default: {  #"n"
            DrawLine(lower, x - r, y + r, x + r, y + r, x, y - r)
            DrawLine(upper, x - r, y + r, x, y - r)
            }
         "s": {
            DrawLine(lower, x, y + r, x + r, y - r)
            DrawLine(upper, x, y + r, x - r, y - r, x + r, y - r)
            }
         "e": {
            DrawLine(lower, x - r, y + r, x + r, y)
            DrawLine(upper, x - r, y + r, x - r, y - r, x + r, y)
            }
         "w": {
            DrawSegment(lower, x - r, y, x + r, y + r, x + r, y + r, x + r, y-r)
            DrawLine(upper, x - r, y, x + r, y - r)
            }
         }
      r -:= 1
      }
   return win
end


#  BevelSquare(win, x, y, r, bw) -- draw beveled square

procedure BevelSquare(win, x, y, r, bw)		#: draw beveled square
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then
      return BevelSquare((\&window | runerr(140)), win, x, y, r)
   /r := 6
   return BevelRectangle(win, x - r, y - r, 2 * r + 1, 2 * r + 1, bw)
end


#  RidgeRectangle(win, x, y, w, h, bw) -- draw ridged rectangle

procedure RidgeRectangle(win, x, y, w, h, bw)	#: draw ridged rectangle
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then
      return RidgeRectangle((\&window | runerr(140)), win, x, y, w, h)
   /bw := 2
   return GrooveRectangle(win, x, y, w, h, -bw)
end


#  GrooveRectangle(win, x, y, w, h, bw) -- draw grooved rectangle

procedure GrooveRectangle(win, x, y, w, h, bw)	#: draw grooved rectangle
   local abw
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then
      return GrooveRectangle((\&window | runerr(140)), win, x, y, w, h)

   /x := -WAttrib(win, "dx")
   /y := -WAttrib(win, "dy")
   /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
   /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))

   if w < 0 then
      x -:= (w := -w)
   if h < 0 then
      y -:= (h := -h)

   /bw := 2
   if bw >= 0 then
      bw := (bw + 1) / 2
   else
      bw := -((-bw + 1) / 2)
   abw := abs(bw)

   BevelRectangle(win, x, y, w, h, -bw)
   BevelRectangle(win, x + abw, y + abw, w - 2 * abw, h - 2 * abw, bw)
   return win
end


#  BevelRectangle(win, x, y, w, h, bw) -- draw beveled rectangle
#
#  bw is the border width (>0 for raised bevel, <0 for sunken bevel).
#  (x,y,w,h) bounds the entire beveled rectangle, not the usable area inside.

procedure BevelRectangle(win, x, y, w, h, bw)	#: draw beveled rectangle
   local b, upper, lower, xx, yy
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then
      return BevelRectangle((\&window | runerr(140)), win, x, y, w, h)
   b := bev_lookup(win)

   /x := -WAttrib(win, "dx")
   /y := -WAttrib(win, "dy")
   /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
   /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))

   if w < 0 then
      x -:= (w := -w)
   if h < 0 then
      y -:= (h := -h)

   /bw := 2
   if bw >= 0 then {
      upper := b.hilite
      lower := b.shadow
      }
   else {
      upper := b.shadow
      lower := b.hilite
      bw := -bw
      }

   xx := x + w
   yy := y + h
   FillRectangle(lower, x, yy, w, -bw, xx, y, -bw, h)

   while (bw -:= 1) >= 0 do {
      DrawLine(upper, x, yy -:= 1, x, y, xx -:= 1, y)
      x +:= 1
      y +:= 1
      }

   return win
end


#  DrawRidge(win, x1, y1, x2, y2, w) -- draw a ridged line
#
#  If w is negative, a groove is drawn instead.

procedure DrawRidge(win, x1, y1, x2, y2, w)	#: draw ridged line
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then
      return DrawRidge((\&window | runerr(140)), win, x1, y1, x2, y2)
   /w := 2

   DrawGroove(win, x1, y1, x2, y2, -w)
   return win
end


#  DrawGroove(win, x1, y1, x2, y2, w) -- draw a grooved line
#
#  If w > 0, draw groove of width 2.
#  If w = 0, erase groove/ridge of width 2.
#  If w < 0, draw ridge of width 2.
#
#  Horizontal and vertical grooves fill the same pixels as lines drawn
#  linewidth=2.  Angled grooves are not necessarily the same, though.

procedure DrawGroove(win, x1, y1, x2, y2, w)	#: draw grooved line
   local a, n, b, upper, lower, fg
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then
      return DrawGroove((\&window | runerr(140)), win, x1, y1, x2, y2)

   /w := 2
   x1 := integer(x1)
   y1 := integer(y1)
   x2 := integer(x2)
   y2 := integer(y2)

   if w ~= 0 then {			# if really drawing
      b := bev_lookup(win)
      upper := b.shadow
      lower := b.hilite
      }
   else {
      fg := Fg(win)			# if erasing, draw in bg color
      Fg(win, Bg(win))
      upper := lower := win
      }

   a := atan(y2 - y1, x2 - x1)
   if a < 0 then
      a +:= &pi
   n := integer(8 * a / &pi)

   if w < 0 then			# if groove/ridge swap
      upper :=: lower
   if n = 2 then			# if tricky illumination angle
      upper :=: lower

   if 2 <= n <= 5 then {		# approximately vertical
      DrawLine(upper, x1 - 1, y1, x2 - 1, y2)
      DrawLine(lower, x1, y1, x2, y2)
      }
   else {				# approximately horizontal
      DrawLine(upper, x1, y1 - 1, x2, y2 - 1)
      DrawLine(lower, x1, y1, x2, y2)
      }

   Fg(win, \fg)				# restore foreground if changed
   return win
end


#  FillSquare(win, x, y, r) -- fill square centered at (x,y)

procedure FillSquare(win, x, y, r)		#: draw filled square
   static type

   initial type := proc("type", 0)	# protect attractive name
   if type(win) ~== "window" then
      return FillSquare((\&window | runerr(140)), win, x, y)
   return FillRectangle(win, x - r, y - r, 2 * r + 1, 2 * r + 1)
end


#  FillDiamond(win, x, y, r) -- fill diamond centered at (x,y)

procedure FillDiamond(win, x, y, r)		#: draw filled diamond
   static type

   initial type := proc("type", 0)	# protect attractive name
   if type(win) ~== "window" then
      return FillDiamond((\&window | runerr(140)), win, x, y)
   return FillPolygon(win, x - r, y, x, y + r + 1, x + r + 1, y, x, y - r - 1)
end


#  FillTriangle(win, x, y, r, o) -- fill triangle centered at (x,y)
#
#  r is "radius" (1/2 of side of enclosing square)
#  o is orientation ("n", "s", "e", "w")

procedure FillTriangle(win, x, y, r, o)		#: draw filled triangle
   static type

   initial type := proc("type", 0)	# protect attractive name
   if type(win) ~== "window" then
      return FillTriangle((\&window | runerr(140)), win, x, y, r)
   return case o of {
      default:  #"n"
         FillPolygon(win, x - r - 1, y + r + 1, x, y - r, x + r + 1, y + r + 1)
      "s":
         FillPolygon(win, x - r, y - r, x, y + r, x + r, y - r)
      "e":
         FillPolygon(win, x - r, y - r, x + r, y, x - r, y + r)
      "w":
         FillPolygon(win, x + r + 1, y - r - 1, x - r, y, x + r + 1, y + r + 1)
      }
end