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