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