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              (srfi srfi-1)
  33              (srfi srfi-13)
  34              (scm framework-ps)
  35              (lily))
  36
  37 ;;; helper functions, not part of output interface
  38 ;;;
  39
  40
  41 ;; ice-9 format uses a lot of memory
  42 ;; using simple-format almost halves lilypond cell usage
  43
  44 (define (str4 num)
  45   (if (or (nan? num) (inf? num))
  46       (begin
  47         (ly:warning (_ "Found infinity or nan in output. Substituting 0.0"))
  48         (if (ly:get-option 'strict-infinity-checking)
  49             (exit 1))
  50         "0.0")
  51       (ly:number->string num)))
  52
  53 (define (number-pair->string4 numpair)
  54   (ly:format "~4l" numpair))
  55
  56 ;;;
  57 ;;; Lily output interface, PostScript implementation --- cleanup and docme
  58 ;;;
  59
  60 ;; two beziers
  61 (define (bezier-sandwich lst thick)
  62   (ly:format "~l ~4f draw_bezier_sandwich"
  63              (map number-pair->string4 lst)
  64           thick))
  65
  66 (define (char font i)
  67   (ly:format "~a (\\~a) show"
  68    (ps-font-command font)
  69    (ly:inexact->string i 8)))
  70
  71 (define (circle radius thick fill)
  72   (ly:format
  73    "~a ~4f ~4f draw_circle"
  74    (if fill
  75      "true"
  76      "false")
  77    radius thick))
  78
  79 (define (dashed-line thick on off dx dy phase)
  80   (ly:format "~4f ~4f ~4f [ ~4f ~4f ] ~4f draw_dashed_line"
  81    dx
  82    dy
  83    thick
  84    on
  85    off
  86    phase))
  87
  88 ;; what the heck is this interface ?
  89 (define (dashed-slur thick on off l)
  90   (ly:format "~l ~4f [ ~4f ~4f ] 0 draw_dashed_slur"
  91           (let ((control-points (append (cddr l) (list (car l) (cadr l)))))
  92             (map number-pair->string4 control-points))
  93           thick
  94           on
  95           off))
  96
  97 (define (dot x y radius)
  98   (ly:format " ~4l draw_dot" (list radius x y)))
  99
 100 (define (draw-line thick x1 y1 x2 y2)
 101   (ly:format "~4f ~4f ~4f ~4f ~4f draw_line"
 102           (- x2 x1) (- y2 y1)
 103           x1 y1 thick))
 104
 105 (define (connected-shape pointlist thick x-scale y-scale connect fill)
 106   (ly:format "~a~4f ~4f ~4f ~4f ~a ~a draw_connected_shape"
 107     (string-concatenate
 108       (map (lambda (x)
 109              (apply (if (eq? (length x) 6)
 110                         (lambda (x1 x2 x3 x4 x5 x6)
 111                           (ly:format "~4f ~4f ~4f ~4f ~4f ~4f 6 "
 112                                      x1
 113                                      x2
 114                                      x3
 115                                      x4
 116                                      x5
 117                                      x6))
 118                         (lambda (x1 x2)
 119                            (ly:format "~4f ~4f 2 " x1 x2)))
 120                     x))
 121            (reverse pointlist)))
 122       (length pointlist)
 123       x-scale
 124       y-scale
 125       thick
 126       (if connect "true" "false")
 127       (if fill "true" "false")))
 128
 129 (define (partial-ellipse x-radius y-radius start-angle end-angle thick connect fill)
 130   (ly:format "~a ~a ~4f ~4f ~4f ~4f ~4f draw_partial_ellipse"
 131         (if fill "true" "false")
 132         (if connect "true" "false")
 133         x-radius
 134         y-radius
 135         start-angle
 136         end-angle
 137         thick))
 138
 139 (define (ellipse x-radius y-radius thick fill)
 140   (ly:format
 141    "~a ~4f ~4f ~4f draw_ellipse"
 142    (if fill
 143      "true"
 144      "false")
 145    x-radius y-radius thick))
 146
 147 (define (embedded-ps string)
 148   string)
 149
 150 (define (glyph-string postscript-font-name
 151                       size
 152                       cid?
 153                       w-x-y-named-glyphs)
 154
 155   (define (glyph-spec w x y g)
 156     (let ((prefix (if (string? g) "/" "")))
 157       (ly:format "~4f ~4f ~4f ~a~a"
 158                  w x y
 159                  prefix g)))
 160
 161   (ly:format
 162    (if cid?
 163 "/~a /CIDFont findresource ~a output-scale div scalefont setfont
 164 ~a
 165 ~a print_glyphs"
 166
 167 "/~a ~a output-scale div selectfont
 168 ~a
 169 ~a print_glyphs")
 170           postscript-font-name
 171           size
 172           (string-join (map (lambda (x) (apply glyph-spec x))
 173                             (reverse w-x-y-named-glyphs)) "\n")
 174           (length w-x-y-named-glyphs)))
 175
 176
 177 (define (grob-cause offset grob)
 178   (if (ly:get-option 'point-and-click)
 179       (let* ((cause (ly:grob-property grob 'cause))
 180              (music-origin (if (ly:stream-event? cause)
 181                                (ly:event-property cause 'origin))))
 182         (if (ly:input-location? music-origin)
 183             (let* ((location (ly:input-file-line-char-column music-origin))
 184                    (raw-file (car location))
 185                    (file (if (is-absolute? raw-file)
 186                              raw-file
 187                              (string-append (ly-getcwd) "/" raw-file)))
 188                    (x-ext (ly:grob-extent grob grob X))
 189                    (y-ext (ly:grob-extent grob grob Y)))
 190
 191               (if (and (< 0 (interval-length x-ext))
 192                        (< 0 (interval-length y-ext)))
 193                   (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n"
 194                              (+ (car offset) (car x-ext))
 195                              (+ (cdr offset) (car y-ext))
 196                              (+ (car offset) (cdr x-ext))
 197                              (+ (cdr offset) (cdr y-ext))
 198
 199                              ;; Backslashes are not valid
 200                              ;; file URI path separators.
 201                              (ly:string-percent-encode
 202                                (ly:string-substitute "\\" "/" file))
 203
 204                              (cadr location)
 205                              (caddr location)
 206                              (cadddr location))
 207                   ""))
 208             ""))
 209       ""))
 210
 211 (define (named-glyph font glyph)
 212   (ly:format "~a /~a glyphshow " ;;Why is there a space at the end?
 213              (ps-font-command font)
 214              glyph))
 215
 216 (define (no-origin)
 217   "")
 218
 219 (define (oval x-radius y-radius thick fill)
 220   (ly:format
 221    "~a ~4f ~4f ~4f draw_oval"
 222    (if fill
 223      "true"
 224      "false")
 225    x-radius y-radius thick))
 226
 227 (define (placebox x y s)
 228   (if (not (string-null? s))
 229       (ly:format "~4f ~4f moveto ~a\n" x y s)
 230       ""))
 231
 232 (define (polygon points blot-diameter filled?)
 233   (ly:format "~a ~4l ~a ~4f draw_polygon"
 234              (if filled? "true" "false")
 235              points
 236              (- (/ (length points) 2) 1)
 237              blot-diameter))
 238
 239 (define (repeat-slash width slope beam-thickness)
 240   (define (euclidean-length x y)
 241     (sqrt (+ (* x x) (* y y))))
 242
 243   (let ((x-width (euclidean-length beam-thickness (/ beam-thickness slope)))
 244         (height (* width slope)))
 245     (ly:format "~4l draw_repeat_slash"
 246              (list x-width width height))))
 247
 248
 249 (define (round-filled-box left right bottom top blotdiam)
 250   (let* ((halfblot (/ blotdiam 2))
 251          (x (- halfblot left))
 252          (width (- right (+ halfblot x)))
 253          (y (- halfblot bottom))
 254          (height (- top (+ halfblot y))))
 255     (ly:format  "~4l draw_round_box"
 256                 (list width height x y blotdiam))))
 257
 258 ;; save current color on stack and set new color
 259 (define (setcolor r g b)
 260   (ly:format "gsave ~4l setrgbcolor\n"
 261               (list r g b)))
 262
 263 ;; restore color from stack
 264 (define (resetcolor) "grestore\n")
 265
 266 ;; rotation around given point
 267 (define (setrotation ang x y)
 268   (ly:format "gsave ~4l translate ~a rotate ~4l translate\n"
 269              (list x y)
 270              ang
 271              (list (* -1 x) (* -1 y))))
 272
 273 (define (resetrotation ang x y)
 274   "grestore  ")
 275
 276 (define (unknown)
 277   "\n unknown\n")
 278
 279 (define (url-link url x y)
 280   (ly:format "~a ~a currentpoint vector_add  ~a ~a currentpoint vector_add (~a) mark_URI"
 281              (car x)
 282              (car y)
 283              (cdr x)
 284              (cdr y)
 285              url))
 286
 287 (define (path thickness exps)
 288   (define (convert-path-exps exps)
 289     (if (pair? exps)
 290         (let*
 291             ((head (car exps))
 292              (rest (cdr exps))
 293              (arity
 294               (cond
 295                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 296                ((memq head '(rcurveto curveto)) 6)
 297                ((eq? head 'closepath) 0)
 298                (else 1)))
 299              (args (take rest arity))
 300              )
 301
 302           ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
 303           (cons (ly:format
 304                         "~l ~a "
 305                         args
 306                         head)
 307                 (convert-path-exps (drop rest arity))))
 308         '()))
 309
 310
 311   (ly:format
 312    "gsave currentpoint translate 1 setlinecap ~a setlinewidth\n~l stroke grestore"
 313    thickness
 314    (convert-path-exps exps)))