Merge ssh+git://hanwen@repo.or.cz/srv/git/lilypond into master-hanwen

[lilypond.git] / scm / framework-ps.scm

diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm
index 957ef0d2da1fd4c62f24b84213451b4e72b8ff91..e17c3d478024cd75757ed71867e14d42bbdbe888 100644 (file)
--- a/scm/framework-ps.scm
+++ b/scm/framework-ps.scm
@@ -409,7 +409,6 @@
             (sort (apply append all-font-names)
                   (lambda (x y) (string<? (cadr x) (cadr y))))))
 
-
           (font-loader (if (ly:get-option 'gs-load-fonts)
                            load-font-via-GS
                            load-font))
@@ -483,11 +482,12 @@
                         (ly:output-formats))))
 
 (define-public (dump-stencil-as-EPS paper dump-me filename
-                                   load-fonts
-                                   )
+                                   load-fonts)
+  
   (let*
       ((xext (ly:stencil-extent dump-me X))
        (yext (ly:stencil-extent dump-me Y))
+       (left-overshoot (ly:get-option 'eps-box-padding))
        (bbox
        (map
         (lambda (x)
@@ -495,19 +495,20 @@
                     ;; FIXME: huh?
                   (equal? (format #f "~S" x) "+#.#")
                   (equal? (format #f "~S" x) "-#.#"))
-              0.0 x))))
+              0.0 x))
 
           ;; the left-overshoot is to make sure that
           ;; bar numbers  stick out of margin uniformly.
           ;;
           (list
            
-           (if (ly:get-option 'pad-eps-boxes) 
+           (if (number? left-overshoot)
                (min left-overshoot (car xext))
                (car xext))
-           (car yext) (cdr xext) (cdr yext)))
+           (car yext) (cdr xext) (cdr yext)))))
 
-       (dump-stencil-as-EPS-with-bbox paper dump-me filename load-fonts bbox)))
+       (dump-stencil-as-EPS-with-bbox paper dump-me filename load-fonts bbox)
+       ))
         
           
 (define-public (dump-stencil-as-EPS-with-bbox paper dump-me filename
@@ -535,10 +536,7 @@
                     (open-file (format "~a.eps" filename) "wb")
                     "ps"))
 
-        (left-overshoot -3)
         (port (ly:outputter-port outputter))
-
-        
         (rounded-bbox (to-bp-box bbox))
         (port (ly:outputter-port outputter))
         (header (eps-header paper rounded-bbox load-fonts)))
@@ -552,35 +550,39 @@
 
 
 
-(define (clip-system-EPS basename paper paper-system clip-regions
-                        do-pdf)
+(define (clip-systems-to-region
+        basename paper systems region
+        do-pdf)
 
   (let*
-      ((system-grob (paper-system-system-grob paper-system))
-       (extents-region-pairs
+      ((extents-system-pairs
        (filtered-map
-        (lambda (region)
+        (lambda (paper-system)
           (let*
-              ((x-ext (system-clipped-x-extent system-grob region)))
+              ((x-ext (system-clipped-x-extent
+                       (paper-system-system-grob paper-system)
+                       region)))
 
             (if x-ext
-                (cons x-ext region)
+                (cons x-ext paper-system)
                 #f)))
         
-        clip-regions)))
+        systems))
+       (count 0))
     
     (for-each
-     (lambda (ext-region-pair)
+     (lambda (ext-system-pair)
        (let*
-          ((xext (car ext-region-pair))
-           (region (cdr ext-region-pair))
+          ((xext (car ext-system-pair))
+           (paper-system (cdr ext-system-pair))
            (yext (paper-system-extent paper-system Y))
            (bbox (list (car  xext) (car yext)
                        (cdr xext) (cdr yext)))
-           (filename (format "~a-clip-~a-~a" basename
-                             (rhythmic-location->file-string (car region))
-                             (rhythmic-location->file-string (cdr region)))))
+           (filename (if (< 0 count)
+                         (format "~a-~a" basename count)
+                         basename)))
 
+        (set! count (1+ count))
         (dump-stencil-as-EPS-with-bbox
          paper
          (paper-system-stencil paper-system)
@@ -592,32 +594,65 @@
             (postscript->pdf  0 0  (format "~a.eps" filename)))
         ))
 
-     extents-region-pairs)
-    
-    
+     extents-system-pairs)
     ))
 
+
 (define (clip-system-EPSes basename paper-book)
+  (define do-pdf (member  "pdf" (ly:output-formats)))
+
+  (define (clip-score-systems basename systems)
+    (let*
+       ((layout (ly:grob-layout (paper-system-system-grob (car systems))))
+        (regions (ly:output-def-lookup layout 'clip-regions)))
+      
+      (for-each
+       (lambda (region)
+        (clip-systems-to-region
+         (format "~a-from-~a-to-~a-clip"
+                 basename
+                 (rhythmic-location->file-string (car region))
+                 (rhythmic-location->file-string (cdr region)))
+         layout systems region
+         do-pdf))
+       
+       regions)))
+  
+
+  ;; partition in system lists sharing their layout blocks
   (let*
-      ((paper-def  (ly:paper-book-paper paper-book))
-       (do-pdf (member  "pdf" (ly:output-formats)))
+      ((systems (ly:paper-book-systems paper-book))
+       (count 0)
+       (score-system-list '()))
 
-       (regions
-       (ly:output-def-lookup paper-def
-                             'clip-regions))
-       (count 1)
-       (systems
-       (ly:paper-book-systems paper-book)))
+    (fold 
+     (lambda (system last-system)
+    
+       
+       (if (not (and last-system
+                    (equal? (paper-system-layout last-system)
+                            (paper-system-layout system))))
+          (set! score-system-list (cons '() score-system-list)))
+       
+       (if (paper-system-layout system)
+          (set-car! score-system-list (cons system (car score-system-list))))
+
+       ;; pass value.
+       system)
+
+     #f 
+     systems)
 
     (for-each
-     (lambda (system)
-       (clip-system-EPS
-       (format "~a-system-~a" basename count) paper-def system regions
-       do-pdf)
-       (set! count (1+ count))
-
-       )
-     systems)))
+     (lambda (system-list)
+       (clip-score-systems
+       (if (> count 0)
+           (format "~a-~a" basename count)
+           basename)
+       system-list))
+
+     score-system-list)))
+
 
 (define-public (output-preview-framework basename book scopes fields)
   (let* ((paper (ly:paper-book-paper book))