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