scm/output-ps.scm

   1 ;;;; output-ps.scm -- implement Scheme output interface for PostScript
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;;                 Han-Wen Nienhuys <hanwen@xs4all.nl>
   7
   8 ;;;; Note: currently misused as testbed for titles with markup, see
   9 ;;;;       input/test/title-markup.ly
  10 ;;;;
  11 ;;;; TODO:
  12 ;;;;   * %% Papersize in (header ...)
  13 ;;;;   * text setting, kerning.
  14 ;;;;   * document output-interface
  15
  16 (define-module (scm output-ps)
  17   #:re-export (quote)
  18
  19   ;; JUNK this -- see lily.scm: ly:all-output-backend-commands
  20   #:export (unknown
  21             bezier-sandwich
  22             char
  23             circle
  24             comment
  25             dashed-line
  26             dashed-slur
  27             dot
  28             draw-line
  29             embedded-ps
  30             named-glyph
  31             no-origin
  32             placebox
  33             polygon
  34             repeat-slash
  35             resetcolor
  36             resetrotation
  37             round-filled-box
  38             setcolor
  39             setrotation
  40             text
  41             zigzag-line))
  42
  43
  44 (use-modules (guile)
  45              (ice-9 regex)
  46              (srfi srfi-1)
  47              (srfi srfi-13)
  48              (scm framework-ps)
  49              (lily))
  50
  51 ;;; helper functions, not part of output interface
  52 ;;;
  53
  54
  55 (define (escape-parentheses s)
  56   (regexp-substitute/global #f "(^|[^\\])([\\(\\)])" s 'pre 1 "\\" 2 'post))
  57
  58 (define (ps-encoding text)
  59   (escape-parentheses text))
  60
  61 (define (round2 num)
  62   (/ (round (* 100 num)) 100))
  63
  64 (define (round4 num)
  65   (/ (round (* 10000 num)) 10000))
  66
  67 (define (str4 num)
  68   (if (or (nan? num) (inf? num))
  69       (begin
  70         (ly:warning (_ "Found infinity or nan in output. Substituting 0.0"))
  71         "0.0")
  72       (format #f "~f" (round4 num))))
  73
  74 (define (number-pair->string4 numpair)
  75   (string-append (str4 (car numpair))
  76                  " "
  77                  (str4 (cdr numpair))))
  78
  79 (define (numbers->string4 numlist)
  80   (string-join (map str4 numlist) " "))
  81
  82 ;; FIXME: lily-def
  83 (define-public (ps-string-def prefix key val)
  84   (format #f "/ ~a~a (~a) def\n"
  85           prefix
  86           (symbol->string key)
  87           (escape-parentheses val)))
  88
  89 (define (ps-number-def prefix key val)
  90   (let ((s (if (integer? val)
  91                (ly:number->string val)
  92                (ly:number->string (exact->inexact val)))))
  93     (format #f "/~a~a ~a def\n"
  94             prefix
  95             (symbol->string key) s)))
  96
  97
  98 ;;;
  99 ;;; Lily output interface, PostScript implementation --- cleanup and docme
 100 ;;;
 101
 102 ;; two beziers
 103 (define (bezier-sandwich lst thick)
 104   (format #f "~a ~a draw_bezier_sandwich"
 105           (string-join (map number-pair->string4 lst) " ")
 106           (str4 thick)))
 107
 108 (define (char font i)
 109   (format #f "~a (\\~a) show"
 110    (ps-font-command font)
 111    (ly:inexact->string i 8)))
 112
 113 (define (circle radius thick fill)
 114   (format #f
 115    "~a ~f ~f draw_circle"
 116    (if fill
 117      "true"
 118      "false")
 119    (round4 radius) (round4 thick)))
 120
 121 (define (dashed-line thick on off dx dy phase)
 122   (format #f "~a ~a ~a [ ~a ~a ] ~a draw_dashed_line"
 123    (str4 dx)
 124    (str4 dy)
 125    (str4 thick)
 126    (str4 on)
 127    (str4 off)
 128    (str4 phase)
 129
 130    ))
 131
 132 ;; what the heck is this interface ?
 133 (define (dashed-slur thick on off l)
 134   (format #f "~a ~a [ ~a ~a ] 0 draw_dashed_slur"
 135           (let ((control-points (append (cddr l) (list (car l) (cadr l)))))
 136             (string-join (map number-pair->string4 control-points) " "))
 137           (str4 thick)
 138           (str4 on)
 139           (str4 off)))
 140
 141 (define (dot x y radius)
 142   (format #f " ~a draw_dot"
 143    (numbers->string4 (list radius x y))))
 144
 145 (define (draw-line thick x1 y1 x2 y2)
 146   (format #f "~a ~a ~a ~a ~a draw_line"
 147           (str4 (- x2 x1))
 148           (str4 (- y2 y1))
 149           (str4 x1)
 150           (str4 y1)
 151           (str4 thick)))
 152
 153 (define (embedded-ps string)
 154   string)
 155
 156 (define (glyph-string postscript-font-name
 157                       size
 158                       cid?
 159                       w-x-y-named-glyphs)
 160
 161   (define (glyph-spec w x y g)
 162     (let ((prefix (if (string? g) "/" "")))
 163       (format #f "~f ~f ~a~a"
 164               (round2 (+ w x))
 165               (round2 y)
 166               prefix g)))
 167
 168   (format #f
 169           (if cid?
 170 "/~a /CIDFont findresource ~a output-scale div scalefont setfont
 171 ~a
 172 ~a print_glyphs"
 173
 174 "/~a ~a output-scale div selectfont
 175 ~a
 176 ~a print_glyphs")
 177           postscript-font-name
 178           size
 179           (string-join (map (lambda (x) (apply glyph-spec x))
 180                             (reverse w-x-y-named-glyphs)) "\n")
 181           (length w-x-y-named-glyphs)))
 182
 183
 184 (define (grob-cause offset grob)
 185   (let* ((cause (ly:grob-property grob 'cause))
 186          (music-origin (if (ly:stream-event? cause)
 187                            (ly:event-property cause 'origin))))
 188     (if (not (ly:input-location? music-origin))
 189         ""
 190         (let* ((location (ly:input-file-line-char-column music-origin))
 191                (raw-file (car location))
 192                (file (if (is-absolute? raw-file)
 193                          raw-file
 194                          (string-append (ly-getcwd) "/" raw-file)))
 195                (x-ext (ly:grob-extent grob grob X))
 196                (y-ext (ly:grob-extent grob grob Y)))
 197
 198           (if (and (< 0 (interval-length x-ext))
 199                    (< 0 (interval-length y-ext)))
 200               (format #f "~$ ~$ ~$ ~$ (textedit://~a:~a:~a:~a) mark_URI\n"
 201                       (+ (car offset) (car x-ext))
 202                       (+ (cdr offset) (car y-ext))
 203                       (+ (car offset) (cdr x-ext))
 204                       (+ (cdr offset) (cdr y-ext))
 205
 206                       ;; TODO
 207                       ;;full escaping.
 208
 209                       ;; backslash is interpreted by GS.
 210                       (string-regexp-substitute "\\\\" "/"
 211                                       (string-regexp-substitute " " "%20" file))
 212                       (cadr location)
 213                       (caddr location)
 214                       (cadddr location))
 215               "")))))
 216
 217 (define (lily-def key val)
 218   (let ((prefix "lilypondlayout"))
 219     (if (string=?
 220           (substring key 0 (min (string-length prefix) (string-length key)))
 221           prefix)
 222       (format "/~a { ~a } bind def\n" key val)
 223       (format "/~a (~a) def\n" key val))))
 224
 225 (define (named-glyph font glyph)
 226   (format #f "~a /~a glyphshow " ;;Why is there a space at the end?
 227           (ps-font-command font)
 228           glyph))
 229
 230 (define (no-origin)
 231   "")
 232
 233 (define (placebox x y s)
 234   (format #f
 235 "~a ~a moveto
 236 ~a\n"
 237   (str4 x)
 238   (str4 y)
 239   s))
 240
 241 (define (polygon points blot-diameter filled?)
 242   (format #f "~a ~a ~a ~a draw_polygon"
 243           (if filled? "true" "false")
 244           (numbers->string4 points)
 245           (number->string (- (/ (length points) 2) 1))
 246           (str4 blot-diameter)))
 247
 248 (define (repeat-slash width slope beam-thickness)
 249   (define (euclidean-length x y)
 250     (sqrt (+ (* x x) (* y y))))
 251
 252   (let ((x-width (euclidean-length beam-thickness (/ beam-thickness slope)))
 253         (height (* width slope)))
 254     (format #f "~a draw_repeat_slash"
 255             (numbers->string4 (list x-width width height)))))
 256
 257
 258 (define (round-filled-box left right bottom top blotdiam)
 259   (let* ((halfblot (/ blotdiam 2))
 260          (x (- halfblot left))
 261          (width (- right (+ halfblot x)))
 262          (y (- halfblot bottom))
 263          (height (- top (+ halfblot y))))
 264     (format #f "~a draw_round_box"
 265             (numbers->string4
 266               (list width height x y blotdiam)))))
 267
 268 ;; save current color on stack and set new color
 269 (define (setcolor r g b)
 270   (format #f "gsave ~a setrgbcolor\n"
 271           (numbers->string4 (list r g b))))
 272
 273 ;; restore color from stack
 274 (define (resetcolor) "grestore \n")
 275
 276 ;; rotation around given point
 277 (define (setrotation ang x y)
 278   (format "gsave ~a translate ~a rotate ~a translate\n"
 279     (numbers->string4 (list x y))
 280     (number->string ang)
 281     (numbers->string4 (list (* -1 x) (* -1 y)))))
 282
 283 (define (resetrotation ang x y)
 284   "grestore  ")
 285
 286
 287 (define (text font s)
 288   ;; (ly:warning (_ "TEXT backend-command encountered in Pango backend"))
 289   ;; (ly:warning (_ "Arguments: ~a ~a"" font str))
 290
 291   (let* ((space-length (cdar (ly:text-dimension font " ")))
 292          (space-move (string-append (number->string space-length)
 293                                     ;; how much precision do we need here?
 294                                     " 0.0 rmoveto "))
 295          (out-vec (decode-byte-string s)))
 296
 297     (string-append
 298      (ps-font-command font) " "
 299      (string-join
 300       (vector->list
 301        (vector-for-each
 302
 303         (lambda (sym)
 304           (if (eq? sym 'space)
 305               space-move
 306               (string-append "/" (symbol->string sym) " glyphshow")))
 307         out-vec))))))
 308
 309 (define (unknown)
 310   "\n unknown\n")
 311
 312 (define (url-link url x y)
 313   (format #f "~$ ~$ ~$ ~$ (~a) mark_URI"
 314           (car x)
 315           (car y)
 316           (cdr x)
 317           (cdr y)
 318           url))
 319
 320 (define (utf-8-string pango-font-description string)
 321   (ly:warning (_ "utf-8-string encountered in PS backend")))
 322
 323
 324 (define (zigzag-line centre? zzw zzh thick dx dy)
 325   (format #f "~a ~a ~a ~a 0 0 ~a ~a draw_zigzag_line"
 326    (if centre? "true" "false")
 327    (str4 zzw)
 328    (str4 zzh)
 329    (str4 thick)
 330    (str4 dx)
 331    (str4 dy)))
 332
 333
 334 (define (path thickness exps)
 335   (define (convert-path-exps exps)
 336     (if (pair? exps)
 337         (let*
 338             ((head (car exps))
 339              (rest (cdr exps))
 340              (arity
 341               (cond
 342                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 343                ((memq head '(rcurveto curveto)) 6)
 344                (else 1)))
 345              (args (take rest arity))
 346              )
 347
 348           ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
 349           (cons (format "~a ~a "
 350                         (string-join (map (lambda (x) (format "~a " x)) args) " ")
 351                         head)
 352                 (convert-path-exps (drop rest arity))))
 353         '()))
 354
 355
 356   (format
 357    "1 setlinecap ~a setlinewidth\n~a stroke"
 358    thickness
 359    (string-join (convert-path-exps exps) " ")))
 360