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