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