X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-ps.scm;h=e17c3d478024cd75757ed71867e14d42bbdbe888;hb=c750e9b0ef41267a9b6be0300c880047f48b9353;hp=53d6447c98484e36a8b27a9b4f115fecea2d683c;hpb=1afc7f48df3385e078d5ec99214559b4b09eccd9;p=lilypond.git

diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm
index 53d6447c98..e17c3d4780 100644
--- a/scm/framework-ps.scm
+++ b/scm/framework-ps.scm
@@ -2,7 +2,7 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;;
-;;;; (c) 2004--2006 Han-Wen Nienhuys <hanwen@cs.uu.nl>
+;;;; (c) 2004--2006 Han-Wen Nienhuys <hanwen@xs4all.nl>
 
 (define-module (scm framework-ps))
 
@@ -16,6 +16,7 @@
 	     (scm paper-system)
 	     (srfi srfi-1)
 	     (srfi srfi-13)
+	     (scm clip-region)
 	     (lily))
 
 
@@ -408,8 +409,7 @@
 	     (sort (apply append all-font-names)
 		   (lambda (x y) (string<? (cadr x) (cadr y))))))
 
-
-	   (font-loader (if (ly:get-option 'gs-font-load)
+	   (font-loader (if (ly:get-option 'gs-load-fonts)
 			    load-font-via-GS
 			    load-font))
 			 
@@ -455,17 +455,19 @@
 	 (page-count (length page-stencils))
 	 (port (ly:outputter-port outputter)))
 
+
+    (if (ly:get-option 'clip-systems)
+	(clip-system-EPSes basename book))
+
     (if (ly:get-option 'dump-signatures)
 	(write-system-signatures basename (ly:paper-book-systems book) 1))
   
     (output-scopes scopes fields basename)
     (display (file-header paper page-count #t) port)
-
     
     ;; don't do BeginDefaults PageMedia: A4 
     ;; not necessary and wrong
     
-
     (write-preamble paper #t port)
 
     (for-each
@@ -479,7 +481,39 @@
     (postprocess-output book framework-ps-module filename
 			 (ly:output-formats))))
 
-(define-public (dump-stencil-as-EPS paper dump-me filename load-fonts?)
+(define-public (dump-stencil-as-EPS paper dump-me filename
+				    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)
+	   (if (or (nan? x) (inf? x)
+		     ;; FIXME: huh?
+		   (equal? (format #f "~S" x) "+#.#")
+		   (equal? (format #f "~S" x) "-#.#"))
+	       0.0 x))
+
+	   ;; the left-overshoot is to make sure that
+	   ;; bar numbers  stick out of margin uniformly.
+	   ;;
+	   (list
+	    
+	    (if (number? left-overshoot)
+		(min left-overshoot (car xext))
+		(car xext))
+	    (car yext) (cdr xext) (cdr yext)))))
+
+       (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
+					      load-fonts
+					      bbox)
   (define (to-bp-box mmbox)
     (let* ((scale (ly:output-def-lookup paper 'output-scale))
 	   (box (map
@@ -502,40 +536,124 @@
 		     (open-file (format "~a.eps" filename) "wb")
 		     "ps"))
 
-	 (left-overshoot -3)
 	 (port (ly:outputter-port outputter))
-	 (xext (ly:stencil-extent dump-me X))
-	 (yext (ly:stencil-extent dump-me Y))
-	 (bbox
-	  (map
-	   (lambda (x)
-	     (if (or (nan? x) (inf? x)
-		     ;; FIXME: huh?
-		     (equal? (format #f "~S" x) "+#.#")
-		     (equal? (format #f "~S" x) "-#.#"))
-		 0.0 x))
-
-	   ;; the left-overshoot is to make sure that
-	   ;; bar numbers  stick out of margin uniformly.
-	   ;;
-	   (list
-
-	    (if (ly:get-option 'eps-pad-boxes) 
-		(min left-overshoot (car xext))
-		(car xext))
-	    (car yext) (cdr xext) (cdr yext))))
-	 
 	 (rounded-bbox (to-bp-box bbox))
 	 (port (ly:outputter-port outputter))
-	 (header (eps-header paper rounded-bbox load-fonts?)))
+	 (header (eps-header paper rounded-bbox load-fonts)))
 
     (display header port)
-    (write-preamble paper load-fonts? port)
+    (write-preamble paper load-fonts port)
     (display "gsave set-ps-scale-to-lily-scale \n" port)
     (ly:outputter-dump-stencil outputter dump-me)
     (display "stroke grestore\n%%Trailer\n%%EOF\n" port)
     (ly:outputter-close outputter)))
 
+
+
+(define (clip-systems-to-region
+	 basename paper systems region
+	 do-pdf)
+
+  (let*
+      ((extents-system-pairs
+	(filtered-map
+	 (lambda (paper-system)
+	   (let*
+	       ((x-ext (system-clipped-x-extent
+			(paper-system-system-grob paper-system)
+			region)))
+
+	     (if x-ext
+		 (cons x-ext paper-system)
+		 #f)))
+	 
+	 systems))
+       (count 0))
+    
+    (for-each
+     (lambda (ext-system-pair)
+       (let*
+	   ((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 (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)
+	  filename
+	  (ly:get-option 'include-eps-fonts)
+	  bbox)
+
+	 (if do-pdf
+	     (postscript->pdf  0 0  (format "~a.eps" filename)))
+	 ))
+
+     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*
+      ((systems (ly:paper-book-systems paper-book))
+       (count 0)
+       (score-system-list '()))
+
+    (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-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))
 	 (systems (ly:paper-book-systems book))
@@ -544,7 +662,7 @@
 
     ;; skip booktitles.
     (if (and
-	 (not (ly:get-option 'preview-include-book-title))
+	 (not (ly:get-option 'include-book-title-preview))
 	 (pair? systems)
 	 (ly:prob-property (car systems) 'is-book-title #f))
 
@@ -591,6 +709,7 @@
 	(postprocess-output book framework-ps-module
 			    (format "~a.preview.eps" basename)
 			     (ly:output-formats)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-public (convert-to-pdf book name)