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