scm/output-ps.scm

   1 ;;;; output-ps.scm -- implement Scheme output routines for PostScript
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c)  1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8 ;; TODO:
   9 ;;   * testbed for titles with markup
  10 ;;   * font size and designsize
  11 ;;   * FIXME: breaks when outputting strings with parentheses.
  12
  13
  14 (debug-enable 'backtrace)
  15
  16 (define-module (scm output-ps))
  17 (define this-module (current-module))
  18
  19 (use-modules
  20  (guile)
  21  (ice-9 regex)
  22  (lily))
  23
  24
  25 ;;; Lily output interface, PostScript implementation --- cleanup and docme
  26
  27 ;; Module entry
  28 (define-public (ps-output-expression expr port)
  29   (display (expression->string expr) port))
  30
  31
  32 (define (expression->string expr)
  33   (eval expr this-module))
  34
  35 ;; Global vars
  36
  37 ;; alist containing fontname -> fontcommand assoc (both strings)
  38 (define font-name-alist '())
  39
  40 ;; WIP -- stencils from markup? values of output-scopes
  41 (define header-stencil #f)
  42
  43 ;; Interface functions
  44 (define (beam width slope thick blot)
  45   (string-append
  46    (numbers->string (list slope width thick blot)) " draw_beam" ))
  47
  48 ;; two beziers
  49 (define (bezier-sandwich l thick)
  50   (string-append
  51    (apply string-append (map number-pair->string l))
  52    (ly:number->string thick)
  53    " draw_bezier_sandwich "))
  54
  55 (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
  56   (string-append
  57    (numbers->string
  58     (list arch_angle arch_width arch_height height arch_thick thick))
  59    " draw_bracket"))
  60
  61 (define (symmetric-x-triangle thick w h)
  62   (string-append
  63    (numbers->string (list h w thick))
  64    " draw_symmetric_x_triangle"))
  65
  66
  67 (define (char i)
  68   (string-append
  69    "(\\" (inexact->string i 8) ") show " ))
  70
  71
  72 (define (comment s)
  73   (string-append "% " s "\n"))
  74
  75
  76 (define (dashed-line thick on off dx dy)
  77   (string-append
  78    (ly:number->string dx)
  79    " "
  80    (ly:number->string dy)
  81    " "
  82    (ly:number->string thick)
  83    " [ "
  84    (ly:number->string on)
  85    " "
  86    (ly:number->string off)
  87    " ] 0 draw_dashed_line"))
  88
  89 ;; what the heck is this interface ?
  90 (define (dashed-slur thick dash l)
  91   (string-append
  92    (apply string-append (map number-pair->string l))
  93    (ly:number->string thick)
  94    " [ "
  95    (ly:number->string dash)
  96    " "
  97    ;;UGH.  10 ?
  98    (ly:number->string (* 10 thick))
  99    " ] 0 draw_dashed_slur"))
 100
 101 (define lily-traced-cm-fonts
 102   (map symbol->string
 103        '(cmbx14
 104          cmbx17
 105          cmbxti12
 106          cmbxti14
 107          cmbxti6
 108          cmbxti7
 109          cmbxti8
 110          cmcsc12
 111          cmcsc7
 112          cmcsc8
 113          cmss5
 114          cmss6
 115          cmss7
 116          cmti5
 117          cmti6
 118          cmtt17
 119          cmtt5
 120          cmtt6
 121          cmtt7)))
 122
 123
 124 (define (define-fonts internal-external-name-mag-pairs)
 125
 126   (define (font-load-command name-mag command)
 127
 128     ;; frobnicate NAME to jibe with external definitions.
 129     (define (possibly-capitalize-font-name name)
 130       (cond
 131        ((and (equal? (substring name 0 2) "cm")
 132              (not (member name lily-traced-cm-fonts)))
 133
 134         ;; huh, how is this supposed to work?
 135         ;;(string-upcase name)
 136
 137         (string-append name ".pfb"))
 138
 139        ((equal? (substring name 0 4) "feta")
 140         (regexp-substitute/global #f "feta([a-z-]*)([0-9]+)" name 'pre "GNU-LilyPond-feta" 1 "-" 2 'post))
 141        (else name)))
 142
 143     (string-append
 144      "/" command
 145      " { /"
 146      ;; Ugh, the Bluesky type1 fonts for computer modern use capitalized
 147      ;; postscript font names.
 148      (possibly-capitalize-font-name (car name-mag))
 149      " findfont "
 150      "20 " (ly:number->string (cdr name-mag)) " mul "
 151      "output-scale div scalefont setfont } bind def "
 152      "\n"))
 153
 154   (define (ps-encoded-fontswitch name-mag-pair)
 155     (let* ((key (car name-mag-pair))
 156            (value (cdr name-mag-pair)))
 157       (cons key
 158             (cons value
 159                   (string-append "lilyfont"
 160                                  (car value)
 161                                  "-"
 162                                  (number->string (cdr value)))))))
 163
 164   (set! font-name-alist (map ps-encoded-fontswitch
 165                              internal-external-name-mag-pairs))
 166
 167   (apply string-append
 168          (map (lambda (x) (font-load-command (car x) (cdr x)))
 169               (map cdr font-name-alist))))
 170
 171 (define (define-origin file line col) "")
 172
 173 (define (dot x y radius)
 174   (string-append
 175    " "
 176    (numbers->string
 177     (list x y radius)) " draw_dot"))
 178
 179 (define (zigzag-line centre? zzw zzh thick dx dy)
 180   (string-append
 181     (if centre? "true" "false")
 182     " "
 183     (ly:number->string zzw)
 184     " "
 185     (ly:number->string zzh)
 186     " "
 187     (ly:number->string thick)
 188     " 0 0 "
 189     (ly:number->string dx)
 190     " "
 191     (ly:number->string dy)
 192     " draw_zigzag_line "))
 193
 194 (define (draw-line thick x1 y1 x2 y2)
 195   (string-append
 196   "     1 setlinecap
 197         1 setlinejoin "
 198   (ly:number->string thick)
 199         " setlinewidth "
 200    (ly:number->string x1)
 201    " "
 202    (ly:number->string y1)
 203    " moveto "
 204    (ly:number->string x2)
 205    " "
 206    (ly:number->string y2)
 207    " lineto stroke"))
 208
 209 (define (polygon points blotdiameter)
 210   (string-append
 211    " "
 212    (numbers->string points)
 213    (ly:number->string (/ (length points) 2))
 214    (ly:number->string blotdiameter)
 215    " draw_polygon"))
 216
 217 (define (end-output)
 218   "\nend-lilypond-output\n")
 219
 220 (define (ez-ball ch letter-col ball-col)
 221   (string-append
 222    " (" ch ") "
 223    (numbers->string (list letter-col ball-col))
 224    " /Helvetica-Bold " ;; ugh
 225    " draw_ez_ball"))
 226
 227 (define (filledbox breapth width depth height)
 228   (string-append (numbers->string (list breapth width depth height))
 229                  " draw_box"))
 230
 231 (define (horizontal-line x1 x2 th)
 232   (draw-line th x1  0 x2 0))
 233
 234 (define (fontify name-mag-pair exp)
 235
 236   (define (select-font name-mag-pair)
 237     (let ((c (assoc name-mag-pair font-name-alist)))
 238
 239       (if c
 240           (string-append " " (cddr c) " ")
 241           (begin
 242             (ly:warn
 243              (format "Programming error: No such font: ~S" name-mag-pair))
 244
 245             (display "FAILED\n" (current-error-port))
 246             (if #f ;(pair? name-mag-pair))
 247                 (display (object-type (car name-mag-pair)) (current-error-port))
 248                 (write name-mag-pair (current-error-port)))
 249             (if #f ;  (pair? font-name-alist)
 250                 (display
 251                  (object-type (caaar font-name-alist)) (current-error-port))
 252                 (write font-name-alist (current-error-port)))
 253
 254             ;; (format #f "\n%FAILED: (select-font ~S)\n" name-mag-pair))
 255             ""))))
 256
 257   (string-append (select-font name-mag-pair) exp))
 258
 259 (define (header creator generate)
 260   (string-append
 261    "%!PS-Adobe-3.0\n"
 262    "%%Creator: " creator generate "\n"))
 263
 264 (define (header-end)
 265   (string-append
 266    ;; URG: now we can't use scm output without Lily
 267    (ly:gulp-file "lilyponddefs.ps")
 268    "{exch pop //systemdict /run get exec}\n\n"
 269    (ly:gulp-file "music-drawing-routines.ps")
 270    "{ exch pop //systemdict /run get exec }\n\n"
 271    ;; ps-testing wreaks havoc when used with lilypond-book.
 272    ;;  -- is this still true with new modules system?
 273 ;;   (if (defined? 'ps-testing) "\n /testing true def" "")
 274   ;   "\n /testing true def"
 275    ))
 276
 277 (define (lily-def key val)
 278   (let ((prefix "lilypondpaper"))
 279     (if (string=?
 280          (substring key 0 (min (string-length prefix) (string-length key)))
 281          prefix)
 282         (string-append "/" key " {" val "} bind def\n")
 283         (string-append "/" key " (" val ") def\n"))))
 284
 285 (define (no-origin) "")
 286
 287 (define (placebox x y s)
 288   (string-append
 289    (ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
 290
 291 (define (repeat-slash wid slope thick)
 292   (string-append
 293    (numbers->string (list wid slope thick))
 294    " draw_repeat_slash"))
 295
 296 (define (round-filled-box x y width height blotdiam)
 297    (string-append
 298     " "
 299     (numbers->string
 300      (list x y width height blotdiam)) " draw_round_box"))
 301
 302 (define (start-system width height)
 303   (string-append
 304    "\n" (ly:number->string height)
 305    " start-system\n"
 306    "{\n"
 307    "set-ps-scale-to-lily-scale\n"))
 308
 309 (define (stem breapth width depth height)
 310   (string-append
 311    (numbers->string (list breapth width depth height))
 312    " draw_box" ))
 313
 314 (define (stop-last-system)
 315   (stop-system))
 316
 317 (define (stop-system)
 318   "}\nstop-system\n")
 319
 320 (define (text s)
 321   (string-append "(" s ") show "))
 322
 323 (define (unknown)
 324   "\n unknown\n")
 325
 326 ;; top-of-file, wtf?
 327 (define (top-of-file)
 328   (header (string-append "GNU LilyPond (" (lilypond-version) "), ")
 329           (strftime "%c" (localtime (current-time))))
 330   ;;; ugh
 331   (ps-string-def
 332    "lilypond" 'tagline
 333    (string-append "Engraved by LilyPond (" (lilypond-version) ")")))
 334
 335 (define (output-paper-def pd)
 336   (apply
 337    string-append
 338    (module-map
 339     (lambda (sym var)
 340       (let ((val (variable-ref var))
 341             (key (symbol->string sym)))
 342
 343         (cond
 344          ((string? val)
 345           (ps-string-def "lilypondpaper" sym val))
 346          ((number? val)
 347           (ps-number-def "lilypondpaper" sym
 348                          (if (integer? val)
 349                              (number->string val)
 350                              (number->string (exact->inexact val)))))
 351          (else ""))))
 352
 353     (ly:output-def-scope pd))))
 354
 355
 356 (define (ps-string-def a b c)
 357   (string-append "/" a (symbol->string b) " (" c ") def\n"))
 358
 359 (define (ps-number-def a b c)
 360   (string-append "/" a (symbol->string b) " " c " def\n"))
 361
 362
 363 (define (output-scopes paper scopes fields basename)
 364
 365   ;; FIXME: customise/generate these
 366   (let ((props '(((font-family . roman)
 367                   (word-space . 1)
 368                   (baseline-skip . 2)
 369                   (font-series . medium)
 370                   (font-style . roman)
 371                   (font-shape . upright)
 372                   (font-size . 0))))
 373         (stencils '())
 374         (baseline-skip 2))
 375
 376     (define (output-scope-entry sym var)
 377       (let ((val (variable-ref var))
 378             (tex-key (symbol->string sym)))
 379
 380         (if (memq sym fields)
 381             (header-to-file basename sym val))
 382
 383         (cond
 384          ((eq? sym 'font)
 385           BARF
 386           (format (current-error-port) "PROPS:~S\n" val)
 387           (set! props (cons val props))
 388           "")
 389
 390          ;; define strings, for /make-lilypond-title to pick up
 391          ((string? val) (ps-string-def "lilypond" sym val))
 392
 393          ;; generate stencil from markup
 394          ((markup? val) (set! stencils
 395                               (append
 396                                stencils
 397                                (list
 398                                 (interpret-markup paper props val))))
 399           "")
 400          ((number? val) (ps-number-def
 401                          "lilypond" sym (if (integer? val)
 402                                             (number->string val)
 403                                             (number->string
 404                                              (exact->inexact val)))))
 405          (else ""))))
 406
 407     (define (output-scope scope)
 408       (apply string-append (module-map output-scope-entry scope)))
 409
 410     (let ((s (string-append (apply string-append (map output-scope scopes)))))
 411       (set! header-stencil (stack-lines DOWN 0 baseline-skip stencils))
 412
 413       ;; trigger font load
 414       (ly:stencil-get-expr header-stencil)
 415       s)))
 416
 417 (define (offset-add a b)
 418   (cons (+ (car a) (car b))
 419         (+ (cdr a) (cdr b))))
 420
 421 (define (make-title port)
 422   (if header-stencil
 423       (let ((x-ext (ly:stencil-get-extent header-stencil Y))
 424             (y-ext (ly:stencil-get-extent header-stencil X)))
 425         (display (start-system (interval-length x-ext) (interval-length y-ext))
 426                  port)
 427         (output-stencil port (ly:stencil-get-expr header-stencil) '(0 . 0))
 428         (display (stop-system) port)))
 429   "")
 430
 431 ;; hmm, looks like recursing call is always last statement, does guile
 432 ;; think so too?
 433 (define (output-stencil port expr offset)
 434   (if (pair? expr)
 435       (let ((head (car expr)))
 436         (cond
 437          ((ly:input-location? head)
 438           (display (apply define-origin (ly:input-location head)) port)
 439           (output-stencil port (cadr expr) offset))
 440          ((eq? head 'no-origin)
 441           (display (expression->string head) port)
 442           (output-stencil port (cadr expr) offset))
 443          ((eq? head 'translate-stencil)
 444           (output-stencil port (caddr expr) (offset-add offset (cadr expr))))
 445          ((eq? head 'combine-stencil)
 446           (output-stencil port (cadr expr) offset)
 447           (output-stencil port (caddr expr) offset))
 448          (else
 449           (display (placebox (car offset) (cdr offset)
 450                              (expression->string expr)) port))))))
 451