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