Divide collision Y extent by staff_space; add regression test.

[lilypond.git] / scm / output-ps.scm

diff --git a/scm/output-ps.scm b/scm/output-ps.scm
index 06b324b799c7abd07f10c1518ead850bd897724e..f20c42f1e1012cea4bd2d7b6142f93d5b3aecbf8 100644 (file)
--- a/scm/output-ps.scm
+++ b/scm/output-ps.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 1998--2010 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; Copyright (C) 1998--2011 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;;                 Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
@@ -18,7 +18,7 @@
 
 ;;;; Note: currently misused as testbed for titles with markup, see
 ;;;;       input/test/title-markup.ly
-;;;; 
+;;;;
 ;;;; TODO:
 ;;;;   * %% Papersize in (header ...)
 ;;;;   * text setting, kerning.
@@ -29,6 +29,7 @@
 
 (use-modules (guile)
             (ice-9 regex)
+            (ice-9 optargs)
             (srfi srfi-1)
             (srfi srfi-13)
             (scm framework-ps)
@@ -44,14 +45,14 @@
 (define (str4 num)
   (if (or (nan? num) (inf? num))
       (begin
-       (ly:warning (_ "Found infinity or nan in output. Substituting 0.0"))
+       (ly:warning (_ "Found infinity or nan in output.  Substituting 0.0"))
        (if (ly:get-option 'strict-infinity-checking)
            (exit 1))
        "0.0")
       (ly:number->string num)))
 
 (define (number-pair->string4 numpair)
-  (ly:format "~4l" numpair)) 
+  (ly:format "~4l" numpair))
 
 ;;;
 ;;; Lily output interface, PostScript implementation --- cleanup and docme
@@ -59,7 +60,7 @@
 
 ;; two beziers
 (define (bezier-sandwich lst thick)
-  (ly:format "~l ~4f draw_bezier_sandwich" 
+  (ly:format "~l ~4f draw_bezier_sandwich"
             (map number-pair->string4 lst)
          thick))
 
@@ -102,6 +103,16 @@
          (- x2 x1) (- y2 y1)
          x1 y1 thick))
 
+(define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill)
+  (ly:format "~a ~a ~4f ~4f ~4f ~4f ~4f draw_partial_ellipse"
+        (if fill "true" "false")
+       (if connect "true" "false")
+       x-radius
+       y-radius
+       start-angle
+       end-angle
+       thick))
+
 (define (ellipse x-radius y-radius thick fill)
   (ly:format
    "~a ~4f ~4f ~4f draw_ellipse"
@@ -123,8 +134,8 @@
       (ly:format "~4f ~4f ~4f ~a~a"
                 w x y
                 prefix g)))
-  
-  (ly:format 
+
+  (ly:format
    (if cid?
 "/~a /CIDFont findresource ~a output-scale div scalefont setfont
 ~a
@@ -190,7 +201,7 @@
      "false")
    x-radius y-radius thick))
 
-(define (placebox x y s) 
+(define (placebox x y s)
   (if (not (string-null? s))
       (ly:format "~4f ~4f moveto ~a\n" x y s)
       ""))
@@ -239,7 +250,7 @@
 (define (resetrotation ang x y)
   "grestore  ")
 
-(define (unknown) 
+(define (unknown)
   "\n unknown\n")
 
 (define (url-link url x y)
@@ -250,13 +261,13 @@
             (cdr y)
             url))
 
-(define (path thickness exps)
+(define* (path thickness exps #:optional (cap 'round) (join 'round) (fill? #f))
   (define (convert-path-exps exps)
     (if (pair? exps)
        (let*
            ((head (car exps))
             (rest (cdr exps))
-            (arity 
+            (arity
              (cond
               ((memq head '(rmoveto rlineto lineto moveto)) 2)
               ((memq head '(rcurveto curveto)) 6)
@@ -268,14 +279,34 @@
          ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
          (cons (ly:format
                        "~l ~a "
-                       args 
+                       args
                        head)
                (convert-path-exps (drop rest arity))))
        '()))
-    
-    
-  (ly:format
-   "gsave currentpoint translate 1 setlinecap ~a setlinewidth\n~l stroke grestore"
-   thickness
-   (convert-path-exps exps)))
-  
+
+  (let ((cap-numeric (case cap ((butt) 0) ((round) 1) ((square) 2)
+                      (else (begin
+                              (ly:warning (_ "unknown line-cap-style: ~S")
+                                          (symbol->string cap))
+                              1))))
+       (join-numeric (case join ((miter) 0) ((round) 1) ((bevel) 2)
+                       (else (begin
+                               (ly:warning (_ "unknown line-join-style: ~S")
+                                           (symbol->string join))
+                               1)))))
+    (ly:format
+     "gsave currentpoint translate
+~a setlinecap ~a setlinejoin ~a setlinewidth
+~l gsave stroke grestore ~a grestore"
+     cap-numeric
+     join-numeric
+     thickness
+     (convert-path-exps exps)
+     (if fill? "fill" ""))))
+
+(define (setscale x y)
+  (ly:format "gsave ~4l scale\n"
+             (list x y)))
+
+(define (resetscale)
+  "grestore\n")