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             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   (if (ly:get-option 'point-and-click)
 151       (let* ((cause (ly:grob-property grob 'cause))
 152              (music-origin (if (ly:stream-event? cause)
 153                                (ly:event-property cause 'origin))))
 154         (if (ly:input-location? music-origin)
 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
 184 (define (named-glyph font glyph)
 185   (ly:format "~a /~a glyphshow " ;;Why is there a space at the end?
 186              (ps-font-command font)
 187              glyph))
 188
 189 (define (no-origin)
 190   "")
 191
 192 (define (placebox x y s)
 193   (ly:format
 194 "~4f ~4f moveto
 195 ~a\n" x y s))
 196
 197 (define (polygon points blot-diameter filled?)
 198   (ly:format "~a ~4l ~a ~4f draw_polygon"
 199              (if filled? "true" "false")
 200              points
 201              (- (/ (length points) 2) 1)
 202              blot-diameter))
 203
 204 (define (repeat-slash width slope beam-thickness)
 205   (define (euclidean-length x y)
 206     (sqrt (+ (* x x) (* y y))))
 207
 208   (let ((x-width (euclidean-length beam-thickness (/ beam-thickness slope)))
 209         (height (* width slope)))
 210     (ly:format "~4l draw_repeat_slash"
 211              (list x-width width height))))
 212
 213
 214 (define (round-filled-box left right bottom top blotdiam)
 215   (let* ((halfblot (/ blotdiam 2))
 216          (x (- halfblot left))
 217          (width (- right (+ halfblot x)))
 218          (y (- halfblot bottom))
 219          (height (- top (+ halfblot y))))
 220     (ly:format  "~4l draw_round_box"
 221                 (list width height x y blotdiam))))
 222
 223 ;; save current color on stack and set new color
 224 (define (setcolor r g b)
 225   (ly:format "gsave ~4l setrgbcolor\n"
 226               (list r g b)))
 227
 228 ;; restore color from stack
 229 (define (resetcolor) "grestore \n")
 230
 231 ;; rotation around given point
 232 (define (setrotation ang x y)
 233   (ly:format "gsave ~4l translate ~a rotate ~4l translate\n"
 234              (list x y)
 235              ang
 236              (list (* -1 x) (* -1 y))))
 237
 238 (define (resetrotation ang x y)
 239   "grestore  ")
 240
 241
 242 (define (text font s)
 243   ;; (ly:warning (_ "TEXT backend-command encountered in Pango backend"))
 244   ;; (ly:warning (_ "Arguments: ~a ~a"" font str))
 245
 246   (let* ((space-length (cdar (ly:text-dimension font " ")))
 247          (space-move (string-append (number->string space-length)
 248                                     ;; how much precision do we need here?
 249                                     " 0.0 rmoveto "))
 250          (out-vec (decode-byte-string s)))
 251
 252     (string-append
 253      (ps-font-command font) " "
 254      (string-join
 255       (vector->list
 256        (vector-for-each
 257
 258         (lambda (sym)
 259           (if (eq? sym 'space)
 260               space-move
 261               (string-append "/" (symbol->string sym) " glyphshow")))
 262         out-vec))))))
 263
 264 (define (unknown)
 265   "\n unknown\n")
 266
 267 (define (url-link url x y)
 268   (ly:format "~a ~a currentpoint vector_add  ~a ~a currentpoint vector_add (~a) mark_URI"
 269              (car x)
 270              (car y)
 271              (cdr x)
 272              (cdr y)
 273              url))
 274
 275 (define (utf-8-string pango-font-description string)
 276   (ly:warning (_ "utf-8-string encountered in PS backend")))
 277
 278 (define (path thickness exps)
 279   (define (convert-path-exps exps)
 280     (if (pair? exps)
 281         (let*
 282             ((head (car exps))
 283              (rest (cdr exps))
 284              (arity
 285               (cond
 286                ((memq head '(rmoveto rlineto lineto moveto)) 2)
 287                ((memq head '(rcurveto curveto)) 6)
 288                (else 1)))
 289              (args (take rest arity))
 290              )
 291
 292           ;; WARNING: this is a vulnerability: a user can output arbitrary PS code here.
 293           (cons (ly:format
 294                         "~l ~a "
 295                         args
 296                         head)
 297                 (convert-path-exps (drop rest arity))))
 298         '()))
 299
 300
 301   (ly:format
 302    "1 setlinecap ~a setlinewidth\n~l stroke"
 303    thickness
 304    (convert-path-exps exps) ))
 305