canvas.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
---------------------------> Sather 1.1 source file <--------------------------
-- canvas.sa: Canvas
-- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>
-- Copyright (C) 1995, International Computer Science Institute
-- canvas.sa,v 1.1 1995/11/15 03:36:37 gomes Exp
--
-- COPYRIGHT NOTICE: This code is provided WITHOUT ANY WARRANTY
-- and is subject to the terms of the SATHER LIBRARY GENERAL PUBLIC
-- LICENSE contained in the file: Sather/Doc/License of the
-- Sather distribution. The license is also available from ICSI,
-- 1947 Center St., Suite 600, Berkeley CA 94704, USA.
-- Main classes
-- TK_CANVAS Canvas widget, which corresponds to a Tk frame
-- + an embedded canvas with optional scrollbars
-- TK_CANVAS_CFG Canvas configuration options
-- CTAG Tag used for binding canvas items
-- TK_CANVAS_CB
-- 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
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
class TK_CANVAS < $TK_WIDGET is
-- A standard canvas with scrollbars
include TK_SCROLL_WIDGET_INCL{TK_CANVAS_CFG};
private attr callback_map: TK_WIDGET_CALLBACKS{ROUT{TK_CANVAS_CB}};
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
callback_map := #;
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_CTAG) 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_CTAG) is
-- Delete the item(s) associated with the tag "tag"
eval(actual_widget_name,"delete",tag.str);
end;
move(tag: TK_CTAG,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_item(event:$TK_EVENT,item:TK_CTAG,action:ROUT{TK_CANVAS_CB}) is
-- Bind an arbitrary event to items with a particular tag. The
-- callback routine "action" is invoked when the binding triggers
bind_item(event,item,action,"unnamed");
end;
bind_item(event:$TK_EVENT,item:TK_CTAG,action:ROUT{TK_CANVAS_CB},deb:STR) is
-- Usually for internal use
-- Same as previous bind_item, 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
deb("Binding to event:"+event.str+" Tag:"+item.str+","+deb);
action_id ::= callback_map.register(action,deb);
action_id := -action_id;
eval("canvasBindItem", actual_widget_name, event.str,
join(item.str,action_id));
end;
scale(t: TK_CTAG,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;
bind_item_motion(trigger,move:TK_CTAG,cb:ROUT{TK_CANVAS_CB},actnm:STR) is
-- 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 ::= callback_map.register(cb,actnm);
eval("motionBinding",actual_widget_name,action_id,trigger.str,move.str);
end;
-- ----------------------- TEXT -------------------------------------
draw_text(text: STR, x,y: FLT) is
-- Draw "text" at (x,y)
draw_text(text,x,y,#ARRAY{TK_CTAG}(0),TK_CTEXT_CFG::std);
end;
draw_text(text: STR, x,y: FLT,tags:ARRAY{TK_CTAG},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_CTAG,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_CTAG}) 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_CTAG}): 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_CTAG}(0),TK_LINE_CFG::std)
end;
draw_line(x1,y1,x2,y2: FLT,tags: ARRAY{TK_CTAG},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_CTAG},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_CTAG,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_CTAG}(0), TK_RECT_CFG::std);
end;
draw_rect(x1,y1,x2,y2: FLT,tags: ARRAY{TK_CTAG},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_CTAG,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_CTAG}(0), TK_OVAL_CFG::std);
end;
draw_oval(x1,y1,x2,y2: FLT,tags: ARRAY{TK_CTAG},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_CTAG,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_CTAG}(0), TK_POLY_CFG::std);
end;
draw_poly(x,y:ARRAY{FLT},tags: ARRAY{TK_CTAG},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_CTAG,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_CTAG}(0), TK_CWIND_CFG::std);
end;
embed_window(w: $TK_WIDGET,x,y:FLT,tags:ARRAY{TK_CTAG},
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_CTAG,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 := bindings.size+1; -- = Index of the next binding
deb("Binding an action with index:"+(-action_index)+"\n");
bindings.append(action);
eval("bind "+actual_widget_name+' '+event.str+' '+" \" sather "
+actual_widget_name+" " +(-action_index)+" "+event.cb_str+"\"");
end;
act_on(id: INT, args: ARRAY{STR}) is
-- Called by "GUI_APP_END" if self is the appropriate recipient.
-- Go through the args - convert them into a CANVAS_CB and then
-- call the appropriate function
-- 0 = id 1 = button 2 = x 3 = y
-- 4 on ward = coods
if args.size < 4 then raise "Not enough arguments to canvas cb!" end;
res: TK_CANVAS_CB := #;
if id < 0 then
-- If it is is negative
id := -id;
deb("Acting on canvas with id:"+(id-1));
func ::= bindings[id-1];
event_info ::= #TK_EVENT_INFO(args);
deb("Event info:"+event_info.str);
func.call(event_info);
return;
end;
rout ::= callback_map.get_action(id);
res.button_number := int_if_poss(args[1],-1);
res.x := int_if_poss(args[2],-1);
res.y := int_if_poss(args[3],-1);
isx ::= true;
i ::= 4; loop until!(i >= args.size);
if i+1 >= args.size then break! end;
x ::= flt_if_poss(args[i],-1.0);
y ::= flt_if_poss(args[i+1],-1.0);
res.add_cood(x,y);
i := i + 2;
end;
if debug then deb("Calling rout:"+res.str); end;
rout.call(res);
if debug then deb("Called rout"); end;
-- char_str ::= raw_args[4];
-- args.character := char_if_poss(char_str,' ');
end;
private tag_str(tags: ARRAY{TK_CTAG}): 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
class TK_CANVAS_CB
class TK_CANVAS_CB is
-- Arguments for a canvas callback. This structure will be
-- passed as an argument into any bound routine which is
-- bound to a canvas item event
-- For now, only use the x and y location, not the list of
-- coordinates - that is for future use
-- Not all these fields will be valid for all types of events.
-- See the tk documentation for "bind"
attr button_number: INT;
-- x and y location of the event - may not correspond to
-- the location of the object
attr x: INT;
attr y: INT;
-- Location of the object specified by it's coods
private attr coodx: FLIST{FLT};
private attr coody: FLIST{FLT};
create: SAME is return new end;
add_cood(x,y: FLT) is coodx := coodx.push(x); coody := coody.push(y) end;
n_coods: INT is return coodx.size; end;
-- Number of coods
cood(i: INT):TUP{FLT,FLT} is
-- Ith cood
if i >= coodx.size then raise "No such cood:"+i
else return #TUP{FLT,FLT}(coodx[i],coody[i]); end;
end;
str: STR is
res ::= "button_number="+button_number+",x="+x+",y="+y;
loop res := res+"{"+coodx.elt!+","+coody.elt!+"}"; end;
return res;
end;
end;
immutable class TK_CTAG 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
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
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
class TK_OVAL_CFG is
-- Circle and oval configuration options
include TK_RECT_CFG;
end;
class TK_LINE_CFG
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
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
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;