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