scm/output-ps.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 1998--2010 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         (if (ly:input-location? music-origin)
 160             (let* ((location (ly:input-file-line-char-column music-origin))
 161                    (raw-file (car location))
 162                    (file (if (is-absolute? raw-file)
 163                              raw-file
 164                              (string-append (ly-getcwd) "/" raw-file)))
 165                    (x-ext (ly:grob-extent grob grob X))
 166                    (y-ext (ly:grob-extent grob grob Y)))
 167
 168               (if (and (< 0 (interval-length x-ext))
 169                        (< 0 (interval-length y-ext)))
 170                   (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n"
 171                              (+ (car offset) (car x-ext))
 172                              (+ (cdr offset) (car y-ext))
 173                              (+ (car offset) (cdr x-ext))
 174                              (+ (cdr offset) (cdr y-ext))
 175
 176                              ;; Backslashes are not valid
 177                              ;; file URI path separators.
 178                              (ly:string-percent-encode
 179                                (ly:string-substitute "\\" "/" file))
 180
 181                              (cadr location)
 182                              (caddr location)
 183                              (cadddr location))
 184                   ""))
 185             ""))
 186       ""))
 187
 188 (define (named-glyph font glyph)
 189   (ly:format "~a /~a glyphshow " ;;Why is there a space at the end?
 190              (ps-font-command font)
 191              glyph))
 192
 193 (define (no-origin)
 194   "")
 195
 196 (define (oval x-radius y-radius thick fill)
 197   (ly:format
 198    "~a ~4f ~4f ~4f draw_oval"
 199    (if fill
 200      "true"
 201      "false")
 202    x-radius y-radius thick))
 203
 204 (define (placebox x y s)
 205   (if (not (string-null? s))
 206       (ly:format "~4f ~4f moveto ~a\n" x y s)
 207       ""))
 208
 209 (define (polygon points blot-diameter filled?)
 210   (ly:format "~a ~4l ~a ~4f draw_polygon"
 211              (if filled? "true" "false")
 212              points
 213              (- (/ (length points) 2) 1)
 214              blot-diameter))
 215
 216 (define (repeat-slash width slope beam-thickness)
 217   (define (euclidean-length x y)
 218     (sqrt (+ (* x x) (* y y))))
 219
 220   (let ((x-width (euclidean-length beam-thickness (/ beam-thickness slope)))
 221         (height (* width slope)))
 222     (ly:format "~4l draw_repeat_slash"
 223              (list x-width width height))))
 224
 225
 226 (define (round-filled-box left right bottom top blotdiam)
 227   (let* ((halfblot (/ blotdiam 2))
 228          (x (- halfblot left))
 229          (width (- right (+ halfblot x)))
 230          (y (- halfblot bottom))
 231          (height (- top (+ halfblot y))))
 232     (ly:format  "~4l draw_round_box"
 233                 (list width height x y blotdiam))))
 234
 235 ;; save current color on stack and set new color
 236 (define (setcolor r g b)
 237   (ly:format "gsave ~4l setrgbcolor\n"
 238               (list r g b)))
 239
 240 ;; restore color from stack
 241 (define (resetcolor) "grestore\n")
 242
 243 ;; rotation around given point
 244 (define (setrotation ang x y)
 245   (ly:format "gsave ~4l translate ~a rotate ~4l translate\n"
 246              (list x y)
 247              ang
 248              (list (* -1 x) (* -1 y))))
 249
 250 (define (resetrotation ang x y)
 251   "grestore  ")
 252
 253 (define (unknown)
 254   "\n unknown\n")
 255
 256 (define (url-link url x y)
 257   (ly:format "~a ~a currentpoint vector_add  ~a ~a currentpoint vector_add (~a) mark_URI"
 258              (car x)
 259              (car y)
 260              (cdr x)
 261              (cdr y)
 262              url))
 263
 264 (define* (path thickness exps #:optional (cap 'round) (join 'round) (fill? #f))
 265   (define (convert-path-exps exps)
 266     (if (pair? exps)
 267         (let*
 268             ((head (car exps))
 269              (rest (cdr exps))
 270              (arity
 271               (cond
 272                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 273                ((memq head '(rcurveto curveto)) 6)
 274                ((eq? head 'closepath) 0)
 275                (else 1)))
 276              (args (take rest arity))
 277              )
 278
 279           ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
 280           (cons (ly:format
 281                         "~l ~a "
 282                         args
 283                         head)
 284                 (convert-path-exps (drop rest arity))))
 285         '()))
 286
 287   (let ((cap-numeric (case cap ((butt) 0) ((round) 1) ((square) 2)
 288                        (else (begin
 289                                (ly:warning (_ "unknown line-cap-style: ~S")
 290                                            (symbol->string cap))
 291                                1))))
 292         (join-numeric (case join ((miter) 0) ((round) 1) ((bevel) 2)
 293                         (else (begin
 294                                 (ly:warning (_ "unknown line-join-style: ~S")
 295                                             (symbol->string join))
 296                                 1)))))
 297     (ly:format
 298      "gsave currentpoint translate
 299 ~a setlinecap ~a setlinejoin ~a setlinewidth
 300 ~l gsave stroke grestore ~a grestore"
 301      cap-numeric
 302      join-numeric
 303      thickness
 304      (convert-path-exps exps)
 305      (if fill? "fill" ""))))