Improvements to Postscript backend (patches included)

[David Feuer]

I sent this some hours ago, but haven't seen it yet.  Is the mailing list
broken, or just really slow?

Original message:

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"))