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