scm/output-ps.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 1998--2010 Jan Nieuwenhuizen <janneke@gnu.org>
   4 ;;;;                 Han-Wen Nienhuys <hanwen@xs4all.nl>
   5 ;;;;
   6 ;;;; LilyPond is free software: you can redistribute it and/or modify
   7 ;;;; it under the terms of the GNU General Public License as published by
   8 ;;;; the Free Software Foundation, either version 3 of the License, or
   9 ;;;; (at your option) any later version.
  10 ;;;;
  11 ;;;; LilyPond is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;;; GNU General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU General Public License
  17 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;;; Note: currently misused as testbed for titles with markup, see
  20 ;;;;       input/test/title-markup.ly
  21 ;;;;
  22 ;;;; TODO:
  23 ;;;;   * %% Papersize in (header ...)
  24 ;;;;   * text setting, kerning.
  25 ;;;;   * document output-interface
  26
  27 (define-module (scm output-ps)
  28   #:re-export (quote))
  29
  30 (use-modules (guile)
  31              (ice-9 regex)
  32              (srfi srfi-1)
  33              (srfi srfi-13)
  34              (scm framework-ps)
  35              (lily))
  36
  37 ;;; helper functions, not part of output interface
  38 ;;;
  39
  40
  41 ;; ice-9 format uses a lot of memory
  42 ;; using simple-format almost halves lilypond cell usage
  43
  44 (define (str4 num)
  45   (if (or (nan? num) (inf? num))
  46       (begin
  47         (ly:warning (_ "Found infinity or nan in output. Substituting 0.0"))
  48         (if (ly:get-option 'strict-infinity-checking)
  49             (exit 1))
  50         "0.0")
  51       (ly:number->string num)))
  52
  53 (define (number-pair->string4 numpair)
  54   (ly:format "~4l" numpair))
  55
  56 ;;;
  57 ;;; Lily output interface, PostScript implementation --- cleanup and docme
  58 ;;;
  59
  60 ;; two beziers
  61 (define (bezier-sandwich lst thick)
  62   (ly:format "~l ~4f draw_bezier_sandwich"
  63              (map number-pair->string4 lst)
  64           thick))
  65
  66 (define (char font i)
  67   (ly:format "~a (\\~a) show"
  68    (ps-font-command font)
  69    (ly:inexact->string i 8)))
  70
  71 (define (circle radius thick fill)
  72   (ly:format
  73    "~a ~4f ~4f draw_circle"
  74    (if fill
  75      "true"
  76      "false")
  77    radius thick))
  78
  79 (define (dashed-line thick on off dx dy phase)
  80   (ly:format "~4f ~4f ~4f [ ~4f ~4f ] ~4f draw_dashed_line"
  81    dx
  82    dy
  83    thick
  84    on
  85    off
  86    phase))
  87
  88 ;; what the heck is this interface ?
  89 (define (dashed-slur thick on off l)
  90   (ly:format "~l ~4f [ ~4f ~4f ] 0 draw_dashed_slur"
  91           (let ((control-points (append (cddr l) (list (car l) (cadr l)))))
  92             (map number-pair->string4 control-points))
  93           thick
  94           on
  95           off))
  96
  97 (define (dot x y radius)
  98   (ly:format " ~4l draw_dot" (list radius x y)))
  99
 100 (define (draw-line thick x1 y1 x2 y2)
 101   (ly:format "~4f ~4f ~4f ~4f ~4f draw_line"
 102           (- x2 x1) (- y2 y1)
 103           x1 y1 thick))
 104
 105 (define (ellipse x-radius y-radius thick fill)
 106   (ly:format
 107    "~a ~4f ~4f ~4f draw_ellipse"
 108    (if fill
 109      "true"
 110      "false")
 111    x-radius y-radius thick))
 112
 113 (define (embedded-ps string)
 114   string)
 115
 116 (define (glyph-string postscript-font-name
 117                       size
 118                       cid?
 119                       w-x-y-named-glyphs)
 120
 121   (define (glyph-spec w x y g)
 122     (let ((prefix (if (string? g) "/" "")))
 123       (ly:format "~4f ~4f ~4f ~a~a"
 124                  w x y
 125                  prefix g)))
 126
 127   (ly:format
 128    (if cid?
 129 "/~a /CIDFont findresource ~a output-scale div scalefont setfont
 130 ~a
 131 ~a print_glyphs"
 132
 133 "/~a ~a output-scale div selectfont
 134 ~a
 135 ~a print_glyphs")
 136           postscript-font-name
 137           size
 138           (string-join (map (lambda (x) (apply glyph-spec x))
 139                             (reverse w-x-y-named-glyphs)) "\n")
 140           (length w-x-y-named-glyphs)))
 141
 142
 143 (define (grob-cause offset grob)
 144   (if (ly:get-option 'point-and-click)
 145       (let* ((cause (ly:grob-property grob 'cause))
 146              (music-origin (if (ly:stream-event? cause)
 147                                (ly:event-property cause 'origin))))
 148         (if (ly:input-location? music-origin)
 149             (let* ((location (ly:input-file-line-char-column music-origin))
 150                    (raw-file (car location))
 151                    (file (if (is-absolute? raw-file)
 152                              raw-file
 153                              (string-append (ly-getcwd) "/" raw-file)))
 154                    (x-ext (ly:grob-extent grob grob X))
 155                    (y-ext (ly:grob-extent grob grob Y)))
 156
 157               (if (and (< 0 (interval-length x-ext))
 158                        (< 0 (interval-length y-ext)))
 159                   (ly:format "~4f ~4f ~4f ~4f (textedit://~a:~a:~a:~a) mark_URI\n"
 160                              (+ (car offset) (car x-ext))
 161                              (+ (cdr offset) (car y-ext))
 162                              (+ (car offset) (cdr x-ext))
 163                              (+ (cdr offset) (cdr y-ext))
 164
 165                              ;; TODO
 166                              ;;full escaping.
 167
 168                              ;; backslash is interpreted by GS.
 169                              (ly:string-substitute "\\" "/"
 170                                                    (ly:string-substitute " " "%20" file))
 171                              (cadr location)
 172                              (caddr location)
 173                              (cadddr location))
 174                   ""))
 175             ""))
 176       ""))
 177
 178 (define (named-glyph font glyph)
 179   (ly:format "~a /~a glyphshow " ;;Why is there a space at the end?
 180              (ps-font-command font)
 181              glyph))
 182
 183 (define (no-origin)
 184   "")
 185
 186 (define (oval x-radius y-radius thick fill)
 187   (ly:format
 188    "~a ~4f ~4f ~4f draw_oval"
 189    (if fill
 190      "true"
 191      "false")
 192    x-radius y-radius thick))
 193
 194 (define (placebox x y s)
 195   (if (not (string-null? s))
 196       (ly:format "~4f ~4f moveto ~a\n" x y s)
 197       ""))
 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 currentpoint vector_add  ~a ~a currentpoint vector_add (~a) mark_URI"
 271              (car x)
 272              (car y)
 273              (cdr x)
 274              (cdr y)
 275              url))
 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                ((eq? head 'closepath) 0)
 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    "gsave currentpoint translate 1 setlinecap ~a setlinewidth\n~l stroke grestore"
 303    thickness
 304    (convert-path-exps exps)))
 305