Index: ps/lilyponddefs.ps
===================================================================
RCS file: /sources/lilypond/lilypond/ps/lilyponddefs.ps,v
retrieving revision 1.44
diff -u -r1.44 lilyponddefs.ps
--- ps/lilyponddefs.ps	6 Feb 2006 01:13:58 -0000	1.44
+++ ps/lilyponddefs.ps	4 Apr 2006 14:31:03 -0000
@@ -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
 
 
Index: ps/music-drawing-routines.ps
===================================================================
RCS file: /sources/lilypond/lilypond/ps/music-drawing-routines.ps,v
retrieving revision 1.42
diff -u -r1.42 music-drawing-routines.ps
--- ps/music-drawing-routines.ps	31 Mar 2006 09:30:03 -0000	1.42
+++ ps/music-drawing-routines.ps	4 Apr 2006 14:31:03 -0000
@@ -7,9 +7,60 @@
 
 % TODO: use dicts or prefixes to prevent namespace pollution.
 
+% Emulation code from Postscript Language Reference.
+
+/*SF
+{
+	exch findfont exch
+	dup type /arraytype eq
+		{makefont}
+		{scalefont}
+	ifelse
+	setfont
+} bind def
+
+/languagelevel where
+	{pop languagelevel}
+	{1}
+ifelse
+
+2 lt
+	{ /selectfont /*SF load def }
+if
+
+% end emulation code
+
 /pdfmark where
 {pop} {userdict /pdfmark /cleartomark load put} ifelse
 
+
+% llx lly urx ury URI
+/mark_URI
+% It's possible to eliminate the coordinate variables by doing [ /Rect [ 7 3
+% roll.  That is, however, kind of ugly.  It would be nice if this procedure
+% were only included when PDF marks are enabled.
+{
+    /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
+
 % from adobe tech note 5002. 
 /BeginEPSF { %def
     /b4_Inc_state save def % Save state for cleanup
@@ -28,7 +79,6 @@
     } if
 } bind def
 
-
 /EndEPSF { %def
   count op_count sub {pop} repeat % Clean up stacks
   countdictstack dict_count sub {end} repeat
@@ -54,28 +104,6 @@
 } 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
 {
@@ -83,116 +111,86 @@
 } bind def
 
 
-
-/euclidean_length
-{
-	1 copy mul exch 1 copy mul add sqrt
+/stroke_and_fill {
+	gsave
+		stroke
+	grestore
+	fill
 } 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
+/vector_add { % x1 y1 x2 y2 vector_add x1+x2 y1+y2
+	exch
+	4 1 roll
+	add
+	3 1 roll
+	add
+	exch
+} bind def
 
+/draw_round_box % width height x y blot
+currentdict /testing known
+{{
+	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
-	} ifelse
-} bind def
-
-
-/draw_round_box % breapth width depth height blot
-{
-	/blot exch def
-
+	
+	rmoveto
+	currentpoint
+	4 2 roll
+	rectstroke
+}}
+{{
+	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
-	} ifelse
-} bind def
+	rmoveto
+	currentpoint
+	4 2 roll
+	4 copy
+	rectfill
+	rectstroke
+}} ifelse 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
+	/polygon_x
+	currentpoint
+	/polygon_y exch def
+	def
+	rmoveto % x(0) y(0)
+	{ polygon_x polygon_y vector_add 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
 
 % this is for drawing slurs.
 /draw_bezier_sandwich  % thickness controls
 {
+	gsave
+	currentpoint translate
     % round ending and round beginning
     1 setlinejoin 1 setlinecap
 	setlinewidth
@@ -201,91 +199,71 @@
 	lineto
 	curveto
 	closepath
-	gsave
-	fill
+	stroke_and_fill
 	grestore
-	stroke
 } bind def
 
-/draw_dot % x1 y2 R
+/draw_dot % radius x y
 {
-%	0 360 arc fill stroke
-	0 360 arc closepath fill stroke
+	rmoveto
+	currentpoint
+	3 2 roll
+	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
+	dup 0 rmoveto
+	currentpoint 3 2 roll
 	0 360 arc closepath
-	gsave stroke grestore
-	filled { fill } if 
-} bind def
-
-
-% JUNKME. use color & circle. 
-/draw_white_dot % x1 y2 R
-{
-%	0 360 arc fill stroke
-	0 360 arc closepath % fill stroke
-gsave
- 1 setgray fill
-grestore
-%	0 360 arc closepath % fill stroke
-  0.05 setlinewidth 0 setgray stroke
+		{ stroke_and_fill } 
+		{ stroke }
+	ifelse
 } bind def
 
 
-% JUNKME: Use color.  
-/draw_white_text  % text scale font
+/draw_line % dx dy x1 y1 thickness
 {
-  exch selectfont
-  1 setgray
-  0 0 moveto
-  %-0.05 -0.05 moveto
-  % text
-  show
+	setlinewidth
+	1 setlinecap
+	1 setlinejoin
+	rmoveto
+	rlineto
+	stroke
 } bind def
 
-
-/draw_dashed_line % dash thickness dx dy
+/draw_dashed_line % dx dy thickness dashpattern
 {
 	1 setlinecap
 	1 setlinejoin
 	setdash
 	setlinewidth
-	0 0 moveto
-	lineto
+	rlineto
 	stroke
 } bind def
 
-/draw_dashed_slur % dash thickness controls
+/draw_dashed_slur % controls thickness dash
 {
+gsave
+	currentpoint translate
 	1 setlinecap
 	1 setlinejoin
 	setdash
 	setlinewidth
-	8 -2 roll
 	moveto
 	curveto
 	stroke
-} bind def
-
-/print_letter {
-	currentpoint
-	3 2 roll
-	glyphshow
-	moveto
+grestore
 } 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
Index: scm/framework-ps.scm
===================================================================
RCS file: /sources/lilypond/lilypond/scm/framework-ps.scm,v
retrieving revision 1.159
diff -u -r1.159 framework-ps.scm
--- scm/framework-ps.scm	31 Mar 2006 09:30:03 -0000	1.159
+++ scm/framework-ps.scm	4 Apr 2006 14:31:03 -0000
@@ -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")
Index: scm/output-ps.scm
===================================================================
RCS file: /sources/lilypond/lilypond/scm/output-ps.scm,v
retrieving revision 1.166
diff -u -r1.166 output-ps.scm
--- scm/output-ps.scm	31 Mar 2006 09:59:05 -0000	1.166
+++ scm/output-ps.scm	4 Apr 2006 14:31:03 -0000
@@ -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"
@@ -118,22 +122,23 @@
 ;; what the heck is this interface ?
 (define (dashed-slur thick on off l)
   (format #f "~a ~a [ ~a ~a ] 0 draw_dashed_slur"
-	  (string-join (map number-pair->string4 l) " ")
+	  (let ((control-points (append (cddr l) (list (car l) (cadr l)))))
+	    (string-join (map number-pair->string4 control-points) " "))
 	  (str4 thick)
 	  (str4 on)
 	  (str4 off)))
 
 (define (dot x y radius)
   (format #f " ~a draw_dot"
-   (numbers->string4 (list x y radius))))
+   (numbers->string4 (list radius x y))))
 
 (define (draw-line thick x1 y1 x2 y2)
-  (format #f "1 setlinecap 1 setlinejoin ~a setlinewidth ~a ~a moveto ~a ~a lineto stroke"
-   (str4 thick)
-   (str4 x1)
-   (str4 y1)
-   (str4 x2)
-   (str4 y2)))
+  (format #f "~a ~a ~a ~a ~a draw_line"
+	  (str4 (- x2 x1))
+	  (str4 (- y2 y1))
+	  (str4 x1)
+	  (str4 y1)
+	  (str4 thick)))
 
 (define (embedded-ps string)
   string)
@@ -143,32 +148,28 @@
 		      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")
+"/~a /CIDFont findresource ~a output-scale div scalefont setfont
+~a
+~a print_glyphs"
+
+"/~a ~a output-scale div selectfont
+~a
+~a print_glyphs")
+	  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))
@@ -208,8 +209,8 @@
     (if (string=?
 	  (substring key 0 (min (string-length prefix) (string-length key)))
 	  prefix)
-      (string-append "/" key " {" val "} bind def\n")
-      (string-append "/" key " (" val ") def\n"))))
+      (format "/~a { ~a } bind def\n" key val)
+      (format "/~a (~a) def\n" key val))))
 
 (define (named-glyph font glyph)
   (format #f "~a /~a glyphshow " ;;Why is there a space at the end?
@@ -221,33 +222,40 @@
 
 (define (placebox x y s) 
   (format #f
-"gsave ~a ~a translate
-0 0 moveto
-~a
-grestore\n"
-
-   (str4 x)
-   (str4 y)
-   s))
+"~a ~a moveto
+~a\n"
+  (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 width height x y blotdiam)))))
 
 ;; save current color on stack and set new color
 (define (setcolor r g b)
@@ -260,6 +268,7 @@
   
   (let* ((space-length (cdar (ly:text-dimension font " ")))
 	 (space-move (string-append (number->string space-length)
+				    ;; how much precision do we need here?
 				    " 0.0 rmoveto "))
 	 (out-vec (decode-byte-string s)))