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