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