From: Han-Wen Nienhuys <hanwen@xs4all.nl>
Date: Thu, 29 Mar 2007 19:23:18 +0000 (-0300)
Subject: clean up graphviz for inclusion in regtest.
X-Git-Tag: release/2.11.22-1~5^2
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=a982b5419c9be31b649ce847ca6fcf60a0823883;p=lilypond.git

clean up graphviz for inclusion in regtest.
---

diff --git a/input/regression/graphviz.ly b/input/regression/graphviz.ly
new file mode 100644
index 0000000000..1e00e99581
--- /dev/null
+++ b/input/regression/graphviz.ly
@@ -0,0 +1,27 @@
+\header {
+  texidoc = "The graphviz feature draws dependency graphs for grob properties."
+
+  }
+
+\version "2.11.21"
+\include "graphviz-init.ly"
+
+#(whitelist-grob 'NoteHead)
+#(whitelist-grob 'Stem)
+#(whitelist-grob "NoteHead")
+#(whitelist-grob "Stem")
+
+#(map whitelist-symbol '(stencil style duration-log
+			 stem-attachment end-position staff-position
+			 glyph-name direction))
+
+
+\book { \score {
+  c'4
+} }
+
+
+#(graph-write graph (current-error-port))
+#(ly:set-grob-modification-callback #f)
+#(ly:set-property-cache-callback #f)
+
diff --git a/lily/grob-property.cc b/lily/grob-property.cc
index 4034eb8297..e4dad5f235 100644
--- a/lily/grob-property.cc
+++ b/lily/grob-property.cc
@@ -38,6 +38,13 @@ print_property_callback_stack ()
 static SCM modification_callback = SCM_EOL;
 static SCM cache_callback = SCM_EOL;
 
+
+/*
+
+FIXME: this should use ly:set-option interface instead.
+
+*/
+
 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 "
@@ -49,9 +56,7 @@ LY_DEFINE (ly_set_grob_modification_callback, "ly:set-grob-modification-callback
 	   "the property to be changed and "
 	   "the new value for the property.")
 {
-  LY_ASSERT_TYPE (ly_is_procedure, cb, 1);
-
-  modification_callback = cb;
+  modification_callback =  (ly_is_procedure (cb)) ? cb : SCM_BOOL_F;
   return SCM_UNSPECIFIED;
 }
 
@@ -65,13 +70,12 @@ LY_DEFINE (ly_set_property_cache_callback, "ly:set-property-cache-callback",
 	   "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;
+  cache_callback =  (ly_is_procedure (cb)) ? cb : SCM_BOOL_F;
   return SCM_UNSPECIFIED;
 }
 #endif
 
+
 void
 Grob::instrumented_set_property (SCM sym, SCM v,
 				 char const *file,
diff --git a/ly/graphviz-init.ly b/ly/graphviz-init.ly
new file mode 100644
index 0000000000..3623d0ace8
--- /dev/null
+++ b/ly/graphviz-init.ly
@@ -0,0 +1,81 @@
+\version "2.11.15"
+
+#(use-modules (scm graphviz))
+
+#(define last-grob-action '())
+
+#(define sym-blacklist '())
+#(define sym-whitelist '())
+
+#(define file-line-blacklist '())
+#(define file-line-whitelist '())
+
+#(define grob-blacklist '())
+#(define grob-whitelist '())
+
+#(define (blacklist-symbol sym)
+  (set! sym-blacklist (cons sym sym-blacklist)))
+
+#(define (whitelist-symbol sym)
+  (set! sym-whitelist (cons sym sym-whitelist)))
+
+#(define (whitelist-grob str)
+  (set! grob-whitelist (cons str grob-whitelist)))
+
+#(define graph (make-graph (format "~a.dot" (ly:parser-output-name parser))))
+
+#(define (grob-name g)
+  (let* ((meta (ly:grob-property g 'meta))
+	 (name-pair (assq 'name meta)))
+   (if (pair? name-pair)
+       (cdr name-pair)
+       #f)))
+
+% 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) (length grob-whitelist))
+     (memq prop sym-whitelist)
+     (memq (grob-name grob) grob-whitelist)
+     (member file-line file-line-whitelist))
+    (and
+     (not (memq prop sym-blacklist))
+     (not (memq (grob-name grob) grob-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* ((val-str (truncate-value val))
+	 (label (format "~a\\n~a:~a\\n~a <- ~a" (grob-name grob) file line prop val-str)))
+   (if (relevant? grob file line prop)
+       (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-name 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-name 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)
diff --git a/ly/graphviz.ly b/ly/graphviz.ly
deleted file mode 100644
index aafd30d72d..0000000000
--- a/ly/graphviz.ly
+++ /dev/null
@@ -1,81 +0,0 @@
-\version "2.11.15"
-
-#(use-modules (scm graphviz))
-
-#(define last-grob-action '())
-
-#(define sym-blacklist '())
-#(define sym-whitelist '())
-
-#(define file-line-blacklist '())
-#(define file-line-whitelist '())
-
-#(define grob-blacklist '())
-#(define grob-whitelist '())
-
-#(define (blacklist-symbol sym)
-  (set! sym-blacklist (cons sym sym-blacklist)))
-
-#(define (whitelist-symbol sym)
-  (set! sym-whitelist (cons sym sym-whitelist)))
-
-#(define (whitelist-grob str)
-  (set! grob-whitelist (cons str grob-whitelist)))
-
-#(define graph (make-graph "graph.dot"))
-
-#(define (grob-name g)
-  (let* ((meta (ly:grob-property g 'meta))
-	 (name-pair (assq 'name meta)))
-   (if (pair? name-pair)
-       (cdr name-pair)
-       #f)))
-
-% 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) (length grob-whitelist))
-     (memq prop sym-whitelist)
-     (memq (grob-name grob) grob-whitelist)
-     (member file-line file-line-whitelist))
-    (and
-     (not (memq prop sym-blacklist))
-     (not (memq (grob-name grob) grob-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* ((val-str (truncate-value val))
-	 (label (format "~a\\n~a:~a\\n~a <- ~a" (grob-name grob) file line prop val-str)))
-   (if (relevant? grob file line prop)
-       (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-name 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-name 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)
diff --git a/scm/graphviz.scm b/scm/graphviz.scm
index 8ad3600ffa..f5db38b7a8 100644
--- a/scm/graphviz.scm
+++ b/scm/graphviz.scm
@@ -7,14 +7,17 @@
 
 (define-module (scm graphviz)
   #:use-module (lily)
-  #:export (make-graph add-node add-edge add-cluster))
+  #:export
+  (make-graph add-node add-edge add-cluster
+	      graph-write
+	      ))
 
 (define (make-graph filename)
-  (let ((empty-graph (list->vector (list filename '() '() '()))))
-    (ly:atexit write-graph (list empty-graph))
-    empty-graph))
+   #(() () () ()))
 
-(define (filename g) (vector-ref g 0))
+
+;; fixme: use structs/records.
+;; fixme add & use setters.
 (define (nodes g) (vector-ref g 1))
 (define (edges g) (vector-ref g 2))
 (define (clusters g) (vector-ref g 3))
@@ -41,12 +44,11 @@
 (define (add-edge graph node1 node2)
   (vector-set! graph 2 (cons `(,node1 . ,node2) (edges graph))))
 
-(define (write-graph graph)
-  (let ((out (open-file (filename graph) "w"))
-	(ns (nodes graph))
+(define (graph-write graph out)
+  (let ((ns (nodes graph))
 	(es (edges graph))
 	(cs (clusters graph)))
-    (ly:message (format "writing graph ~s..." (filename graph)))
+    (ly:message (format (_ "Writing graph `~a'...") (port-filename out)))
     (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)