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