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