#
# $Id: guiprocs.icn,v 1.7 2004/11/06 00:28:13 rparlett Exp $
#
# This file is in the public domain.
#
# Author: Robert Parlett (parlett@dial.pipex.com)
#

package gui
link graphics

$include "guih.icn"     

procedure EraseRectangle(W, x, y, w, h)
   if x < 0 then {
      w +:= x
      x := 0
   }

   if y < 0 then {
      h +:= y
      y := 0
   }

   return EraseArea(W, x, y, w, h)
end

procedure DrawImageEx(W, x, y, i)
   i := get_extended_image(W, i) | fail
   #
   # This gets round a bug whereby painting an image
   # in a -ve location (off screen) takes a really long
   # time (it should be a no-op of course).
   #
   if x + img_width(i) < 0 & y + img_height(i) < 0 then
      return
   DrawImage(W, x, y, i)
end

procedure PaletteKeyEx(W, palette, spec)
   local color
   color := case spec of {
      "hilite" : WAttrib(get_hilite_win(W), "fg")
      "shadow" : WAttrib(get_shadow_win(W), "fg")
      "fg" : WAttrib(W, "fg")
      "bg" : WAttrib(W, "bg")
      "trans" : return "\377"
      default : spec
   }
   return PaletteKey(W, palette, color)
end

procedure get_extended_image(W, img)
   local s1, s2, head, spec, palette

   img ? {
      ="(" | return img
      spec := tab(upto(')')) | fail
      =")"
      tab(many(' '))
      head := tab(upto(',')) || move(1) ||
         (palette := tab(upto(','))) || move(1) | fail

      s1 := s2 := ""
      spec ? repeat {
         tab(many('; '))
         if pos(0) then 
            break
         s1 ||:= move(1) | fail
         ="=" | fail
         spec := tab(upto(';') | 0)
         s2 ||:= PaletteKeyEx(W, palette, spec) | fail
      }
      return head || map(tab(0), s1, s2)
   }
end

procedure Rectangle(W, x, y, w, h)
   return DrawRectangle(W, x, y, w - 1, h - 1)
end

#
# Return the char width for ch, which may be a tab
#
procedure CharWidth(win, ch)
   if ch == "\t" then
      return TextWidth(win, " ")
   else
      return TextWidth(win, ch)
end

#
# Extended TextWidth function, handling tabs in s.  Returns the
# width of the string from positions i through j.
#
procedure TextWidthEx(win, s, i, j, tw)
   local tp, w, lr, cc, ch

   if /i then {
      i := 1
      j := *s + 1
   } else {
      /j:= i + 1
      if j <= 0 then
         j +:= *s + 1
   }

   if not upto('\t', s) then
      return TextWidth(win,s[i:j])

   /tw := 8
   tp := 0
   w := 0
   lr := 0
   every cc := 1 to *s do {
      if cc = i then
         lr := w
      if cc = j then
         break
      ch := s[cc]

      if ch == "\t" then {
         repeat {
            w +:= TextWidth(win, " ")
            tp +:= 1
            if tp % tw = 0 then 
               break
         }
      } else {
         w +:= TextWidth(win, ch)
         tp +:= 1
      }
   }
   return w - lr
end

#
# Draw a raised rectangle.
#
procedure DrawRaisedRectangle(W, x, y, w, h, i)
   /i := BORDER_WIDTH
   BevelRectangle(W, x, y, w, h, i)
end

#
# Draw a sunken rectangle.
#
procedure DrawSunkenRectangle(W, x, y, w, h, i)
   /i := -BORDER_WIDTH
   BevelRectangle(W, x, y, w, h, i)
end

#
# Draw a dashed rectangle using the shadow color.
#
procedure DashedRectangle(W, x, y, w, h)
   local cw
   cw := Clone(get_shadow_win(W), "pattern=gray", "fillstyle=masked")
   #cw := Clone(W, "fg=black", "pattern=gray", "fillstyle=masked")
   Rectangle(cw, x, y, w, h)
   Uncouple(cw)
end

#
# Draw an etched line.
#
procedure DrawEtchedLine(W, x1, y1, x2, y2, w)
   /w := 3
   DrawGroove(W, x1, y1, x2, y2, w)
end

procedure get_shadow_win(W)
   return bev_lookup(W).shadow
end

procedure get_hilite_win(W)
   return bev_lookup(W).hilite
end

procedure FilterRectangle(W, x, y, w, h)
   local cw
$ifdef _MS_WINDOWS_NT
   cw := Clone(W, "fillstyle=masked", "drawop=reverse", "pattern=verydark")
   FillRectangle(cw, x, y, w, h)
$else
   cw := Clone(W, "fillstyle=masked", "reverse=on", "pattern=waves")
   FillRectangle(cw, x, y, w, h)
$endif
   Uncouple(cw)
end

procedure left_string(win, x, y, s, k)
   local i

   y +:= (WAttrib(win, "ascent") - WAttrib(win, "descent")) / 2
   DrawString(win, x, y, s)
   if i := upto(\k, map(s)) then {
      x1 := x + TextWidth(win, s[1:i])
      y1 := y + WAttrib(win, "descent") - 1
      DrawLine(win, x1, y1, x1 + TextWidth(win, s[i]), y1)
   }
end

procedure center_string(win, x, y, s, k)
   left_string(win, x - TextWidth(win, s) / 2, y, s, k)
end

procedure right_string(win, x, y, s, k) 
   left_string(win, x - TextWidth(win, s), y, s, k)
end

procedure img_width(s)
   s ? {
      if ="(" then {
         tab(upto(')')) 
         move(1)
      }
      return integer(tab(upto(',')))
   }
end

procedure img_height(s)
   s ? {
      if ="(" then {
         tab(upto(')')) 
         move(1)
      }
      w := integer(tab(upto(',')))
      move(1)
      tab(upto(','))
      move(1)
      return *tab(0) / (0 ~= \w)
   }
end

procedure img_style(s)
   return case s of {
      "box_up" :
"(0=shadow;1=hilite;~=trans)13,c6,_
~~~~~~~~~~~~~_
~11111111111~_
~11111111110~_
~11~~~~~~~00~_
~11~~~~~~~00~_
~11~~~~~~~00~_
~11~~~~~~~00~_
~11~~~~~~~00~_
~11~~~~~~~00~_
~11~~~~~~~00~_
~11000000000~_
~10000000000~_
~~~~~~~~~~~~~_
"
         "box_down" :
"(b=black;0=shadow;1=hilite;~=trans)13,c6,_
~~~~~~~~~~~~~_
~00000000001~_
~00000000001~_
~00~~~~~~~11~_
~00~bbbbb~11~_
~00~bbbbb~11~_
~00~bbbbb~11~_
~00~bbbbb~11~_
~00~bbbbb~11~_
~00~~~~~~~11~_
~01111111111~_
~11111111111~_
~~~~~~~~~~~~~_
"
      "diamond_up2":
"(0=shadow;1=hilite;~=trans)11,c6,_
~~~~~1~~~~~_
~~~~111~~~~_
~~~11~11~~~_
~~11~~~11~~_
~11~~~~~11~_
11~~~~~~~11_
~00~~~~~00~_
~~00~~~00~~_
~~~00~00~~~_
~~~~000~~~~_
~~~~~0~~~~~_
"
         "diamond_down2":
"(b=black;0=shadow;1=hilite;~=trans)11,c6,_
~~~~~0~~~~~_
~~~~000~~~~_
~~~00~00~~~_
~~00~b~00~~_
~00~bbb~00~_
00~bbbbb~00_
~11~bbb~11~_
~~11~b~11~~_
~~~11~11~~~_
~~~~111~~~~_
~~~~~1~~~~~_
"

      "diamond_up" :
"(0=shadow;1=hilite;~=trans)13,c6,_
~~~~~~1~~~~~~_
~~~~~111~~~~~_
~~~~11~11~~~~_
~~~11~~~11~~~_
~~11~~~~~11~~_
~11~~~~~~~11~_
11~~~~~~~~~11_
~00~~~~~~~00~_
~~00~~~~~00~~_
~~~00~~~00~~~_
~~~~00~00~~~~_
~~~~~000~~~~~_
~~~~~~0~~~~~~_
"
         "diamond_down" :
"(b=black;0=shadow;1=hilite;~=trans)13,c6,_
~~~~~~0~~~~~~_
~~~~~000~~~~~_
~~~~00~00~~~~_
~~~00~b~00~~~_
~~00~bbb~00~~_
~00~bbbbb~00~_
00~bbbbbbb~00_
~11~bbbbb~11~_
~~11~bbb~11~~_
~~~11~b~11~~~_
~~~~11~11~~~~_
~~~~~111~~~~~_
~~~~~~1~~~~~~_
"

      "arrow_up" :
"11,c1,_
~~~~~0~~~~~_
~~~~000~~~~_
~~~00000~~~_
~~0000000~~_
~000000000~_
00000000000_
"
      "arrow_down" :
"11,c1,_
00000000000_
~000000000~_
~~0000000~~_
~~~00000~~~_
~~~~000~~~~_
~~~~~0~~~~~_
"
      "arrow_left" :
"9,c1,_
~~~~~~~~0_
~~~~~~000_
~~~~00000_
~~0000000_
000000000_
~~0000000_
~~~~00000_
~~~~~~000_
~~~~~~~~0_
"
      "arrow_right" : "9,c1,_
0~~~~~~~~_
000~~~~~~_
00000~~~~_
0000000~~_
000000000_
0000000~~_
00000~~~~_
000~~~~~~_
0~~~~~~~~_
"
      "closed_folder" : "16,c1,_
~~~~~~~~~~~~~~~~_
~~~~0000~~~~~~~~_
~~~0;;;;0~~~~~~~_
~~0;;;;;;0~~~~~~_
~0000000000000~~_
~0;;;;;;;;;;;0~~_
~0;;;;;;;;;;;0~~_
~0;;;;;;;;;;;0~~_
~0;;;;;;;;;;;0~~_
~0;;;;;;;;;;;0~~_
~0;;;;;;;;;;;0~~_
~0;;;;;;;;;;;0~~_
~0000000000000~~_
~~~~~~~~~~~~~~~~_
"

      "open_folder" : "16,c1,_
~~~~~~~~~~~~~~~~_
~~~0000~~~~~~~~~_
~~0DDDD0~~~~~~~~_
~0DDDDDD0~~~~~~~_
0000000000000~~~_
02D2D2D2D2D20~~~_
0D2D000000000000_
02D0DDDDDDDDDDD0_
0D20DDDDDDDDDD0~_
020DDDDDDDDDDD0~_
0D0DDDDDDDDDDD0~_
00DDDDDDDDDD00~~_
0000000000000~~~_
~~~~~~~~~~~~~~~~_
"

      "file" : "16,c1,_
~~~~~~~~~~~~~~~~_
~~~0000000~~~~~~_
~~~06666600~~~~~_
~~~0606060~0~~~~_
~~~0666660000~~~_
~~~0600606660~~~_
~~~0666666660~~~_
~~~0600600060~~~_
~~~0666666660~~~_
~~~0600060660~~~_
~~~0666666660~~~_
~~~0666666660~~~_
~~~0000000000~~~_
~~~~~~~~~~~~~~~~_
"

      "plus" : "9,g2,_
000000000_
0~~~~~~~0_
0~~~0~~~0_
0~~~0~~~0_
0~00000~0_
0~~~0~~~0_
0~~~0~~~0_
0~~~~~~~0_
000000000_
"

      "minus" : "9,g2,_
000000000_
0~~~~~~~0_
0~~~~~~~0_
0~~~~~~~0_
0~00000~0_
0~~~~~~~0_
0~~~~~~~0_
0~~~~~~~0_
000000000_
"
      "tiny_arrow_up" :
"7,c1,_
~~~0~~~_
~~000~~_
~00000~_
0000000_
"
      "tiny_arrow_down" :
"7,c1,_
0000000_
~00000~_
~~000~~_
~~~0~~~_
"
      default : stop("unknown image style")
   }
end

procedure set_CheckBoxes_by_flag(i, checkboxes)
   j := 1
   every c := !checkboxes do {
      if iand(i, j) ~= 0 then
         c.toggle_is_checked()
      j *:= 2
   }
end

procedure get_CheckBoxes_by_flag(checkboxes)
   i := 1
   j := 0
   every c := !checkboxes do {
      if c.is_checked() then
         j +:= i
      i *:= 2
   }
   return j
end