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