------------------------->  GNU Sather - sourcefile  <-------------------------
-- Copyright (C) 1995 by International Computer Science Institute            --
-- This file is part of the GNU Sather library. It is free software; you may --
-- redistribute  and/or modify it under the terms of the GNU Library General --
-- Public  License (LGPL)  as published  by the  Free  Software  Foundation; --
-- either version 2 of the license, or (at your option) any later version.   --
-- This  library  is distributed  in the  hope that it will  be  useful, but --
-- WITHOUT ANY WARRANTY without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See Doc/LGPL for more details.       --
-- The license text is also available from:  Free Software Foundation, Inc., --
-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA                     --
-------------->  Please email comments to <bug-sather@gnu.org>  <--------------

-- canvas.sa: Canvas
-- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>

-- Main classes
-- TK_CANVAS  Canvas widget, which corresponds to a Tk frame 
--            + an embedded canvas with optional scrollbars
-- TK_CANVAS_CFG  Canvas configuration options
-- TK_CANVAS_TAG       Tag used for binding canvas items
-- TK_EVENT_INFO  
--            Canvas callback structure. Any bound routine invoked
--            by a canvas callback will be passed a CANVAS_CB as its argument
-- Item Configuration specification
-- TK_RECT_CFG, TK_OVAL_CFG, TK_LINE_CFG,TK_CWIND_CFG
--            Specify configuration options for various canvas items
------------------------------------------------------------------
class TK_CANVAS_CFG < $TK_WIDGET_CFG is
   include TK_WIDGET_CFG_INCL
	 height->height,
	 width->width,
	 relief_none->relief_none,relief_raised->relief_raised,
	 relief_sunken->relief_sunken,
	 relief_flat->relief_flat,relief_ridge->relief_ridge,
	 relief_groove->relief_groove,
	 borderwidth->borderwidth,
	 background->background,
	 insertwidth->insertwidth,
	 insertbackground->insertbackground,
	 insertborderwidth->insertborderwidth,
	 insertofftime->insertofftime,
	 insertontime->insertontime,
   -- takefocus
   -- cursor->cursor
	 selectforeground->selectforeground,
	 selectbackground->selectbackground,
	 selectborderwidth->selectborderwidth,
	 highlightcolor->highlightcolor,
	 highlightbackground->highlightbackground,
	 highlightthickness->highlightthickness;
    
    
   attr hscroll,vscroll: BOOL;	-- Treated differently
   hscroll(v: BOOL): SAME is hscroll := v; return self end;
   vscroll(v: BOOL): SAME is vscroll := v; return self end;
    
    
   confine(b: BOOL) is 
      if b then config("confine","true") else config("confine","false") end;
   end;
   confine(b: BOOL): SAME is confine(b); return self end;
    
   closeenough(i: INT) is config("closeenough",i.str) end;
   closeenough(i: INT): SAME is closeenough(i); return self end;
    
   scroll_region(left,top,right,bot: FLT): SAME is
      scroll_region(left,top,right,bot); return self; 
   end;
    
   scroll_region(left,top,right,bot: FLT) is
      -- Specify the boundaries of the canvas. These are the actual
      -- dimensions of the canvas
      config("scrollregion", 
	     "[ list "+left.str+" "+top.str+" "+right.str+" "+bot.str+" ]"
	     );
   end;
    
   std: SAME is return new.hscroll(true).vscroll(true) end;
    
end;
------------------------------------------------------------------
class TK_CANVAS < $TK_WIDGET is
   -- A standard canvas with scrollbars
   include TK_SCROLL_WIDGET_INCL{TK_CANVAS_CFG};
    
   private const tk_widget_type: STR := "canvas";

   private default_config: TK_CANVAS_CFG is  return TK_CANVAS_CFG::std; end;
   
   private default_init(c: TK_CANVAS_CFG) is       
      if c.vscroll then vscroll end;
      if c.hscroll  then hscroll end;
   end;
    
   -- The following routines are associated with particular tags
   raise_tag(t1,t2:TK_CANVAS_TAG) is
      -- Raise items with tag "t1" above items with tag "t2".
      -- raise is a pSather keyword!
      eval(actual_widget_name,"raise",t1.str,t2.str);
   end;
    
   delete(tag: TK_CANVAS_TAG) is
      -- Delete the item(s) associated with the tag "tag"
      eval(actual_widget_name,"delete",tag.str);
   end;
    
   move(tag: TK_CANVAS_TAG,byx,byy:FLT) is
      -- Move the item(s) associated with the tag "tag" by "byx","byy"
      eval(actual_widget_name,"move",tag.str,join(byx.str,byy.str));
   end;
   
   bind_motion(trigger,move:TK_CANVAS_TAG,cb:ROUT{TK_EVENT_INFO},actnm:STR) is
      -- Deprecated. For compatibility with existing debugger code.  A
      -- specialized routine that very simply implements the
      -- "standard" kind of user directed motion - moving tagged items
      -- using the middle mouse button. Use individual bindings if you
      -- are interested in doing more sophisticated moves.  Bind the
      -- items associated with "tag" to be moved all together using
      -- the second mouse button. A callback will be invoked when the
      -- motion is completed.  This is mostly done with tcl code, so
      -- the sather end is not involved, making this sort of move
      -- faster with the dual process gui.
      action_id ::= add_to_bindings(cb);
      eval("motionBinding",actual_widget_name,action_id,trigger.str,move.str);
   end;
    
   bind_event(event:$TK_EVENT,item:TK_CANVAS_TAG,action:ROUT{TK_EVENT_INFO}) is
      -- Bind an arbitrary event to items with a particular tag. The 
      -- callback routine "action" is invoked when the binding triggers
      bind_event(event,item,action,"unnamed");
   end;
    
   bind_event(event:$TK_EVENT,item:TK_CANVAS_TAG,action:ROUT{TK_EVENT_INFO},deb:STR) is
      -- Usually for internal use
      -- Same as previous bind_event, but specify a string "deb" for
      -- debugging. An action_id is associated with this binding and
      -- this action_id is used to re-invoke the routine Negative
      -- numbers are for the action_id's to distinguish them from
      -- standard bindings
      action_index:INT := add_to_bindings(action);
      eval(actual_widget_name," bind ", 
	   item.str+" "+quote(event.str),
	   quote("sather "+actual_widget_name
		 +" "+action_index
		 +" "+event.cb_str));
   end;
    
   scale(t: TK_CANVAS_TAG,xorig,yorig,xscale,yscale: FLT) is
      -- Rescale all items associated with the tag "t"
      eval(actual_widget_name,"scale",t.str,
	   " "+xorig+" "+yorig+" "+xscale+" "+yscale+" ");
	
   end;
    
   -- ----------------------- TEXT -------------------------------------
   draw_text(text: STR, x,y: FLT) is
      -- Draw "text" at (x,y)
      draw_text(text,x,y,#ARRAY{TK_CANVAS_TAG}(0),TK_CTEXT_CFG::std);
   end;
    
   draw_text(text: STR, x,y: FLT,tags:ARRAY{TK_CANVAS_TAG},config: TK_CTEXT_CFG) is
      -- Draw text at x,y tagged with "tags" and with details specified by 
      -- TK_CTEXT_CFG
      cfg: TK_CTEXT_CFG := config;
      if void(config) then cfg := TK_CTEXT_CFG::std; end;
      eval(actual_widget_name,"create text", 
	   " "+x+" "+y+" -text "+quote(text),
	   tag_str(tags),cfg.str);
   end;
    
   text_configure(tag: TK_CANVAS_TAG,config: TK_CTEXT_CFG) is
      -- (re)configure the item(s) associated with the tag "tag".
      -- See Tk_itemconfigure
      eval(actual_widget_name,"itemconfigure",tag.str,config.str);
   end;
    
   -- ----------------------- POINTS -------------------------------------
   draw_rect_points(x,y: FLIST{FLT},tags:ARRAY{TK_CANVAS_TAG}) is
      -- Hack: The only way in tcl to draw points is to use small
      -- rectangles. This is a faster way to send a bunch of
      -- coordinates for lines that will be drawn as small
      -- rectangles. Don't use unless you have to !  These rectangles
      -- can be configured later using a TK_RECT_CFG.  This can later
      -- be changed to make points be full fledged objects
      eval("canvasPoints",actual_widget_name,
	   tcl_list(tags),
	   tcl_list(x)+" "+tcl_list(y));
   end;
    
   private tcl_list(a: FLIST{FLT}): STR is
      res ::= #FSTR("{ "); loop res := res+" "+a.elt!; end; res := res + " } ";
      return res.str;
   end;
    
   private tcl_list(a: ARRAY{TK_CANVAS_TAG}): STR is
      res ::= #FSTR("{ "); 
      loop res := res+" "+a.elt!.str; end; res := res + " } ";
      return res.str;
   end;
    
   -- ----------------------- LINES -------------------------------------
   draw_line(x1,y1,x2,y2: FLT) is
      -- Draw line from (x1,y1) to (x2,y2)
      draw_line(x1,y1,x2,y2,#ARRAY{TK_CANVAS_TAG}(0),TK_LINE_CFG::std) 
   end;
    
   draw_line(x1,y1,x2,y2: FLT,tags: ARRAY{TK_CANVAS_TAG},config:TK_LINE_CFG) is
      cfg: TK_LINE_CFG := config;
      if void(config) then cfg := TK_LINE_CFG::std; end;
      eval(actual_widget_name,"create line",
	   " "+x1+" "+y1+" "+x2+" "+y2+" ", 
	   tag_str(tags),cfg.str);
   end;
    
   draw_line(x,y: ARRAY{FLT},tags:ARRAY{TK_CANVAS_TAG},config:TK_LINE_CFG) is
      -- Draw a multipoint line
      ptString ::= "";
      assert x.size = y.size;
      loop ptString := ptString+" "+x.elt!+" "+y.elt!; end;
      eval(actual_widget_name,"create line",ptString,tag_str(tags),config.str);
   end;
    
   line_configure(tag: TK_CANVAS_TAG,config: TK_LINE_CFG) is
      eval(actual_widget_name,"itemconfigure",tag.str,config.str);
   end;
   -- ----------------------- RECTANGLES -------------------------------------
   draw_rect(x1,y1,x2,y2: FLT) is
      draw_rect(x1,y1,x2,y2,#ARRAY{TK_CANVAS_TAG}(0), TK_RECT_CFG::std);
   end;
    
   draw_rect(x1,y1,x2,y2: FLT,tags: ARRAY{TK_CANVAS_TAG},config: TK_RECT_CFG) is
      eval(actual_widget_name,"create rectangle",
	   " "+x1+" "+y1+" "+x2+" "+y2+" ", 
	   tag_str(tags),config.str);
   end;
   
   rect_configure(tag: TK_CANVAS_TAG,config: TK_RECT_CFG) is
      eval(actual_widget_name,"itemconfigure",tag.str,config.str);
   end;

   -- ----------------------- OVALS -------------------------------------
   draw_oval(x1,y1,x2,y2: FLT) is
      draw_oval(x1,y1,x2,y2,#ARRAY{TK_CANVAS_TAG}(0), TK_OVAL_CFG::std);
   end;
    
   draw_oval(x1,y1,x2,y2: FLT,tags: ARRAY{TK_CANVAS_TAG},config: TK_OVAL_CFG) is
      eval(actual_widget_name,"create oval",
	   " "+x1+" "+y1+" "+x2+" "+y2+" ", 
	   tag_str(tags),config.str);
   end;
   
   oval_configure(tag: TK_CANVAS_TAG,config: TK_OVAL_CFG) is
      eval(actual_widget_name,"itemconfigure",tag.str,config.str);
   end;

   -- ----------------------- POLYGONS -------------------------------------
   draw_poly(x:ARRAY{FLT},y:ARRAY{FLT}) 
      pre ~void(x) and ~void(y) and x.size = y.size 
   -- Draw a polygon
   is
      draw_poly(x,y,#ARRAY{TK_CANVAS_TAG}(0), TK_POLY_CFG::std);
   end;
    
   draw_poly(x,y:ARRAY{FLT},tags: ARRAY{TK_CANVAS_TAG},config: TK_POLY_CFG) is
      -- Draw a polygon
      points:STR := "";
      loop points := points+x.elt!.str+" "+y.elt!.str+" "; end;
      eval(actual_widget_name,"create polygon", points,
	   tag_str(tags),config.str);
   end;
   
   poly_configure(tag: TK_CANVAS_TAG,config: TK_POLY_CFG) is
      eval(actual_widget_name,"itemconfigure",tag.str,config.str);
   end;

   -- ----------------------- WINDOWS -------------------------------------
   embed_window(w: $TK_WIDGET,x,y: FLT) is
      embed_window(w,x,y,#ARRAY{TK_CANVAS_TAG}(0), TK_CWIND_CFG::std);
   end;
    
   embed_window(w: $TK_WIDGET,x,y:FLT,tags:ARRAY{TK_CANVAS_TAG},
		config: TK_CWIND_CFG) is
      eval(actual_widget_name,
	   "create window "+ x+ " "+y+" -window "+w.widget_name,
	   tag_str(tags),config.str);
   end;
    
   wind_configure(tag: TK_CANVAS_TAG,config: TK_CWIND_CFG) is
      eval(actual_widget_name,"itemconfigure",tag.str,config.str);
   end;
    
   ------------------------------- IMPLEMENTATION DETAILS --------------------
   bind_event(event: $TK_EVENT,action: ROUT{TK_EVENT_INFO}) is
      -- Bind the event "event" to the action "action", a bound
      -- routine which takes an EVENT_INFO as an argument
      -- The first argument to the callback is an index in to
      -- the list of bindings that corresponds to this "action"
      action_index: INT := add_to_bindings(action);
      eval("bind "+actual_widget_name+' '+event.str+' '+" \" sather "
	   +actual_widget_name+" " +action_index+" "+event.cb_str+"\"");
   end;
      
   private tag_str(tags: ARRAY{TK_CANVAS_TAG}): STR is
      if tags.size = 0 then return " " end;
      tag_list ::= "-tags { ";
      loop tag_list := tag_list+" "+tags.elt!.str; end;
      tag_list := tag_list+" }";
      return tag_list
   end;
    
end; -- class TK_CANVAS
-------------------------------------------------------------------
immutable class TK_CANVAS_TAG is include TK_TAG_INCL end;
-- A generic canvas item tag that can be used with any kind of item.
-------------------------------------------------------------------
-- Configuration options for the various item types
-------------------------------------------------------------------
class TK_RECT_CFG is
   private include TK_ARG_UTIL;
    
   private attr fill_col,outline_col,outline_wid: STR;
    
   fill_color(color:STR) is fill_col:=color; end;
   outline_color(color:STR) is  outline_col:=color; end;
   outline_width(i:INT) is outline_wid:=i.str; end;
   fill_color(color:STR): SAME is fill_color(color); return self; end;
   outline_color(color:STR): SAME is outline_color(color); return self; end;
   outline_width(i:INT): SAME is outline_width(i); return self; end;
   -- stipple(b: TK_BITMAP) is bitmap := b; end;
   -- stipple(b: TK_BITMAP): SAME is bitmap(b); return self end;
    
   create: SAME is   return new;  end;
   std: SAME is res ::= #SAME; return res end;
    
   str: STR is 
      return ""
	    +pair("fill",fill_col)
	    +pair("outline",outline_col)
	    +pair("width",outline_wid);
   end;
end;
-------------------------------------------------------------------
class TK_POLY_CFG is
   private include TK_ARG_UTIL;
    
   private attr fill_col: STR;
   private attr smoothstr:STR;
   private attr splinestepsstr:STR;
   
   fill_color(color:STR) is fill_col:=color; end;
   fill_color(color:STR): SAME is fill_color(color); return self; end;
   smooth(b: BOOL) is 
      if b then smoothstr:="true" else smoothstr:="false" end;
   end;
   smooth(b:BOOL): SAME is smooth(b); return self end;
   splinesteps(n: INT) is splinestepsstr := n.str; end;
   splinesteps(n:INT): SAME is splinesteps(n); return self end;
   
   create: SAME is   return new;  end;
   std: SAME is res ::= #SAME; return res end;
    
   str: STR is 
      return ""
	    +pair("splinesteps",splinestepsstr)
	    +pair("smooth",smoothstr)
	    +pair("fill",fill_col); 
   end;
end;
-------------------------------------------------------------------
class TK_OVAL_CFG is
   -- Circle and oval configuration options
   include TK_RECT_CFG;
    
end;
-------------------------------------------------------------------
class TK_LINE_CFG is
   -- Line configuration options
   private include TK_ARG_UTIL;
    
   private attr line_color,line_arrow,line_width: STR;
   private attr arrow_shape_str,smoothstr,splinestepsstr:STR;
    
   fill(c: STR) is line_color := c end;   
   width(i: INT) is line_width := i.str end;
   fill(c: STR): SAME is fill(c); return self end;
   width(i: INT): SAME is width(i); return self end;
   smooth(b: BOOL) is 
      if b then smoothstr:="true" else smoothstr:="false" end;
   end;
   smooth(b:BOOL): SAME is smooth(b); return self end;
   splinesteps(n: INT) is splinestepsstr := n.str; end;
   splinesteps(n:INT): SAME is splinesteps(n); return self end;
    
   arrow(beg,last: BOOL) is 
      if beg and last then line_arrow := "both" 
      elsif beg then line_arrow := "first" 
      elsif last then line_arrow := "last" 
      else line_arrow := " " end;
   end;
   arrow(beg,last:BOOL): SAME is arrow(beg,last); return self end;
   arrow_shape(neck_to_tip,wing_to_tip,body_to_wing:FLT) is
      -- Untested
      arrow_shape_str := " [ list "+neck_to_tip+" "+wing_to_tip+" "+
	    body_to_wing+"]";
   end;
    
   create: SAME is   return new; end;
   std: SAME is res ::= #SAME; return res end;
   str: STR is  return ""
      +pair("arrow",line_arrow)
	    +pair("splinesteps",splinestepsstr)
	    +pair("smooth",smoothstr)
	    +pair("width",line_width)
	    +pair("fill",line_color); 
   end;
    
end;
-------------------------------------------------------------------
class TK_CTEXT_CFG is
   -- Canvas text configuration (not to be confused with a text widget's
   -- configuration)
   private include TK_ARG_UTIL;
    
   private attr text_color,font_name,justify,text_width: STR;
    
   attr anchor: TK_ANCHOR;
   anchor(val:TK_ANCHOR): SAME is anchor := val; return self; end;
    
   fill(color: STR) is   text_color := color;  end;
   font(f: STR) is   font_name := f;  end;
   justify_right is justify := "right" end;
   justify_left is justify := "left" end; -- Default
   justify_center is justify := "center" end;
   width(sz: FLT) is   text_width := sz.str;   end;
   fill(color: STR): SAME is  fill(color); return self end;
   font(f: STR): SAME is  font(f); return self end;
   justify_right: SAME is justify_right; return self; end;
   justify_left: SAME is justify_left; return self end;
   justify_center: SAME is justify_center;  return self; end;
   width(sz: FLT): SAME is  width(sz); return self end;
    
   create: SAME is return new; end;
   std: SAME is res ::= #SAME; res.anchor := TK_ANCHOR::nw; return res end;
    
   str: STR is 
      return ""
	    +pair("fill",text_color)
	    +pair("font",font_name)
	    +pair("justify",justify)
	    +pair("width",text_width)
	    +pair("anchor",anchor);
   end;
    
end;
-------------------------------------------------------------------
class TK_CWIND_CFG is
   -- Canvas text configuration (not to be confused with a text widget's
   -- configuration)
   private include TK_ARG_UTIL;
    
   attr anchor: TK_ANCHOR;
    
   create: SAME is return new end;
    
   std: SAME is res ::= #SAME; res.anchor := TK_ANCHOR::nw; return res end;
    
   str: STR is return ""+pair("anchor",anchor); end;
    
end;
-------------------------------------------------------------------
