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