Menu
▾
▴
[Maxima-commits] CVS: maxima/share/contrib/graphs draw_graph.mac, 1.3, 1.4 graph_core.lisp, 1.4, 1.5
|
From: Andrej V. <an...@us...> - 2007-07-31 11:38:28
|
Update of /cvsroot/maxima/maxima/share/contrib/graphs In directory sc8-pr-cvs16.sourceforge.net:/tmp/cvs-serv17633/share/contrib/graphs Modified Files: draw_graph.mac graph_core.lisp Log Message: Updating the graphs package. Index: draw_graph.mac =================================================================== RCS file: /cvsroot/maxima/maxima/share/contrib/graphs/draw_graph.mac,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- draw_graph.mac 5 Jul 2007 09:46:12 -0000 1.3 +++ draw_graph.mac 31 Jul 2007 11:38:18 -0000 1.4 @@ -25,25 +25,25 @@ load("draw")$ gp_file_out : "out.txt"$ -gp_file_in : "in.txt"$ +gp_file_in : "in.txt"$ circular_positions(G) := block( [v_list, numer : true, n : graph_size(G)], v_list : vertices(G), - makelist([v_list[i+1], [2+cos(2*i*%pi/n), 2+sin(2*i*%pi/n)]], i, 0, graph_size(G)-1) -)$ + makelist( + [v_list[i+1], + [2+cos(2*i*%pi/n), 2+sin(2*i*%pi/n)]], + i, 0, graph_size(G)-1))$ write_file(G) := block( [display2d:false, file, e], file : openw(sunlisp(gp_file_in)), printf(file, "graph {"), for e in edges(G) do ( - printf(file, "~s -- ~s~%", e[1], e[2]) - ), + printf(file, "~s -- ~s~%", e[1], e[2])), printf(file, "}"), close(file), - 'done -)$ + 'done)$ read_file() := block( [lst : read_list(gp_file_out), @@ -64,15 +64,20 @@ [command], write_file(G), if program = 'dot then - command : concat("dot -Tplain \"", gp_file_in, "\" > \"", gp_file_out, "\"") + command : concat("dot -Tplain \"", + gp_file_in, "\" > \"", gp_file_out, "\"") else if program = 'twopi then - command : concat("twopi -Tplain \"", gp_file_in, "\" > \"", gp_file_out, "\"") + command : concat("twopi -Tplain \"", + gp_file_in, "\" > \"", gp_file_out, "\"") else if program = 'circo then - command : concat("circo -Tplain \"", gp_file_in, "\" > \"", gp_file_out, "\"") + command : concat("circo -Tplain \"", + gp_file_in, "\" > \"", gp_file_out, "\"") else if program = 'fdp then - command : concat("fdp -Tplain \"", gp_file_in, "\" > \"", gp_file_out, "\"") + command : concat("fdp -Tplain \"", + gp_file_in, "\" > \"", gp_file_out, "\"") else - command : concat("neato -Tplain \"", gp_file_in, "\" > \"", gp_file_out, "\""), + command : concat("neato -Tplain \"", + gp_file_in, "\" > \"", gp_file_out, "\""), system(command), read_file() )$ @@ -91,11 +96,16 @@ head_length : 0.03, head_angle : 20, vertices:[], edges:[], v_pos, vertex_labels:[], edge_weights:[], program : 'neato, directed : false, - command, x_max, y_max, gp_options, terminal : 'screen, file_name : "graph", - gp_file_in : temp_filename(gp_file_in), gp_file_out : temp_filename(gp_file_out) + show_vertices : [], vertices1 : [], show_color : 'blue, + show_edges : [], edges1 : [], show_edge_color : 'blue, + command, x_max, y_max, gp_options, + terminal : 'screen, file_name : "graph", + gp_file_in : temp_filename(gp_file_in), + gp_file_out : temp_filename(gp_file_out) ], - if not(is_graph(G)) and not(is_digraph(G)) then error("First argument to `draw_graph' is not a graph:", G), + if not(is_graph(G)) and not(is_digraph(G)) then + error("First argument to `draw_graph' is not a graph:", G), if get('wxmaxima, 'version)#false then terminal : 'wxmaxima, if is_digraph(G) then directed : true, @@ -122,27 +132,46 @@ else edges : cons(points([assoc(e[1], v_pos), assoc(e[2], v_pos)]), edges) ), + for e in show_edges do ( + if directed=true then block( + [p1 : assoc(e[1], v_pos), p2 : assoc(e[2], v_pos)], + edges1 : cons(vector(p1, p2-p1), edges1) + ) + else + edges1 : cons(points([assoc(e[1], v_pos), assoc(e[2], v_pos)]), edges1) + ), vertices : [points(map(second, v_pos))], + for v in show_vertices do ( + vertices1 : cons(assoc(v, v_pos), vertices1) + ), + if length(vertices1) > 0 then vertices1 : [points(vertices1)], if show_id=true then ( for v in vertices(G) do block( [p : assoc(v, v_pos)], - vertex_labels : cons(label(concat(" ", v), p[1], p[2]), vertex_labels) + vertex_labels : cons([concat(" ", v), p[1], p[2]], vertex_labels) ) ) else if show_label=true then ( for v in vertices(G) do block( [p : assoc(v, v_pos)], - vertex_labels : cons(label(concat(" ", get_vertex_label(v, G)), p[1], p[2]), vertex_labels) + vertex_labels : cons([concat(" ", + get_vertex_label(v, G)), p[1], p[2]], + vertex_labels) ) ), + if length(vertex_labels) > 0 then + vertex_labels : [apply(label, vertex_labels)], if show_weight=true then ( for e in edges(G) do block( [p1 : assoc(e[1], v_pos), p2 : assoc(e[2], v_pos)], - edge_weights : cons(label(concat(get_edge_weight(e, G)), (2*p1[1]+p2[1])/3, (2*p1[2]+p2[2])/3), edge_weights) + edge_weights : cons([concat(get_edge_weight(e, G)), + (2*p1[1]+p2[1])/3, (2*p1[2]+p2[2])/3], edge_weights) ) - ), + ), + if length(edge_weights) > 0 then + edge_weights : [apply(label, edge_weights)], if terminal='wxmaxima then command : wxdraw2d else command : draw2d, @@ -152,6 +181,19 @@ apply(command, append( [ + 'color = color, + 'point_type = 0, + 'line_type = 'solid, + 'points_joined = true, + 'head_length = head_length, + 'head_angle = head_angle + ], + edges, + [ + 'color = show_edge_color + ], + edges1, + [ 'points_joined = false, 'point_size = 1, 'point_type = vertex_type, @@ -159,13 +201,9 @@ ], vertices, [ - 'point_type = 0, - 'line_type = 'solid, - 'points_joined = true, - 'head_length = head_length, - 'head_angle = head_angle + 'color = show_color ], - edges, + vertices1, [ 'color = text_color, 'label_alignment = 'left @@ -185,3 +223,14 @@ ), 'done )$ + +vertices_to_path(lst) := block( + [path : []], + + while length(lst)>1 do ( + path : cons([lst[1], lst[2]], path), + lst : rest(lst)), + + path)$ + +vertices_to_cycle(lst) := vertices_to_path(append(lst, [first(lst)]))$ Index: graph_core.lisp =================================================================== RCS file: /cvsroot/maxima/maxima/share/contrib/graphs/graph_core.lisp,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- graph_core.lisp 5 Jul 2007 09:55:48 -0000 1.4 +++ graph_core.lisp 31 Jul 2007 11:38:18 -0000 1.5 @@ -81,7 +81,7 @@ (dolist (u (neighbors v gr)) (format t " ~2d" u)))) (t - (format t "~%Diraph on ~d vertices with ~d arcs." + (format t "~%Digraph on ~d vertices with ~d arcs." (digraph-size gr) (digraph-order gr)) (if (> (digraph-size gr) 0 ) (format t "~%Adjacencies:")) @@ -159,7 +159,12 @@ ($error "Argument" i "to" m "is not a valid vertex."))) (defun is-vertex-in-graph (i gr) - (not (null (member i (vertices gr))))) + (not (equal (gethash i + (if (graph-p gr) + (graph-neighbors gr) + (digraph-out-neighbors gr)) + 'not-in-graph) + 'not-in-graph))) (defun require-vertex-in-graph (m i gr) (if (not (is-vertex-in-graph i gr)) @@ -406,8 +411,8 @@ (defun is-edge-in-graph (e gr) (if (graph-p gr) - (not (null (member e (graph-edges gr) :test #'equal))) - (not (null (member e (digraph-edges gr) :test #'equal))))) + (not (null (member (second e) (neighbors (first e) gr)))) + (not (null (member (second e) (out-neighbors (first e) gr)))) )) (defun $add_edge (e gr) (require-medge 'add_edge 1 e) @@ -586,6 +591,43 @@ ($add_edge `((mlist simp) ,u ,v) gr))) '$done) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; implementation of a set using hash tables +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defstruct ht-set + (content (make-hash-table))) + +(defun new-set (&rest initial-content) + (let ((set (make-ht-set))) + (dolist (obj initial-content) + (set-add obj set)) + set)) + +(defun set-member (obj set) + (gethash obj (ht-set-content set))) + +(defun set-add (obj set) + (setf (gethash obj (ht-set-content set)) t)) + +(defun set-remove (obj set) + (remhash obj (ht-set-content set))) + +(defun set-emptyp (set) + (= 0 (hash-table-count (ht-set-content set)))) + +(defun set-elements (set) + (let (elts) + (maphash #'(lambda (key val) + (declare (ignore val)) + (setq elts (cons key elts))) + (ht-set-content set)) + elts)) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; graph definitions @@ -900,7 +942,7 @@ g)) (defun $wheel_graph (n) - (if (not (and (integerp n) (> n 3))) + (if (not (and (integerp n) (>= n 3))) ($error "wheel_graph: first argument is no an integer greater than 3")) (let ((g ($cycle_graph n))) (add-vertex n g) @@ -1022,23 +1064,25 @@ (let ((girth (1+ (graph-size gr)))) (dolist (v (graph-vertices gr)) (let - ((visited (list v)) - (active (list v)) - (next ()) + ((visited (new-set v)) + (active (new-set v)) + (next) (depth 1)) (do () - ((or (null active) (> (* 2 depth) girth) (<= girth 3))) - (setq next ()) - (dolist (u active) + ((or (set-emptyp active) + (> (* 2 depth) girth) + (<= girth 3))) + (setq next (new-set)) + (dolist (u (set-elements active)) (dolist (w (neighbors u gr)) - (if (not (member w visited)) + (if (not (set-member w visited)) (progn - (push w visited) - (push w next)) + (set-add w visited) + (set-add w next)) (progn - (if (member w active) + (if (set-member w active) (setq girth (- (* 2 depth) 1))) - (if (and (not odd) (member w next)) + (if (and (not odd) (set-member w next)) (setq girth (min girth (* 2 depth)))))))) (setq active next) (setq depth (1+ depth))))) @@ -1058,19 +1102,18 @@ (let ((diameter 0)) (dolist (v (graph-vertices gr)) (let - ((visited (list v)) - (active (list v)) - (next ()) + ((visited (new-set v)) + (active (new-set v)) + (next) (depth -1)) (do () - ((null active)) - (setq next ()) - (dolist (u active) + ((set-emptyp active)) + (setq next (new-set)) + (dolist (u (set-elements active)) (dolist (w (neighbors u gr)) - (if (not (member w visited)) - (progn - (push w visited) - (push w next))))) + (when (not (set-member w visited)) + (set-add w visited) + (set-add w next)))) (setq active next) (setq depth (1+ depth))) (if (> depth diameter) @@ -1084,19 +1127,19 @@ (let ((radius (graph-size gr))) (dolist (v (graph-vertices gr)) (let - ((visited (list v)) - (active (list v)) - (next ()) + ((visited (new-set v)) + (active (new-set v)) + (next) (depth -1)) (do () - ((null active)) - (setq next ()) - (dolist (u active) + ((set-emptyp active)) + (setq next (new-set)) + (dolist (u (set-elements active)) (dolist (w (neighbors u gr)) - (if (not (member w visited)) + (if (not (set-member w visited)) (progn - (push w visited) - (push w next))))) + (set-add w visited) + (set-add w next))))) (setq active next) (setq depth (1+ depth))) (if (< depth radius) @@ -1126,7 +1169,7 @@ (let ((A ()) (B ()) - (visited ()) + (visited (new-set)) (active `(,v)) (colors (make-hash-table))) (setf (gethash v colors) 1) @@ -1135,12 +1178,12 @@ (let* ((w (pop active)) (wc (gethash w colors))) - (push w visited) + (set-add w visited) (if (= wc 1) (push w A) (push w B)) (dolist (u (neighbors w gr)) - (if (member u visited) + (if (set-member u visited) (if (= (gethash u colors) wc) (return-from bi-partition ())) (if (not (member u active)) |