X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fframework-ps.scm;h=c7214da3c597d25c5dcf49210a1f90efe829ab1c;hb=dc9f32df583b0931f0e946b9a7d13dd4983d4701;hp=fbab6a03a2ea9001c1ffb3bad39800a528bb1bb8;hpb=c4b604cde47ac2f7fcc4cb4f57a6bc8b6b58efa9;p=lilypond.git

diff --git a/scm/framework-ps.scm b/scm/framework-ps.scm
index fbab6a03a2..c7214da3c5 100644
--- a/scm/framework-ps.scm
+++ b/scm/framework-ps.scm
@@ -2,15 +2,13 @@
 ;;;;
 ;;;;  source file of the GNU LilyPond music typesetter
 ;;;;
-;;;; (c) 2004--2006 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; (c) 2004--2007 Han-Wen Nienhuys <hanwen@xs4all.nl>
 
 (define-module (scm framework-ps))
 
 ;;; this is still too big a mess.
 
-(use-modules (ice-9 regex)
-	     (ice-9 string-fun)
-	     (ice-9 format)
+(use-modules (ice-9 string-fun)
 	     (guile)
 	     (scm page)
 	     (scm paper-system)
@@ -19,6 +17,7 @@
 	     (scm clip-region)
 	     (lily))
 
+(define format ergonomic-simple-format)
 
 (define framework-ps-module (current-module))
 
@@ -31,7 +30,12 @@
 
     (string-append
      "magfont"
-     (string-regexp-substitute "[ /%]" "_" name)
+     (ly:string-substitute
+      " " "_"
+      (ly:string-substitute
+       "/" "_"
+       (ly:string-substitute
+	"%" "_" name)))
      "m" (string-encode-integer (inexact->exact (round (* 1000 magnify)))))))
 
 (define (tex-font? fontname)
@@ -45,10 +49,6 @@
     (string-append
       "/" command " { /" fontname " " (ly:number->string scaling) " output-scale div selectfont } bind def\n"))
 
-  (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
@@ -63,10 +63,6 @@
 	   (ops (ly:output-def-lookup paper 'output-scale))
 	   (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)))
@@ -165,13 +161,13 @@
 	       (ly:output-def-lookup paper 'output-scale))
 	    (ly:bp 1)))
 	(landscape? (eq? (ly:output-def-lookup paper 'landscape) #t)))
-  (format "%%DocumentMedia: ~a ~$ ~$ ~a ~a ~a\n"
-   (ly:output-def-lookup paper 'papersizename)
-   (if landscape? h w)
-   (if landscape? w h)
-   80  ;; weight
-   "()" ;; color
-   "()"  ;; type
+  (ly:format "%%DocumentMedia: ~a ~2f ~2f ~a ~a ~a\n"
+	     (ly:output-def-lookup paper 'papersizename)
+	     (if landscape? h w)
+	     (if landscape? w h)
+	     80  ;; weight
+	     "()" ;; color
+	     "()"  ;; type
   )))
 
 
@@ -250,14 +246,21 @@
 
 
 (define (write-preamble paper load-fonts? port)
-
-  (define (load-font-via-GS font-name-filename)
-    (define (ps-load-file name)
-      (format
-       (if (string? name)
-	   "(~a) (r) file .loadfont\n"
-	   "% can't find font file: ~a\n")
-       name))
+  (define (internal-font? file-name)
+    (or (string-startswith file-name "Emmentaler")
+	(string-startswith file-name "emmentaler")
+	(string-startswith file-name "aybabtu")
+	(string-startswith file-name "Aybabtu")))
+  (define (load-font-via-GS font-name-filename)       
+    (define (ps-load-file file-name)
+      (if (string? file-name)
+	  (if (string-contains file-name (ly:get-option 'datadir))
+	      (begin
+		(set! file-name (ly:string-substitute (ly:get-option 'datadir) "" file-name))
+		(format "lilypond-datadir (~a) concatstrings (r) file .loadfont" file-name))
+	      
+	      (format "(~a) (r) file .loadfont\n" file-name))
+	  (format "% cannot find font file: ~a\n" file-name)))
 
     (let* ((font (car font-name-filename))
 	   (name (cadr font-name-filename))
@@ -270,13 +273,13 @@
        (if (mac-font? bare-file-name)
 	   (handle-mac-font name bare-file-name)
 	   (cond
-	    ((string-match "^([eE]mmentaler|[Aa]ybabtu)" file-name)
+	    ((internal-font? file-name)
 	     (ps-load-file (ly:find-file
 			    (format "~a.otf"  file-name))))
 	    ((string? bare-file-name)
 	     (ps-load-file file-name))
 	    (else
-	     (ly:warning (_ "can't embed ~S=~S") name file-name)
+	     (ly:warning (_ "cannot embed ~S=~S") name file-name)
 	     "")))
 
 	  )))
@@ -329,7 +332,7 @@
       (if (not embed)
 	  (begin
 	    (set! embed "% failed \n")
-	    (ly:warning (_ "can't extract file matching ~a from ~a") name filename)))
+	    (ly:warning (_ "cannot extract file matching ~a from ~a") name filename)))
       embed))
 
     (define (font-file-as-ps-string name file-name)
@@ -337,16 +340,16 @@
 	  ((downcase-file-name (string-downcase file-name)))
 	
       (cond
-       ((and file-name (string-match "\\.pfa" downcase-file-name))
+       ((and file-name (string-endswith downcase-file-name ".pfa"))
 	(embed-document file-name))
-       ((and file-name (string-match "\\.pfb" downcase-file-name))
+       ((and file-name (string-endswith downcase-file-name ".pfb"))
 	(ly:pfb->pfa file-name))
-       ((and file-name (string-match "\\.ttf" downcase-file-name))
+       ((and file-name (string-endswith downcase-file-name ".ttf"))
 	(ly:ttf->pfa file-name))
-       ((and file-name (string-match "\\.otf" downcase-file-name))
+       ((and file-name (string-endswith downcase-file-name ".otf"))
 	(ps-embed-cff (ly:otf->cff file-name) name 0))
        (else
-	(ly:warning (_ "don't know how to embed ~S=~S") name file-name)
+	(ly:warning (_ "do not know how to embed ~S=~S") name file-name)
 	""))))
 
     (define (mac-font? bare-file-name)
@@ -354,7 +357,7 @@
        (eq? PLATFORM 'darwin)
        bare-file-name
        (or
-	(string-match "\\.dfont" bare-file-name)
+	(string-endswith  bare-file-name ".dfont")
 	(= (stat:size (stat bare-file-name)) 0))))
 
   (define (load-font font-name-filename)
@@ -377,12 +380,14 @@
 
 	(bare-file-name (font-file-as-ps-string name bare-file-name))
 	(else
-	 (ly:warning (_ "don't know how to embed font ~s ~s ~s")
+	 (ly:warning (_ "do not know how to embed font ~s ~s ~s")
 		     name file-name font))))))
 	
 
   (define (load-fonts paper)
     (let* ((fonts (ly:paper-fonts paper))
+
+	   ;; todo - doc format of list.
 	   (all-font-names
 	    (map
 	     (lambda (font)
@@ -409,15 +414,30 @@
 	     (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))
+	   ;; slightly spaghetti-ish: deciding what to load where
+	   ;; is smeared out.
+	   (font-loader (lambda (name)
+			  (cond
+			   ((ly:get-option 'gs-load-fonts) 
+			    (load-font-via-GS name))
+			   ((ly:get-option 'gs-load-lily-fonts)
+			    (if (or
+				 (string-contains (caddr name) (ly:get-option 'datadir))
+				 (internal-font? (caddr name)))
+
+				(load-font-via-GS name)
+				(load-font name)))
+			   (else (load-font name)))))
 			 
 	   (pfas (map font-loader font-names)))
       pfas))
 
   (display "%%BeginProlog\n" port)
+
+  (format port
+	    "/lilypond-datadir where {pop} {userdict /lilypond-datadir (~a) put } ifelse"
+	    (ly:get-option 'datadir))
+  
   (if load-fonts?
       (for-each
        (lambda (f)
@@ -432,9 +452,6 @@
   (display (procset "music-drawing-routines.ps") port)
   (display (procset "lilyponddefs.ps") port)
 
-  (if (not (ly:get-option 'point-and-click))
-      (display "/mark_URI { pop pop pop pop pop } bind def\n" port)) 
-
   (display "%%EndProlog\n" port)
   
   (display "%%BeginSetup\ninit-lilypond-parameters\n%%EndSetup\n\n" port))
@@ -446,7 +463,7 @@
 		     ;; content-mangling is always bad.
 		     ;; MINGW hack: need to have "b"inary for embedding CFFs
 		     (open-file filename "wb")
-		     "ps"))
+		     'ps))
 	 (paper (ly:paper-book-paper book))
 	 (systems (ly:paper-book-systems book))
 	 (page-stencils (map page-stencil (ly:paper-book-pages book)))
@@ -483,12 +500,15 @@
 			 (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 -3)
+       (padding (ly:get-option 'eps-box-padding))
+       (left-overshoot (if (number? padding)
+			   (* -1 padding (ly:output-def-lookup paper 'mm))
+			   #f))
        (bbox
 	(map
 	 (lambda (x)
@@ -503,7 +523,7 @@
 	   ;;
 	   (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)))))
@@ -515,19 +535,22 @@
 (define-public (dump-stencil-as-EPS-with-bbox paper dump-me filename
 					      load-fonts
 					      bbox)
-  (define (to-bp-box mmbox)
+  "Create an EPS file from stencil DUMP-ME to FILENAME. BBOX has format
+   (left-x, lower-y, right x, up-y).  If LOAD-FONTS set, include fonts inline." 
+
+  (define (to-rounded-bp-box box)
+    "Convert box to 1/72 inch with rounding to enlarge the box."
     (let* ((scale (ly:output-def-lookup paper 'output-scale))
-	   (box (map
-		 (lambda (x)
-		   (if (or (nan? x) (inf? x))
-		       0
-		       (inexact->exact
-			(round (/ (* x scale) (ly:bp 1)))))) mmbox)))
-      
-    (list (car box)
-	  (cadr box)
-	  (max (1+ (car box)) (caddr box))
-	  (max (1+ (cadr box)) (cadddr box))
+	   (strip-non-number (lambda (x)
+			       (if (or (nan? x) (inf? x)) 0.0 x)))
+	   (directed-round (lambda (x rounder)
+			     (inexact->exact
+			      (rounder (/ (* (strip-non-number x) scale)
+					  (ly:bp 1)))))))
+      (list (directed-round (car box) floor)
+	    (directed-round (cadr box) floor)
+	    (directed-round (max (1+ (car box)) (caddr box)) ceiling)
+	    (directed-round (max (1+ (cadr box)) (cadddr box)) ceiling)
 	  )))
 
   (let* ((outputter (ly:make-paper-outputter
@@ -535,12 +558,10 @@
 		     ;; content-mangling is always bad.
 		     ;; MINGW hack: need to have "b"inary for embedding CFFs
 		     (open-file (format "~a.eps" filename) "wb")
-		     "ps"))
+		     'ps))
 
 	 (port (ly:outputter-port outputter))
-
-	 
-	 (rounded-bbox (to-bp-box bbox))
+	 (rounded-bbox (to-rounded-bp-box bbox))
 	 (port (ly:outputter-port outputter))
 	 (header (eps-header paper rounded-bbox load-fonts)))
 
@@ -579,7 +600,7 @@
 	   ((xext (car ext-system-pair))
 	    (paper-system (cdr ext-system-pair))
 	    (yext (paper-system-extent paper-system Y))
-	    (bbox (list (car  xext) (car yext)
+	    (bbox (list (car xext) (car yext)
 			(cdr xext) (cdr yext)))
 	    (filename (if (< 0 count)
 			  (format "~a-~a" basename count)
@@ -601,7 +622,7 @@
     ))
 
 
-(define (clip-system-EPSes basename paper-book)
+(define-public (clip-system-EPSes basename paper-book)
   (define do-pdf (member  "pdf" (ly:output-formats)))
 
   (define (clip-score-systems basename systems)
@@ -729,7 +750,7 @@
 	 )
 
     (if (equal? (basename name ".ps") "-")
-	(ly:warning (_ "can't convert <stdout> to ~S" "PDF"))
+	(ly:warning (_ "cannot convert <stdout> to ~S" "PDF"))
 	(postscript->pdf w h name))))
 
 (define-public (convert-to-png book name)
@@ -748,20 +769,25 @@
 		     name)))
 
 (define-public (convert-to-dvi book name)
-  (ly:warning (_ "can't generate ~S using the postscript back-end") "DVI"))
+  (ly:warning (_ "cannot generate ~S using the postscript back-end") "DVI"))
 
 (define-public (convert-to-tex book name)
-  (ly:warning (_ "can't generate ~S using the postscript back-end") "TeX"))
+  (ly:warning (_ "cannot generate ~S using the postscript back-end") "TeX"))
 
 (define-public (convert-to-ps book name)
   #t)
 
 (define-public (output-classic-framework basename book scopes fields)
 
-  (ly:error (_ "\nThe PostScript backend does not support the 'classic'
-framework. Use the EPS backend instead,
+  (ly:error (_ "\nThe PostScript backend does not support the system-by-system 
+output. For that, use the EPS backend instead,
+
+  lilypond -dbackend=eps FILE
 
-  lilypond -b eps <file>
+If have cut & pasted a lilypond fragment from a webpage, be sure
+to only remove anything before
 
-or remove the lilypond-book specific settings from the input.
+  %% ****************************************************************
+  %% Start cut-&-pastable-section
+  %% ****************************************************************
 ")))