]> git.donarmstrong.com Git - lilypond.git/blobdiff - scm/stencil.scm
Fix some bugs in the dynamic engraver and PostScript backend
[lilypond.git] / scm / stencil.scm
index 541b4bf28e8677830344f111676aa18bcc225257..01694195714c8e3cbfbb3ac5c33f155b5c247971 100644 (file)
@@ -19,7 +19,9 @@
    ((null? stils) empty-stencil)
    ((null? (cdr stils)) (car stils))
    (else (ly:stencil-combine-at-edge
-         (car stils) axis dir (stack-stencils-padding-list axis dir (cdr padding) (cdr stils))
+         (car stils)
+         axis dir
+         (stack-stencils-padding-list axis dir (cdr padding) (cdr stils))
          (car padding)))))
 
 (define-public (centered-stencil stencil)
@@ -246,7 +248,10 @@ encloses the contents.
          'embedded-ps
          (string-append
           (format
-          "BeginEPSF
+          "
+gsave
+currentpoint translate
+BeginEPSF
 ~a ~a scale
 %%BeginDocument: ~a
 "         factor factor
@@ -254,10 +259,129 @@ encloses the contents.
           )
           contents
           "%%EndDocument
-EndEPSF"))
+EndEPSF
+grestore
+"))
        
         (cons (list-ref scaled-bbox 0) (list-ref scaled-bbox 2))
         (cons (list-ref scaled-bbox 1) (list-ref scaled-bbox 3)))
        
        (ly:make-stencil "" '(0 . 0) '(0 . 0)))
     ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; output signatures.
+
+(define-public (write-system-signatures basename paper-systems count)
+  (if (pair? paper-systems)
+      (begin
+       (let*
+           ((outname (format "~a-~a.signature" basename count)) )
+            
+         (ly:message "Writing ~a" outname)
+         (write-system-signature outname (car paper-systems))
+         (write-system-signatures basename (cdr paper-systems) (1+ count))))))
+
+
+(define-public (write-system-signature filename paper-system)
+  (define (float? x)
+    (and (number? x) (inexact? x)))
+
+  (define system-grob
+    (paper-system-system-grob paper-system))
+  
+  (define output (open-output-file filename))
+  
+  (define (strip-floats expr)
+    "Replace floats by #f"
+    (cond
+     ((float? expr) #f)
+     ((ly:font-metric? expr) (ly:font-name expr))
+     ((pair? expr) (cons (strip-floats (car expr))
+                        (strip-floats (cdr expr))))
+     (else expr)))
+
+  (define (fold-false-pairs expr)
+    "Try to remove lists of #f as much as possible."
+    (if (pair? expr)
+       (let*
+           ((first (car expr))
+            (rest (fold-false-pairs (cdr expr))))
+
+         (if first
+             (cons (fold-false-pairs first) rest)
+             rest))
+       expr))
+  
+  (define (music-cause grob)
+    (let*
+       ((cause (ly:grob-property  grob 'cause)))
+      
+      (cond
+       ((ly:music? cause) cause)
+       ((ly:grob? cause) (music-cause cause))
+       (else #f))))
+
+  (define (pythonic-string expr)
+    "escape quotes and slashes for python consumption"
+    (regexp-substitute/global #f "([\\\\'\"])" (format "~a" expr) 'pre "\\" 1 'post))
+
+  (define (pythonic-pair expr)
+    (format "(~a,~a)"
+           (car expr) (cdr expr)))
+                   
+  (define (found-grob expr)
+    (let*
+       ((grob (car expr))
+        (rest (cdr expr))
+        (collected '())
+        (cause (music-cause grob))
+        (input (if (ly:music? cause) (ly:music-property cause 'origin) #f))
+        (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
+
+        (x-ext (ly:grob-extent grob system-grob X))
+        (y-ext (ly:grob-extent grob system-grob Y))
+        )
+
+      (interpret-for-signature #f (lambda (e)
+                                   (set! collected (cons e collected)))
+                              rest)
+
+      (format output
+             "['~a', '~a', ~a, ~a, '~a'],\n"
+             (cdr (assq 'name (ly:grob-property grob 'meta) ))
+             (pythonic-string location)
+             (pythonic-pair (if (interval-empty? x-ext) '(0 . 0) x-ext))
+             (pythonic-pair (if (interval-empty? y-ext) '(0 . 0) y-ext))
+             (pythonic-string collected))
+      ))
+
+  (define (interpret-for-signature escape collect expr)
+    (define (interpret expr)
+      (let*
+         ((head (if (pair? expr)
+                    (car expr)
+                    #f)))
+
+       (cond
+        ((eq? head 'grob-cause) (escape (cdr expr)))
+        ((eq? head 'color) (interpret (caddr expr)))
+        ((eq? head 'rotate-stencil) (interpret (caddr expr)))
+        ((eq? head 'translate-stencil) (interpret (caddr expr)))
+        ((eq? head 'combine-stencil)
+         (for-each (lambda (e) (interpret e))  (cdr expr)))
+        (else
+         (collect (fold-false-pairs (strip-floats expr))))
+        
+        )))
+
+    (interpret expr))
+
+  (if (ly:grob? system-grob)
+      (begin
+       (display (format "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
+                output)
+       (interpret-for-signature found-grob (lambda (x) #f)
+                                (ly:stencil-expr
+                                 (paper-system-stencil paper-system))))))
+