From: Joe Neeman <joeneeman@gmail.com>
Date: Thu, 1 Feb 2007 20:56:08 +0000 (+0200)
Subject: New hooks for graphing.
X-Git-Tag: release/2.11.16-1^2~4
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=0c269f6f2987ca62acef20b669dc157ce75931f1;p=lilypond.git

New hooks for graphing.
---

diff --git a/lily/grob-property.cc b/lily/grob-property.cc
index 1473157209..f89d42194d 100644
--- a/lily/grob-property.cc
+++ b/lily/grob-property.cc
@@ -22,6 +22,7 @@
 
 #ifndef NDEBUG
 static SCM modification_callback = SCM_EOL;
+static SCM cache_callback = SCM_EOL;
 
 LY_DEFINE (ly_set_grob_modification_callback, "ly:set-grob-modification-callback",
 	   1, 0, 0, (SCM cb),
@@ -40,6 +41,22 @@ LY_DEFINE (ly_set_grob_modification_callback, "ly:set-grob-modification-callback
   return SCM_UNSPECIFIED;
 }
 
+LY_DEFINE (ly_set_property_cache_callback, "ly:set-property-cache-callback",
+	   1, 0, 0, (SCM cb),
+	   "Specify a procedure that will be called whenever lilypond calculates "
+	   "a callback function and caches the result. The callback will "
+	   "receive as arguments "
+	   "the grob whose property it is, "
+	   "the name of the property, "
+	   "the name of the callback that calculated the property and "
+	   "the new (cached) value of the property.")
+{
+  LY_ASSERT_TYPE (ly_is_procedure, cb, 1);
+  
+  cache_callback = cb;
+  return SCM_UNSPECIFIED;
+}
+
 void
 Grob::instrumented_set_property (SCM sym, SCM v,
 				 char const *file,
@@ -195,7 +212,18 @@ Grob::try_callback_on_alist (SCM *alist, SCM sym, SCM proc)
 	*alist = scm_assq_remove_x (*alist, marker);
     }
   else
-    internal_set_value_on_alist (alist, sym, value);
+    {
+#ifndef NDEBUG
+      if (ly_is_procedure (cache_callback))
+	scm_apply_0 (cache_callback,
+		     scm_list_n (self_scm (),
+				 sym,
+				 proc,
+				 value,
+				 SCM_UNDEFINED));
+#endif
+      internal_set_value_on_alist (alist, sym, value);
+    }
   
   return value;
 }
diff --git a/ly/graphviz.ly b/ly/graphviz.ly
index 097805337f..71956d7b02 100644
--- a/ly/graphviz.ly
+++ b/ly/graphviz.ly
@@ -16,6 +16,9 @@
 #(define file-line-whitelist
   '())
 
+#(define (blacklist-symbol sym)
+  (set! sym-blacklist (cons sym sym-blacklist)))
+
 #(define (whitelist-symbol sym)
   (set! sym-whitelist (cons sym sym-whitelist)))
 
@@ -37,21 +40,33 @@
      (not (memq prop sym-blacklist))
      (not (member file-line file-line-blacklist))))))
 
+#(define (grob-event-node grob label cluster)
+  (let ((node-id (add-node graph label cluster))
+	(prev (assv grob last-grob-action)))
+   (if (pair? prev)
+       (add-edge graph (cdr prev) node-id))
+   (set! last-grob-action (assv-set! last-grob-action grob node-id))))
+
+#(define (truncate-value val)
+  (let ((val-str (format "~a" val)))
+   (string-take val-str (min 50 (string-length val-str)))))
+
 #(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))))
+  (let* ((val-str (truncate-value val))
 	 (label (format "~a\\n~a:~a\\n~a <- ~a" grob file line prop val-str)))
    (if (relevant? grob file line prop)
-    (let ((node-id (add-node graph label file)))
-     (if (pair? prev)
-      (add-edge graph (cdr prev) node-id))
-     (set! last-grob-action (assv-set! last-grob-action grob node-id))))))
+       (grob-event-node grob label file))))
+
+#(define (grob-cache grob prop callback value)
+  (let* ((val-str (truncate-value value))
+	 (label (format "caching ~a.~a\\n~a -> ~a" grob prop callback value)))
+   (if (relevant? grob #f #f prop)
+       (grob-event-node grob label #f))))
 
 #(define (grob-create grob file line func)
-  (let* ((label (format "~a\\n~a:~a" grob file line))
-	 (node-id (add-node graph label file)))
-   (set! last-grob-action (assv-set! last-grob-action grob node-id))))
+  (let ((label (format "~a\\n~a:~a" grob file line)))
+   (grob-event-node grob label file)))
 
 #(ly:set-grob-modification-callback grob-mod)
+#(ly:set-property-cache-callback grob-cache)
 %#(ly:set-grob-creation-callback grob-create)