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