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 (define (char font i)
  62   (ly:format "~a (\\~a) show"
  63    (ps-font-command font)
  64    (ly:inexact->string i 8)))
  65
  66 (define (circle radius thick fill)
  67   (ly:format
  68    "~a ~4f ~4f draw_circle"
  69    (if fill
  70      "true"
  71      "false")
  72    radius thick))
  73
  74 (define (start-enclosing-id-node s)
  75   "")
  76
  77 (define (end-enclosing-id-node)
  78   "")
  79
  80 (define (dashed-line thick on off dx dy phase)
  81   (ly:format "~4f ~4f ~4f [ ~4f ~4f ] ~4f draw_dashed_line"
  82    dx
  83    dy
  84    thick
  85    on
  86    off
  87    phase))
  88
  89 (define (draw-line thick x1 y1 x2 y2)
  90   (ly:format "~4f ~4f ~4f ~4f ~4f draw_line"
  91           (- x2 x1) (- y2 y1)
  92           x1 y1 thick))
  93
  94 (define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill)
  95   (ly:format "~a ~a ~4f ~4f ~4f ~4f ~4f draw_partial_ellipse"
  96         (if fill "true" "false")
  97         (if connect "true" "false")
  98         x-radius
  99         y-radius
 100         start-angle
 101         end-angle
 102         thick))
 103
 104 (define (ellipse x-radius y-radius thick fill)
 105   (ly:format
 106    "~a ~4f ~4f ~4f draw_ellipse"
 107    (if fill
 108      "true"
 109      "false")
 110    x-radius y-radius thick))
 111
 112 (define (embedded-ps string)
 113   string)
 114
 115 (define (glyph-string postscript-font-name
 116                       size
 117                       cid?
 118                       w-x-y-named-glyphs)
 119
 120   (define (glyph-spec w x y g)
 121     (let ((prefix (if (string? g) "/" "")))
 122       (ly:format "~4f ~4f ~4f ~a~a"
 123                  w x y
 124                  prefix g)))
 125
 126   (ly:format
 127    (if cid?
 128 "/~a /CIDFont findresource ~a output-scale div scalefont setfont
 129 ~a
 130 ~a print_glyphs"
 131
 132 "/~a ~a output-scale div selectfont
 133 ~a
 134 ~a print_glyphs")
 135           postscript-font-name
 136           size
 137           (string-join (map (lambda (x) (apply glyph-spec x))
 138                             (reverse w-x-y-named-glyphs)) "\n")
 139           (length w-x-y-named-glyphs)))
 140
 141
 142 (define (grob-cause offset grob)
 143   (if (ly:get-option 'point-and-click)
 144       (let* ((cause (ly:grob-property grob 'cause))
 145              (music-origin (if (ly:stream-event? cause)
 146                                (ly:event-property cause 'origin)))
 147              (point-and-click (ly:get-option 'point-and-click)))
 148         (if (and
 149              (ly:input-location? music-origin)
 150              (cond ((boolean? point-and-click) point-and-click)
 151                    ((symbol? point-and-click)
 152                     (ly:in-event-class? cause point-and-click))
 153                    (else (any (lambda (t)
 154                                 (ly:in-event-class? cause t))
 155                               point-and-click))))
 156             (let* ((location (ly:input-file-line-char-column music-origin))
 157                    (raw-file (car location))
 158                    (file (if (is-absolute? raw-file)
 159                              raw-file
 160                              (string-append (ly-getcwd) "/" raw-file)))
 161                    (x-ext (ly:grob-extent grob grob X))
 162                    (y-ext (ly:grob-extent grob grob Y)))
 163
 164               (if (and (< 0 (interval-length x-ext))
 165                        (< 0 (interval-length y-ext)))
 166                   (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n"
 167                              (+ (car offset) (car x-ext))
 168                              (+ (cdr offset) (car y-ext))
 169                              (+ (car offset) (cdr x-ext))
 170                              (+ (cdr offset) (cdr y-ext))
 171
 172                              ;; Backslashes are not valid
 173                              ;; file URI path separators.
 174                              (ly:string-percent-encode
 175                                (ly:string-substitute "\\" "/" file))
 176
 177                              (cadr location)
 178                              (caddr location)
 179                              (cadddr location))
 180                   ""))
 181             ""))
 182       ""))
 183
 184 (define (named-glyph font glyph)
 185   (ly:format "~a /~a glyphshow " ;;Why is there a space at the end?
 186              (ps-font-command font)
 187              glyph))
 188
 189 (define (no-origin)
 190   "")
 191
 192 (define (placebox x y s)
 193   (if (not (string-null? s))
 194       (ly:format "~4f ~4f moveto ~a\n" x y s)
 195       ""))
 196
 197 (define (polygon points blot-diameter filled?)
 198   (ly:format "~a ~4l ~a ~4f draw_polygon"
 199              (if filled? "true" "false")
 200              points
 201              (- (/ (length points) 2) 1)
 202              blot-diameter))
 203
 204 (define (repeat-slash width slope beam-thickness)
 205   (define (euclidean-length x y)
 206     (sqrt (+ (* x x) (* y y))))
 207
 208   (let ((x-width (euclidean-length beam-thickness (/ beam-thickness slope)))
 209         (height (* width slope)))
 210     (ly:format "~4l draw_repeat_slash"
 211              (list x-width width height))))
 212
 213
 214 (define (round-filled-box left right bottom top blotdiam)
 215   (let* ((halfblot (/ blotdiam 2))
 216          (x (- halfblot left))
 217          (width (- right (+ halfblot x)))
 218          (y (- halfblot bottom))
 219          (height (- top (+ halfblot y))))
 220     (ly:format  "~4l draw_round_box"
 221                 (list width height x y blotdiam))))
 222
 223 ;; save current color on stack and set new color
 224 (define (setcolor r g b)
 225   (ly:format "gsave ~4l setrgbcolor\n"
 226               (list r g b)))
 227
 228 ;; restore color from stack
 229 (define (resetcolor) "grestore\n")
 230
 231 ;; rotation around given point
 232 (define (setrotation ang x y)
 233   (ly:format "gsave ~4l translate ~a rotate ~4l translate\n"
 234              (list x y)
 235              ang
 236              (list (* -1 x) (* -1 y))))
 237
 238 (define (resetrotation ang x y)
 239   "grestore  ")
 240
 241 (define (unknown)
 242   "\n unknown\n")
 243
 244 (define (url-link url x y)
 245   (ly:format "~a ~a currentpoint vector_add  ~a ~a currentpoint vector_add (~a) mark_URI"
 246              (car x)
 247              (car y)
 248              (cdr x)
 249              (cdr y)
 250              url))
 251
 252 (define (page-link page-no x y)
 253   (if (number? page-no)
 254     (ly:format "~a ~a currentpoint vector_add  ~a ~a currentpoint vector_add ~a mark_page_link"
 255                (car x)
 256                (car y)
 257                (cdr x)
 258                (cdr y)
 259                page-no)
 260     ""))
 261
 262 (define* (path thickness exps #:optional (cap 'round) (join 'round) (fill? #f))
 263   (define (convert-path-exps exps)
 264     (if (pair? exps)
 265         (let*
 266             ((head (car exps))
 267              (rest (cdr exps))
 268              (arity
 269               (cond
 270                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 271                ((memq head '(rcurveto curveto)) 6)
 272                ((eq? head 'closepath) 0)
 273                (else 1)))
 274              (args (take rest arity))
 275              )
 276
 277           ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
 278           (cons (ly:format
 279                         "~l ~a "
 280                         args
 281                         head)
 282                 (convert-path-exps (drop rest arity))))
 283         '()))
 284
 285   (let ((cap-numeric (case cap ((butt) 0) ((round) 1) ((square) 2)
 286                        (else (begin
 287                                (ly:warning (_ "unknown line-cap-style: ~S")
 288                                            (symbol->string cap))
 289                                1))))
 290         (join-numeric (case join ((miter) 0) ((round) 1) ((bevel) 2)
 291                         (else (begin
 292                                 (ly:warning (_ "unknown line-join-style: ~S")
 293                                             (symbol->string join))
 294                                 1)))))
 295     (ly:format
 296      "gsave currentpoint translate
 297 ~a setlinecap ~a setlinejoin ~a setlinewidth
 298 ~l gsave stroke grestore ~a grestore"
 299      cap-numeric
 300      join-numeric
 301      thickness
 302      (convert-path-exps exps)
 303      (if fill? "fill" ""))))
 304
 305 (define (setscale x y)
 306   (ly:format "gsave ~4l scale\n"
 307               (list x y)))
 308
 309 (define (resetscale)
 310   "grestore\n")