Improvements to Postscript backend (patches included)

[David Feuer]

I made some changes to the Postscript backend, making the output more 
readable (especially for text), around 10% shorter, and, at least in theory, 
also faster to interpret.  These changes are just a start, but I hope they 
help.  I'd like to know if it might be possible to make the backend work at 
a slightly higher level, which should allow much smaller files (e.g., 
Postscript could easily understand the concept of "filled dotted quarter 
note in current note font with upward stem 3 staff spaces long").

I'm not a master of diff, so let me know if the following aren't done right.
Diffs (made with -u) against the 2.8.0 source:

--- ../Installation 
Programs/lilypond-2.8.0-src/lilypond-2.8.0/scm/framework-ps.scm     
2006-03-20 19:45:18.000000000 -0500
+++ framework-ps.scm    2006-03-25 18:25:43.875475200 -0500
@@ -42,8 +42,10 @@
  (define font-list (ly:paper-fonts paper))
  (define (define-font command fontname scaling)
    (string-append
-     "/" command " { /" fontname " findfont "
-     (ly:number->string scaling) " output-scale div scalefont } bind 
def\n"))
+      "/" command " { /" fontname " " (ly:number->string scaling) " 
output-scale div selectfont } bind def\n"))
+;    (string-append
+;     "/" command " { /" fontname " findfont "
+;     (ly:number->string scaling) " output-scale div scalefont } bind 
def\n"))

  (define (standard-tex-font? x)
    (or (equal? (substring x 0 2) "ms")


--- ../Installation 
Programs/lilypond-2.8.0-src/lilypond-2.8.0/ps/music-drawing-routines.ps     
2006-03-16 05:52:27.000000000 -0500
+++ music-drawing-routines.ps   2006-03-25 18:25:10.447408000 -0500
@@ -241,10 +241,7 @@
% JUNKME: Use color.
/draw_white_text  % text scale font
{
-  %font
-  findfont
-  %scale
-  exch scalefont setfont
+  exch selectfont
  1 setgray
  0 0 moveto
  %-0.05 -0.05 moveto
@@ -276,5 +273,19 @@
       stroke
} bind def

+/printletter {
+       currentpoint
+       3 2 roll
+       glyphshow
+       moveto
+} bind def

+/printglyphs {
+       -1 1
+       {
+               3 mul -3 roll
+               printletter
+               rmoveto
+       }for
+}bind def
%end music-drawing-routines.ps




--- ../Installation 
Programs/lilypond-2.8.0-src/lilypond-2.8.0/scm/output-ps.scm        
2006-03-07 13:14:23.000000000 -0500
+++ output-ps.scm       2006-03-25 18:25:34.061363200 -0500
@@ -54,6 +54,21 @@
(define (ps-encoding text)
  (escape-parentheses text))

+(define (round2 num)
+  (/ (round (* 100 num)) 100))
+
+(define (round4 num)
+  (/ (round (* 10000 num)) 10000))
+
+(define (str4 num)
+  (format #f "~f" (round4 num)))
+
+(define (number-pair->string4 numpair)
+  (format #f "~f ~f" (round4 (car numpair)) (round4 (cdr numpair))))
+
+(define (numbers->string4 numlist)
+  (apply string-append (map (lambda (x) (string-append (str4 x) " ")) 
numlist)))
+
;; FIXME: lily-def
(define-public (ps-string-def prefix key val)
  (string-append "/" prefix (symbol->string key) " ("
@@ -75,59 +90,61 @@
;; two beziers
(define (bezier-sandwich lst thick)
  (string-append
-   (string-join (map ly:number-pair->string lst) " ")
+   (string-join (map number-pair->string4 lst) " ")
   " "
-   (ly:number->string thick)
+   (str4 thick)
   " draw_bezier_sandwich"))

(define (char font i)
  (string-append
-   (ps-font-command font) " setfont "
-   "(\\" (ly:inexact->string i 8) ") show"))
+   (ps-font-command font) ; " "
+   " (\\" (ly:inexact->string i 8) ") show"))

(define (circle radius thick fill)
  (format
-   "~a ~a ~a draw_circle" radius thick
+   "~f ~f ~a draw_circle" (round4 radius) (round4 thick)
   (if fill
       "true "
       "false ")))

(define (dashed-line thick on off dx dy)
  (string-append
-   (ly:number->string dx) " "
-   (ly:number->string dy) " "
-   (ly:number->string thick)
+   (str4 dx) " "
+   (str4 dy) " "
+   (str4 thick)
   " [ "
-   (ly:number->string on) " "
-   (ly:number->string off)
+   (str4 on) " "
+   (str4 off)
   " ] 0 draw_dashed_line"))

;; what the heck is this interface ?
(define (dashed-slur thick on off l)
  (string-append
-   (string-join (map ly:number-pair->string l) " ")
+   (string-join (map number-pair->string4 l) " ")
   " "
-   (ly:number->string thick)
+   (str4 thick)
   " [ "
-   (ly:number->string on)
+   (str4 on)
   " "
-   (ly:number->string off)
+   (str4 off)
   " ] 0 draw_dashed_slur"))

+;;  s/\.\([0-9]\{-}\)0* /\1 /g
+
(define (dot x y radius)
  (string-append
   " "
-   (ly:numbers->string
+   (numbers->string4
    (list x y radius)) " draw_dot"))

(define (draw-line thick x1 y1 x2 y2)
  (string-append
   "1 setlinecap 1 setlinejoin "
-   (ly:number->string thick) " setlinewidth "
-   (ly:number->string x1) " "
-   (ly:number->string y1) " moveto "
-   (ly:number->string x2) " "
-   (ly:number->string y2) " lineto stroke"))
+   (str4 thick) " setlinewidth "
+   (str4 x1) " "
+   (str4 y1) " moveto "
+   (str4 x2) " "
+   (str4 y2) " lineto stroke"))

(define (embedded-ps string)
  string)
@@ -138,12 +155,10 @@
        w-x-y-named-glyphs)

  (format #f "gsave
-  /~a ~a ~a output-scale div scalefont setfont\n~a grestore"
+  /~a ~a output-scale div selectfont\n~a grestore"
         postscript-font-name
-         (if cid?
-             " /CIDFont findresource "
-             " findfont")
         size
+         (string-append
         (apply
          string-append
          (map (lambda  (item)
@@ -154,9 +169,12 @@
                      (g (cadddr item))
                      (prefix (if  (string? g) "/" "")))

-                   (format #f " gsave ~a~a glyphshow grestore ~$ ~$ rmoveto 
\n" prefix g (+ w x) y)
+                   (format #f "~f ~f ~a~a\n" (round2 (+ w x))
+                           (round2 y) prefix g)
                   ))
-               w-x-y-named-glyphs))))
+               w-x-y-named-glyphs))
+         (format #f "~a printglyphs" (length w-x-y-named-glyphs)))
+        ))

(define (grob-cause offset grob)
  (let* ((cause (ly:grob-property grob 'cause))
@@ -201,7 +219,7 @@

(define (named-glyph font glyph)
  (string-append
-   (ps-font-command font) " setfont "
+   (ps-font-command font) " "
   "/" glyph " glyphshow "))

(define (no-origin)
@@ -214,21 +232,21 @@
~a
grestore\n"

-   (ly:number->string x)
-   (ly:number->string y)
+   (str4 x)
+   (str4 y)
   s))

(define (polygon points blot-diameter filled?)
  (string-append
-   (ly:numbers->string points) " "
-   (ly:number->string (/ (length points) 2)) " "
-   (ly:number->string blot-diameter)
+   (numbers->string4 points) " "
+   (str4 (/ (length points) 2)) " "
+   (str4 blot-diameter)
   (if filled? " true " " false ")
   " draw_polygon"))

(define (repeat-slash wid slope thick)
  (string-append
-   (ly:numbers->string (list wid slope thick))
+   (numbers->string4 (list wid slope thick))
   " draw_repeat_slash"))

;; restore color from stack
@@ -237,13 +255,13 @@

(define (round-filled-box x y width height blotdiam)
  (string-append
-   (ly:numbers->string
+   (numbers->string4
    (list x y width height blotdiam)) " draw_round_box"))

;; save current color on stack and set new color
(define (setcolor r g b)
  (string-append "currentrgbcolor "
-  (ly:numbers->string (list r g b))
+  (numbers->string4 (list r g b))
  " setrgbcolor\n"))

(define (text font s)
@@ -256,7 +274,7 @@
        (out-vec (decode-byte-string s)))

    (string-append
-     (ps-font-command font) " setfont "
+     (ps-font-command font) " "
     (string-join
      (vector->list
       (vector-for-each
@@ -286,10 +304,10 @@
(define (zigzag-line centre? zzw zzh thick dx dy)
  (string-append
   (if centre? "true" "false") " "
-   (ly:number->string zzw) " "
-   (ly:number->string zzh) " "
-   (ly:number->string thick) " "
+   (str4 zzw) " "
+   (str4 zzh) " "
+   (str4 thick) " "
   "0 0 "
-   (ly:number->string dx) " "
-   (ly:number->string dy)
+   (str4 dx) " "
+   (str4 dy)
   " draw_zigzag_line"))

_________________________________________________________________
Don’t just search. Find. Check out the new MSN Search! 
http://search.msn.click-url.com/go/onm00200636ave/direct/01/