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