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