X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-ps.scm;h=443d3aeeaffd0d4358a79c3b18d79d982515e760;hb=f27a0658b549dc41903280c62388e76df87523f0;hp=4c535726067ad0348aaee33d769536061b9241ff;hpb=3b2376c6828136cdbc078015c0b9bee26bffb448;p=lilypond.git

diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm
index 4c53572606..443d3aeeaf 100644
--- a/scm/framework-ps.scm
+++ b/scm/framework-ps.scm
@@ -6,6 +6,8 @@
 
 (define-module (scm framework-ps))
 
+;;; this is still too big a mess.
+
 (use-modules (ice-9 regex)
 	     (ice-9 string-fun)
 	     (ice-9 format)
@@ -14,6 +16,8 @@
 	     (srfi srfi-13)
 	     (lily))
 
+(define framework-ps-module (current-module))
+
 (define (stderr string . rest)
   (apply format (cons (current-error-port) (cons string rest)))
   (force-output (current-error-port)))
@@ -37,70 +41,16 @@
    (equal? (substring fontname 0 2) "cm")
    (equal? (substring fontname 0 2) "ec")))
 
-(define (ps-embed-cff body font-set-name version)
-  (let* ((binary-data 
-	  (string-append
-	   (format "/~a ~s StartData " font-set-name (string-length body))
-	   body)))
-    
-    (string-append
-     (format
-      "%!PS-Adobe-3.0 Resource-FontSet
-%%DocumentNeededResources: ProcSet (FontSetInit)
-%%EndComments
-%%IncludeResource: ProcSet (FontSetInit)
-%%BeginResource: FontSet (~a)
-%%Title: (FontSet/~a)
-%%Version: ~s
-/FontSetInit /ProcSet findresource begin
-%%BeginData: ~s Binary Bytes
-"
-      font-set-name font-set-name version (string-length binary-data))
-     binary-data
-     "\n%%EndData
-%%EndResource
-%%EOF
-")))
+(define (ps-embed-pfa body font-name version)
+  (string-append
+   (format
+    "%%BeginResource: font ~a
+~a
+%%EndResource"
+    font-name body)))
 
 
-(define (load-fonts paper)
-  (let* ((fonts (ly:paper-fonts paper))
-	 (all-font-names
-	  (map
-	   (lambda (font)
-	     (if (string? (ly:font-file-name font))
-		 (list (ly:font-file-name font))
-		 (ly:font-sub-fonts font)))
-
-	   fonts))
-	 (font-names
-	  (uniq-list
-	   (sort (apply append all-font-names) string<?)))
-	 (pfas (map
-		(lambda (x)
-		  (let* ((bare-file-name (ly:find-file x))
-			 (cffname (string-append x ".cff"))
-			 (aname (string-append x ".pfa"))
-			 (bname (string-append x ".pfb"))
-			 (cff-file-name (ly:find-file cffname))
-			 (a-file-name (ly:kpathsea-find-file aname))
-			 (b-file-name (ly:kpathsea-find-file bname)))
-		    (cond
-		     (bare-file-name (if (string-match "\\.pfb" bare-file-name)
-					 (ly:pfb->pfa bare-file-name)
-					 (ly:gulp-file bare-file-name)))
-		     (cff-file-name (ps-embed-cff (ly:gulp-file cff-file-name) x 0))
-		     (a-file-name (ly:gulp-file a-file-name))
-		     (b-file-name (ly:pfb->pfa b-file-name))
-		     (else
-		      (ly:warn "cannot find CFF/PFA/PFB font ~S" x)
-		      ""))))
-		(filter string? font-names))))
-    
-    (string-join pfas "\n")))
-
 (define (define-fonts paper)
-  
   (define font-list (ly:paper-fonts paper))
   (define (define-font command fontname scaling)
     (string-append
@@ -110,14 +60,14 @@
   (define (standard-tex-font? x)
     (or (equal? (substring x 0 2) "ms")
 	(equal? (substring x 0 2) "cm")))
-  
+
   (define (font-load-command font)
     (let* ((specced-font-name (ly:font-name font))
 	   (fontname (if specced-font-name
 			 specced-font-name
 			 (ly:font-file-name font)))
 	   (command (ps-font-command font))
-	   
+
 	   ;; FIXME -- see (ps-font-command )
 	   (plain (ps-font-command font #f))
 	   (designsize (ly:font-design-size font))
@@ -125,13 +75,12 @@
 	   (ops (ly:output-def-lookup paper 'outputscale))
 	   (scaling (* ops magnification designsize)))
 
-      
       ;; Bluesky pfbs have UPCASE names (sigh.)
-      ;;
+      ;; FIXME - don't support Bluesky?
       (if (standard-tex-font? fontname)
 	  (set! fontname (string-upcase fontname)))
-      
-      
+      (if (equal? fontname "unknown")
+	  (display (list font fontname)))
       (define-font plain fontname scaling)))
 
   (apply string-append
@@ -153,21 +102,23 @@
   (define (output-entry ps-key ly-key)
     (string-append
      "/" ps-key " "
-     (value->string (ly:output-def-lookup layout ly-key)) " def \n"))
+     (value->string (ly:output-def-lookup layout ly-key)) " def\n"))
 
   (string-append
-   "/lily-output-units " (number->string mm-to-bigpoint) " def %% milimeter \n"
+   "/lily-output-units "
+     (number->string mm-to-bigpoint)
+     " def %% millimeter\n"
    (output-entry "staff-line-thickness" 'linethickness)
    (output-entry "line-width" 'linewidth)
    (output-entry "paper-size" 'papersizename)
    (output-entry "staff-height" 'staffheight)	;junkme.
    "/output-scale "
-   (number->string (ly:output-def-lookup layout 'outputscale))
-   " lily-output-units mul def \n"
+     (number->string (ly:output-def-lookup layout 'outputscale))
+     " def\n"
    (output-entry "page-height" 'vsize)
    (output-entry "page-width" 'hsize)))
 
-(define (dump-page outputter page page-number page-count landscape?) 
+(define (dump-page outputter page page-number page-count landscape?)
   (ly:outputter-dump-string outputter
 			    (string-append
 			     "%%Page: "
@@ -185,8 +136,19 @@
   (ly:outputter-dump-stencil outputter page)
   (ly:outputter-dump-string outputter "} stop-system \nshowpage\n"))
 
-(define (eps-header paper bbox)
-  (string-append "%!PS-Adobe-2.0 EPSF-2.0\n"
+(define (supplies-or-needs paper load-fonts?)
+  (let* ((fonts (ly:paper-fonts paper)))
+    (apply string-append
+	   (map (lambda (f)
+		  (format
+		   (if load-fonts?
+		    "%%DocumentSuppliedResources: font ~a\n"
+		    "%%DocumentNeededResources: font ~a\n")
+		   (ly:font-name f)))
+		fonts))))
+
+(define (eps-header paper bbox load-fonts?)
+    (string-append "%!PS-Adobe-2.0 EPSF-2.0\n"
 		 "%%Creator: creator time-stamp\n"
 		 "%%BoundingBox: "
 		 (string-join (map ly:number->string bbox) " ") "\n"
@@ -194,9 +156,10 @@
 		 (if (eq? (ly:output-def-lookup paper 'landscape) #t)
 		     "Landscape\n"
 		     "Portrait\n")
+		 (supplies-or-needs paper load-fonts?)
 		 "%%EndComments\n"))
 
-(define (page-header paper page-count)
+(define (page-header paper page-count load-fonts?)
   (string-append "%!PS-Adobe-3.0\n"
 		 "%%Creator: creator time-stamp\n"
 		 "%%Pages: " (number->string page-count) "\n"
@@ -206,47 +169,119 @@
 		     "Landscape\n"
 		     "Portrait\n")
 		 "%%DocumentPaperSizes: "
-		 (ly:output-def-lookup paper 'papersizename) "\n"))
+		 (ly:output-def-lookup paper 'papersizename) "\n"
+		 (supplies-or-needs paper load-fonts?)
+		 "%%EndComments\n"))
 
-(define (preamble paper)
-  (list
+(define (procset file-name)
+  (string-append
+   (format
+    "%%BeginResource: procset (~a) 1 0
+~a
+%%EndResource
+"
+    file-name (ly:gulp-file file-name))))
+
+(define (setup paper)
+  (string-append
+   "\n"
+   "%%BeginSetup\n"
+   (define-fonts paper)
    (output-variables paper)
-   (ly:gulp-file "music-drawing-routines.ps")
-   (ly:gulp-file "lilyponddefs.ps")
-   (load-fonts paper)
-   (define-fonts paper)))
+   "init-lilypond-parameters\n"
+   "%%EndSetup\n"))
+
+(define (preamble paper load-fonts?)
+  (define (load-fonts paper)
+    (let* ((fonts (ly:paper-fonts paper))
+	   (all-font-names
+	    (map
+	     (lambda (font)
+	       (if (string? (ly:font-file-name font))
+		   (list (ly:font-file-name font))
+		   (ly:font-sub-fonts font)))
+
+	     fonts))
+	   (font-names
+	    (uniq-list
+	     (sort (apply append all-font-names) string<?)))
+	   (pfas (map
+		  (lambda (x)
+		    (let* ((bare-file-name (ly:find-file x))
+			   (cffname (string-append x ".cff"))
+			   (aname (string-append x ".pfa"))
+			   (bname (string-append x ".pfb"))
+			   (cff-file-name (ly:find-file cffname))
+			   (a-file-name (ly:kpathsea-find-file aname))
+			   (b-file-name (ly:kpathsea-find-file bname)))
+		      (cond
+		       (bare-file-name (if (string-match "\\.pfb" bare-file-name)
+					   (ly:pfb->pfa bare-file-name)
+					   (ly:gulp-file bare-file-name)))
+		       (cff-file-name (ps-embed-cff (ly:gulp-file cff-file-name) x 0))
+		       (a-file-name (ps-embed-pfa (ly:gulp-file a-file-name) x 0))
+		       (b-file-name (ps-embed-pfa (ly:pfb->pfa b-file-name) x 0))
+		       (else
+			(ly:warn "cannot find CFF/PFA/PFB font ~S" x)
+			""))))
+		  (filter string? font-names))))
+
+      (string-join pfas "\n")))
 
-(define-public (output-framework outputter book scopes fields basename)
-  (let* ((paper (ly:paper-book-paper book))
+  (list
+   (procset "music-drawing-routines.ps")
+   (procset "lilyponddefs.ps")
+   (if load-fonts?
+       (load-fonts paper)
+       "")
+   
+   (setup paper)))
+
+(define-public (output-framework basename book scopes fields)
+  (let* ((filename (format "~a.ps" basename))
+	 (outputter  (ly:make-paper-outputter filename
+					      (ly:output-backend)))
+	 (paper (ly:paper-book-paper book))
 	 (pages (ly:paper-book-pages book))
 	 (landscape? (eq? (ly:output-def-lookup paper 'landscape) #t))
 	 (page-number (1- (ly:output-def-lookup paper 'firstpagenumber)))
 	 (page-count (length pages)))
-    
+
     (for-each
      (lambda (x)
        (ly:outputter-dump-string outputter x))
      (cons
-      (page-header paper page-count)
-      (preamble paper)))
-    
+      (page-header paper page-count #t)
+      (preamble paper #t)))
+
     (for-each
      (lambda (page)
        (set! page-number (1+ page-number))
        (dump-page outputter page page-number page-count landscape?))
      pages)
-    
-    (ly:outputter-dump-string outputter "%%Trailer\n%%EOF\n")))
 
-(define-public (output-preview-framework outputter book scopes fields basename)
-  (let* ((paper (ly:paper-book-paper book))
+    (ly:outputter-dump-string outputter "%%Trailer\n%%EOF\n")
+        (ly:outputter-close outputter)
+    (postprocess-output book framework-ps-module filename (ly:output-formats))
+))
+
+(if (not (defined? 'nan?))
+    (define (nan? x) #f))
+(if (not (defined? 'inf?))
+    (define (inf? x) #f))
+
+(define-public (output-preview-framework basename book scopes fields )
+  (let* ((filename (format "~a.ps" basename))
+	 (outputter  (ly:make-paper-outputter filename
+					      (ly:output-backend)))
+	 (paper (ly:paper-book-paper book))
 	 (systems (ly:paper-book-systems book))
 	 (scale  (ly:output-def-lookup paper 'outputscale ))
 	 (titles (take-while ly:paper-system-title? systems))
 	 (non-title (find (lambda (x)
 			    (not (ly:paper-system-title? x))) systems))
 	 (dump-me
-	  (stack-stencils Y DOWN 0.0 
+	  (stack-stencils Y DOWN 0.0
 			  (map ly:paper-system-stencil
 			       (append titles (list non-title)))))
 	 (xext (ly:stencil-extent dump-me X))
@@ -257,19 +292,20 @@
 	     (if (or (nan? x) (inf? x))
 		 0.0 x))
 	   (list (car xext) (car yext)
-		 (cdr xext) (cdr yext)))	       ))
-    
+		 (cdr xext) (cdr yext))))
+	 (rounded-bbox
+	  (map
+	   (lambda (x)
+	     (inexact->exact
+	      (round (* x scale mm-to-bigpoint))))))
+	  )
+
     (for-each
      (lambda (x)
        (ly:outputter-dump-string outputter x))
      (cons
-      (eps-header paper
-		  (map
-		   (lambda (x)
-		     (inexact->exact
-		      (round (* x scale mm-to-bigpoint))))
-		   bbox))
-      (preamble paper)))
+      (eps-header paper rounded-bbox #t)
+      (preamble paper #t)))
 
 
     (ly:outputter-dump-string outputter
@@ -278,7 +314,128 @@
 					     "\n"))
 
     (ly:outputter-dump-stencil outputter dump-me)
-    (ly:outputter-dump-string outputter "} stop-system\n%%Trailer\n%%EOF\n")))
+    (ly:outputter-dump-string outputter "} stop-system\n%%Trailer\n%%EOF\n")
+        (ly:outputter-close outputter)
+    (postprocess-output book framework-ps-module filename
+			(ly:output-formats))
+))
+
+
+(define-public (output-classic-framework
+		basename book scopes fields)
+  (define paper (ly:paper-book-paper book))
+  (define (dump-line outputter line)
+    (let*
+	((dump-me (ly:paper-system-stencil line))
+	 (xext (ly:stencil-extent dump-me X))
+	 (yext (ly:stencil-extent dump-me Y))
+	 (scale  (ly:output-def-lookup paper 'outputscale))
+	 (bbox
+	  (map
+	   (lambda (x)
+	     (if (or (nan? x) (inf? x))
+		 0.0 x))
+	   (list (car xext) (car yext)
+		 (cdr xext) (cdr yext))))
+	 (rounded-bbox
+	  (map
+	   (lambda (x)
+	     (inexact->exact
+	      (round (* x scale mm-to-bigpoint)))) bbox))
+	  
+	 (header (eps-header paper rounded-bbox #f)))
+
+      (for-each
+       (lambda (str) (ly:outputter-dump-string outputter str))
+       (cons
+	header
+	(preamble paper #f)))
+
+      (ly:outputter-dump-string outputter
+				(string-append "start-system { "
+					       "set-ps-scale-to-lily-scale "
+					       "\n"))
+
+      (ly:outputter-dump-stencil outputter dump-me)
+      (ly:outputter-dump-string outputter "} stop-system\n%%Trailer\n%%EOF\n")
+      (ly:outputter-close outputter)))
+
+  (define (dump-infinite-page lines)
+    (let*
+	((outputter  (ly:make-paper-outputter (format "~a.eps" basename)
+					      (ly:output-backend)))
+	 (stencils (map ly:paper-system-stencil lines))
+	 (dump-me (stack-stencils Y DOWN 2.0 stencils))
+	 (xext (ly:stencil-extent dump-me X))
+	 (yext (ly:stencil-extent dump-me Y))
+	 (scale  (ly:output-def-lookup paper 'outputscale))
+	 (bbox
+	  (map
+	   (lambda (x)
+	     (if (or (nan? x) (inf? x))
+		 0.0 x))
+	   (list (car xext) (car yext)
+		 (cdr xext) (cdr yext))))
+	 (ps-bbox (map (lambda (x)
+				  (inexact->exact
+				   (round (* x scale mm-to-bigpoint))))
+				bbox))
+	 
+	 (header (eps-header paper ps-bbox #t)))
+
+      (for-each
+       (lambda (str) (ly:outputter-dump-string outputter str))
+       (cons
+	header
+	(preamble paper #t)))
+
+      (ly:outputter-dump-string outputter
+				(string-append "start-system { "
+					       "set-ps-scale-to-lily-scale "
+					       "\n"))
+
+      (ly:outputter-dump-stencil outputter dump-me)
+      (ly:outputter-dump-string outputter "} stop-system\n%%Trailer\n%%EOF\n")
+      (ly:outputter-close outputter)))
+
+  (define (dump-lines lines count)
+    (if (pair? lines)
+	(let*
+	    ((outputter  (ly:make-paper-outputter (format "~a-~a.eps" basename count)
+						  (ly:output-backend)))
+	     (line (car lines))
+	     (rest (cdr lines)))
+	  (dump-line outputter line)
+	  (dump-lines rest (1+ count))
+	  )))
+
+  (let* ((lines (ly:paper-book-systems book))
+	 (tex-system-port (open-output-file (format "~a-systems.tex" basename)))
+	 (texi-system-port (open-output-file (format "~a-systems.texi" basename)))
+	 (last-line (car (last-pair lines)))
+	 (pages (ly:paper-book-pages book))
+	 )
+
+    (dump-lines lines 1)
+    (for-each (lambda (c)
+		(display (format "\\includegraphics{~a-~a.eps}%\n"
+				 basename (1+ c)) tex-system-port)
+		(display (format "@image{~a-~a}%\n"
+				 basename (1+ c)) texi-system-port)
+
+		)
+	      (iota (length lines)))
+
+    (display "@c eof" texi-system-port)
+    (display "% eof" tex-system-port)
+
+    (dump-infinite-page lines))
+
+    (postprocess-output book framework-ps-module (format "~a.eps" basename) (ly:output-formats))
+  )
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-public (convert-to-pdf book name)
   (let* ((defs (ly:paper-book-paper book))