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