From: Joe Neeman Date: Thu, 1 Feb 2007 16:17:40 +0000 (+0200) Subject: resurrect graphing support X-Git-Tag: release/2.11.16-1^2~9 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=73f6abcd0aa9a2b6f64269b1a82625d39036f3d7;p=lilypond.git resurrect graphing support --- diff --git a/lily/context.cc b/lily/context.cc index 7e5ea8ae2a..f5543c0105 100644 --- a/lily/context.cc +++ b/lily/context.cc @@ -460,6 +460,13 @@ Context::add_alias (SCM sym) aliases_ = scm_cons (sym, aliases_); } +/* we don't (yet) instrument context properties */ +void +Context::instrumented_set_property (SCM sym, SCM val, const char*, int, const char*) +{ + internal_set_property (sym, val); +} + void Context::internal_set_property (SCM sym, SCM val) { diff --git a/lily/grob-property.cc b/lily/grob-property.cc index 7bf13062a5..1473157209 100644 --- a/lily/grob-property.cc +++ b/lily/grob-property.cc @@ -27,9 +27,11 @@ LY_DEFINE (ly_set_grob_modification_callback, "ly:set-grob-modification-callback 1, 0, 0, (SCM cb), "Specify a procedure that will be called every time lilypond modifies " "a grob property. The callback will receive as arguments " - "the grob that is being modified, the name of the C++ file in which " - "the modification was requested, the line number in the C++ file in " - "which the modification was requested, the property to be changed and " + "the grob that is being modified, " + "the name of the C++ file in which the modification was requested, " + "the line number in the C++ file in which the modification was requested, " + "the name of the function in which the modification was requested, " + "the property to be changed and " "the new value for the property.") { LY_ASSERT_TYPE (ly_is_procedure, cb, 1); @@ -37,6 +39,22 @@ LY_DEFINE (ly_set_grob_modification_callback, "ly:set-grob-modification-callback modification_callback = cb; return SCM_UNSPECIFIED; } + +void +Grob::instrumented_set_property (SCM sym, SCM v, + char const *file, + int line, + char const *fun) +{ + if (ly_is_procedure (modification_callback)) + scm_apply_0 (modification_callback, + scm_list_n (self_scm (), + scm_from_locale_string (file), + scm_from_int (line), + scm_from_locale_string (fun), + sym, v, SCM_UNDEFINED)); + internal_set_property (sym, v); +} #endif SCM @@ -51,43 +69,6 @@ Grob::get_property_alist_chain (SCM def) const extern void check_interfaces_for_property (Grob const *me, SCM sym); -#if 0 - -/* - We can't change signatures depending on NDEBUG, since NDEBUG comes - over the command line and may be different per .cc file. This - should be done through the macro expansion of get_property (). - */ -void -Grob::internal_set_property (SCM sym, SCM v, char const *file, int line, char const *fun) -{ - SCM grob_p = ly_lily_module_constant ("ly:grob?"); - SCM grob_list_p = ly_lily_module_constant ("grob-list?"); - SCM type = scm_object_property (sym, ly_symbol2scm ("backend-type?")); - - if (type == grob_p - || type == grob_list_p - || (unsmob_grob (v) && ly_symbol2scm ("cause") != sym)) - { - scm_display (scm_list_2 (sym, type), scm_current_output_port ()); - assert (0); - } - - internal_set_value_on_alist (&mutable_property_alist_, - sym, v); - - - if (ly_is_procedure (modification_callback)) - scm_apply_0 (modification_callback, - scm_list_n (self_scm (), - scm_from_locale_string (file), - scm_from_int (line), - scm_from_locale_string (fun), - sym, v, SCM_UNDEFINED)); -} -#else - - void Grob::internal_set_property (SCM sym, SCM v) { @@ -95,7 +76,6 @@ Grob::internal_set_property (SCM sym, SCM v) sym, v); } -#endif void Grob::internal_set_value_on_alist (SCM *alist, SCM sym, SCM v) diff --git a/lily/include/context.hh b/lily/include/context.hh index 39babf7b66..7cd01bf5bb 100644 --- a/lily/include/context.hh +++ b/lily/include/context.hh @@ -85,6 +85,7 @@ public: Context *where_defined (SCM name_sym, SCM *value) const; void unset_property (SCM var_sym); + void instrumented_set_property (SCM, SCM, const char*, int, const char*); void internal_set_property (SCM var_sym, SCM value); Context *create_context (Context_def *, string, SCM); diff --git a/lily/include/grob.hh b/lily/include/grob.hh index d134068568..73d58a8c2c 100644 --- a/lily/include/grob.hh +++ b/lily/include/grob.hh @@ -84,6 +84,7 @@ public: SCM internal_get_object (SCM symbol) const; void internal_set_object (SCM sym, SCM val); void internal_del_property (SCM symbol); + void instrumented_set_property (SCM, SCM, char const*, int, char const*); void internal_set_property (SCM sym, SCM val); /* messages */ diff --git a/lily/include/lily-guile-macros.hh b/lily/include/lily-guile-macros.hh index 6b0a60a2f0..86d2517dee 100644 --- a/lily/include/lily-guile-macros.hh +++ b/lily/include/lily-guile-macros.hh @@ -195,7 +195,7 @@ void ly_check_name (string cxx, string fname); TODO: include modification callback support here, perhaps through intermediate Grob::instrumented_set_property( .. __LINE__ ). */ -#define set_property(x, y) internal_set_property (ly_symbol2scm (x), y) +#define set_property(x, y) instrumented_set_property (ly_symbol2scm (x), y, __FILE__, __LINE__, __FUNCTION__) #else #define set_property(x, y) internal_set_property (ly_symbol2scm (x), y) #endif diff --git a/lily/include/prob.hh b/lily/include/prob.hh index 839edd4aba..b01fb4d42d 100644 --- a/lily/include/prob.hh +++ b/lily/include/prob.hh @@ -42,6 +42,7 @@ public: SCM type () const { return type_; } SCM get_property_alist (bool mutble) const; SCM internal_get_property (SCM sym) const; + void instrumented_set_property (SCM, SCM, const char*, int, const char*); void internal_set_property (SCM sym, SCM val); }; DECLARE_UNSMOB(Prob,prob); diff --git a/lily/prob.cc b/lily/prob.cc index ce51546d8e..4e068fa4d4 100644 --- a/lily/prob.cc +++ b/lily/prob.cc @@ -157,6 +157,13 @@ Prob::internal_get_property (SCM sym) const return (s == SCM_BOOL_F) ? SCM_EOL : scm_cdr (s); } +/* We don't (yet) instrument probs */ +void +Prob::instrumented_set_property (SCM sym, SCM val, const char*, int, const char*) +{ + internal_set_property (sym, val); +} + void Prob::internal_set_property (SCM sym, SCM val) { diff --git a/ly/graphviz.ly b/ly/graphviz.ly new file mode 100644 index 0000000000..65b6538ec6 --- /dev/null +++ b/ly/graphviz.ly @@ -0,0 +1,53 @@ +\version "2.11.15" + +#(define last-grob-action '()) + +#(define sym-blacklist + '(cause font)) + +#(define sym-whitelist + '(control-points)) + +#(define file-line-blacklist + '()) + +#(define file-line-whitelist + '()) + +#(define graph (make-graph "graph.dot")) + +% an event is relevant if +% (it is on some whitelist or all whitelists are empty) +% and +% (it isn't on any blacklist) + +#(define (relevant? grob file line prop) + (let ((file-line `(,file . ,line))) + (and + (or + (= 0 (length file-line-whitelist) (length sym-whitelist)) + (memq prop sym-whitelist) + (member file-line file-line-whitelist)) + (and + (not (memq prop sym-blacklist)) + (not (member file-line file-line-blacklist)))))) + +#(define (grob-mod grob file line func prop val) + (let* ((prev (assv grob last-grob-action)) + (val-str0 (format "~a" val)) + (val-str (string-take val-str0 (min 50 (string-length val-str0)))) + (label (format "~a\\n~a:~a\\n~a <- ~a" grob file line prop val-str)) + (node-id (make-node graph label file))) + (if (relevant? grob file line prop) + (begin + (if (pair? prev) + (add-edge graph (cdr prev) node-id)) + (set! last-grob-action (assv-set! last-grob-action grob node-id)))))) + +#(define (grob-create grob file line func) + (let* ((label (format "~a\\n~a:~a" grob file line)) + (node-id (make-node graph label file))) + (set! last-grob-action (assv-set! last-grob-action grob node-num)))) + +#(ly:set-grob-modification-callback grob-mod) +#(ly:set-grob-creation-callback grob-create) diff --git a/scm/graphviz.scm b/scm/graphviz.scm index d3a858fcef..d361302fed 100644 --- a/scm/graphviz.scm +++ b/scm/graphviz.scm @@ -1,6 +1,13 @@ +;;;; graphviz.scm -- utilities for creating graphviz output +;;;; +;;;; source file of the GNU LilyPond music typesetter +;;;; +;;;; (c) 2007 Joe Neeman + + (define-module (scm graphviz) #:use-module (lily) - #:export (make-graph add-node add-edge)) + #:export (make-graph add-node add-edge add-cluster)) (define (make-graph filename) (let ((empty-graph (list->vector (list filename '() '() '())))) @@ -12,10 +19,24 @@ (define (edges g) (vector-ref g 2)) (define (clusters g) (vector-ref g 3)) -(define (add-node graph label) - (let ((ns (nodes graph))) - (vector-set! graph 1 (cons `(,(length ns) . ,label) ns)) - (length ns))) +(define (add-cluster graph node-id cluster-name) + (let ((cs (clusters g)) + (cluster (assq cluster-name cs)) + (already-in-cluster (if cluster + (cdr cluster) + '()))) + (vector-set! graph 3 (assq-set! cluster-name + (cons node-id already-in-cluster) + cs)))) + +(define (add-node graph label . cluster-name) + (let ((ns (nodes graph)) + (id (length ns))) + (vector-set! graph 1 (cons `(,id . ,label) ns)) + (if (and (not (null? cluster-name)) + (string? (car cluster-name))) + (add-cluster graph id (car cluster-name))) + id)) (define (add-edge graph node1 node2) (vector-set! graph 2 (cons `(,node1 . ,node2) (edges graph)))) @@ -24,12 +45,19 @@ (let ((out (open-file (filename graph) "w")) (ns (nodes graph)) (es (edges graph)) - (cc (clusters graph))) + (cs (clusters graph))) (ly:message (format "writing graph ~s..." (filename graph))) (display "digraph G {\nrankdir=\"LR\"\nnode [shape=rectangle]\n" out) (map (lambda (n) (display (format "~a [label=\"~a\"]\n" (car n) (cdr n)) out)) ns) (map (lambda (e) (display (format "~a -> ~a\n" (car e) (cdr e)) out)) es) + (map (lambda (c) + (display (format "subgraph cluster_~a {\nlabel= \"~a\"\ncolor=blue\n" + (string-filter char-alphabetic? (car c)) + (car c)) + out) + (map (lambda (n) (display (format "~a\n" n) out)) (cdr c)) + (display "}\n" out)) + cs) (display "}" out))) - \ No newline at end of file