scm/output-ps.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 1998--2014 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 pango-font
 116                       postscript-font-name
 117                       size
 118                       cid?
 119                       w-x-y-named-glyphs)
 120
 121   (define (glyph-spec w h x y g) ; h not used
 122     (let ((prefix (if (string? g) "/" "")))
 123       (ly:format "~4f ~4f ~4f ~a~a"
 124                  w x y
 125                  prefix g)))
 126
 127   (ly:format
 128    (if cid?
 129        "/~a /CIDFont findresource ~a output-scale div scalefont setfont
 130 ~a
 131 ~a print_glyphs"
 132
 133        "/~a ~a output-scale div selectfont
 134 ~a
 135 ~a print_glyphs")
 136    postscript-font-name
 137    size
 138    (string-join (map (lambda (x) (apply glyph-spec x))
 139                      (reverse w-x-y-named-glyphs)) "\n")
 140    (length w-x-y-named-glyphs)))
 141
 142
 143 (define (grob-cause offset grob)
 144   (if (ly:get-option 'point-and-click)
 145       (let* ((cause (ly:grob-property grob 'cause))
 146              (music-origin (if (ly:stream-event? cause)
 147                                (ly:event-property cause 'origin)))
 148              (point-and-click (ly:get-option 'point-and-click)))
 149         (if (and
 150              (ly:input-location? music-origin)
 151              (cond ((boolean? point-and-click) point-and-click)
 152                    ((symbol? point-and-click)
 153                     (ly:in-event-class? cause point-and-click))
 154                    (else (any (lambda (t)
 155                                 (ly:in-event-class? cause t))
 156                               point-and-click))))
 157             (let* ((location (ly:input-file-line-char-column music-origin))
 158                    (raw-file (car location))
 159                    (file (if (is-absolute? raw-file)
 160                              raw-file
 161                              (string-append (ly-getcwd) "/" raw-file)))
 162                    (x-ext (ly:grob-extent grob grob X))
 163                    (y-ext (ly:grob-extent grob grob Y)))
 164
 165               (if (and (< 0 (interval-length x-ext))
 166                        (< 0 (interval-length y-ext)))
 167                   (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n"
 168                              (+ (car offset) (car x-ext))
 169                              (+ (cdr offset) (car y-ext))
 170                              (+ (car offset) (cdr x-ext))
 171                              (+ (cdr offset) (cdr y-ext))
 172
 173                              ;; Backslashes are not valid
 174                              ;; file URI path separators.
 175                              (ly:string-percent-encode
 176                               (ly:string-substitute "\\" "/" file))
 177
 178                              (cadr location)
 179                              (caddr location)
 180                              (1+ (cadddr location)))
 181                   ""))
 182             ""))
 183       ""))
 184
 185 (define (named-glyph font glyph)
 186   (ly:format "~a /~a glyphshow " ;;Why is there a space at the end?
 187              (ps-font-command font)
 188              glyph))
 189
 190 (define (no-origin)
 191   "")
 192
 193 (define (placebox x y s)
 194   (if (not (string-null? s))
 195       (ly:format "~4f ~4f moveto ~a\n" x y s)
 196       ""))
 197
 198 (define (polygon points blot-diameter filled?)
 199   (ly:format "~a ~4l ~a ~4f draw_polygon"
 200              (if filled? "true" "false")
 201              points
 202              (- (/ (length points) 2) 1)
 203              blot-diameter))
 204
 205 (define (round-filled-box left right bottom top blotdiam)
 206   (let* ((halfblot (/ blotdiam 2))
 207          (x (- halfblot left))
 208          (width (- right (+ halfblot x)))
 209          (y (- halfblot bottom))
 210          (height (- top (+ halfblot y))))
 211     (ly:format  "~4l draw_round_box"
 212                 (list width height x y blotdiam))))
 213
 214 ;; save current color on stack and set new color
 215 (define (setcolor r g b)
 216   (ly:format "gsave ~4l setrgbcolor\n"
 217              (list r g b)))
 218
 219 ;; restore color from stack
 220 (define (resetcolor) "grestore\n")
 221
 222 ;; rotation around given point
 223 (define (setrotation ang x y)
 224   (ly:format "gsave ~4l translate ~a rotate ~4l translate\n"
 225              (list x y)
 226              ang
 227              (list (* -1 x) (* -1 y))))
 228
 229 (define (resetrotation ang x y)
 230   "grestore  ")
 231
 232 (define (unknown)
 233   "\n unknown\n")
 234
 235 (define (url-link url x y)
 236   (ly:format "~a ~a currentpoint vector_add  ~a ~a currentpoint vector_add (~a) mark_URI"
 237              (car x)
 238              (car y)
 239              (cdr x)
 240              (cdr y)
 241              url))
 242
 243 (define (page-link page-no x y)
 244   (if (number? page-no)
 245       (ly:format "~a ~a currentpoint vector_add  ~a ~a currentpoint vector_add ~a mark_page_link"
 246                  (car x)
 247                  (car y)
 248                  (cdr x)
 249                  (cdr y)
 250                  page-no)
 251       ""))
 252
 253 (define* (path thickness exps #:optional (cap 'round) (join 'round) (fill? #f))
 254   (define (convert-path-exps exps)
 255     (if (pair? exps)
 256         (let*
 257             ((head (car exps))
 258              (rest (cdr exps))
 259              (arity
 260               (cond
 261                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 262                ((memq head '(rcurveto curveto)) 6)
 263                ((eq? head 'closepath) 0)
 264                (else 1)))
 265              (args (take rest arity))
 266              )
 267
 268           ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
 269           (cons (ly:format
 270                  "~l ~a "
 271                  args
 272                  head)
 273                 (convert-path-exps (drop rest arity))))
 274         '()))
 275
 276   (let ((cap-numeric (case cap ((butt) 0) ((round) 1) ((square) 2)
 277                            (else (begin
 278                                    (ly:warning (_ "unknown line-cap-style: ~S")
 279                                                (symbol->string cap))
 280                                    1))))
 281         (join-numeric (case join ((miter) 0) ((round) 1) ((bevel) 2)
 282                             (else (begin
 283                                     (ly:warning (_ "unknown line-join-style: ~S")
 284                                                 (symbol->string join))
 285                                     1)))))
 286     (ly:format
 287      "gsave currentpoint translate
 288 ~a setlinecap ~a setlinejoin ~a setlinewidth
 289 ~l gsave stroke grestore ~a grestore"
 290      cap-numeric
 291      join-numeric
 292      thickness
 293      (convert-path-exps exps)
 294      (if fill? "fill" ""))))
 295
 296 (define (setscale x y)
 297   (ly:format "gsave ~4l scale\n"
 298              (list x y)))
 299
 300 (define (resetscale)
 301   "grestore\n")