#!/usr/bin/q -- #! -c main ARGS /* graphed: the Q graph editor $Id: graphed.q,v 1.7 2006/02/19 07:23:47 agraef Exp $ */ /* This file is part of the Q programming system. The Q programming system is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. The Q programming system 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 the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ /* TODO: ******************************************************************* - plugin interface, e.g.: circular, grid and spring embeddings; make loopless, bidirected; induced and spanning subgraphs; generic algorithm plugin - add support for various common graph file formats (plugin) - optimize display update for various operations (watch out for FIXMEs) **************************************************************************/ import graph, tk; /* program version */ def VERSION = "1.3"; /* default printer setup *****************************************************/ /* You might wish to customize this for your purposes. */ /* paper sizes */ def DIM = dict [("A2", (1190.6, 1683.8)), ("A3", (841.9, 1190.6)), ("A4", (595.3, 841.9)), ("A5", (419.5, 595.3)), ("B4", (708.7, 1000.6)), ("B5", (498.9, 708.7)), ("Letter", (612.0, 792.0)), ("Tabloid", (792.0, 1224.0)), ("Ledger", (1224.0, 792.0)), ("Legal", (612.0, 1008.0)), ("Executive", (540.0, 720.0))]; private swap; def RDIM = hdict (map swap (list DIM)); swap (X,Y) = (Y,X); /* length units */ def UNITS = dict [("pt",1.0),("in",72.0),("cm",72/2.54),("mm",72/25.4)]; to_pt U X = X*UNITS!U; to_pt2 U X = round (to_pt U X*100)/100; to_unit U X = X/UNITS!U; to_unit2 U X = round (to_unit U X*100)/100; /* setup */ def PRINT_CMD = "lpr", EPS_FILTER = "epssplit %b %m %p %x %y %o -ps", PDF_FILTER = "ps2pdf", PRINT_CROPMARKS = false, UNIT = "mm", PAPER = DIM!"A4", MARGIN = 10, XPAGES = 0, YPAGES = 0, LANDSCAPE = false; /* configuration information ************************************************/ /* hardcoded defaults */ defaults = (// display parameters (-0.1,-0.1, // lower left corner of coordinate range 1.1, 1.1, // upper right corner .002,.002, // X and Y resolution in units/pixel .1, .1, // grid spacing 1.2), // zoom factor // node and edge geometry ( 5, 1, // node and edge width 15,(1,0), // node label offset and default placement 5,(1,0), // edge label offset and default placement (0,1)), // loop placement // colors ("black", // node outline color "black", // node fill color "red", // selection color "black", // edge color "black", // label color "grey"), // grid color /* display options */ (true, // enable display of node numbers true, // enable display of node labels true, // enable display of edge labels false, // enable grid display false)); // enable snap to grid /* get config data from .graphed file if present, use defaults otherwise */ private load_config; config = CONFIG where CONFIG:Tuple = load_config; = defaults otherwise; /* valid directions for loop and label placement */ public type Direction = const c, e, ne, n, nw, w, sw, s, se; /* mapping between direction vectors and symbolic values */ def DIRLIST = [(c, ( 0, 0)), (e, ( 1, 0)), (ne, ( 1, 1)), (n, ( 0, 1)), (nw, (-1, 1)), (w, (-1, 0)), (sw, (-1,-1)), (s, ( 0,-1)), (se, ( 1,-1))]; def DIRVECT = dict DIRLIST; def DIRVAL = hdict (zip (vals DIRVECT) (keys DIRVECT)); /* public functions *********************************************************/ /* There are two main entry points: graphed edits a graph in "directed mode" where edges are drawn as arrows, whereas graphed2 is used to edit a bidirected graph in "undirected mode" where edges are depicted as lines. Both operations can either be invoked on a graph object or the name of a file to be loaded at startup. You can also switch between both modes of operation while in the editor. */ public graphed G, graphed2 G; /* Besides this, we also provide two convenience routines for loading and saving graphs in files. */ public load_graph FNAME, save_graph FNAME G; /* main program *************************************************************/ /* Program name and installation prefix. */ private basename NAME, prefix NAME; def PROG = ARGS!0, SELF = basename PROG, PREFIX = prefix "graphed"; // determine the basename of the script basename NAME = BASE where [BASE|_] = split "." (last (split "/\\" NAME)) if pos "mingw" sysinfo >= 0; = BASE where [BASE|_] = split "." (last (split "/" NAME)); // determine the installation prefix prefix NAME = substr ANAME 0 (#ANAME-2) where ANAME:String = which NAME; = NAME otherwise; /* This is to be executed when we are invoked from the (Unix) shell. NOTE: The main function to be invoked is `graphed' by default, but if the script is named `graphed2', the alternative entry point of this name will be used instead. */ private getopts ARGS, set_scriptname, main_func; main ARGS:List = main (getopts ARGS); main (ARGS,OPTS) = fprintf ERROR "%s: this program requires Q version >= 4.1\n" PROG || exit 1 if version < "4.1"; = fprintf ERROR "%s: %s could not be found, please check your installation\n" (PROG,FNAME) || exit 1 if not isfile (fopen FNAME "r") where FNAME = PREFIX++".tcl"; = fprintf ERROR "USAGE: %s [graph-file]\n" PROG || exit 1 if (#ARGS>2) or else any (<>"-2") OPTS; = set_scriptname || main_func (ARGS!1) || exit 0 if #ARGS > 1; = set_scriptname || main_func emptygraph || exit 0 otherwise; set_scriptname = tk "wm withdraw ." || tk (sprintf "proc graphed { } { return %s }" (str SELF)); main_func = graphed2 if SELF = "graphed2"; = graphed otherwise; // simple command line parser private getopts2; getopts [CMD|ARGS] = getopts2 ([CMD],[]) ARGS; getopts2 (ARGS,OPTS) [] = (ARGS,OPTS); getopts2 (ARGS,OPTS) [ARG|REST] = (ARGS++REST,OPTS) if ARG="--"; = getopts2 (ARGS,append OPTS ARG) REST if not null ARG and then ARG!0="-"; = getopts2 (append ARGS ARG,OPTS) REST otherwise; /* main entry points ********************************************************/ private init_graph, init_app, main_loop; private bidirected G; graphed G:Graph = main_loop (init_app () "Ready" STATE) where CONFIG = config++(true,1.0,()), STATE = (init_graph CONFIG G,CONFIG); graphed FNAME:String = main_loop (init_app FNAME "Ready" STATE) where G:Graph = load_graph FNAME, CONFIG = config++(true,1.0,()), STATE = (init_graph CONFIG G,CONFIG); = main_loop (init_app FNAME "New file" STATE) where G = emptygraph, CONFIG = config++(true,1.0,()), STATE = (init_graph CONFIG G, CONFIG); graphed2 G:Graph = main_loop (init_app () "Graph is not bidirected, \ switching to digraph mode" STATE) where CONFIG = config++(true,1.0,()), STATE = (init_graph CONFIG G,CONFIG) if not bidirected G; = main_loop (init_app () "Ready" STATE) where CONFIG = config++(false,1.0,()), STATE = (init_graph CONFIG G,CONFIG); graphed2 FNAME:String = main_loop (init_app FNAME "Graph is not bidirected, \ switching to digraph mode" STATE) where CONFIG = config++(true,1.0,()), STATE = (init_graph CONFIG G,CONFIG) if not bidirected G where G:Graph = load_graph FNAME; = main_loop (init_app FNAME "Ready" STATE) where G:Graph = load_graph FNAME, CONFIG = config++(false,1.0,()), STATE = (init_graph CONFIG G,CONFIG); = main_loop (init_app FNAME "New file" STATE) where G = emptygraph, CONFIG = config++(false,1.0,()), STATE = (init_graph CONFIG G, CONFIG); // quick and dirty check whether a graph is bidirected bidirected G:Graph = eq H (revgraph H) where H = revgraph G; /* forward declarations of miscellaneous helper functions */ private config_data; private valid_zoom, get_zoom, set_zoom, get_viewport, set_viewport, get_scrollregion, set_scrollregion; private shift_status, lshift_status, rshift_status, ctrl_status, lctrl_status, rctrl_status; private set_var, get_var; private get_fname, set_fname, get_edited, set_edited, get_grid, set_grid, get_snap, set_snap, get_digraph_mode, set_digraph_mode, get_entry, set_entry, set_msg, set_status; private params, geom, colors, options, digraph, actzoom, lastG; private set_digraph, set_actzoom, set_lastG, set_actgrid, set_actsnap; private init_canvas, init_print_setup, draw, draw_grid, update_title, update_commands, update_entry, update_undo, update_edit, update_clipboard; private dg, dg_from, cval, _f, _i; /* initialize the application */ init_app FNAME MSG (G,CONFIG) = set_msg MSG || set_status "EDIT" || set_fname FNAME || update_title || update_commands STATE || STATE where STATE = tk "wm withdraw ." || ifelse (null (tk "info command graphed")) (tk_quit || tk "wm withdraw .") () || tk "set argc 0; set argv {}" || tk (sprintf "source %s" (str (PREFIX++".tcl"))) || tk "proc exit { {returnCode 0} } { q [graphed]::quit_cb }" || tk "wm protocol $widget(Toplevel1) WM_DELETE_WINDOW exit" || tk "wm protocol $widget(Toplevel2) WM_DELETE_WINDOW \ {q [graphed]::print_setup_cancel_cb}" || tk "wm protocol $widget(Toplevel3) WM_DELETE_WINDOW \ {q [graphed]::config_cancel_cb}" || tk "$widget(ComboBox1) configure -values {20% 50% 75% 100% 150% 200% 250% 300%}" || tk "$widget(CancelButton) configure -state disabled" || tk "$widget(OkButton) configure -state disabled" || tk (sprintf "$widget(PaperSizeBox) configure -values {%s}" (join " " (keys DIM++["Custom"]))) || tk (sprintf "$widget(UnitBox) configure -values {%s}" (join " " (keys UNITS))) || init_print_setup || do dg_from (config_data CONFIG) || set_zoom 1.0 || set_digraph_mode (digraph CONFIG) || tk "set placement ()" || tk "set lshift 0; set rshift 0; set lctrl 0; set rctrl 0" || init_canvas CONFIG || draw_grid CONFIG || (draw CONFIG G,CONFIG); /* application main loop */ private chk, fini_graph; // catch unimplemented and partial callbacks main_loop (val S:String STATE) = set_msg (sprintf "Not implemented: %s" S) || main_loop STATE; main_loop (CB STATE) = set_msg (sprintf "Not implemented: %s" (str CB)) || main_loop STATE; main_loop STATE = main_loop (chk STATE (tk_read STATE)) if tk_ready; = tk_quit || fini_graph CONFIG G where (G,CONFIG) = STATE; /* keep track of state and process undo information */ private save_undo OLDSTATE STATE; const purge; chk OLDSTATE STATE = update_entry || update_commands STATE || save_undo OLDSTATE STATE if tk_ready; = STATE otherwise; save_undo (LASTG,_) (G,CONFIG) = (G,set_lastG CONFIG ()) if eq purge (lastG CONFIG); = (G,set_lastG CONFIG LASTG) if neq G LASTG; = (G,CONFIG) otherwise; update_commands STATE = update_undo STATE || update_edit STATE || update_clipboard STATE; update_undo (_,CONFIG) = tk "$widget(EditMenu) entryconfigure 0 -state normal" if isgraph (lastG CONFIG); = tk "$widget(EditMenu) entryconfigure 0 -state disabled" otherwise; update_edit _ = tk "$widget(EditMenu) entryconfigure 2 -state normal" || tk "$widget(EditMenu) entryconfigure 3 -state normal" || tk "$widget(EditMenu) entryconfigure 6 -state normal" || tk "$widget(CutButton) configure -state normal" || tk "$widget(CopyButton) configure -state normal" if not null (tk "$widget(Canvas) find withtag sel"); = tk "$widget(EditMenu) entryconfigure 2 -state disabled" || tk "$widget(EditMenu) entryconfigure 3 -state disabled" || tk "$widget(EditMenu) entryconfigure 6 -state disabled" || tk "$widget(CutButton) configure -state disabled" || tk "$widget(CopyButton) configure -state disabled" otherwise; update_clipboard _ = tk "$widget(EditMenu) entryconfigure 4 -state normal" || tk "$widget(PasteButton) configure -state normal" if not null (catch (cst ()) (tk "selection get -selection CLIPBOARD")); = tk "$widget(EditMenu) entryconfigure 4 -state disabled" || tk "$widget(PasteButton) configure -state disabled" otherwise; /* handle errors in the Tk interpreter */ tk_error S = throw '(tk_error S); tk_reads = "[graphed]::quit_cb" if not tk_ready; /* initialize and finalize the graph's embedding */ /* The "embedding" actually consists of several different types of node and edge labels which are processed by the editor. The node position must be the first label of a node. The second label of a node (or the first one, if the node embedding is missing) and the first label of an edge may denote a direction used for placing node and edge labels, as well as loops. Internally, the node positions are translated to display coordinates for faster processing, and labels for storing the display object ids and selection status of nodes and edges are added. These are removed when the modified graph is returned by the editor. */ private init_node, init_edge; init_graph CONFIG G = graph (map (init_node CONFIG) (adj_list G)); private edge_filter, disp_coords, rand_coords, user_coords; init_node CONFIG (N,E,(X:Num,Y:Num)|L) = (N,map init_edge (edge_filter CONFIG N E), disp_coords CONFIG (X,Y),(),false|L); init_node CONFIG (N,E|L) = (N,map init_edge (edge_filter CONFIG N E), rand_coords CONFIG,(),false|L) otherwise; private fwd_edge; edge_filter CONFIG N E = E if digraph CONFIG; = filter (fwd_edge N) E otherwise; fwd_edge N M:Int = N<=M; fwd_edge N (M:Int|_) = N<=M; init_edge (M|L) = (M,(),false|L); init_edge M = (M,(),false); private fini_node, fini_edge; fini_graph CONFIG G = graph (map (fini_node CONFIG) (adj_list G)) if digraph CONFIG; = graph2 (map (fini_node CONFIG) (adj_list G)) otherwise; fini_node CONFIG (N,E,P,_,_|L) = (N,map fini_edge E,user_coords CONFIG P|L); fini_edge (M,_,_|L) = M if null L; = (M|L) otherwise; /* The following combination of init_graph and fini_graph is used for internal processing where the selection flags must be kept when the graph display is reconstructed. */ private reinit_node, reinit_edge, sel_status; reinit_graph OLDCONFIG NEWCONFIG G = graph2 (map (reinit_node OLDCONFIG NEWCONFIG) (adj_list G)) if digraph NEWCONFIG > digraph OLDCONFIG; = graph (map (reinit_node OLDCONFIG NEWCONFIG) (adj_list G)) otherwise; reinit_node OLDCONFIG NEWCONFIG (N,E,(X:Num,Y:Num),ID,_|L) = (N,map reinit_edge (edge_filter NEWCONFIG N E), disp_coords NEWCONFIG (user_coords OLDCONFIG (X,Y)), (),sel_status ID|L) if digraph NEWCONFIG < digraph OLDCONFIG; = (N,map reinit_edge E, disp_coords NEWCONFIG (user_coords OLDCONFIG (X,Y)), (),sel_status ID|L) otherwise; reinit_edge (M,ID,_|L) = (M,(),sel_status ID|L); const act; private selected; sel_status ID = act if active ID; = selected ID otherwise; /* This is a simplified version of reinit_graph which just updates the selection. */ private update_sel_node, update_sel_edge; update_sel_graph G = graph (map update_sel_node (adj_list G)); update_sel_node (N,E,P,ID,_|L) = (N,map update_sel_edge E,P,(),sel_status ID|L); update_sel_edge (M,ID,_|L) = (M,(),sel_status ID|L); /* coordinate translations */ disp_coords CONFIG (X,Y) = ((X-X1)/XRES*Z,(Y2-Y)/YRES*Z) where (X1,Y1,X2,Y2,XRES,YRES|_) = params CONFIG, Z = actzoom CONFIG; user_coords CONFIG (X,Y) = (X1+X/Z*XRES,Y2-Y/Z*YRES) where (X1,Y1,X2,Y2,XRES,YRES|_) = params CONFIG, Z = actzoom CONFIG; /* random display coordinates for default embedding */ rand = random/0xffffffff; rand_coords CONFIG = ((X-X1)/XRES*Z,(Y2-Y)/YRES*Z) where (X1,Y1,X2,Y2,XRES,YRES|_) = params CONFIG, (X,Y) = (X1+(X2-X1)*rand,Y1+(Y2-Y1)*rand), Z = actzoom CONFIG; /* configure the canvas */ init_canvas CONFIG = set_scrollregion ((X2-X1)/XRES*Z,(Y2-Y1)/YRES*Z) where (X1,Y1,X2,Y2,XRES,YRES|_) = params CONFIG, Z = actzoom CONFIG; /* draw the grid */ private draw_vline, draw_hline; var I; draw_grid CONFIG = do (draw_vline CONFIG) (listof (X1+I*XGRID) (I in nums 0 NX)) || do (draw_hline CONFIG) (listof (Y1+I*YGRID) (I in nums 0 NY)) || tk "$widget(Canvas) lower grid (!grid)" where (X1,Y1,X2,Y2,_,_,XGRID,YGRID|_) = params CONFIG, NX = trunc ((X2-X1)/XGRID), NY = trunc ((Y2-Y1)/YGRID) if GRID where (_,_,_,GRID|_) = options CONFIG; = tk "$widget(Canvas) delete grid" otherwise; private grid_dash; draw_vline CONFIG X = val (tk (sprintf "$widget(Canvas) create line %g %g %g %g \ -fill %s -dash \"%s\" -tags grid" (DX,DY1+5,DX,DY2-5,GRIDCOL,grid_dash CONFIG))) where (_,_,_,_,_,GRIDCOL|_) = colors CONFIG, (X1,Y1,X2,Y2|_) = params CONFIG, (DX,DY1) = disp_coords CONFIG (X,Y1), (DX,DY2) = disp_coords CONFIG (X,Y2); draw_hline CONFIG Y = val (tk (sprintf "$widget(Canvas) create line %g %g %g %g \ -fill %s -dash \"%s\" -tags grid" (DX1-5,DY,DX2+5,DY,GRIDCOL,grid_dash CONFIG))) where (_,_,_,_,_,GRIDCOL|_) = colors CONFIG, (X1,Y1,X2,Y2|_) = params CONFIG, (DX1,DY) = disp_coords CONFIG (X1,Y), (DX2,DY) = disp_coords CONFIG (X2,Y); /* provide some visual feedback for snap to grid mode */ snap_indicator CONFIG = tk (sprintf "$widget(Canvas) itemconfigure grid -dash \"%s\"" (grid_dash CONFIG)); grid_dash CONFIG = ". - " if SNAP where (_,_,_,_,SNAP|_) = options CONFIG; = ". " otherwise; /* snap point to grid */ grid_point CONFIG (X,Y) = (X,Y) where (X1,Y1,_,_,_,_,XGRID,YGRID|_) = params CONFIG, (X,Y) = user_coords CONFIG (X,Y), NX = round ((X-X1)/XGRID), NY = round ((Y-Y1)/YGRID), (X,Y) = disp_coords CONFIG (X1+NX*XGRID,Y1+NY*YGRID) if SNAP where (_,_,_,_,SNAP|_) = options CONFIG; = (_f X,_f Y) otherwise; /* file operations **********************************************************/ /* render the display to a postscript file */ postscript CONFIG FNAME = tk (sprintf "$widget(Canvas) postscript -file %s \ -x 0.0 -y 0.0 -width %g -height %g" (str FNAME,(X2-X1)/XRES*Z,(Y2-Y1)/YRES*Z)) where (X1,Y1,X2,Y2,XRES,YRES|_) = params CONFIG, Z = actzoom CONFIG; /* the following are provided as additional entry points */ /* load a graph from a file */ private parse_graph; const bad_graph; load_graph FNAME = parse_graph F (freads F) where F:File = fopen FNAME "r"; parse_graph F S:String = parse_graph F (freads F) if null S or else (S!0="%"); = G where G:Graph = val S; parse_graph _ _ = bad_graph otherwise; /* save a graph in a file */ save_graph FNAME G:Graph = fprintf F "%% created by graphed %s %s\n" (VERSION,ctime time) || fwrite F G || fwrites F "\n" where F:File = fopen FNAME "w"; /* graph drawing ************************************************************/ private draw_node, raise_node; draw CONFIG G = do raise_node (reverse NODES) || set_msg "Ready" || graph NODES where NODES = set_msg "Drawing, please wait..." || map (draw_node CONFIG G) (adj_list G); // we raise nodes above edges so that they get selected first raise_node (_,_,_,ID|_) = tk (sprintf "$widget(Canvas) raise %d (edge||loop)" ID) if not null (tk "$widget(Canvas) find withtag (edge||loop)"); // draw a node and all its outgoing edges sel_tags act = "sel act"; sel_tags SEL = "sel" if SEL; = "" otherwise; sel_col act MARKCOL COL = MARKCOL; sel_col SEL MARKCOL COL = MARKCOL if SEL; = COL otherwise; private draw_node_labels, draw_node_labels_at, draw_edge; var TAG; draw_node CONFIG G (N,E,(X,Y),_,SEL|L) = (N,E1,(X,Y),ID,false|L) where (NODEWD|_) = geom CONFIG, (OUTLCOL,FILLCOL,MARKCOL|_) = colors CONFIG, ID = val (tk (sprintf "$widget(Canvas) create oval %g %g %g %g -outline %s \ -fill %s -tags {n%d}" (X-NODEWD,Y-NODEWD,X+NODEWD,Y+NODEWD,OUTLCOL, sel_col SEL MARKCOL FILLCOL,N))), LID = draw_node_labels CONFIG N ID (X,Y) SEL L, _ = tk (sprintf "$widget(Canvas) addtag r%d withtag %d" (LID,ID)), _ = tk (sprintf "$widget(Canvas) addtag node withtag %d" ID), _ = do tk (map (sprintf "$widget(Canvas) addtag %s withtag %d") (listof (TAG,ID) (TAG in split " " (sel_tags SEL)))), E1 = map (draw_edge CONFIG G N (X,Y)) E; // draw the node labels draw_node_labels CONFIG N NID P SEL (D:Direction|L) = draw_node_labels_at CONFIG N NID P (DIRVECT!D) SEL L; draw_node_labels CONFIG N NID P SEL L = draw_node_labels_at CONFIG N NID P DIR SEL L where (_,_,_,DIR|_) = geom CONFIG; private anchor, offs, len, vert, hor, label_str, tkstr; private sqr; draw_node_labels_at CONFIG N NID (X,Y) DIR SEL L = val (tk (sprintf "$widget(Canvas) create text %g %g \ -fill %s -text %s -anchor %s -tags {l%d r%d label %s}" (X+XOFFS,Y-YOFFS,sel_col SEL MARKCOL LBLCOL, tkstr (str N++": "++label_str L), anchor XOFFS YOFFS,N,NID,sel_tags SEL))) where (XOFFS,YOFFS) = offs OFFS DIR if NODENUM and then NODELBL and then not null L where (NODENUM,NODELBL|_) = options CONFIG, (_,_,MARKCOL,_,LBLCOL|_) = colors CONFIG, (_,_,OFFS|_) = geom CONFIG; = val (tk (sprintf "$widget(Canvas) create text %g %g \ -fill %s -text %s -anchor %s -tags {l%d r%d label %s}" (X+XOFFS,Y-YOFFS,sel_col SEL MARKCOL LBLCOL,str N, anchor XOFFS YOFFS,N,NID,sel_tags SEL))) where (XOFFS,YOFFS) = offs OFFS DIR if NODENUM where (NODENUM,NODELBL|_) = options CONFIG, (_,_,MARKCOL,_,LBLCOL|_) = colors CONFIG, (_,_,OFFS|_) = geom CONFIG; = val (tk (sprintf "$widget(Canvas) create text %g %g \ -fill %s -text %s -anchor %s -tags {l%d r%d label %s}" (X+XOFFS,Y-YOFFS,sel_col SEL MARKCOL LBLCOL, tkstr (label_str L), anchor XOFFS YOFFS,N,NID,sel_tags SEL))) where (XOFFS,YOFFS) = offs OFFS DIR if NODELBL and then not null L where (NODENUM,NODELBL|_) = options CONFIG, (_,_,MARKCOL,_,LBLCOL|_) = colors CONFIG, (_,_,OFFS|_) = geom CONFIG; = () otherwise; offs W D = D*W/L if L>0 where L = len D; = D otherwise; len (X,Y) = sqrt (sqr X+sqr Y); sqr X = X*X; anchor XOFFS YOFFS = ifelse (null A) "center" A where A = vert (_i YOFFS) ++ hor (_i XOFFS); vert OFFS = "s" if OFFS>0; = "n" if OFFS<0; = "" otherwise; hor OFFS = "w" if OFFS>0; = "e" if OFFS<0; = "" otherwise; label_str (L,) = str L; label_str L = str L otherwise; // draw a loop private draw_edge_labels, draw_edge_labels_at, translate; private get_tags, set_tags, class, shift_labels, shift_label, get_ind, set_ind, get_dir, get_place, get_labels, change_labels; draw_edge CONFIG G N (X,Y) (N,_,SEL,D:Direction|L) = (N,EID,false,D|L) where (NODEWD,EDGEWD|_) = geom CONFIG, (_,_,MARKCOL,EDGECOL|_) = colors CONFIG, DIR = DIRVECT!D, (XOFFS,YOFFS) = offs (3*NODEWD) DIR, (X1,Y1,X2,Y2) = (X-2*NODEWD,Y-2*NODEWD,X+2*NODEWD,Y+2*NODEWD), EID = val (tk (sprintf "$widget(Canvas) create oval %g %g %g %g -width %g \ -outline %s -tags {s%d t%d}" (X1+XOFFS,Y1-YOFFS,X2+XOFFS,Y2-YOFFS,_f EDGEWD, sel_col SEL MARKCOL EDGECOL,N,N))), LID = draw_edge_labels_at CONFIG (N,N) EID (X,Y) (XOFFS,YOFFS) DIR SEL L, _ = tk (sprintf "$widget(Canvas) addtag r%d withtag %d" (LID,EID)), _ = tk (sprintf "$widget(Canvas) addtag loop withtag %d" EID), _ = do tk (map (sprintf "$widget(Canvas) addtag %s withtag %d") (listof (TAG,EID) (TAG in split " " (sel_tags SEL)))); draw_edge CONFIG G N (X,Y) (N,_,SEL|L) = (N,EID,false|L) where (NODEWD,EDGEWD|_) = geom CONFIG, (_,_,MARKCOL,EDGECOL|_) = colors CONFIG, (_,_,_,_,_,_,DIR|_) = geom CONFIG, (XOFFS,YOFFS) = offs (3*NODEWD) DIR, (X1,Y1,X2,Y2) = (X-2*NODEWD,Y-2*NODEWD,X+2*NODEWD,Y+2*NODEWD), EID = val (tk (sprintf "$widget(Canvas) create oval %g %g %g %g -width %g \ -outline %s -tags {s%d t%d}" (X1+XOFFS,Y1-YOFFS,X2+XOFFS,Y2-YOFFS,_f EDGEWD, sel_col SEL MARKCOL EDGECOL,N,N))), LID = draw_edge_labels_at CONFIG (N,N) EID (X,Y) (XOFFS,YOFFS) DIR SEL L, _ = tk (sprintf "$widget(Canvas) addtag r%d withtag %d" (LID,EID)), _ = tk (sprintf "$widget(Canvas) addtag loop withtag %d" EID), _ = do tk (map (sprintf "$widget(Canvas) addtag %s withtag %d") (listof (TAG,EID) (TAG in split " " (sel_tags SEL)))); // draw an ordinary edge draw_edge CONFIG G N (X1,Y1) (M,_,SEL|L) = (M,EID,false|L) where (_,_,(X2,Y2)|_) = G!M, (NODEWD,EDGEWD|_) = geom CONFIG, (_,_,MARKCOL,EDGECOL|_) = colors CONFIG, DIGRAPH = digraph CONFIG, [(X1,Y1),(X2,Y2)] = translate NODEWD [(X1,Y1),(X2,Y2)], EID = val (tk (sprintf "$widget(Canvas) create line %g %g %g %g -width %g \ -fill %s -arrow %s -tags {s%d t%d}" (X1,Y1,X2,Y2,_f EDGEWD,sel_col SEL MARKCOL EDGECOL, ifelse DIGRAPH "last" "none",N,M))), LID = draw_edge_labels CONFIG (N,M) EID (X1,Y1) (X2,Y2) SEL L, _ = tk (sprintf "$widget(Canvas) addtag r%d withtag %d" (LID,EID)), _ = tk (sprintf "$widget(Canvas) addtag edge withtag %d" EID), _ = do tk (map (sprintf "$widget(Canvas) addtag %s withtag %d") (listof (TAG,EID) (TAG in split " " (sel_tags SEL)))); translate W [P,Q] = [P+D,Q-D] where D = (Q-P)*W/L if L>2*W where L = len (Q-P); = [P,Q] otherwise; // draw the edge labels draw_edge_labels CONFIG (N,M) ID P Q SEL (D:Direction|L) = draw_edge_labels_at CONFIG (N,M) ID P Q (DIRVECT!D) SEL L; draw_edge_labels CONFIG (N,M) ID P Q SEL L = draw_edge_labels_at CONFIG (N,M) ID P Q DIR SEL L where (_,_,_,_,_,DIR|_) = geom CONFIG; def PI = 4*atan 1; // arrange labels for same source-target combination last_label C (N,M) = I where ID:Int = val (last (split " " (tk (sprintf "$widget(Canvas) find withtag (l%d_%d&&c%s)" (N,M,C))))), (_,_,_,I:Int) = sscanf (get_tags ID) "l%d_%d r%d i%d"; delta A = 1 if (A!0="s") or else (A!0="e"); = -1 otherwise; draw_edge_labels_at CONFIG (N,N) ID P Q (DIRX,DIRY) SEL L = // loop label val (tk (sprintf "$widget(Canvas) create text %g %g \ -fill %s -text %s -anchor %s -tags {l%d_%d r%d i%d c%s label %s}" (X+XOFFS,Y-YOFFS-I*DELTA,sel_col SEL MARKCOL LBLCOL, tkstr (label_str L), A,N,N,ID,I+1,A,sel_tags SEL))) if EDGELBL and then not null L where A = anchor DIRX DIRY, I:Int = last_label A (N,N), (_,_,EDGELBL|_) = options CONFIG, (_,_,MARKCOL,_,LBLCOL|_) = colors CONFIG, (NODEWD,_,_,_,OFFS|_) = geom CONFIG, (X,Y) = P, (XOFFS,YOFFS) = offs (5*NODEWD+OFFS) (DIRX,DIRY), // vertical spacing DELTA = 15*delta A; draw_edge_labels_at CONFIG (N,M) ID P Q (DIRX,DIRY) SEL L = // ordinary edge val (tk (sprintf "$widget(Canvas) create text %g %g \ -fill %s -text %s -anchor %s -tags {l%d_%d r%d i%d c%s label %s}" (X+XOFFS,Y+YOFFS-I*DELTA,sel_col SEL MARKCOL LBLCOL, tkstr (label_str L), A,N,M,ID,I+1,A,sel_tags SEL))) if EDGELBL and then not null L where (_,_,EDGELBL|_) = options CONFIG, (_,_,MARKCOL,_,LBLCOL|_) = colors CONFIG, (NODEWD,_,_,_,OFFS|_) = geom CONFIG, DIFF = offs 1 (Q-P)*exp((0,1)*PI/2), (XOFFS,YOFFS) = offs OFFS (DIFF*(DIRX,-DIRY)), (X,Y) = (P+Q)/2, A = anchor XOFFS (-YOFFS), I:Int = last_label A (N,M), DELTA = 15*delta A if N<>M; // first label for each source-target combination is drawn here draw_edge_labels_at CONFIG (N,N) ID P Q (DIRX,DIRY) SEL L = // loop label val (tk (sprintf "$widget(Canvas) create text %g %g \ -fill %s -text %s -anchor %s -tags {l%d_%d r%d i1 c%s label %s}" (X+XOFFS,Y-YOFFS,sel_col SEL MARKCOL LBLCOL, tkstr (label_str L), A,N,N,ID,A,sel_tags SEL))) if EDGELBL and then not null L where A = anchor DIRX DIRY, (_,_,EDGELBL|_) = options CONFIG, (_,_,MARKCOL,_,LBLCOL|_) = colors CONFIG, (NODEWD,_,_,_,OFFS|_) = geom CONFIG, (X,Y) = P, (XOFFS,YOFFS) = offs (5*NODEWD+OFFS) (DIRX,DIRY); draw_edge_labels_at CONFIG (N,M) ID P Q (DIRX,DIRY) SEL L = // ordinary edge val (tk (sprintf "$widget(Canvas) create text %g %g \ -fill %s -text %s -anchor %s -tags {l%d_%d r%d i1 c%s label %s}" (X+XOFFS,Y+YOFFS,sel_col SEL MARKCOL LBLCOL, tkstr (label_str L), A,N,M,ID,A,sel_tags SEL))) if EDGELBL and then not null L where (_,_,EDGELBL|_) = options CONFIG, (_,_,MARKCOL,_,LBLCOL|_) = colors CONFIG, (NODEWD,_,_,_,OFFS|_) = geom CONFIG, // normalize difference vector and rotate it by 90 deg DIFF = offs 1 (Q-P)*exp((0,1)*PI/2), // calculate the displacement vector (XOFFS,YOFFS) = offs OFFS (DIFF*(DIRX,-DIRY)), // calculate the middle point and anchor (X,Y) = (P+Q)/2, A = anchor XOFFS (-YOFFS); = () otherwise; /* redraw the entire graph */ redraw CONFIG G = tk "$widget(Canvas) delete (!grid)" || draw CONFIG G where G = update_sel_graph G; /* redraw the graph with a new configuration */ reconfig OLDCONFIG NEWCONFIG G = tk "$widget(Canvas) delete all" || init_canvas NEWCONFIG || set_viewport VP || draw_grid NEWCONFIG || draw NEWCONFIG G where VP = get_viewport, G = reinit_graph OLDCONFIG NEWCONFIG G; /* update individual nodes and edges */ // delete a node or edge item and its labels from the canvas private erase_incident_edges; erase_node ID = tk (sprintf "$widget(Canvas) delete (n%d||l%d)" (N,N)) || erase_incident_edges N where N:Int = sscanf (get_tags ID) "n%d"; private erase_edge, raw_item_list; erase_incident_edges N = do erase_edge IDS where IDS = raw_item_list (tk (sprintf "$widget(Canvas) find withtag (s%d||t%d)" (N,N))); erase_edge ID = tk (sprintf "$widget(Canvas) delete %d" ID) || tk (sprintf "$widget(Canvas) delete %d" LID) where (_,_,LID:Int) = sscanf (get_tags ID) "s%d t%d r%d"; = tk (sprintf "$widget(Canvas) delete %d" ID) otherwise; // redraw a node private redraw_node_labels, redraw_node_labels_at; redraw_node CONFIG (N,P,ID,SEL|L) = redraw_node_labels CONFIG LID N ID P SEL L || ID where (_,LID:Int) = sscanf (get_tags ID) "n%d r%d"; = set_tags ID (join " " [hd TAGS,sprintf "r%d" LID|tl TAGS]) || ID where LID = draw_node_labels CONFIG N ID P SEL L, TAGS = split " " (get_tags ID) otherwise; // update existing node labels redraw_node_labels CONFIG ID N NID P SEL (D:Direction|L) = redraw_node_labels_at CONFIG ID N NID P (DIRVECT!D) SEL L; redraw_node_labels CONFIG ID N NID P SEL L = redraw_node_labels_at CONFIG ID N NID P DIR SEL L where (_,_,_,DIR|_) = geom CONFIG; redraw_node_labels_at CONFIG ID N NID (X,Y) DIR SEL L = tk (sprintf "$widget(Canvas) coords %d %g %g" (ID,X+XOFFS,Y-YOFFS)) || tk (sprintf "$widget(Canvas) itemconfigure %d -text %s \ -anchor %s" (ID, tkstr (str N++": "++label_str L), anchor XOFFS YOFFS)) || ID if NODENUM and then NODELBL and then not null L where (NODENUM,NODELBL|_) = options CONFIG, (_,_,OFFS|_) = geom CONFIG, (XOFFS,YOFFS) = offs OFFS DIR; = tk (sprintf "$widget(Canvas) coords %d %g %g" (ID,X+XOFFS,Y-YOFFS)) || tk (sprintf "$widget(Canvas) itemconfigure %d -text %s \ -anchor %s" (ID, str N, anchor XOFFS YOFFS)) || ID if NODENUM where (NODENUM,NODELBL|_) = options CONFIG, (_,_,OFFS|_) = geom CONFIG, (XOFFS,YOFFS) = offs OFFS DIR; = tk (sprintf "$widget(Canvas) coords %d %g %g" (ID,X+XOFFS,Y-YOFFS)) || tk (sprintf "$widget(Canvas) itemconfigure %d -text %s \ -anchor %s" (ID, tkstr (label_str L), anchor XOFFS YOFFS)) || ID if NODELBL and then not null L where (NODENUM,NODELBL|_) = options CONFIG, (_,_,OFFS|_) = geom CONFIG, (XOFFS,YOFFS) = offs OFFS DIR; = ID otherwise; // redraw an edge /* This is a bit more tricky to do efficiently than updating a node. If only the label text is changed, we just update the label item on the canvas accordingly. Otherwise the source, target and/or placement of the edge label might have changed, so we delete the existing and draw a new edge item. We also have to handle existing labels of edges for the former source, target and placement; we might have to shift some of these to fill the void of a deleted edge label. */ redraw_edge CONFIG G N P (M,ID,SEL|L) = // in this case (source, target and placement equal) we only // have to update the text of an existing label tk (sprintf "$widget(Canvas) itemconfigure %d -text %s" (LID,tkstr (label_str L))) || ID if not null L and then (N=N1) and then (M=M1) and then (C=C1) where L = get_labels L where (N1:Int,M1:Int,LID:Int) = sscanf (get_tags ID) "s%d t%d r%d", (_,_,_,_,C1) = sscanf (get_tags LID) "l%d_%d r%d i%d c%s", (DIRX,DIRY) = get_dir CONFIG (N,M) L, (_,_,Q|_) = G!M, C = class (N,M) P Q (DIRX,DIRY); = // if the current edge has a label, draw a new edge, and // update existing labels accordingly EID where (N1,M1,LID:Int) = sscanf (get_tags ID) "s%d t%d r%d", (_,_,_,I,C) = sscanf (get_tags LID) "l%d_%d r%d i%d c%s", (_,EID|_) = tk (sprintf "$widget(Canvas) delete %d" ID) || tk (sprintf "$widget(Canvas) delete %d" LID) || shift_labels I C (N1,M1) || draw_edge CONFIG G N P (M,ID,SEL|L), _ = tk (sprintf "$widget(Canvas) lower %d node" EID); = // otherwise simply delete the old and draw a new edge EID where (_,EID|_) = tk (sprintf "$widget(Canvas) delete %d" ID) || draw_edge CONFIG G N P (M,ID,SEL|L), _ = tk (sprintf "$widget(Canvas) lower %d node" EID); // move an edge to the front /* This is a simplified version of redraw_edge in which we simply draw the edge anew. */ to_front CONFIG G N P (M,ID,SEL|L) = EID where (N1,M1,LID:Int) = sscanf (get_tags ID) "s%d t%d r%d", (_,_,_,I,C) = sscanf (get_tags LID) "l%d_%d r%d i%d c%s", (_,EID|_) = tk (sprintf "$widget(Canvas) delete %d" ID) || tk (sprintf "$widget(Canvas) delete %d" LID) || shift_labels I C (N1,M1) || draw_edge CONFIG G N P (M,ID,SEL|L), _ = tk (sprintf "$widget(Canvas) lower %d node" EID); = EID where (_,EID|_) = tk (sprintf "$widget(Canvas) delete %d" ID) || draw_edge CONFIG G N P (M,ID,SEL|L), _ = tk (sprintf "$widget(Canvas) lower %d node" EID); /* miscellaneous helper routines */ def SPECIAL_TAGS = set ["current","act","sel","node","edge","loop","grid"]; // FIXME: Do we have to sort the node/edge-specific tags as well? get_tags ID = join " " TAGS where TAGS:String = tk (sprintf "$widget(Canvas) gettags %d" ID), TAGS = split " " TAGS, // make sure the grouping tags come last TAGS = filter (neg (member SPECIAL_TAGS)) TAGS ++ filter (member SPECIAL_TAGS) TAGS; = "" otherwise; set_tags ID TAGS = tk (sprintf "$widget(Canvas) itemconfigure %d -tags {%s}" (ID,TAGS)); class (N,M) P Q (DIRX,DIRY) = anchor DIRX DIRY if N=M; = anchor XOFFS (-YOFFS) otherwise where DIFF = offs 1 (Q-P)*exp((0,1)*PI/2), (XOFFS,YOFFS) = DIFF*(DIRX,-DIRY); shift_labels I C (N,M) = do (shift_label (15*delta C)) ITEMS where ITEMS = filter ((>I).get_ind) (raw_item_list (tk (sprintf "$widget(Canvas) find withtag (l%d_%d&&c%s)" (N,M,C)))); shift_label DY ID = tk (sprintf "$widget(Canvas) coords %d %g %g" (ID,X,Y+DY)) || set_ind ID (get_ind ID-1) where (X,Y) = sscanf (tk (sprintf "$widget(Canvas) coords %d" ID)) "%g %g"; get_ind ID = I where (_,_,_,I:Int) = sscanf (get_tags ID) "l%d_%d r%d i%d"; set_ind ID I = tk (sprintf "$widget(Canvas) itemconfigure %d -tags {%s}" (ID,join " " TAGS)) where TAGS = [L,R,sprintf "i%d" I|OTHER_TAGS] where [L,R,_|OTHER_TAGS] = split " " (get_tags ID); get_dir CONFIG _ (D:Direction|L) = DIRVECT!D; get_dir CONFIG (N,N) _ = DIR otherwise where (_,_,_,_,_,_,DIR|_) = geom CONFIG; get_dir CONFIG _ _ = DIR otherwise where (_,_,_,_,_,DIR|_) = geom CONFIG; get_place CONFIG _ () = (); get_place CONFIG E L = get_dir CONFIG E L otherwise; get_labels (DIR:Direction|L) = L; get_labels L = L otherwise; change_labels (DIR:Direction|_) L = (DIR|L); change_labels _ L = L otherwise; /* Selection handling *******************************************************/ private rmdups, rmdups2; private isobj, item, raw_items_at, raw_items_between; /* items_at locates the objects at the given coordinates on the canvas. The result is a list in stacking order (lowest objects first). Each entry is the id of a node or edge on the canvas; label positions are mapped to the corresponding node or edge automagically. */ items_at P = rmdups (filter isint (map item (raw_items_at P))); /* item_at only returns the id of the topmost object (() if none). */ item_at P = ID where ID:Int = last (items_at P); = () otherwise; /* items_between returns all items in a given rectangle. Here, only the nodes and edges which are in the range themselves are considered. */ items_between P Q = rmdups (filter isobj (raw_items_between P Q)); // remove duplicates from the list rmdups Xs = rmdups2 emptyset Xs; rmdups2 M [] = []; rmdups2 M [X|Xs] = rmdups2 M Xs if member M X; = [X|rmdups2 (insert M X) Xs] otherwise; // get the actual item (node or edge) an item belongs to private map_item; item ID = map_item ID (get_tags ID); map_item ID TAGS = EID where (N:Int,M:Int,EID:Int) = sscanf TAGS "l%d_%d r%d"; = NID where (N:Int,NID:Int) = sscanf TAGS "l%d r%d"; = ID where (N:Int,M:Int) = sscanf TAGS "s%d t%d"; = ID where N:Int = sscanf TAGS "n%d"; = () otherwise; // determine a raw list of items on the canvas raw_items_at (X,Y) = ITEMS where ITEMS:List = raw_item_list (tk (sprintf "$widget(Canvas) find overlapping %d %d %d %d" (X-2,Y-2,X+2,Y+2))); = [] otherwise; raw_items_between (X1,Y1) (X2,Y2) = raw_items_between (X2,Y1) (X1,Y2) if X2 only update the labels replace_edge CONFIG G:Graph (N:Int,M:Int,ID1:Int) (N,M,ID2,SEL2|L2) = update_edge_with (with_id ID1) G (N,M,ID2,SEL2|L2) if get_place CONFIG (N,M) L1=get_place CONFIG (N,M) L2 where (_,_,_|L1) = search_edge (with_id ID1) G (N,M); // otherwise we delete the old and create a new edge replace_edge CONFIG G:Graph (N1:Int,M1:Int,ID1:Int) E = G where G = delete_edge CONFIG G (N1,M1,ID1), G = add_edge G E; /* delete an edge */ delete_edge CONFIG G:Graph (N:Int,M:Int,ID:Int) = del_edge_with (with_id ID) G (N,M); /* move a node */ move_node CONFIG D G N = update_node G (N,P+grid_point CONFIG D|L) where (_,_,P|L) = G!N; /* complex graph update operations ******************************************/ /* update a node or edge */ private edit_node, edit_edge; edit_obj CONFIG G ID OBJ = edit_node CONFIG G (N,ID) OBJ where N:Int = obj ID; = edit_edge CONFIG G (obj ID) OBJ otherwise; /* update a node */ edit_node CONFIG G (N,ID) (N:Int|L) = set_edited true || update_title || update_node G (N,P,ID,SEL|L1) where L1 = change_labels L0 L, ID = redraw_node CONFIG (N,P,ID,sel_status ID|L1) if neq L L2 where (_,_,P,_,SEL|L0) = G!N, L2 = get_labels L0, L = get_labels L; = G otherwise; edit_node CONFIG G (N,ID) (M:Int|L) = set_edited true || update_title || update_node (rename_node G N M) (M,P,ID,SEL|L1) where L1 = change_labels L0 (get_labels L), ID = redraw_node CONFIG (M,P,ID,sel_status ID|L1) where (_,_,P,_,SEL|L0) = G!N if not member G M; /* update an edge */ private edit_edge_check, edit_edge_check2, edit_edge_replace; // check that the given edge is valid edit_edge CONFIG G (N1,M1,ID1) (N2,M2|L2) = edit_edge_check CONFIG G (N1,M1,ID1) (N2,M2|L2) if member G N2 and then member G M2; // take care of the trivial case that nothing has changed edit_edge_check CONFIG G (N1,M1,ID1) (N2,M2|L2) = edit_edge_check2 CONFIG G (N1,M1,ID1,SEL|L1) (N2,M2|L2) if (N1<>N2) or else (M1<>M2) or else neq L2 (get_labels L1) where (_,_,SEL|L1) = search_edge (with_id ID1) G (N1,M1); = G otherwise; // take care of the bidirected case edit_edge_check2 CONFIG G (N1,M1,ID1,SEL1|L1) (N2,M2|L2) = edit_edge_replace CONFIG G (N1,M1,ID1,SEL1|L1) (N2,M2|L2) if digraph CONFIG or else (N2<=M2); = edit_edge_replace CONFIG G (N1,M1,ID1,SEL1|L1) (M2,N2|L2) otherwise; // perform the replacement edit_edge_replace CONFIG G (N1,M1,ID1,SEL1|L1) (N2,M2|L2) = set_edited true || update_title || G where G = replace_edge CONFIG G (N1,M1,ID1) (N2,M2,ID2,SEL1|L21) where (_,_,P2|_) = G!N2, L21 = change_labels L1 (get_labels L2), SEL2 = sel_status ID1, ID2 = redraw_edge CONFIG G N2 P2 (M2,ID1,SEL2|L21); /* update the labels of a node or edge */ edit_labels CONFIG G (N,ID) L = set_edited true || update_title || update_node G (N,P,ID,SEL|L) where ID = redraw_node CONFIG (N,P,ID,sel_status ID|L) if neq L L0 where (_,_,P,_,SEL|L0) = G!N; = G otherwise; edit_labels CONFIG G (N,M,ID) L = set_edited true || update_title || G where G = replace_edge CONFIG G (N,M,ID) (N,M,ID2,false|L) where (_,_,P|_) = G!N, SEL = sel_status ID, ID2 = redraw_edge CONFIG G N P (M,ID,SEL|L) if digraph CONFIG or else (N>=M); = edit_labels CONFIG G (M,N,ID) L otherwise; /* create nodes and edges */ create_node CONFIG G (X,Y) = (G,N,ID) where ID:Int = item_at (X,Y), N:Int = obj ID; = (G,N,ID) where N = ifelse (null G) 0 (maxnode G) + 1, NODE = draw_node CONFIG G (N,[],grid_point CONFIG (X,Y),(),false), (_,_,P,ID|_) = NODE, G = add_node G (N,P,ID,false) otherwise; create_edge CONFIG G (N,M) = (G,EID) where (_,_,P|_) = G!N, (_,EID|_) = draw_edge CONFIG G N P (M,(),false), _ = tk (sprintf "$widget(Canvas) lower %d node" EID), G = add_edge G (N,M,EID,false) if digraph CONFIG or else (N<=M); = create_edge CONFIG G (M,N) otherwise; /* delete nodes and edges */ del_obj CONFIG G ID = erase_node ID || del_node G N where N:Int = obj ID; del_obj CONFIG G ID = erase_edge ID || delete_edge CONFIG G (N,M,ID) where (N:Int,M:Int|_) = obj ID; /* callbacks ****************************************************************/ // entry callbacks edit_cb ID OBJ (G,CONFIG) = (G,CONFIG) where G:Graph = edit_obj CONFIG G ID OBJ; edit_cb _ _ STATE = tk "bell" || STATE otherwise; cancel_cb STATE = set_entry (get_obj_text G (obj ID)) || STATE where ID:Int = get_active, (G,_) = STATE; = STATE otherwise; enter_cb STATE = edit_cb ID (cval get_entry) STATE where ID:Int = get_active; = STATE otherwise; // selections and drags private move_drag, select_drag, toggle_sent, select_mod_status, select_drag_loop, select_drag_cb, move_drag_loop, move_drag_cb, select2_drag, select2_drag_loop, select2_drag_cb, select3, popup; start_select_cb (X,Y) STATE = move_drag id (X,Y) STATE if selected ID where ID:Int = item_at (xlat_coords (X,Y)); = set_entry (get_obj_text G (obj ID)) || select ID || move_drag id (X,Y) STATE otherwise where ID:Int = item_at (xlat_coords (X,Y)), (G,_) = STATE; = select_drag (X,Y) || STATE otherwise; start_shift_select_cb (X,Y) STATE = add_select ID || STATE where ID:Int = item_at (xlat_coords (X,Y)); = select_drag (X,Y) || STATE otherwise; start_ctrl_select_cb (X,Y) STATE = move_drag (toggle_sent ID) (X,Y) STATE if selected ID where ID:Int = item_at (xlat_coords (X,Y)); = toggle ID || move_drag id (X,Y) STATE where ID:Int = item_at (xlat_coords (X,Y)); = select_drag (X,Y) || STATE otherwise; toggle_sent ID STATE = toggle ID || STATE; select_drag (X,Y) = select_mod_status || set_msg "Drag cursor to opposite corner to select, Esc to abort" || select_drag_loop (X,Y,rubberband (X,Y) (X,Y)) || set_status "EDIT" || set_msg "Ready" where (X,Y) = xlat_coords (X,Y); select_mod_status = set_status "SEL+/-" if ctrl_status; = set_status "SEL+" if shift_status; = set_status "SELECT" otherwise; select_drag_loop STATE = select_drag_cb tk_read STATE if tk_ready; = () otherwise; select_drag_cb (motion_cb (X2,Y2)) (X1,Y1,ID) = update_rubberband ID (X1,Y1) (X2,Y2) || select_drag_loop (X1,Y1,ID) where (X2,Y2) = xlat_coords (X2,Y2); select_drag_cb (end_select_cb (X2,Y2)) (X1,Y1,ID) = delete_rubberband ID || deselect_all || do add_select (items_between (X1,Y1) (X2,Y2)) where (X2,Y2) = xlat_coords (X2,Y2); select_drag_cb (end_shift_select_cb (X2,Y2)) (X1,Y1,ID) = delete_rubberband ID || do add_select (items_between (X1,Y1) (X2,Y2)) where (X2,Y2) = xlat_coords (X2,Y2); select_drag_cb (end_ctrl_select_cb (X2,Y2)) (X1,Y1,ID) = delete_rubberband ID || do toggle (items_between (X1,Y1) (X2,Y2)) where (X2,Y2) = xlat_coords (X2,Y2); select_drag_cb mod_cb LSTATE = select_mod_status || select_drag_loop LSTATE; select_drag_cb _ (X1,Y1,ID) = delete_rubberband ID; move_drag CB (X,Y) STATE = tk (sprintf "$widget(Canvas) configure -cursor {%s}" CURSOR) || STATE where (X,Y) = xlat_coords (X,Y), // save the current cursor CURSOR = tk "$widget(Canvas) cget -cursor", CURSOR = ifelse (null CURSOR) "" CURSOR, // set a new one (crosshair seems to be portable) STATE = tk "$widget(Canvas) configure -cursor crosshair" || move_drag_loop CB STATE (X,Y,0,0,0,0,()); move_mod_status = set_status "COPY" if ctrl_status; = set_status "MOVE" otherwise; move_drag_loop CB STATE LSTATE = move_drag_cb CB tk_read STATE LSTATE if tk_ready; = STATE otherwise; move_drag_cb CB (motion_cb (X,Y)) STATE (X0,Y0,X1,Y1,X2,Y2,ID:Int) = update_rubberband ID (X1+DX,Y1+DY) (X2+DX,Y2+DY) || move_drag_loop CB STATE (X0,Y0,X1,Y1,X2,Y2,ID) where (X,Y) = xlat_coords (X,Y), (DX,DY) = (X,Y)-(X0,Y0); move_drag_cb CB (motion_cb (X,Y)) STATE (X0,Y0,X1,Y1,X2,Y2,_) = // initiate the move when the mouse starts to move move_mod_status || set_msg "Drag cursor to move, hold Ctrl to copy selection, Esc to abort" || move_drag_loop id STATE (X0,Y0,X1,Y1,X2,Y2,rubberband (X1+DX,Y1+DY) (X2+DX,Y2+DY)) where (X,Y) = xlat_coords (X,Y), (DX,DY) = (X,Y)-(X0,Y0), (G,_) = STATE, (X1,Y1,X2,Y2) = extend_selection G || bbox get_selected; // FIXME: optimize display update move_drag_cb CB (end_select_cb (X,Y)) STATE (X0,Y0,X1,Y1,X2,Y2,ID:Int) = set_edited true || update_title || delete_rubberband ID || set_status "EDIT" || set_msg "Ready" || (G,CONFIG) where (X,Y) = xlat_coords (X,Y), (DX,DY) = (X,Y)-(X0,Y0), (G,CONFIG) = STATE, NODES = filter isint (map obj get_selected), G = foldl (move_node CONFIG (DX,DY)) G NODES, G = redraw CONFIG G; // FIXME: optimize display update move_drag_cb CB (end_ctrl_select_cb (X,Y)) STATE (X0,Y0,X1,Y1,X2,Y2,ID:Int) = set_edited true || update_title || delete_rubberband ID || set_status "EDIT" || set_msg "Ready" || (G,CONFIG) where (X,Y) = xlat_coords (X,Y), (DX,DY) = (X,Y)-(X0,Y0), (G,CONFIG) = STATE, V = filter isint (map obj get_selected), H = subgraph G V, H = foldl (move_node CONFIG (DX,DY)) H V, G = redraw CONFIG (addgraph G H), _ = del_selection G V; move_drag_cb CB mod_cb STATE LSTATE = move_mod_status || move_drag_loop CB STATE LSTATE if isint (LSTATE!6); = move_drag_loop CB STATE LSTATE otherwise; move_drag_cb CB _ STATE (X0,Y0,X1,Y1,X2,Y2,ID:Int) = delete_rubberband ID || set_status "EDIT" || set_msg "Ready" || STATE; move_drag_cb CB _ STATE _ = CB STATE otherwise; start_select2_cb (X,Y) STATE = select2_drag (X,Y) || STATE; select2_drag (X,Y) = set_status "PAN" || set_msg "Drag cursor to pan view" || tk (sprintf "$widget(Canvas) scan mark %d %d" (X,Y)) || select2_drag_loop || set_status "EDIT" || set_msg "Ready"; select2_drag_loop = select2_drag_cb tk_read if tk_ready; = () otherwise; select2_drag_cb (motion_cb (X,Y)) = tk (sprintf "$widget(Canvas) scan dragto %d %d 1" (X,Y)) || select2_drag_loop; select2_drag_cb mod_cb = select2_drag_loop; select2_drag_cb _ = (); end_select_cb _ STATE = STATE; end_shift_select_cb _ STATE = STATE; end_ctrl_select_cb _ STATE = STATE; cancel_select_cb STATE = STATE; motion_cb _ STATE = STATE; mod_cb STATE = STATE; select3_cb (X0,Y0) (X,Y) STATE = select3 (X0,Y0) (X,Y) ID STATE where (X,Y) = xlat_coords (X,Y), ID = item_at (X,Y); select3 (X0,Y0) (X,Y) ID:Int STATE = deselect_all || set_entry (get_obj_text G (obj ID)) || select ID || fail where (G,_) = STATE if not selected ID; = popup (X0,Y0) (X,Y) ID STATE || STATE otherwise; select3 (X0,Y0) (X,Y) ID STATE = popup (X0,Y0) (X,Y) () STATE || STATE otherwise; // popup menu callbacks create_node_cb (X,Y) (G,CONFIG) = deselect_all || set_entry (get_obj_text G N) || select ID || (G,CONFIG) where (G,N,ID) = create_node CONFIG G (X,Y); create_edge_cb (X,Y) (G,CONFIG) = create_edge_cb (maxnode G) (G,CONFIG) where (G,CONFIG) = create_node_cb (X,Y) (G,CONFIG); private edge_target; create_edge_cb N (G,CONFIG) = edge_target N (X,Y) (G,CONFIG) where (_,_,(X,Y)|_) = G!N, (X,Y) = (_i X,_i Y); private edge_target_loop, edge_target_cb, edge_mod_status; edge_target N (X,Y) STATE = edge_mod_status || set_msg "Ready" || STATE where STATE = set_status "EDGE" || set_msg "Button-1 to select target node, Shift/Ctrl-Button-1: extend, Esc to abort" || edge_target_loop STATE (N,(X,Y),line (X,Y) (X,Y)); edge_mod_status = set_status "PATH+" if ctrl_status; = set_status "EDGE+" if shift_status; = set_status "EDGE" otherwise; edge_target_loop STATE LSTATE = edge_target_cb tk_read STATE LSTATE if tk_ready; = STATE otherwise; edge_target_cb (motion_cb (X2,Y2)) STATE (N,(X1,Y1),ID) = update_line ID (X1,Y1) (X2,Y2) || edge_target_loop STATE (N,(X1,Y1),ID) where (X2,Y2) = xlat_coords (X2,Y2); edge_target_cb (start_select_cb (X2,Y2)) (G,CONFIG) (N,(X1,Y1),ID) = set_edited true || update_title || delete_line ID || (G,CONFIG) where (G,M,_) = create_node CONFIG G (xlat_coords (X2,Y2)), (G,EID) = create_edge CONFIG G (N,M); edge_target_cb (start_shift_select_cb (X2,Y2)) (G,CONFIG) (N,(X1,Y1),ID) = set_edited true || update_title || edge_target_loop (G,CONFIG) (N,(X1,Y1),ID) where (G,M,_) = create_node CONFIG G (xlat_coords (X2,Y2)), (G,EID) = create_edge CONFIG G (N,M); edge_target_cb (start_ctrl_select_cb (X2,Y2)) (G,CONFIG) (N,(X1,Y1),ID) = set_edited true || update_title || update_line ID (X2,Y2) (X2,Y2) || edge_target_loop (G,CONFIG) (M,(X2,Y2),ID) where (G,M,MID) = create_node CONFIG G (xlat_coords (X2,Y2)), (G,EID) = create_edge CONFIG G (N,M), (_,_,(X2,Y2)|_) = G!M, (X2,Y2) = (_i X2,_i Y2); edge_target_cb (end_select_cb _) STATE LSTATE = edge_target_loop STATE LSTATE; edge_target_cb (end_shift_select_cb _) STATE LSTATE = edge_target_loop STATE LSTATE; edge_target_cb (end_ctrl_select_cb _) STATE LSTATE = edge_target_loop STATE LSTATE; edge_target_cb mod_cb STATE LSTATE = edge_mod_status || edge_target_loop STATE LSTATE; edge_target_cb _ STATE (N,(X1,Y1),ID) = delete_line ID || STATE otherwise; placement_cb (N,ID) DIR:Direction (G,CONFIG) = (G,CONFIG) where (_,_,_|L) = labels (G!N), G:Graph = edit_labels CONFIG G (N,ID) (DIR|get_labels L); placement_cb (N,ID) _ (G,CONFIG) = (G,CONFIG) where (_,_,_|L) = labels (G!N), G:Graph = edit_labels CONFIG G (N,ID) (get_labels L); placement_cb (N,M,ID) DIR:Direction (G,CONFIG) = (G,CONFIG) where (_,_,_|L) = search_edge (with_id ID) G (N,M), G:Graph = edit_labels CONFIG G (N,M,ID) (DIR|get_labels L); placement_cb (N,M,ID) _ (G,CONFIG) = (G,CONFIG) where (_,_,_|L) = search_edge (with_id ID) G (N,M), G:Graph = edit_labels CONFIG G (N,M,ID) (get_labels L); to_front_cb (N,M,EID) (G,CONFIG) = set_entry (get_obj_text G (N,M,EID2)) || select EID2 || (G,CONFIG) where (_,_,P|_) = G!N, (_,_,_|L) = search_edge (with_id EID) G (N,M), EID2 = to_front CONFIG G N P (M,EID,false|L), G = delete_edge CONFIG G (N,M,EID), G = add_edge G (N,M,EID2,false|L); select_cb ID STATE = deselect_all || set_entry (get_obj_text G (obj ID)) || select ID || STATE where (G,_) = STATE; // file menu private check_edited, save_edited; private yesno_dg, error_dg, warn_dg, open_dg, save_dg, save_as_dg, print_file_dg, print_setup_dg, config_dg, about_dg; new_cb STATE = STATE if not check_edited STATE; new_cb (_,CONFIG) = set_fname () || set_edited false || update_title || (G,CONFIG) where G = redraw CONFIG emptygraph; check_edited (G,CONFIG) = save_edited CONFIG FNAME G ANS where ANS = yesno_dg (sprintf "File %s has been modified. Save?" FNAME) if tk_ready and then not null FNAME and then get_edited where FNAME = get_fname; = true otherwise; save_edited CONFIG FNAME G ANS = save_graph FNAME (fini_graph CONFIG G) || true if ANS="yes"; = (ANS="no") otherwise; open_cb STATE = STATE if not check_edited STATE; open_cb STATE = (G,CONFIG) where (_,CONFIG) = STATE, (G:Graph,CONFIG) = open CONFIG open_dg, G = redraw CONFIG G; = STATE otherwise; private check_graph; open _ () = (); open CONFIG FNAME = set_fname FNAME || set_edited false || update_title || (G,CONFIG) where (G:Graph,CONFIG) = check_graph CONFIG (load_graph FNAME); = error_dg ("Error loading "++FNAME) || () otherwise; check_graph CONFIG G:Graph = warn_dg "This graph does not appear to be\n\ bidirected, switching to digraph mode." || set_digraph_mode true || (init_graph CONFIG G,CONFIG) where CONFIG = set_digraph CONFIG true if not BIDI where _ = set_msg "Checking graph, please wait...", H = revgraph G, BIDI = eq H (revgraph H), _ = set_msg "Ready" if not digraph CONFIG; = (init_graph CONFIG G,CONFIG) otherwise; private save; save_cb STATE = save CONFIG (save_dg FNAME) G || STATE where FNAME = get_fname, (G,CONFIG) = STATE; save_as_cb STATE = save CONFIG (save_dg ()) G || STATE where (G,CONFIG) = STATE; save _ () _ = (); save CONFIG FNAME G = set_fname FNAME || set_edited false || update_title where () = save_graph FNAME (fini_graph CONFIG G); = error_dg ("Error saving "++FNAME) || () otherwise; private print_lpr, print_file; print_cb STATE = print_lpr CONFIG || STATE where (_,CONFIG) = STATE; print_file_cb STATE = print_file CONFIG FNAME || STATE where FNAME:String = print_file_dg, (_,CONFIG) = STATE; = STATE otherwise; private printer_cmd, filter_cmd; private print_cmd, print_cropmarks, paper, unit, margin, xpages, ypages, landscape; print_lpr CONFIG = error_dg "Bad printer command." if null print_cmd; = postscript CONFIG NAME || printer_cmd (filter_cmd NAME) where TIMESTR = strftime "%F %R" (localtime time), NAME = ifelse (null get_fname) TIMESTR (get_fname++" "++TIMESTR) otherwise; private expand_filter_cmd; filter_cmd NAME = system (sprintf "%s %s > %s" (expand_filter_cmd EPS_FILTER, str NAME, str NAME2)) || unlink NAME || NAME2 where NAME2 = tmpnam if not null EPS_FILTER; = NAME otherwise; private portrait, scan_dsc, check_dsc; printer_cmd NAME = system (sprintf "%s %s" (print_cmd,str NAME)) || unlink NAME where NAME = portrait NAME; portrait NAME = scan_dsc (fopen NAME "rb") (fopen NAME2 "wb") || unlink NAME || NAME2 where NAME2 = tmpnam; scan_dsc F G = check_dsc F G (fgets F); def DSC = "%%Orientation", N_DSC = #DSC; def BUFSZ = 512*1024; fcopy F G = () if bwrite G (bread F BUFSZ) < BUFSZ; = fcopy F G otherwise; check_dsc F G S = fputs G S || fcopy F G if not isstr S or else null S or else (S!0<>"%"); = fcopy F G if sub S 0 (N_DSC-1) = DSC; = fputs G S || check_dsc F G (fgets F) otherwise; subst S (VAR,VAL) = subst (sub S 0 (P-1)++VAL++sub S (P+#VAR) (#S-1)) (VAR,VAL) if P>=0 where P = pos VAR S; = S otherwise; expand_filter_cmd CMD = foldl subst CMD [("%b",ifelse print_cropmarks "" "--border 0"), ("%m",sprintf "-mar %d" (_i margin)), ("%p",sprintf "-pw %d -ph %d" (_i WD, _i HT)), ("%x",ifelse (xpages>0) (sprintf "-x %d" xpages) ""), ("%y",ifelse (ypages>0) (sprintf "-y %d" ypages) ""), ("%o",sprintf "-O %s" (ifelse landscape "landscape" "portrait"))] where (WD,HT) = paper; ftype TYPE FNAME = (sub FNAME (N-M) (N-1) = TYPE) where M = #TYPE, N = #FNAME; private filter_cmd2; print_file CONFIG FNAME = error_dg "Bad file name." if null FNAME; = error_dg "PDF conversion not supported." if ftype ".pdf" FNAME and then null PDF_FILTER; = postscript CONFIG FNAME if ftype ".eps" FNAME; = postscript CONFIG NAME || filter_cmd2 (filter_cmd NAME) FNAME where TIMESTR = strftime "%F %R" (localtime time), NAME = ifelse (null get_fname) TIMESTR (get_fname++" "++TIMESTR) otherwise; filter_cmd2 NAME FNAME = system (sprintf "%s %s %s" (PDF_FILTER, str NAME, str FNAME)) || unlink NAME if ftype ".pdf" FNAME and then not null PDF_FILTER; = fcopy (fopen NAME "rb") (fopen FNAME "wb") || unlink NAME otherwise; print_setup_cb STATE = print_setup_dg STATE; private clr_print_setup, restore_print_setup, update_scale_checkboxes; print_setup_ok_cb STATE = clr_print_setup || STATE; print_setup_cancel_cb STATE = restore_print_setup || STATE; scale_cb = update_scale_checkboxes; paper_cb = tk_set "width" (str (to_unit2 unit (PAPER!0))) || tk_set "height" (str (to_unit2 unit (PAPER!1))) || tk "set last_width $width; set last_height $height" where PAPER = paper if tk_get "paper" <> "Custom"; = () otherwise; paper_check_cb = tk "$widget(PaperSizeBox) setvalue last" if (tk_get "width"<>tk_get "last_width") or else (tk_get "height"<>tk_get "last_height"); unit_cb = tk_set "unit" U || tk_set "last_unit" U || tk_set "width" (str (to_unit2 unit (PAPER!0))) || tk_set "height" (str (to_unit2 unit (PAPER!1))) || tk_set "margin" (str (to_unit2 unit MARGIN)) where U = tk_get "unit", (PAPER,MARGIN) = tk "set unit $last_unit" || (paper,margin); quit_cb STATE = tk_quit || STATE if check_edited STATE; = STATE otherwise; // edit menu undo_cb (G,CONFIG) = set_edited true || update_title || (G,CONFIG) where LASTG:Graph = lastG CONFIG, G = tk "$widget(Canvas) delete (!grid)" || draw CONFIG LASTG; = (G,CONFIG) otherwise; cut_cb (G,CONFIG) = set_edited true || update_title || tk (sprintf "clipboard clear; clipboard append %s" (tkstr (str (fini_graph CONFIG H)))) || (G,CONFIG) where H = span G, G = foldl (del_obj CONFIG) G get_selected; copy_cb (G,CONFIG) = tk (sprintf "clipboard clear; clipboard append %s" (tkstr (str (fini_graph CONFIG (span G))))) || (G,CONFIG); private paste, move_to; paste_cb STATE = paste id STATE SEL if not null SEL where SEL = tk "selection get -selection CLIPBOARD"; = STATE otherwise; // this actually belongs to the popup menu paste_at_cb P STATE = paste (move_to CONFIG P) STATE SEL where (_,CONFIG) = STATE if not null SEL where SEL = tk "selection get -selection CLIPBOARD"; = STATE otherwise; // FIXME: optimize display update paste F STATE SEL = ifelse (null H) () (set_edited true || update_title) || (G,CONFIG) where H:Graph = cval SEL, (G,CONFIG) = STATE, H = F (init_graph CONFIG H), V = ifelse (null G) id (map (+(maxnode G-minnode H+1))) (nodes H), _ = deselect_all, G = redraw CONFIG (addgraph G H), _ = add_selection G V; = // invalid format tk "bell" || STATE otherwise; // move the origin of the embedding to the specified position private node_pos, shift_node_pos; move_to CONFIG P G = G if null G; = graph (map (shift_node_pos (P-(X0,Y0))) L) otherwise where L = adj_list G, // calculate the origin of the embedding (Xs,Ys) = unzip (map node_pos L), X0 = foldl1 min Xs, Y0 = foldl1 min Ys, P = grid_point CONFIG P; node_pos (_,_,P|_) = P; shift_node_pos D (N,E,P|L) = (N,E,P+D|L); delete_cb (G,CONFIG) = set_edited true || update_title || (G,CONFIG) where G = foldl (del_obj CONFIG) G SEL if not null SEL where SEL = get_selected; = (G,CONFIG) otherwise; select_all_cb STATE = select_all || STATE; invert_all_cb STATE = toggle_all || STATE; extend_cb STATE = extend_selection G || STATE where (G,_) = STATE; // view menu grid_cb (G,CONFIG) = draw_grid CONFIG || (G,CONFIG) where CONFIG = set_actgrid CONFIG get_grid; toggle_grid_cb STATE = set_grid (not get_grid) || grid_cb STATE; snap_cb (G,CONFIG) = snap_indicator CONFIG || (G,CONFIG) where CONFIG = set_actsnap CONFIG get_snap; toggle_snap_cb STATE = set_snap (not get_snap) || snap_cb STATE; private digraph_mode, mode_check, mode_action; digraph_mode_cb STATE = digraph_mode (mode_check STATE); digraph_mode (PROCEED,G,CONFIG) = (G1,set_lastG CONFIG1 purge) where DI = get_digraph_mode, CONFIG1 = set_digraph CONFIG DI, _ = set_var "mode" (ifelse DI "D" "U"), G1 = reconfig CONFIG CONFIG1 G if PROCEED; = (G,CONFIG) otherwise; mode_check STATE = mode_action STATE ANS where ANS = yesno_dg "Your graph does not appear to be\n\ bidirected. I can make it bidirected\n\ if you want.\n\n\ Your options are:\n\ - YES, make it bidirected;\n\ - NO, don't make it bidirected and\n\ proceed anyway (some edges\n\ may be lost);\n\ - CANCEL the entire operation.\n\n\ Should I make the graph bidirected?" if not BIDI where (G,CONFIG) = STATE, _ = set_msg "Checking graph, please wait...", G = fini_graph CONFIG G, H = revgraph G, BIDI = eq H (revgraph H), _ = set_msg "Ready" if not get_digraph_mode; = (true|STATE) otherwise; mode_action (G,CONFIG) ANS = (true,graph2 (adj_list G),CONFIG) if ANS="yes"; = (true,G,CONFIG) if ANS="no"; = set_digraph_mode true || (false,G,CONFIG) otherwise; redraw_cb (G,CONFIG) = (G,CONFIG) where G = redraw CONFIG G; defaults_cb (G,CONFIG) = do dg_from (config_data CONFIG1) || (G1,CONFIG1) where G1 = reconfig CONFIG CONFIG1 G if CONFIG1<>CONFIG where CONFIG1 = defaults++sub CONFIG 4 99; defaults_cb STATE = STATE otherwise; private save_config; save_config_cb STATE = save_config CONFIG || STATE where (_,CONFIG) = STATE; reload_config_cb (G,CONFIG) = (G1,CONFIG1) where CONFIG1:Tuple = load_config, CONFIG1 = CONFIG1++sub CONFIG 4 99, G1 = reconfig CONFIG CONFIG1 G; reload_config_cb STATE = STATE otherwise; config_cb STATE = config_dg CONFIG STATE where (_,CONFIG) = STATE; private set_config_data; config_ok_cb DATA (G,CONFIG) = (G1,CONFIG1) where G1 = reconfig CONFIG CONFIG1 G if CONFIG1<>CONFIG where CONFIG1 = set_config_data CONFIG DATA; config_ok_cb _ STATE = STATE otherwise; config_cancel_cb STATE = STATE; set_config_data (_,_,_,_|C) [X1,Y1,X2,Y2,XRES,YRES,XGRID,YGRID,ZFACT, NODEWD,EDGEWD,NLBLOFFS,NLBLDIR,ELBLOFFS,ELBLDIR,LOOPDIR, OUTLCOL,FILLCOL,MARKCOL,EDGECOL,LBLCOL,GRIDCOL, NODENUM,NODELBL,EDGELBL,GRID,SNAP] = ((X1,Y1,X2,Y2,XRES,YRES,XGRID,YGRID,ZFACT), (NODEWD,EDGEWD,NLBLOFFS,NLBLDIR,ELBLOFFS,ELBLDIR,LOOPDIR), (OUTLCOL,FILLCOL,MARKCOL,EDGECOL,LBLCOL,GRIDCOL), (NODENUM,NODELBL,EDGELBL,GRID,SNAP)|C); zoom_cb STATE = (G1,CONFIG1) where CONFIG1 = set_actzoom CONFIG Z1, G1 = reconfig CONFIG CONFIG1 G if Z0<>Z1 where (G,CONFIG) = STATE, Z0 = actzoom CONFIG, Z1 = get_zoom; = STATE otherwise; zoom_in_cb STATE = set_zoom (Z*ZF) || zoom_cb STATE if Z*ZF <= 100 where (_,CONFIG) = STATE, Z = actzoom CONFIG, ZF = params CONFIG!8; zoom_out_cb STATE = set_zoom (round (Z/ZF*100)/100) || zoom_cb STATE if Z/ZF >= .05 where (_,CONFIG) = STATE, Z = actzoom CONFIG, ZF = params CONFIG!8; = STATE otherwise; // zoom combobox zoom_entry_cb STATE = zoom_cb STATE if valid_zoom; = STATE otherwise; // help menu about_cb STATE = about_dg (sprintf "This is version %s of graphed, the Q\n\ graph editor.\n\ Copyright (c) 2002-03 by Albert Graef.\n\n\ This program comes with ABSOLUTELY\n\ NO WARRANTY. Graphed is distributed\n\ under the GNU General Public License\n\ V2 or later. See the file COPYING\n\ for details." VERSION) || STATE; /* popup menu ***************************************************************/ /* Create the popup menu. This routine is invoked with the absolute (root) and relative (canvas) coordinates of the mouse, the id of the object under the cursor (if any) and the current state. */ private make_popup; popup (X0,Y0) (X,Y) ID STATE = update_commands STATE || tk "destroy $widget(Toplevel1).popup" || tk "menu $widget(Toplevel1).popup \ -font {Helvetica -12} -tearoff 0" || make_popup (X,Y) ID STATE || tk (sprintf "tk_popup $widget(Toplevel1).popup %d %d" (X0,Y0)); private make_placement_menu, make_selection_menu; private node_placement, edge_placement, std_options; make_popup (X,Y) ID:Int STATE = make_placement_menu (N,ID) (node_placement (labels (G!N))) || make_selection_menu G (items_at (X,Y)) || tk (sprintf "$widget(Toplevel1).popup add command \ -label {Create edge} -underline 7 -command {q [graphed]::create_edge_cb %d}" N) || tk "$widget(Toplevel1).popup add separator" || tk "$widget(Toplevel1).popup add cascade \ -label {Placement} -underline 2 -menu $widget(Toplevel1).popup.placement" || tk "$widget(Toplevel1).popup add cascade \ -label {Select} -underline 0 -menu $widget(Toplevel1).popup.selection" || tk "$widget(Toplevel1).popup add separator" || std_options (X,Y) where N:Int = obj ID, (G,_) = STATE; = make_placement_menu (N,M,ID) (edge_placement (labels (N|E))) || make_selection_menu G (items_at (X,Y)) || tk (sprintf "$widget(Toplevel1).popup add command \ -label {Move to front} -underline 8 -command {q [graphed]::to_front_cb %s}" (str (N,M,ID))) || tk "$widget(Toplevel1).popup add separator" || tk "$widget(Toplevel1).popup add cascade \ -label {Placement} -underline 2 -menu $widget(Toplevel1).popup.placement" || tk "$widget(Toplevel1).popup add cascade \ -label {Select} -underline 0 -menu $widget(Toplevel1).popup.selection" || tk "$widget(Toplevel1).popup add separator" || std_options (X,Y) where (N:Int,M:Int|_) = obj ID, (G,_) = STATE, E = search_edge (with_id ID) G (N,M); make_popup (X,Y) _ STATE = tk (sprintf "$widget(Toplevel1).popup add command \ -label {Create node} -underline 7 -command {q [graphed]::create_node_cb %s}" (str (X,Y))) || tk (sprintf "$widget(Toplevel1).popup add command \ -label {Create edge} -underline 7 -command {q [graphed]::create_edge_cb %s}" (str (X,Y))) || tk "$widget(Toplevel1).popup add separator" || std_options (X,Y) otherwise; std_options (X,Y) = tk "$widget(Toplevel1).popup add command \ -label Cut -underline 2 -accelerator {Ctrl+X} \ -command {q [graphed]::cut_cb} \ -state [$widget(CutButton) cget -state]" || tk "$widget(Toplevel1).popup add command \ -label Copy -underline 0 -accelerator {Ctrl+C} \ -command {q [graphed]::copy_cb} \ -state [$widget(CopyButton) cget -state]" || tk (sprintf "$widget(Toplevel1).popup add command \ -label Paste -underline 0 -accelerator {Ctrl+V} \ -command {q [graphed]::paste_at_cb %s} \ -state [$widget(PasteButton) cget -state]" (str (X,Y))) || tk "$widget(Toplevel1).popup add separator" || tk "$widget(Toplevel1).popup add command \ -label Delete -underline 0 -accelerator {Shift+Del} \ -command {q [graphed]::delete_cb} \ -state [$widget(EditMenu) entrycget 6 -state]" || tk "$widget(Toplevel1).popup add separator" || tk "$widget(Toplevel1).popup add command \ -label {Select all} -underline 7 -accelerator {Ctrl+A} \ -command {q [graphed]::select_all_cb}" || tk "$widget(Toplevel1).popup add command \ -label {Invert all} -underline 3 -accelerator {Ctrl+E} \ -command {q [graphed]::invert_all_cb}" || tk "$widget(Toplevel1).popup add command \ -label {Extend} -underline 2 -accelerator {Ctrl+T} \ -command {q [graphed]::extend_cb}"; make_placement_menu X P = tk "menu $widget(Toplevel1).popup.placement \ -font {Helvetica -12} -tearoff 0" || tk (sprintf "$widget(Toplevel1).popup.placement \ add radiobutton -label default -variable placement -value () \ -command {q [graphed]::placement_cb %s $placement}" (str X)) || do (tk. sprintf (sprintf "$widget(Toplevel1).popup.placement \ add radiobutton -label %%s -variable placement \ -command {q [graphed]::placement_cb %s $placement}" (str X))) (map str (keys DIRVECT)) || set_var "placement" (str P); node_placement (_,_,_,DIR:Direction|_) = DIR; node_placement _ = () otherwise; edge_placement (_,_,DIR:Direction|_) = DIR; edge_placement _ = () otherwise; private obj_label; make_selection_menu G IDS = tk "menu $widget(Toplevel1).popup.selection \ -font {Helvetica -12} -tearoff 0" || do (tk. sprintf "$widget(Toplevel1).popup.selection \ add command -label %s -command {q [graphed]::select_cb %d}") (zip (map (obj_label G) IDS) IDS); obj_label G ID = tkstr (get_obj_text G (obj ID)); /* dialogs ******************************************************************/ open_dg = tk "tk_getOpenFile -parent $widget(Toplevel1) \ -title \"Open...\" -filetypes {{{All Files} *}}"; save_dg NAME = save_as_dg if null NAME; = NAME otherwise; save_as_dg = tk "tk_getSaveFile -parent $widget(Toplevel1) \ -title \"Save as...\" -filetypes {{{All Files} *}}"; print_file_dg = tk "tk_getSaveFile -parent $widget(Toplevel1) \ -title \"Print to file...\" -filetypes {{{EPSF Files} *.eps} {{PostScript Files} *.ps} {{PDF Files} *.pdf} {{All Files} *}}"; error_dg MSG = tk (sprintf "tk_messageBox -parent $widget(Toplevel1) \ -icon error -title Error -type ok -message %s" (str MSG)); warn_dg MSG = tk (sprintf "tk_messageBox -parent $widget(Toplevel1) \ -icon warning -title Warning -type ok -message %s" (str MSG)); yesno_dg MSG = tk (sprintf "tk_messageBox -parent $widget(Toplevel1) \ -icon question -title Warning -type yesnocancel -message %s" (str MSG)); about_dg MSG = tk (sprintf "tk_messageBox -parent $widget(Toplevel1) \ -icon info -title {About graphed} -type ok -message %s" (str MSG)); /* print setup dialog */ private save_print_setup, update_print_setup; print_setup_dg = save_print_setup || update_print_setup || dg "Toplevel2" "PrintSetupOkButton" (cst true) []; /* printer setup */ chkfloat MIN MAX DFL VAL = DFL if not isfloat VAL or else (VALMAX); = VAL otherwise; print_cmd = tk_get "print_cmd"; print_cropmarks = val (tk_get "print_cropmarks") > 0; paper = PAPER where PAPER:Tuple = DIM!tk_get "paper"; = (WD,HT) where WD = chkfloat 0.0 1e999 0.0 (to_pt2 unit (val (tk_get "width"))), HT = chkfloat 0.0 1e999 0.0 (to_pt2 unit (val (tk_get "height"))); unit = tk_get "unit"; margin = chkfloat 0.0 100.0 0.0 (to_pt2 unit (val (tk_get "margin"))); xpages = val (tk_get "xpages") if val (tk_get "scalex") > 0; = 0 otherwise; ypages = val (tk_get "ypages") if val (tk_get "scaley") > 0; = 0 otherwise; landscape = val (tk_get "landscape") > 0; def PRINT_SETUP = ref (); private set_print_setup; init_print_setup = set_print_setup (PRINT_CMD, PRINT_CROPMARKS, PAPER, UNIT, MARGIN, XPAGES, YPAGES, LANDSCAPE); update_print_setup = set_print_setup (print_cmd, print_cropmarks, paper, unit, margin, xpages, ypages, landscape) || tk "set last_width $width; set last_height $height" || tk "set last_unit $unit" || update_scale_checkboxes; private update_scale_checkbox; update_scale_checkboxes = do update_scale_checkbox [("XPagesBox",xpages),("YPagesBox",ypages)]; update_scale_checkbox (BOX,VAL) = tk (sprintf "$widget(%s) configure -state disabled" BOX) if VAL=0; = tk (sprintf "$widget(%s) configure -state normal" BOX) otherwise; save_print_setup = put PRINT_SETUP (print_cmd, print_cropmarks, paper, unit, margin, xpages, ypages, landscape); set_print_setup (PRINT_CMD, PRINT_CROPMARKS, PAPER, UNIT, MARGIN, XPAGES, YPAGES, LANDSCAPE) = tk_set "print_cmd" PRINT_CMD || tk_set "print_cropmarks" (ifelse PRINT_CROPMARKS "1" "0") || tk_set "paper" (ifelse (member RDIM PAPER) (RDIM!PAPER) "Custom") || tk_set "unit" UNIT || tk_set "width" (str (to_unit2 unit (PAPER!0))) || tk_set "height" (str (to_unit2 unit (PAPER!1))) || tk_set "margin" (str (to_unit2 unit MARGIN)) || tk_set "scalex" (ifelse (XPAGES>0) "1" "0") || tk_set "xpages" (str (max 1 XPAGES)) || tk_set "scaley" (ifelse (YPAGES>0) "1" "0") || tk_set "ypages" (str (max 1 YPAGES)) || tk_set "landscape" (ifelse LANDSCAPE "1" "0"); restore_print_setup = set_print_setup (get PRINT_SETUP) || clr_print_setup if neq () PRINT_SETUP; clr_print_setup = put PRINT_SETUP (); /* config dialog */ private valid_config; config_dg CONFIG = dg "Toplevel3" "ConfigureOkButton" valid_config (config_data CONFIG); /* config dialog client data */ private from_bool, to_bool, from_num, to_num, from_dim, to_dim, from_dir, to_dir, from_col; private valid_bool, valid_dim, valid_dim0, valid_dir, valid_coord, valid_res, valid_grid, valid_zfact, valid_col; config_data ((X1,Y1,X2,Y2,XRES,YRES,XGRID,YGRID,ZFACT), (NODEWD,EDGEWD,NLBLOFFS,NLBLDIR,ELBLOFFS,ELBLDIR,LOOPDIR), (OUTLCOL,FILLCOL,MARKCOL,EDGECOL,LBLCOL,GRIDCOL), (NODENUM,NODELBL,EDGELBL,GRID,SNAP)|_) = [(X1, "x1", from_num, to_num, valid_coord, "Bad X1 coordinate."), (Y1, "y1", from_num, to_num, valid_coord, "Bad Y1 coordinate."), (X2, "x2", from_num, to_num, valid_coord, "Bad X2 coordinate."), (Y2, "y2", from_num, to_num, valid_coord, "Bad Y2 coordinate."), (XRES, "xres", from_num, to_num, valid_res, "Bad X resolution value."), (YRES, "yres", from_num, to_num, valid_res, "Bad Y resolution value."), (XGRID, "xgrid", from_num, to_num, valid_grid, "Bad X grid spacing value."), (YGRID, "ygrid", from_num, to_num, valid_grid, "Bad Y grid spacing value."), (ZFACT, "zfact", from_num, to_num, valid_zfact, "Bad zoom factor."), (NODEWD, "nodewd", from_dim, to_dim, valid_dim, "Bad node radius."), (EDGEWD, "edgewd", from_dim, to_dim, valid_dim, "Bad edge width."), (NLBLOFFS, "nlbloffs", from_dim, to_dim, valid_dim0, "Bad node label offset."), (NLBLDIR, "nlbldir", from_dir, to_dir, valid_dir, "Bad node label placement."), (ELBLOFFS, "elbloffs", from_dim, to_dim, valid_dim0, "Bad edge label offset."), (ELBLDIR, "elbldir", from_dir, to_dir, valid_dir, "Bad edge label placement."), (LOOPDIR, "loopdir", from_dir, to_dir, valid_dir, "Bad loop placement."), (OUTLCOL, "outlcol", from_col "Outl",id, valid_col, "Bad node outline color value."), (FILLCOL, "fillcol", from_col "Fill",id, valid_col, "Bad node fill color value."), (MARKCOL, "markcol", from_col "Mark",id, valid_col, "Bad node mark color value."), (EDGECOL, "edgecol", from_col "Edge",id, valid_col, "Bad edge color value."), (LBLCOL, "lblcol", from_col "Lbl", id, valid_col, "Bad label color value."), (GRIDCOL, "gridcol", from_col "Grid",id, valid_col, "Bad grid color value."), (NODENUM, "nodenum", from_bool, to_bool, valid_bool, "This can't happen."), (NODELBL, "nodelbl", from_bool, to_bool, valid_bool, "This can't happen."), (EDGELBL, "edgelbl", from_bool, to_bool, valid_bool, "This can't happen."), (GRID, "grid", from_bool, to_bool, valid_bool, "This can't happen."), (SNAP, "snap", from_bool, to_bool, valid_bool, "This can't happen.")]; // validation predicates valid_bool S = isbool (to_bool S); valid_coord S = isnum (to_num S); valid_res S = isnum X and then (X>0) where X = to_num S; valid_zfact S = isnum X and then (X>1) and then (X<=10000) where X = to_num S; valid_dim S = isint X and then (X>0) where X = to_dim S; valid_dim0 S = isint X and then (X>=0) where X = to_dim S; valid_grid S = isnum X and then (X>0) where X = to_num S; valid_dir S = true where (X,Y) = to_dir S; = false otherwise; valid_col S = true; valid_config [X1,Y1,X2,Y2,XRES,YRES,XGRID,YGRID,ZFACT, NODEWD,EDGEWD,NLBLOFFS,NLBLDIR,ELBLOFFS,ELBLDIR,LOOPDIR, OUTLCOL,FILLCOL,MARKCOL,EDGECOL,LBLCOL,GRIDCOL, NODENUM,NODELBL,EDGELBL,GRID,SNAP] = error_dg "Bad coordinate range." || false if (X1>=X2) or else (Y1>=Y2); = true otherwise; // update callbacks for the color buttons private set_button; from_col BUT COL = set_button BUT COL || COL; col_cb VAR BUT = set_var VAR COL || set_button BUT COL if not null COL where COL = tk (sprintf "tk_chooseColor -initialcolor %s \ -title \"Choose color\"" (get_var VAR)); set_button BUT COL = tk (sprintf "$widget(%sButton) configure -background %s \ -activebackground %s" (BUT,COL,COL)); outlcol_cb = col_cb "outlcol" "Outl"; fillcol_cb = col_cb "fillcol" "Fill"; markcol_cb = col_cb "markcol" "Mark"; edgecol_cb = col_cb "edgecol" "Edge"; lblcol_cb = col_cb "lblcol" "Lbl"; gridcol_cb = col_cb "gridcol" "Grid"; /* create a modal dialog from a toplevel */ /* The dg function is invoked with three arguments, the name TOPLEVEL of the toplevel, the name FOCUS of the widget inside the toplevel to receive initial focus (usually the OK button of the dialog), a global validation predicate VALID, and the client data DATA. The client data is a list of tuples of the form (VAL,VAR,FROM,TO,VALID, MSG). Each item in the list denotes an input value for the dialog whose final value is to be retrieved when the dialog is finished. The meaning of the different tuple components is as follows: - VAL: the input value. - VAR: the name of the variable in the Tk interpreter that receives the value. - FROM: a function which converts the value to its (string) representation in the Tk Interpreter. (For strings this may just be the identity.) - TO: a function which converts the Tk representation back to its Q representation. (For strings this may again be the identity function.) - VALID: a predicate which checks whether the Tk string represents a legal value. This predicate is applied before the value is converted back with FROM. (If no validation is required then this may be the (cst true) function.) - MSG: An error message to be displayed when the validation of this item fails. When converting back the client data upon exit, first the individual items are checked, then the global validation function. If the validation of a single item fails, the corresponding message is displayed. No message is displayed if the global validation fails; the application is assumed to handle this case itself with an appropriate error message. The dg function recognizes two special callbacks. First, the convert_cb callback is used to exit the dialog after validating and converting the client data back from the Tk data. This callback is invoked with a single argument, a function which is to be applied to the converted data. The resulting value is then returned by the dg function, unless the validation fails. In the latter case the dialog keeps running, to let the user correct any errors. Second, the update_cb callback can be used to inform the caller of any status changes in the dialog. It is invoked with one argument, the function to invoke. The dialog keeps running after invoking the callback. Any other callback causes the dialog to exit with the value of the callback as its result, without returning any data, and bypassing validation. Moreover, the original input values are restored. This provides a way to cancel the dialog. */ private geometry, center; private dg_flush, dg_loop, dg_check, dg_global_check, dg_valid, dg_from, dg_to; dg TOPLEVEL FOCUS VALID DATA = RES where // convert the client data _ = do dg_from DATA, // calculate the geometries of the main window and the dialog GEOM = geometry (tk "wm geometry $widget(Toplevel1)"), GEOM2 = geometry (tk (sprintf "wm geometry $widget(%s)" TOPLEVEL)), // show the dialog centered on the main window, grab the cursor and set the // focus to the focus widget _ = tk (sprintf "wm transient $widget(%s) $widget(Toplevel1)" TOPLEVEL) || tk (sprintf "wm geometry $widget(%s) +%d+%d" (TOPLEVEL|center GEOM GEOM2)) || tk (sprintf "wm deiconify $widget(%s)" TOPLEVEL) || tk (sprintf "grab $widget(%s)" TOPLEVEL) || tk (sprintf "focus $widget(%s)" FOCUS), // flush the callback queue _ = dg_flush, // get the result from the dialog RES = dg_loop VALID DATA, // release the grab and hide the dialog window _ = tk (sprintf "grab release $widget(%s)" TOPLEVEL) || tk (sprintf "wm withdraw $widget(%s)" TOPLEVEL); // we first flush the callback queue, to get rid of any spurious callbacks // which might have been generated while setting up the dialog dg_flush = tk_reads || dg_flush if tk_check; = () otherwise; // basic event loop for a dialog, with validation dg_loop VALID DATA = dg_check VALID DATA tk_read if tk_ready; = quit_cb otherwise; dg_check VALID DATA (update_cb CB) = CB || dg_loop VALID DATA; dg_check VALID DATA (convert_cb CB) = dg_loop VALID DATA if not dg_valid DATA; = dg_global_check VALID DATA (map dg_to DATA) CB otherwise; dg_check VALID DATA CB = do dg_from DATA || CB; dg_global_check VALID DATA CONV CB = dg_loop VALID DATA if not VALID CONV; = CB CONV otherwise; dg_valid [] = true; dg_valid [(_,VAR,_,_,VALID,MSG)|DATA] = error_dg MSG || false if not VALID (get_var VAR); = dg_valid DATA otherwise; // value conversions dg_from (VAL,VAR,FROM|_) = set_var VAR (FROM VAL); dg_to (_,VAR,_,TO|_) = TO (get_var VAR); // parse a geometry value geometry GEOM = sscanf GEOM "%dx%d+%d+%d"; // calculate the center position of one window on another center (W,H,X,Y) (W2,H2,X2,Y2) = (X + (W-W2) div 2, Y + (H-H2) div 2); /* application interface ****************************************************/ // get and set state variables in the Tcl/Tk interpreter get_var NAME = VAL where VAL:String = tk_get NAME; = () otherwise; set_var NAME () = tk_unset NAME; set_var NAME VAL:String = tk_set NAME VAL; set_var NAME VAL = tk_set NAME (str VAL) otherwise; // some special characters in a Tcl string have to be quoted; we take care of // this here private tkch C; tkstr S:String = sprintf "\"%s\"" (strcat (map tkch (chars S))); tkch "{" = "\\{"; tkch "}" = "\\}"; tkch "[" = "\\["; tkch "]" = "\\]"; tkch "$" = "\\$"; tkch "\\" = "\\\\"; tkch "\"" = "\\\""; tkch C = C otherwise; // conversions for specific data types _f X:Int = float X; _f X = X otherwise; _i X:Float = round X; _i X = X otherwise; from_bool X = ifelse X 1 0; to_bool () = false; to_bool S = (X<>0) where X:Int = to_num S; from_num X = _f X; to_num S = X where X:Num = cval S; from_dim X = _i X; to_dim S = X where X:Int = cval S; def DIRVECTS = dict (zip (map str (keys DIRVECT)) (vals DIRVECT)); from_dir X = DIRVAL!X; to_dir () = c; to_dir S = DIRVECTS!S; // validate a zoom value entered by the user valid_zoom = tk (sprintf "$widget(ComboBox1) configure -values \ [concat [$widget(ComboBox1) cget -values] {%s}]" S) || true if (Z>=5) and then (Z<10000) where S = get_var "zoom", Z:Int = sscanf S "%d%%"; = false otherwise; // get and set the zoom value get_zoom = Z/100 where Z:Int = sscanf (get_var "zoom") "%d%%"; = 1.0 otherwise; set_zoom Z = set_var "zoom" (sprintf "%d%%" (_i (Z*100))); // get and set the viewport of the canvas get_viewport = (sscanf (tk "$widget(Canvas) xview") "%g", sscanf (tk "$widget(Canvas) yview") "%g"); set_viewport (X,Y) = tk (sprintf "$widget(Canvas) xview moveto %g" (_f X)) || tk (sprintf "$widget(Canvas) yview moveto %g" (_f Y)); // get and set the scroll region of the canvas get_scrollregion = (X,Y) where (_,_,X,Y) = sscanf (tk "$widget(Canvas) cget -scrollregion") "%g %g %g %g"; set_scrollregion P = tk (sprintf "$widget(Canvas) configure -scrollregion {0.0 0.0 %g %g}" P); // modifier status shift_status = lshift_status or else rshift_status; lshift_status = to_bool (get_var "lshift"); rshift_status = to_bool (get_var "rshift"); ctrl_status = lctrl_status or else rctrl_status; lctrl_status = to_bool (get_var "lctrl"); rctrl_status = to_bool (get_var "rctrl"); // miscellaneous other state variables get_fname = get_var "fname"; set_fname FNAME = set_var "fname" FNAME; get_edited = to_bool (get_var "edited"); set_edited FLAG = set_var "edited" (from_bool FLAG); get_grid = to_bool (get_var "grid"); set_grid FLAG = set_var "grid" (from_bool FLAG); get_snap = to_bool (get_var "snap"); set_snap FLAG = set_var "snap" (from_bool FLAG); get_digraph_mode = to_bool (get_var "digraph_mode"); set_digraph_mode FLAG = set_var "mode" (ifelse FLAG "D" "U") || set_var "digraph_mode" (from_bool FLAG); get_entry = get_var "entry"; set_entry VAL = set_var "entry" VAL; set_msg S = set_var "msg" S; set_status S = set_var "status" S; // update the title of the application update_title = tk (sprintf "wm title $widget(Toplevel1) %s" (tkstr (sprintf "%s%s - graphed" (FNAME,ifelse ED "*" "")))) if not null FNAME where FNAME = get_fname, ED = get_edited; = tk "wm title $widget(Toplevel1) graphed" otherwise; /* "safe" val. This only allows constant values in val. */ private chkval X; cval S:String = val S if chkval (valq S); chkval '(X Y) = isconst (X Y); chkval '[X|Y] = chkval 'X and then chkval 'Y; chkval '(X|Y) = chkval 'X and then chkval 'Y; chkval 'X = isconst X or else isvar X; chkval _ = false otherwise; /* configuration handling ***************************************************/ /* load config file */ private config_file, parse_config, check_config; const bad_config; load_config = parse_config F (freads F) where F:File = fopen config_file "r"; parse_config F S:String = parse_config F (freads F) if null S or else (S!0="%"); = check_config ((X1,Y1,X2,Y2,XRES,YRES,XGRID,YGRID,ZFACT), (NODEWD,EDGEWD,NLBLOFFS,NLBLDIR,ELBLOFFS,ELBLDIR,LOOPDIR), (OUTLCOL,FILLCOL,MARKCOL,EDGECOL,LBLCOL,GRIDCOL), (NODENUM,NODELBL,EDGELBL,GRID,SNAP)) where ((X1:Num,Y1:Num,X2:Num,Y2:Num, XRES:Num,YRES:Num,XGRID:Num,YGRID:Num, ZFACT:Num), (NODEWD:Num,EDGEWD:Num,NLBLOFFS:Num,NLBLDIR, ELBLOFFS:Num,ELBLDIR,LOOPDIR), (OUTLCOL:String,FILLCOL:String, MARKCOL:String, EDGECOL:String, LBLCOL:String,GRIDCOL:String), (NODENUM:Bool,NODELBL:Bool,EDGELBL:Bool, GRID:Bool,SNAP:Bool)) = cval S, (_:Num,_:Num) = NLBLDIR, (_:Num,_:Num) = ELBLDIR, (_:Num,_:Num) = LOOPDIR; parse_config _ _ = bad_config otherwise; check_config CONFIG = bad_config if (X1>X2) or else (Y1>Y2) or else (XRES<=0) or else (YRES<=0) or else (XGRID<=0) or else (YGRID<=0) or else (ZFACT<=1) or else (ZFACT>10000) where (X1,Y1,X2,Y2,XRES,YRES,XGRID,YGRID,ZFACT) = params CONFIG; = bad_config if (NODEWD<1) or else (EDGEWD<1) or else (NLBLOFFS<0) or else (ELBLOFFS<0) or else not all (member DIRVAL) [NLBLDIR,ELBLDIR,LOOPDIR] where (NODEWD,EDGEWD,NLBLOFFS,NLBLDIR,ELBLOFFS,ELBLDIR,LOOPDIR) = geom CONFIG; = bad_config if not all valid_col (list (colors CONFIG)); = bad_config if not all isbool (list (options CONFIG)); = CONFIG otherwise; /* save config file */ save_config CONFIG = fprintf F "%% config written by graphed %s %s -- DO NOT EDIT!\n" (VERSION,ctime time) || fwrite F (sub CONFIG 0 3) || fwrites F "\n" where FNAME = config_file, F:File = fopen FNAME "w"; private home; config_file = ".graphed" if isfile (fopen ".graphed" "r"); = home++"/.graphed" otherwise; home = S where S:String = getenv "HOME"; = "" otherwise; /* query and modify display settings */ params CONFIG = CONFIG!0; geom CONFIG = CONFIG!1; colors CONFIG = CONFIG!2; options CONFIG = CONFIG!3; // the following additional options are used internally digraph CONFIG = CONFIG!4; actzoom CONFIG = CONFIG!5; lastG CONFIG = CONFIG!6; set_digraph (C0,C1,C2,C3,C4,C5,C6) FLAG = (C0,C1,C2,C3,FLAG,C5,C6); set_actzoom (C0,C1,C2,C3,C4,C5,C6) Z = (C0,C1,C2,C3,C4,Z,C6); set_lastG (C0,C1,C2,C3,C4,C5,C6) G = (C0,C1,C2,C3,C4,C5,G); set_actgrid (C0,C1,C2,(NODENUM,NODELBL,EDGELBL,GRID,SNAP),C4,C5,C6) FLAG = (C0,C1,C2,(NODENUM,NODELBL,EDGELBL,FLAG,SNAP),C4,C5,C6); set_actsnap (C0,C1,C2,(NODENUM,NODELBL,EDGELBL,GRID,SNAP),C4,C5,C6) FLAG = (C0,C1,C2,(NODENUM,NODELBL,EDGELBL,GRID,FLAG),C4,C5,C6);