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