More improvements to PostScript backend

[David Feuer]

In my nonexistent free time I've done some more work.  I'd really like
to do something about the compulsive gsave x y translate 0 0 moveto
grestore wrapping that everything gets.  Could someone give me an idea
of what could get stuffed into placebox?  Is there actually some kind
of global graphics state that we need to maintain as a default?  It
looks like pretty much everything sets all the variables it cares
about.  I'd like to change all the drawing procedures to draw at the
current point.  If they want to translate to make their lives easier
they should clean up after themselves.  Then the box wrapper becomes
simply x y moveto, and we don't have to waste our time pushing and
popping graphics states for no reason.  By the way, in the future,
should I include patches inline or attach them?  This time I did both.
 The attached one is less likely to have line wrapping problems.  This
patch is against the versions in CVS.

Changelog:

* Cleaned up PostScript code

* Cleaned up interfaces between PostScript and Scheme

* Moved computations from PostScript to Scheme

* Rewrote glyph-string: it should now be much easier to read and edit.

* Removed apparently-unused draw_box (note: if something actually uses this,
  it should be implemented using draw_round_box, rather than
duplicating all the code.)

* Removed print_letter (print_glyphs is now simple enough not to need a helper)

David Feuer


diff -u --strip-trailing-cr original/framework-ps.scm latest/framework-ps.scm
--- original/framework-ps.scm   2006-04-01 11:57:18.109097600 -0500
+++ latest/framework-ps.scm     2006-04-01 11:32:15.448377600 -0500
@@ -43,9 +43,6 @@
   (define (define-font command fontname scaling)
     (string-append
       "/" 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")
diff -u --strip-trailing-cr original/lilyponddefs.ps latest/lilyponddefs.ps
--- original/lilyponddefs.ps    2006-04-01 11:57:18.109097600 -0500
+++ latest/lilyponddefs.ps      2006-04-01 11:26:32.515264000 -0500
@@ -11,8 +11,7 @@


 /set-ps-scale-to-lily-scale {
-       lily-output-units output-scale mul
-       lily-output-units output-scale mul scale
+       lily-output-units output-scale mul dup scale
 } bind def


diff -u --strip-trailing-cr original/music-drawing-routines.ps
latest/music-drawing-routines.ps
--- original/music-drawing-routines.ps  2006-04-01 11:57:18.109097600 -0500
+++ latest/music-drawing-routines.ps    2006-04-01 11:26:08.270401600 -0500
@@ -10,6 +10,36 @@
 /pdfmark where
 {pop} {userdict /pdfmark /cleartomark load put} ifelse

+% llx lly urx ury URI
+/mark_URI
+{
+    /command exch def
+    /ury exch def
+    /urx exch def
+    /lly exch def
+    /llx exch def
+    [
+       /Rect [ llx lly urx ury ]
+
+% it's possible to eliminate the coordinate variables by doing [ /Rect [ 7 3
+% roll It is, however, kind of ugly.  Another possibility, probably better, is
+% to put the [ and ] into the other side, so this procedure will take an array.
+% Yet another is to make pdfmark take its coordinates on the stack.
+
+
+/Border [ 0 0 0 ]
+
+        /Action
+           <<
+               /Subtype /URI
+               /URI command
+           >>
+        /Subtype /Link
+    /ANN
+    pdfmark
+}
+bind def
+
 % from adobe tech note 5002.
 /BeginEPSF { %def
     /b4_Inc_state save def % Save state for cleanup
@@ -28,7 +58,6 @@
     } if
 } bind def

-
 /EndEPSF { %def
   count op_count sub {pop} repeat % Clean up stacks
   countdictstack dict_count sub {end} repeat
@@ -54,28 +83,7 @@
 } bind def


-% llx lly urx ury URI
-/mark_URI
-{
-    /command exch def
-    /ury exch def
-    /urx exch def
-    /lly exch def
-    /llx exch def
-    [
-       /Rect [ llx lly urx ury ]
-       /Border [ 0 0 0 ]

-        /Action
-           <<
-               /Subtype /URI
-               /URI command
-           >>
-        /Subtype /Link
-    /ANN
-    pdfmark
-}
-bind def

 /set_tex_dimen
 {
@@ -89,104 +97,56 @@
        1 copy mul exch 1 copy mul add sqrt
 } bind def

-% FIXME.  translate to middle of box.
-% Nice rectangle with rounded corners
-/draw_box % breapth width depth height
-{
-%      currentdict /testing known {
-               %% real thin lines for testing
-               /blot 0.005 def
-%      }{
-%              /blot blot-diameter def
-%      } ifelse
-
-       0 setlinecap
-       blot setlinewidth
-       1 setlinejoin
-
-       blot 2 div sub /h exch def
-       blot 2 div sub /d exch def
-       blot 2 div sub /w exch def
-       blot 2 div sub /b exch def
-
-       b neg d neg moveto
-       b w add 0 rlineto
-       0 d h add rlineto
-       b w add neg 0 rlineto
-       0 d h add neg rlineto
-
-       currentdict /testing known {
-               %% outline only, for testing:
+/stroke_and_fill {
+       gsave
                stroke
-       }{
-               closepath gsave stroke grestore fill
-       } ifelse
+       grestore
+       fill
 } bind def

-
-/draw_round_box % breapth width depth height blot
+/draw_round_box % x y width height blot
 {
-       /blot exch def
-
+       setlinewidth
        0 setlinecap
-       blot setlinewidth
        1 setlinejoin

-       blot 2 div sub /h exch def
-       blot 2 div sub /d exch def
-       blot 2 div sub /w exch def
-       blot 2 div sub /b exch def
-
-       b neg d neg moveto
-       b w add 0 rlineto
-       0 d h add rlineto
-       b w add neg 0 rlineto
-       0 d h add neg rlineto
-
        currentdict /testing known {
                %% outline only, for testing:
-               stroke
        }{
-               closepath gsave stroke grestore fill
+               4 copy
+               rectfill
        } ifelse
+       rectstroke
 } bind def

-/draw_polygon % x(n) y(n) x(n-1) y(n-1) ... x(1) y(1) n blot fill
+/draw_polygon % fill? x(n) y(n) x(n-1) y(n-1) ... x(0) y(0) n blot
 {
-       /fillp exch def
-       /blot exch def
+       setlinewidth %set to blot

        0 setlinecap
-       blot setlinewidth
        1 setlinejoin

-       /points exch def
-       2 copy
-       moveto
-       1 1 points { pop lineto } for
+       3 1 roll
+       moveto % x(0) y(0)
+       { lineto } repeat % n times
        closepath
-       fillp {
-               gsave stroke grestore fill
+       { %fill?
+               stroke_and_fill
        }{
                stroke
        } ifelse
 } bind def

-/draw_repeat_slash % width slope thick
+/draw_repeat_slash % x-width width height
 {
+       2 index % duplicate x-width
        1 setlinecap
        1 setlinejoin
-
-       /beamthick exch def
-       /slope exch def
-       /width exch def
-       beamthick beamthick slope div euclidean_length
-         /xwid exch def
+
        0 0 moveto
-       xwid 0  rlineto
-       width slope width mul rlineto
-       xwid neg 0 rlineto
-      %  width neg width angle sin mul neg rlineto
+         0  rlineto % x-width 0
+            rlineto % width height
+       neg 0 rlineto % -x-width 0
        closepath fill
 } bind def

@@ -201,27 +161,24 @@
        lineto
        curveto
        closepath
-       gsave
-       fill
-       grestore
-       stroke
+       stroke_and_fill
 } bind def

 /draw_dot % x1 y2 R
 {
 %      0 360 arc fill stroke
-       0 360 arc closepath fill stroke
+       0 360 arc closepath stroke_and_fill
 } bind def

-/draw_circle % R T F
+/draw_circle % F R T
 {
-       /filled exch def
        setlinewidth
        dup 0 moveto
        0 exch 0 exch
        0 360 arc closepath
-       gsave stroke grestore
-       filled { fill } if
+               { stroke_and_fill }
+               { stroke }
+       ifelse
 } bind def


@@ -273,19 +230,13 @@
        stroke
 } bind def

-/print_letter {
-       currentpoint
-       3 2 roll
-       glyphshow
-       moveto
-} bind def
-
 /print_glyphs {
-       -1 1
        {
-               3 mul -3 roll
-               print_letter
+               currentpoint
+               3 2 roll
+               glyphshow
+               moveto
                rmoveto
-       }for
+       }repeat
 }bind def
 %end music-drawing-routines.ps
diff -u --strip-trailing-cr original/output-ps.scm latest/output-ps.scm
--- original/output-ps.scm      2006-04-01 11:57:18.109097600 -0500
+++ latest/output-ps.scm        2006-04-01 11:25:55.051393600 -0500
@@ -48,6 +48,9 @@
             (lily))

 ;;; helper functions, not part of output interface
+;;;
+
+
 (define (escape-parentheses s)
   (regexp-substitute/global #f "(^|[^\\])([\\(\\)])" s 'pre 1 "\\" 2 'post))

@@ -102,10 +105,11 @@

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

 (define (dashed-line thick on off dx dy)
   (format #f "~a ~a ~a [ ~a ~a ] 0 draw_dashed_line"
@@ -143,32 +147,31 @@
                      cid?
                      w-x-y-named-glyphs)

-  (format #f "gsave
-  /~a ~a ~a output-scale div scalefont setfont\n~a grestore"
-         postscript-font-name
-
-         ;; with normal findfont, GS throws /typecheck for glyphshow.
+  (define (glyph-spec w x y g)
+    (let ((prefix (if (string? g) "/" "")))
+      (format #f "~f ~f ~a~a"
+             (round2 (+ w x))
+             (round2 y)
+             prefix g)))
+
+  (format #f
          (if cid?
-             " /CIDFont findresource "
-             " findfont")
+"gsave
+/~a /CIDFont findresource ~a output-scale div scalefont setfont
+~a
+~a print_glyphs
+grestore"
+
+"gsave\n/~a ~a output-scale div selectfont
+~a
+~a print_glyphs
+grestore")
+         postscript-font-name
          size
-         (string-append
-           (apply
-             string-append
-             (map (lambda  (item)
-                    (let*
-                      ((w (car item))
-                       (x (cadr item))
-                       (y (caddr item))
-                       (g (cadddr item))
-                       (prefix (if  (string? g) "/" "")))
-
-                      (format #f "  ~f ~f ~a~a\n" (round2 (+ w x))
-                              (round2 y) prefix g)
-                      ))
-                  w-x-y-named-glyphs))
-           (format #f "~a print_glyphs" (length w-x-y-named-glyphs)))
-         ))
+         (string-join (map (lambda (x) (apply glyph-spec x))
+                           (reverse w-x-y-named-glyphs)) "\n")
+         (length w-x-y-named-glyphs)))
+

 (define (grob-cause offset grob)
   (let* ((cause (ly:grob-property grob 'cause))
@@ -226,28 +229,38 @@
 ~a
 grestore\n"

-   (str4 x)
-   (str4 y)
-   s))
+  (str4 x)
+  (str4 y)
+  s))

 (define (polygon points blot-diameter filled?)
   (format #f "~a ~a ~a ~a draw_polygon"
+         (if filled? "true" "false")
          (numbers->string4 points)
-         (str4 (/ (length points) 2))
-         (str4 blot-diameter)
-         (if filled? "true" "false")))
-
-(define (repeat-slash wid slope thick)
-  (format #f "~a draw_repeat_slash"
-   (numbers->string4 (list wid slope thick))))
+         (number->string (- (/ (length points) 2) 1))
+         (str4 blot-diameter)))
+
+(define (repeat-slash width slope beam-thickness)
+  (define (euclidean-length x y)
+    (sqrt (+ (* x x) (* y y))))
+
+  (let ((x-width (euclidean-length slope (/ beam-thickness slope)))
+       (height (* width slope)))
+    (format #f "~a draw_repeat_slash"
+           (numbers->string4 (list x-width width height)))))

 ;; restore color from stack
 (define (resetcolor) "setrgbcolor\n")

-(define (round-filled-box x y width height blotdiam)
-  (format #f "~a draw_round_box"
-         (numbers->string4
-           (list x y width height blotdiam))))
+(define (round-filled-box left right bottom top blotdiam)
+  (let* ((halfblot (/ blotdiam 2))
+        (x (- halfblot left))
+        (width (- right (+ halfblot x)))
+        (y (- halfblot bottom))
+        (height (- top (+ halfblot y))))
+    (format #f "~a draw_round_box"
+           (numbers->string4
+             (list x y width height blotdiam)))))

 ;; save current color on stack and set new color
 (define (setcolor r g b)

newchanges.diff
Description: Binary data