scm/output-ps.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 1998--2012 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;;;                 Han-Wen Nienhuys <hanwen@xs4all.nl>
   5 ;;;;
   6 ;;;; LilyPond is free software: you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation, either version 3 of the License, or
   9 ;;;; (at your option) any later version.
  10 ;;;;
  11 ;;;; LilyPond is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;;; Note: currently misused as testbed for titles with markup, see
  20 ;;;;       input/test/title-markup.ly
  21 ;;;;
  22 ;;;; TODO:
  23 ;;;;   * %% Papersize in (header ...)
  24 ;;;;   * text setting, kerning.
  25 ;;;;   * document output-interface
  26
  27 (define-module (scm output-ps)
  28   #:re-export (quote))
  29
  30 (use-modules (guile)
  31              (ice-9 regex)
  32              (ice-9 optargs)
  33              (srfi srfi-1)
  34              (srfi srfi-13)
  35              (scm framework-ps)
  36              (lily))
  37
  38 ;;; helper functions, not part of output interface
  39 ;;;
  40
  41
  42 ;; ice-9 format uses a lot of memory
  43 ;; using simple-format almost halves lilypond cell usage
  44
  45 (define (str4 num)
  46   (if (or (nan? num) (inf? num))
  47       (begin
  48         (ly:warning (_ "Found infinity or nan in output.  Substituting 0.0"))
  49         (if (ly:get-option 'strict-infinity-checking)
  50             (exit 1))
  51         "0.0")
  52       (ly:number->string num)))
  53
  54 (define (number-pair->string4 numpair)
  55   (ly:format "~4l" numpair))
  56
  57 ;;;
  58 ;;; Lily output interface, PostScript implementation --- cleanup and docme
  59 ;;;
  60
  61 ;; two beziers
  62 (define (bezier-sandwich lst thick)
  63   (ly:format "~l ~4f draw_bezier_sandwich"
  64              (map number-pair->string4 lst)
  65           thick))
  66
  67 (define (char font i)
  68   (ly:format "~a (\\~a) show"
  69    (ps-font-command font)
  70    (ly:inexact->string i 8)))
  71
  72 (define (circle radius thick fill)
  73   (ly:format
  74    "~a ~4f ~4f draw_circle"
  75    (if fill
  76      "true"
  77      "false")
  78    radius thick))
  79
  80 (define (start-enclosing-id-node s)
  81   "")
  82
  83 (define (end-enclosing-id-node)
  84   "")
  85
  86 (define (dashed-line thick on off dx dy phase)
  87   (ly:format "~4f ~4f ~4f [ ~4f ~4f ] ~4f draw_dashed_line"
  88    dx
  89    dy
  90    thick
  91    on
  92    off
  93    phase))
  94
  95 ;; what the heck is this interface ?
  96 (define (dashed-slur thick on off l)
  97   (ly:format "~l ~4f [ ~4f ~4f ] 0 draw_dashed_slur"
  98           (let ((control-points (append (cddr l) (list (car l) (cadr l)))))
  99             (map number-pair->string4 control-points))
 100           thick
 101           on
 102           off))
 103
 104 (define (dot x y radius)
 105   (ly:format " ~4l draw_dot" (list radius x y)))
 106
 107 (define (draw-line thick x1 y1 x2 y2)
 108   (ly:format "~4f ~4f ~4f ~4f ~4f draw_line"
 109           (- x2 x1) (- y2 y1)
 110           x1 y1 thick))
 111
 112 (define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill)
 113   (ly:format "~a ~a ~4f ~4f ~4f ~4f ~4f draw_partial_ellipse"
 114         (if fill "true" "false")
 115         (if connect "true" "false")
 116         x-radius
 117         y-radius
 118         start-angle
 119         end-angle
 120         thick))
 121
 122 (define (ellipse x-radius y-radius thick fill)
 123   (ly:format
 124    "~a ~4f ~4f ~4f draw_ellipse"
 125    (if fill
 126      "true"
 127      "false")
 128    x-radius y-radius thick))
 129
 130 (define (embedded-ps string)
 131   string)
 132
 133 (define (glyph-string postscript-font-name
 134                       size
 135                       cid?
 136                       w-x-y-named-glyphs)
 137
 138   (define (glyph-spec w x y g)
 139     (let ((prefix (if (string? g) "/" "")))
 140       (ly:format "~4f ~4f ~4f ~a~a"
 141                  w x y
 142                  prefix g)))
 143
 144   (ly:format
 145    (if cid?
 146 "/~a /CIDFont findresource ~a output-scale div scalefont setfont
 147 ~a
 148 ~a print_glyphs"
 149
 150 "/~a ~a output-scale div selectfont
 151 ~a
 152 ~a print_glyphs")
 153           postscript-font-name
 154           size
 155           (string-join (map (lambda (x) (apply glyph-spec x))
 156                             (reverse w-x-y-named-glyphs)) "\n")
 157           (length w-x-y-named-glyphs)))
 158
 159
 160 (define (grob-cause offset grob)
 161   (if (ly:get-option 'point-and-click)
 162       (let* ((cause (ly:grob-property grob 'cause))
 163              (music-origin (if (ly:stream-event? cause)
 164                                (ly:event-property cause 'origin)))
 165              (point-and-click (ly:get-option 'point-and-click)))
 166         (if (and
 167              (ly:input-location? music-origin)
 168              (cond ((boolean? point-and-click) point-and-click)
 169                    ((symbol? point-and-click)
 170                     (ly:in-event-class? cause point-and-click))
 171                    (else (any (lambda (t)
 172                                 (ly:in-event-class? cause t))
 173                               point-and-click))))
 174             (let* ((location (ly:input-file-line-char-column music-origin))
 175                    (raw-file (car location))
 176                    (file (if (is-absolute? raw-file)
 177                              raw-file
 178                              (string-append (ly-getcwd) "/" raw-file)))
 179                    (x-ext (ly:grob-extent grob grob X))
 180                    (y-ext (ly:grob-extent grob grob Y)))
 181
 182               (if (and (< 0 (interval-length x-ext))
 183                        (< 0 (interval-length y-ext)))
 184                   (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n"
 185                              (+ (car offset) (car x-ext))
 186                              (+ (cdr offset) (car y-ext))
 187                              (+ (car offset) (cdr x-ext))
 188                              (+ (cdr offset) (cdr y-ext))
 189
 190                              ;; Backslashes are not valid
 191                              ;; file URI path separators.
 192                              (ly:string-percent-encode
 193                                (ly:string-substitute "\\" "/" file))
 194
 195                              (cadr location)
 196                              (caddr location)
 197                              (cadddr location))
 198                   ""))
 199             ""))
 200       ""))
 201
 202 (define (named-glyph font glyph)
 203   (ly:format "~a /~a glyphshow " ;;Why is there a space at the end?
 204              (ps-font-command font)
 205              glyph))
 206
 207 (define (no-origin)
 208   "")
 209
 210 (define (oval x-radius y-radius thick fill)
 211   (ly:format
 212    "~a ~4f ~4f ~4f draw_oval"
 213    (if fill
 214      "true"
 215      "false")
 216    x-radius y-radius thick))
 217
 218 (define (placebox x y s)
 219   (if (not (string-null? s))
 220       (ly:format "~4f ~4f moveto ~a\n" x y s)
 221       ""))
 222
 223 (define (polygon points blot-diameter filled?)
 224   (ly:format "~a ~4l ~a ~4f draw_polygon"
 225              (if filled? "true" "false")
 226              points
 227              (- (/ (length points) 2) 1)
 228              blot-diameter))
 229
 230 (define (repeat-slash width slope beam-thickness)
 231   (define (euclidean-length x y)
 232     (sqrt (+ (* x x) (* y y))))
 233
 234   (let ((x-width (euclidean-length beam-thickness (/ beam-thickness slope)))
 235         (height (* width slope)))
 236     (ly:format "~4l draw_repeat_slash"
 237              (list x-width width height))))
 238
 239
 240 (define (round-filled-box left right bottom top blotdiam)
 241   (let* ((halfblot (/ blotdiam 2))
 242          (x (- halfblot left))
 243          (width (- right (+ halfblot x)))
 244          (y (- halfblot bottom))
 245          (height (- top (+ halfblot y))))
 246     (ly:format  "~4l draw_round_box"
 247                 (list width height x y blotdiam))))
 248
 249 ;; save current color on stack and set new color
 250 (define (setcolor r g b)
 251   (ly:format "gsave ~4l setrgbcolor\n"
 252               (list r g b)))
 253
 254 ;; restore color from stack
 255 (define (resetcolor) "grestore\n")
 256
 257 ;; rotation around given point
 258 (define (setrotation ang x y)
 259   (ly:format "gsave ~4l translate ~a rotate ~4l translate\n"
 260              (list x y)
 261              ang
 262              (list (* -1 x) (* -1 y))))
 263
 264 (define (resetrotation ang x y)
 265   "grestore  ")
 266
 267 (define (unknown)
 268   "\n unknown\n")
 269
 270 (define (url-link url x y)
 271   (ly:format "~a ~a currentpoint vector_add  ~a ~a currentpoint vector_add (~a) mark_URI"
 272              (car x)
 273              (car y)
 274              (cdr x)
 275              (cdr y)
 276              url))
 277
 278 (define (page-link page-no x y)
 279   (if (number? page-no)
 280     (ly:format "~a ~a currentpoint vector_add  ~a ~a currentpoint vector_add ~a mark_page_link"
 281                (car x)
 282                (car y)
 283                (cdr x)
 284                (cdr y)
 285                page-no)
 286     ""))
 287
 288 (define* (path thickness exps #:optional (cap 'round) (join 'round) (fill? #f))
 289   (define (convert-path-exps exps)
 290     (if (pair? exps)
 291         (let*
 292             ((head (car exps))
 293              (rest (cdr exps))
 294              (arity
 295               (cond
 296                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 297                ((memq head '(rcurveto curveto)) 6)
 298                ((eq? head 'closepath) 0)
 299                (else 1)))
 300              (args (take rest arity))
 301              )
 302
 303           ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
 304           (cons (ly:format
 305                         "~l ~a "
 306                         args
 307                         head)
 308                 (convert-path-exps (drop rest arity))))
 309         '()))
 310
 311   (let ((cap-numeric (case cap ((butt) 0) ((round) 1) ((square) 2)
 312                        (else (begin
 313                                (ly:warning (_ "unknown line-cap-style: ~S")
 314                                            (symbol->string cap))
 315                                1))))
 316         (join-numeric (case join ((miter) 0) ((round) 1) ((bevel) 2)
 317                         (else (begin
 318                                 (ly:warning (_ "unknown line-join-style: ~S")
 319                                             (symbol->string join))
 320                                 1)))))
 321     (ly:format
 322      "gsave currentpoint translate
 323 ~a setlinecap ~a setlinejoin ~a setlinewidth
 324 ~l gsave stroke grestore ~a grestore"
 325      cap-numeric
 326      join-numeric
 327      thickness
 328      (convert-path-exps exps)
 329      (if fill? "fill" ""))))
 330
 331 (define (setscale x y)
 332   (ly:format "gsave ~4l scale\n"
 333               (list x y)))
 334
 335 (define (resetscale)
 336   "grestore\n")