## graphviz-widget.pkg
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib# This package gets used in:
# src/lib/x-kit/widget/old/fancy/graphviz/scrollable-graphviz-widget.pkgstipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package fil = file__premicrothread; # file__premicrothread is from src/lib/std/src/posix/file--premicrothread.pkg package f8b = eight_byte_float; # eight_byte_float is from src/lib/std/eight-byte-float.pkg package g2d = geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg package gf = geometry2d_float; # geometry2d_float is from src/lib/std/2d/geometry2d-float.pkg package bs = beta2_spline; # beta2_spline is from src/lib/x-kit/draw/beta2-spline.pkg #
package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkg #
package wg = widget; # widget is from src/lib/x-kit/widget/old/basic/widget.pkg package gm = get_mouse_selection; # get_mouse_selection is from src/lib/x-kit/widget/old/fancy/graphviz/get-mouse-selection.pkg package pu = popup_menu; # popup_menu is from src/lib/x-kit/widget/old/menu/popup-menu.pkg package pg = planar_graphtree; # planar_graphtree is from src/lib/std/dot/planar-graphtree.pkg package ffc = font_family_cache; # font_family_cache is from src/lib/x-kit/widget/old/fancy/graphviz/font-family-cache.pkg #
package xtr = xlogger; # xlogger is from src/lib/x-kit/xclient/src/stuff/xlogger.pkgherein
package graphviz_widget
: (weak) Graphviz_Widget # Graphviz_Widget is from src/lib/x-kit/widget/old/fancy/graphviz/graphviz-widget.api {
exception ERROR(String);
truncate = f8b::truncate;
Viewdim
=
VIEWDIM
{ min: Int,
size: Int,
total: Int
};
Viewnode
=
{ node: pg::Node,
bbox: g2d::Box, # "bbox" == "bounding box"
draw: (xc::Drawable, xc::Pen) -> g2d::Box -> Void,
fill: (xc::Drawable, xc::Pen) -> g2d::Box -> Void,
label: String
};
Graph_To_Window_Space_Coordinate_Transform = gf::Point -> g2d::Point;
Window_To_Graph_Space_Coordinate_Transform = g2d::Point -> gf::Point;
Plea_Mail
= SET_VERTICAL_VIEW Int
| SET_HORIZONTAL_VIEW Int
| DELETE
;
Graphviz_Widget
=
GRAPHVIZ_WIDGET
{ widget: wg::Widget,
graph: pg::Traitful_Graph,
plea_slot: Mailslot( Plea_Mail ),
#
to_scrollbars_slot: Mailslot { horizontal: Viewdim,
vertical: Viewdim
}
};
View_Data
=
{ graph_to_window_space: Graph_To_Window_Space_Coordinate_Transform, # Graph -> Window space coordinate transformation function.
window_to_graph_space: Window_To_Graph_Space_Coordinate_Transform, # Window -> Graph space coordinate transformation function.
#
visible_nodes: List( Viewnode ), # List of visible nodes.
font: Null_Or( xc::Font ), # Font scaled to view.
picked_node: Null_Or( pg::Node ) # Picked node.
};
fun map_box_from_window_to_graph_space (projfn: Window_To_Graph_Space_Coordinate_Transform) box
=
{ (projfn (g2d::box::upperleft box)) -> { x=>ul_x, y=>ul_y }; # "ul" == "upper left"
(projfn (g2d::box::lowerright1 box)) -> { x=>lr_x, y=>lr_y }; # "lr" == "lower right"
gf::BOX { x => ul_x,
y => ul_y,
#
wide => lr_x - ul_x,
high => lr_y - ul_y
};
};
fun map_box_from_graph_to_window_space (projfn: Graph_To_Window_Space_Coordinate_Transform) box
=
{ (projfn ( gf::upperleft_of_box box)) -> { col=>ul_x, row=>ul_y }; # "ul" == "upper left"
(projfn (gf::lowerright_of_box box)) -> { col=>lr_x, row=>lr_y }; # "lr" == "lower right"
{ col => ul_x,
row => ul_y,
#
wide => lr_x - ul_x,
high => lr_y - ul_y
};
};
# Curried fn to write text in given window,
# centered in the given box, and using largest
# font so that text fits in the box.
#
fun put_text (window, THE font, black_pen) # + below '\\' args.
=>
{ (xc::font_high font)
->
{ ascent, descent };
font_high = ascent + descent;
draw_text = xc::draw_transparent_string
(xc::drawable_of_window window)
black_pen
font;
\\ (text, { col, row, wide, high } )
=
{ slen = xc::text_width font text;
col = col + (wide - slen ) / 2;
row = row + ascent + (high - font_high) / 2;
draw_text ({ col, row }, text);
};
};
put_text (_, NULL, _)
=>
(\\ _ = ());
end;
# Generate the draw-outline and draw-filled-shape
# functions for an ellipse, diamond or box:
#
stipulate
fun diamond_of_box ({ col, row, wide, high } )
=
{ midx = col + wide / 2;
midy = row + high / 2;
startp = { col, row=>midy };
[ startp,
{ col => midx, row },
{ col => col + wide, row => midy },
{ col => midx, row => row+high },
startp
];
};
full_angle = 360 * 64;
fun draw_ellipse drawfn (drawable, pen) ({ col, row, wide, high } )
=
drawfn drawable pen ({ col, row, wide, high, angle1=>0, angle2=>full_angle } );
fun draw_diamond (drawable, pen) box
=
xc::draw_lines drawable pen (diamond_of_box box);
fun fill_diamond (drawable, pen) box
=
xc::fill_polygon
drawable
pen
{ verts => diamond_of_box box,
shape => xc::CONVEX_SHAPE
};
fun draw_box drawfn (drawable, pen) box
=
drawfn drawable pen box;
herein
fun get_draw_fns dot_graphtree_traits::ELLIPSE => (draw_ellipse xc::draw_arc, draw_ellipse xc::fill_arc);
get_draw_fns dot_graphtree_traits::DIAMOND => (draw_diamond, fill_diamond);
get_draw_fns _ => (draw_box xc::draw_box, draw_box xc::fill_box);
end;
end;
# Return the smallest box containing
# given box with the same origin, and
# same wide/high ratio as given template.
#
fun make_box
{ containing => gf::BOX { wide, high, x, y }, # Given box.
shaped_like => { wide=>tx, high=>ty, ... }: g2d::Box # Given template.
}
=
{ tmpy = (wide * (f8b::from_int ty)) / (f8b::from_int tx);
if (tmpy >= high) gf::BOX { x, y, wide, high => tmpy };
else gf::BOX { x, y, wide => (high * (f8b::from_int tx)) / (f8b::from_int ty), high };
fi;
};
# Resize viewport onto graph in response
# (e.g.) to a resize of the toplevel window.
#
fun resize_box
( graph_bbox,
gf::BOX { x=>new_x, y=>new_y, wide=>new_wide, high=>new_high },
gf::BOX { x=>old_x, y=>old_y, wide=>old_wide, high=>old_high }
)
=
{ graph_bbox -> gf::BOX { x=>bb_x, y=>bb_y, wide=>bb_wide, high=>bb_high }; # "bb" == "bounding box"
new_y = if (new_high >= bb_high)
#
bb_y - (new_high - bb_high) / 2.0;
else
ybot = old_y + old_high;
ytop = ybot - new_high;
if (ytop < bb_y) (ybot <= bb_y ) ?? bb_y :: ytop;
else (ytop >= bb_y + bb_high) ?? bb_y+bb_high-new_high :: ytop;
fi;
fi;
new_x = if (new_wide >= bb_wide)
#
bb_x - (new_wide - bb_wide) / 2.0;
else
xl = old_x;
xr = old_x + new_wide;
if (xl < bb_x) if (xr <= bb_x ) bb_x; else xl; fi;
else if (xl >= bb_x+bb_wide) bb_x+bb_wide-new_wide; else xl; fi;
fi;
fi;
gf::BOX { x => new_x,
y => new_y,
#
wide => new_wide,
high => new_high
};
};
# Update position of scrollbar thumbs
# to reflect resized window or such:
#
fun set_scrollbars
(to_scrollbars_slot, gf::BOX { x=>minx, y=>miny, wide, high } )
visible_box # Currently visible part of full graph.
=
{ fun max (a: Float, b) = if (a > b) a; else b; fi;
fun min (a: Float, b) = if (a < b) a; else b; fi;
my { x=>ul_x, y=>ul_y } = gf::upperleft_of_box visible_box; # "ul" == "upper left"
my { x=>lr_x, y=>lr_y } = gf::lowerright_of_box visible_box; # "lr" == "lower right"
startx = max (ul_x, minx);
starty = max (ul_y, miny);
sizex = min (lr_x, minx+wide) - startx;
sizey = min (lr_y, miny+high) - starty;
high = truncate high;
wide = truncate wide;
put_in_mailslot ( to_scrollbars_slot,
{ horizontal => VIEWDIM { min=>truncate (startx-minx), size=>truncate sizex, total=>wide },
vertical => VIEWDIM { min=>truncate (starty-miny), size=>truncate sizey, total=>high }
}
);
};
fun make_coordinate_transformation_functions (window_box, graph_box)
=
{ # Generate transformation functions between
# universal (graph) and window spaces.
# We assume the two rectangles have
# the same high/wide ratio:
window_box -> { col=>wmin_x, row=>wmin_y, wide=>wdelta_x, high=>wdelta_y };
graph_box -> gf::BOX { x =>umin_x, y =>umin_y, wide=>udelta_x, high=>udelta_y };
wmin_x = f8b::from_int wmin_x;
wmin_y = f8b::from_int wmin_y;
wdelta_x = f8b::from_int wdelta_x;
wdelta_y = f8b::from_int wdelta_y;
# Projection function from universal (graph)
# to window coordinates:
#
fun u2w ({ x, y })
=
{ col => floor((wdelta_x * (x - umin_x)) / udelta_x + wmin_x),
row => floor((wdelta_y * (y - umin_y)) / udelta_y + wmin_y)
};
# Projection function from window
# to universal (graph) coordinates:
#
fun w2u ({ col, row } )
=
{ x => (udelta_x*((f8b::from_int col) - wmin_x)) / wdelta_x + umin_x,
y => (udelta_y*((f8b::from_int row) - wmin_y)) / wdelta_y + umin_y
};
(u2w, w2u);
};
fun find_visible_nodes graph (window_box, graph_to_window_space)
=
pg::nodes_fold note_node_if_visible graph []
where
gws = map_box_from_graph_to_window_space graph_to_window_space;
fun is_visible node
=
g2d::box::intersect (window_box, gws (pg::node_info_of node).bbox);
fun make_view_node node
=
{ (pg::node_info_of node)
->
{ bbox, label, shape, ... };
(get_draw_fns shape)
->
(draw, fill);
{ node, label, fill, draw, bbox => gws bbox };
};
fun note_node_if_visible (node, results)
=
if (is_visible node) make_view_node node ! results;
else results;
fi;
end;
# Draw all nodes and edges visible
# in the current graph viewport:
#
fun draw_viewport_full
(graph, window, white_pen, black_pen, red_pen)
( { graph_to_window_space, visible_nodes, font, picked_node, ... }: View_Data)
=
{ drawable = xc::drawable_of_window window;
draw_spline
=
(xc::draw_lines drawable black_pen)
o
bs::b_spline;
put_text = put_text (window, font, black_pen);
fun draw_arrowhead points
=
xc::fill_polygon
drawable
black_pen
{ verts => map graph_to_window_space points,
shape => xc::CONVEX_SHAPE
};
fun draw_edges ( { node, ... } : Viewnode)
=
{ pg::out_edges_apply draw_edge (graph, node);
pg::in_edges_apply draw_edge (graph, node);
}
where
fun draw_edge edge
=
{ my { points, arrowhead, ... }
=
pg::edge_info_of edge;
draw_spline (map graph_to_window_space points); # Body of edge.
draw_arrowhead arrowhead; # Head of edge.
};
end;
# Draw a node, white on black:
#
fun draw_node ( { bbox, label, draw, fill, ... }: Viewnode)
=
{ # clear_area (drawable_of_window window) bbox;
fill (drawable, white_pen) bbox;
put_text (label, bbox);
draw (drawable, black_pen) bbox;
};
# Draw a node, white on red if
# picked, else white on black:
#
fun draw_node' picked_node ({ bbox, label, draw, fill, node }: Viewnode)
=
{ if (pg::eq_node (node, picked_node)) fill (drawable, red_pen) bbox;
else fill (drawable, white_pen) bbox;
fi;
put_text (label, bbox);
draw (drawable, black_pen) bbox;
};
xc::clear_drawable (xc::drawable_of_window window);
apply draw_edges visible_nodes;
case picked_node
#
NULL => apply draw_node visible_nodes;
THE picked_node => apply (draw_node' picked_node) visible_nodes;
esac;
}; # fun draw_viewport_full
# When a window is uncovered, the X server
# sends a list of sub-rectangles of that
# window which need redrawing. Our job
# here is to redraw one of those sub-rectangles,
# specified by 'windowspace_clip_box':
#
fun draw_viewport_part
(graph, window, white_pen, black_pen, red_pen)
( { graph_to_window_space, window_to_graph_space, visible_nodes, font, picked_node, ... }: View_Data)
windowspace_clip_box
=
{ drawable = xc::drawable_of_window window;
#
draw_spline = (xc::draw_lines drawable black_pen) o bs::b_spline;
put_text = put_text (window, font, black_pen);
graphspace_clip_box
=
map_box_from_window_to_graph_space
window_to_graph_space
windowspace_clip_box;
fun draw_arrowhead points
=
xc::fill_polygon
drawable
black_pen
{ verts => map graph_to_window_space points,
shape => xc::CONVEX_SHAPE
};
fun draw_edges ( { node, ... }: Viewnode)
=
{ pg::out_edges_apply draw_edge (graph, node);
pg::in_edges_apply draw_edge (graph, node);
}
where
fun draw_edge edge
=
{ (pg::edge_info_of edge)
->
{ points, arrowhead, bbox };
if (gf::intersect (bbox, graphspace_clip_box))
#
draw_spline (map graph_to_window_space points);
draw_arrowhead arrowhead;
fi;
};
end;
# Draw a node, white on black:
#
fun draw_node ( { bbox, label, draw, fill, ... }: Viewnode)
=
if (g2d::box::intersect (bbox, windowspace_clip_box))
#
# clear_area (xc::drawable_of_window window) bbox;
#
fill (drawable, white_pen) bbox;
put_text (label, bbox);
draw (drawable, black_pen) bbox;
fi;
# Draw a node, white on red if
# picked, else white on black:
#
fun draw_node' picked_node ({ node, bbox, label, draw, fill }: Viewnode)
=
if (g2d::box::intersect (bbox, windowspace_clip_box))
#
if (pg::eq_node (node, picked_node)) fill (drawable, red_pen) bbox;
else fill (drawable, white_pen) bbox;
fi;
put_text (label, bbox);
draw (drawable, black_pen) bbox;
fi;
apply draw_edges visible_nodes;
case picked_node
#
NULL => apply draw_node visible_nodes;
THE picked_node => apply (draw_node' picked_node) visible_nodes;
esac;
};
# Redraw in black-on-red a node,
# to acknowledge a user click on it,
# then update state.picked_node:
#
fun set_select (window, black_pen, red_pen)
( { visible_nodes, graph_to_window_space, window_to_graph_space, font, ... }: View_Data,
{ node, bbox, label, fill, draw }: Viewnode
)
=
{ fill (xc::drawable_of_window window, red_pen) bbox;
put_text (window, font, black_pen) (label, bbox);
draw (xc::drawable_of_window window, black_pen) bbox;
{ visible_nodes, graph_to_window_space, window_to_graph_space, font, picked_node => THE node };
};
# Redraw in black-on-white a previously black-on-red node,
# to show that it is no longer the 'picked' node, then
# clear state.picked_node:
#
fun unset_select (window, black_pen, white_pen)
( { visible_nodes, graph_to_window_space, window_to_graph_space, font, ... }: View_Data, node)
=
{ (pg::node_info_of node)
->
{ bbox, label, shape, ... };
(get_draw_fns shape)
->
(draw, fill);
window_box = map_box_from_graph_to_window_space graph_to_window_space bbox;
fill (xc::drawable_of_window window, white_pen) window_box;
put_text (window, font, black_pen)
(label, window_box);
draw (xc::drawable_of_window window, black_pen)
window_box;
{ visible_nodes, font, graph_to_window_space, window_to_graph_space, picked_node => NULL };
};
# Messages sent from mouse thread to main thread,
# reflecting mouse actions abstracted into higher-
# level operations:
#
Mouse_Mail
= PICK g2d::Point
| ZOOM_IN g2d::Box
| ZOOM_OUT g2d::Box
| RESET
| BLOCK
| UNBLOCK
| GET_PICK Oneshot_Maildrop( Null_Or( (String, String, Null_Or( (Int, Int) ) ) ) )
;
fun mouse_thread (root_window, window, m, mouse_slot)
=
mouse_loop ()
where
fun get_pick ()
=
{ oneshot = make_oneshot_maildrop ();
#
put_in_mailslot (mouse_slot, GET_PICK oneshot);
get_from_oneshot oneshot;
};
mevt = if_then' (m, xc::get_contents_of_envelope); # "threadkit::if_then'" is the plain name for threadkit::(==>).
getrect = gm::get_box (window, m);
no_bttns = xc::make_mousebutton_state [];
fun getr msg
=
{ put_in_mailslot (mouse_slot, BLOCK);
#
null_or_box = block_until_mailop_fires (getrect (xc::MOUSEBUTTON 3));
put_in_mailslot (mouse_slot, UNBLOCK);
case null_or_box
#
NULL => ();
THE box => put_in_mailslot (mouse_slot, msg box);
esac;
};
fun popup menu
=
pu::make_lowlevel_popup_menu (root_window, menu, NULL);
fun menu2 (mname, fname, range)
=
{ fun open_view (loc, range) ()
=
show_graph::open_viewer root_window
{
loc,
range,
file => fname,
module => mname
};
case range
#
NULL =>
pu::POPUP_MENU
[
pu::POPUP_MENU_ITEM ("View " + mname, open_view (1, NULL))
];
THE (first, last)
=>
pu::POPUP_MENU
[
pu::POPUP_MENU_ITEM ("View " + fname, open_view (first, NULL)),
pu::POPUP_MENU_ITEM ("View " + mname, open_view (first, THE { first, last } ))
];
esac;
};
popup3
=
popup
(pu::POPUP_MENU
[
pu::POPUP_MENU_ITEM ("Zoom in", \\ () = getr ZOOM_IN),
pu::POPUP_MENU_ITEM ("Zoom out", \\ () = getr ZOOM_OUT),
pu::POPUP_MENU_ITEM ("Reset", \\ () = put_in_mailslot (mouse_slot, RESET)),
pu::POPUP_MENU_ITEM ("Quit", \\ () = { widget::delete_root_window root_window; shut_down_thread_scheduler winix__premicrothread::process::success; } )
]
);
fun mouse_loop ()
=
for (;;) {
#
case (block_until_mailop_fires mevt)
#
xc::MOUSE_FIRST_DOWN { mouse_button=>btn, window_point, screen_point, ... }
=>
case btn
#
xc::MOUSEBUTTON 1
=>
put_in_mailslot (mouse_slot, PICK window_point);
xc::MOUSEBUTTON 2
=>
case (get_pick ())
#
NULL => ();
THE info
=>
{ popup2 = popup (menu2 info);
#
case (block_until_mailop_fires (popup2 (btn, pu::PUT_POPUP_MENU_ITEM_BENEATH_MOUSE 0, screen_point, m)))
#
NULL => ();
THE action => action ();
esac;
};
esac;
xc::MOUSEBUTTON 3
=>
case (block_until_mailop_fires (popup3 (btn, pu::PUT_POPUP_MENU_ITEM_BENEATH_MOUSE 0, screen_point, m)))
#
NULL => ();
THE action => action ();
esac;
xc::MOUSEBUTTON _
=>
();
esac;
_ => ();
esac;
};
end;
fun make_graphviz_widget (font_family_cache, root_window) graph
=
GRAPHVIZ_WIDGET {
plea_slot,
to_scrollbars_slot,
#
widget => w,
graph
}
where
(pg::graph_info_of graph)
->
{ graph_bbox, fontsize, ... };
screen = wg::screen_of root_window;
# We draw edges, text and node outlines in black.
# We fill nodes in white, except that
# we fill the currently picked node (if any) in red.
#
white_pen = xc::make_pen [xc::p::FOREGROUND xc::rgb8_white];
black_pen = xc::make_pen [xc::p::FOREGROUND xc::rgb8_black];
red_pen = xc::make_pen [xc::p::FOREGROUND xc::rgb8_red ];
plea_slot = make_mailslot (); # We get external requests via this.
mouse_slot = make_mailslot (); # we get analysed mouse input from the mouse_thread via this.
to_scrollbars_slot = make_mailslot (); # We send scrollbar update commands to our parent scrollable_graphviz_widget via this.
min_size = 30;
# The dimensions should be scaled
# to fit reasonably in the screen:
#
graph_bbox -> gf::BOX { wide, high, ... };
size_preferences
=
{ col_preference => wg::INT_PREFERENCE { start_at=>0, step_by=>1, min_steps=>min_size, best_steps=>max (min_size, floor wide), max_steps=>NULL },
row_preference => wg::INT_PREFERENCE { start_at=>0, step_by=>1, min_steps=>min_size, best_steps=>max (min_size, floor high), max_steps=>NULL }
};
set_scrollbars = set_scrollbars (to_scrollbars_slot, graph_bbox);
# Most 2D graphics are sized in pixels,
# but fonts are sized in points. This
# fn maps pixel sizes to point sizes.
# We use this as part of selecting an
# appropriate size font for node text:
#
pix2pts
=
{ my { high=>htpx, ... } = wg::size_of_screen root_window;
my { high=>htmm, ... } = wg::mm_size_of_screen root_window;
fact = (((f8b::from_int htmm)/(f8b::from_int htpx))/25.4) * 72.0;
\\ px = floor((f8b::from_int px)*fact);
};
fun scale_font proj
=
{ my { row=>y, ... }: g2d::Point = proj gf::point_zero;
my { row=>y', ... }: g2d::Point = proj ({ x=>0.0, y=> f8b::from_int fontsize });
pix2pts (y' - y);
};
fun set_state (window_box, graph_box, picked_node)
=
{ (make_coordinate_transformation_functions (window_box, graph_box))
->
(graph_to_window_space, window_to_graph_space);
{ graph_to_window_space,
window_to_graph_space,
#
visible_nodes => find_visible_nodes graph (window_box, graph_to_window_space),
#
font => ffc::get_font font_family_cache (scale_font graph_to_window_space),
picked_node
};
};
fun set_view (arg as (_, graph_box, _))
#
# Set visible part of graph, for ETC_RESIZE, zoom in/out etc.
=
{ set_scrollbars graph_box;
set_state arg;
};
fun realize_widget { kidplug, window, window_size }
=
{ xtr::make_thread "graphviz mouse" {.
#
mouse_thread (root_window, window, from_mouse', mouse_slot);
};
xtr::make_thread "graphviz widget" {.
#
main_thread (window_size, initial_state);
();
};
();
}
where
my xc::KIDPLUG { from_mouse', from_other', to_mom, ... }
=
xc::ignore_keyboard kidplug;
draw_viewport_full' = draw_viewport_full (graph, window, white_pen, black_pen, red_pen);
draw_viewport_part' = draw_viewport_part (graph, window, white_pen, black_pen, red_pen);
set_select = set_select (window, black_pen, red_pen);
unset_select = unset_select (window, black_pen, white_pen);
window_box = g2d::box::make (g2d::point::zero, window_size);
initial_state
=
set_view (window_box, make_box { containing => graph_bbox, shaped_like => window_box }, NULL);
fun main_thread (window_size, state)
=
main_loop state
where
fun scroll_mailop (horizontal, newst, { window_to_graph_space, picked_node, ... }: View_Data)
=
{ window_box = g2d::box::make (g2d::point::zero, window_size);
my gf::BOX { x, y, wide, high }
=
map_box_from_window_to_graph_space window_to_graph_space window_box;
my (x, y)
=
horizontal
##
?? (f8b::from_int newst, y)
:: (x, f8b::from_int newst);
new_state
=
set_state (window_box, gf::BOX { x, y, wide, high }, picked_node);
draw_viewport_full' new_state;
new_state;
};
fun do_mom (xc::ETC_REDRAW damaged_screen_areas, state)
=>
{ # 'damaged_screen_areas' is a list of rectangular
# areas within our window which the X server
# wants us to redraw.
#
xlogger::log_if xlogger::hostwindow_to_widget_router_tracing 0 {. "redraw"; };
apply (draw_viewport_part' state) damaged_screen_areas;
state;
};
do_mom (xc::ETC_RESIZE ({ wide, high, ... } ),{ graph_to_window_space, window_to_graph_space, picked_node, ... } )
=>
{ new_window_size = { wide, high };
window_box = g2d::box::make (g2d::point::zero, new_window_size);
new_box = map_box_from_window_to_graph_space window_to_graph_space window_box;
old_box = map_box_from_window_to_graph_space window_to_graph_space (g2d::box::make (g2d::point::zero, window_size));
new_state = set_view (window_box, resize_box (graph_bbox, new_box, old_box), picked_node);
xlogger::log_if xlogger::hostwindow_to_widget_router_tracing 0 {. "resize."; };
xc::clear_drawable (xc::drawable_of_window window);
main_thread (new_window_size, new_state);
};
do_mom (_, state)
=>
state;
end;
fun zoom_in (box, { window_to_graph_space, picked_node, ... }: View_Data)
=
{ window_box = g2d::box::make (g2d::point::zero, window_size);
graph_box = map_box_from_window_to_graph_space window_to_graph_space box;
fun check (box as gf::BOX { x, y, wide, high } )
=
if (wide < 30.0 or high < 30.0) gf::BOX { x, y, wide=>30.0, high=>30.0 };
else box;
fi;
new_state = set_view (window_box, make_box { containing => check graph_box, shaped_like => window_box }, picked_node);
draw_viewport_full' new_state;
new_state;
};
fun zoom_out (box, { window_to_graph_space, picked_node, ... }: View_Data)
=
{ window_box = g2d::box::make (g2d::point::zero, window_size);
graph_box = map_box_from_window_to_graph_space window_to_graph_space window_box;
new_state = set_state (gf::to_box (make_box { containing => gf::from_box box, shaped_like => window_box }), graph_box, picked_node);
# Note that the 2nd argument to set_scrollbars is
# not graph_box, as we have changed the perspective.
set_scrollbars (map_box_from_window_to_graph_space new_state.window_to_graph_space window_box);
draw_viewport_full' new_state;
new_state;
};
# Process a user mouseclick in the graph viewport:
# Redraw in black-on-white any previously picked node.
# If a node was clicked on, redraw it in black-on-red and remember it.
#
fun do_pick (point, state as { visible_nodes, picked_node, ... }: View_Data)
=
{ fun accept ( { bbox, ... }: Viewnode)
=
g2d::point::in_box (point, bbox);
case (list::find accept visible_nodes)
#
THE (nvn as { node=>newvn, ... } ) # New pick
=>
case picked_node
#
THE oldvn # Old pick
=>
# If old == new, do nothing:
#
if (pg::eq_node (newvn, oldvn))
#
state;
else
unset_select (state, oldvn);
set_select (state, nvn);
fi;
_ =>
set_select (state, nvn);
esac;
_ => # No new pick
case picked_node
#
THE oldvn => unset_select (state, oldvn); # Old pick
_ => state;
esac;
esac;
};
fun reset ( { picked_node, ... }: View_Data)
=
{ window_box = g2d::box::make (g2d::point::zero, window_size);
new_state
=
set_view
( window_box,
make_box { containing => graph_bbox, shaped_like => window_box },
picked_node
);
draw_viewport_full' new_state;
new_state;
};
fun block (state, ci_list)
=
do_one_mailop [
take_from_mailslot' mouse_slot
==>
(\\ msg = case msg
#
UNBLOCK => fold_backward (\\ (m, s) = do_mom (m, s)) # 2009-12-28 CrT: Changed 'fold' to 'fold_backward', I hope that is right!
state
ci_list;
_ => block (state, ci_list);
esac
),
from_other'
==>
(\\ envelope = block (state, (xc::get_contents_of_envelope envelope) ! ci_list))
];
fun get_pick ( { picked_node => NULL, ... }: View_Data)
=>
NULL;
get_pick { picked_node => THE node, ... }
=>
{ info = pg::node_info_of node;
get_trait = dot_graphtree::get_trait (dot_graphtree::NODE_PART info.base);
fun error trait
=
{ fil::print("missing " + trait + " trait\n");
#
raise exception DIE (cat [ "missing ", trait, " trait" ]);
};
fname = case (get_trait "file")
#
NULL => error "file";
THE s => s;
esac;
range = case (get_trait "range")
#
NULL => NULL;
#
THE s => case (scanf::sscanf_by "%d:%d" s)
THE [scanf::INT a, scanf::INT b] => THE (a, b);
_ => error "range";
esac;
esac;
THE (info.label, fname, range);
};
end;
fun do_mouse (PICK point, state: View_Data)
=>
do_pick (point, state);
do_mouse (ZOOM_IN box, state) => zoom_in (box, state);
do_mouse (ZOOM_OUT box, state) => zoom_out (box, state);
do_mouse (RESET, state) => reset state;
do_mouse (BLOCK, state) => block (state,[]);
do_mouse (GET_PICK oneshot, state) => { put_in_oneshot (oneshot, get_pick state); state; };
do_mouse (_, state) => state;
end;
fun do_plea (SET_VERTICAL_VIEW v, state: View_Data) => scroll_mailop (FALSE, v, state);
do_plea (SET_HORIZONTAL_VIEW v, state: View_Data) => scroll_mailop (TRUE, v, state);
do_plea (DELETE, state: View_Data) => state;
end;
fun main_loop state
=
main_loop (
#
do_one_mailop [
#
take_from_mailslot' mouse_slot
==>
(\\ mail = do_mouse (mail, state)),
from_other'
==>
(\\ envelope = do_mom (xc::get_contents_of_envelope envelope, state)),
take_from_mailslot' plea_slot
==>
(\\ msg = do_plea (msg, state))
]
);
end;
end;
w = wg::make_widget
{
root_window,
args => (\\ () = { background => NULL }), # Added 2009-12-28 CrT just to get it to compile
size_preference_thunk_of => {. size_preferences; },
realize_widget
};
end; # fun make_graphviz_widget
fun as_widget (GRAPHVIZ_WIDGET { widget, ... } ) = widget;
fun set_horizontal_view (GRAPHVIZ_WIDGET { plea_slot, ... } ) v = put_in_mailslot (plea_slot, SET_HORIZONTAL_VIEW v);
fun set_vertical_view (GRAPHVIZ_WIDGET { plea_slot, ... } ) v = put_in_mailslot (plea_slot, SET_VERTICAL_VIEW v);
fun to_scrollbars_mailop_of (GRAPHVIZ_WIDGET { to_scrollbars_slot, ... } ) = take_from_mailslot' to_scrollbars_slot;
}; # package graphviz_widget
end;