scm/output-ps.scm

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