scm/output-ps.scm

   1 ;;;; 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     ;;(format (current-error-port) "DEFINE-FONTS: ~S\n" internal-external-name-mag-pairs)
 139
 140     (string-append
 141      "/" command
 142      " { /"
 143      ;; Ugh, the Bluesky type1 fonts for computer modern use capitalized
 144      ;; postscript font names.
 145      (possibly-capitalize-font-name (car name-mag))
 146      " findfont "
 147      "20 " (ly:number->string (cdr name-mag)) " mul "
 148      "output-scale div scalefont setfont } bind def "
 149      "\n"))
 150
 151   (define (ps-encoded-fontswitch name-mag-pair)
 152     (let* ((key (car name-mag-pair))
 153            (value (cdr name-mag-pair)))
 154       (cons key
 155             (cons value
 156                   (string-append "lilyfont"
 157                                  (car value)
 158                                  "-"
 159                                  (number->string (cdr value)))))))
 160
 161   (set! font-name-alist (map ps-encoded-fontswitch
 162                              internal-external-name-mag-pairs))
 163
 164   (apply string-append
 165          (map (lambda (x) (font-load-command (car x) (cdr x)))
 166               (map cdr font-name-alist))))
 167
 168 (define (define-origin file line col) "")
 169
 170 (define (dot x y radius)
 171   (string-append
 172    " "
 173    (numbers->string
 174     (list x y radius)) " draw_dot"))
 175
 176 (define (zigzag-line centre? zzw zzh thick dx dy)
 177   (string-append
 178     (if centre? "true" "false")
 179     " "
 180     (ly:number->string zzw)
 181     " "
 182     (ly:number->string zzh)
 183     " "
 184     (ly:number->string thick)
 185     " 0 0 "
 186     (ly:number->string dx)
 187     " "
 188     (ly:number->string dy)
 189     " draw_zigzag_line "))
 190
 191 (define (draw-line thick x1 y1 x2 y2)
 192   (string-append
 193   "     1 setlinecap
 194         1 setlinejoin "
 195   (ly:number->string thick)
 196         " setlinewidth "
 197    (ly:number->string x1)
 198    " "
 199    (ly:number->string y1)
 200    " moveto "
 201    (ly:number->string x2)
 202    " "
 203    (ly:number->string y2)
 204    " lineto stroke"))
 205
 206 (define (polygon points blotdiameter)
 207   (string-append
 208    " "
 209    (numbers->string points)
 210    (ly:number->string (/ (length points) 2))
 211    (ly:number->string blotdiameter)
 212    " draw_polygon"))
 213
 214 (define (end-output)
 215   "\nend-lilypond-output\n")
 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 (horizontal-line x1 x2 th)
 229   (draw-line th x1  0 x2 0))
 230
 231 (define (fontify name-mag-pair exp)
 232
 233   (define (select-font name-mag-pair)
 234     (let ((c (assoc name-mag-pair font-name-alist)))
 235
 236       (if c
 237           (string-append " " (cddr c) " ")
 238           (begin
 239             (ly:warn
 240              (format "Programming error: No such font: ~S" name-mag-pair))
 241
 242             (display "FAILED\n" (current-error-port))
 243             (if #f ;(pair? name-mag-pair))
 244                 (display (object-type (car name-mag-pair)) (current-error-port))
 245                 (write name-mag-pair (current-error-port)))
 246             (if #f ;  (pair? font-name-alist)
 247                 (display
 248                  (object-type (caaar font-name-alist)) (current-error-port))
 249                 (write font-name-alist (current-error-port)))
 250
 251             ;; (format #f "\n%FAILED: (select-font ~S)\n" name-mag-pair))
 252             ""))))
 253
 254   (string-append (select-font name-mag-pair) exp))
 255
 256 (define (header creator generate)
 257   (string-append
 258    "%!PS-Adobe-3.0\n"
 259    "%%Creator: " creator generate "\n"))
 260
 261 (define (header-end)
 262   (string-append
 263    ;; URG: now we can't use scm output without Lily
 264    (ly:gulp-file "lilyponddefs.ps")
 265    "{exch pop //systemdict /run get exec}\n\n"
 266    (ly:gulp-file "music-drawing-routines.ps")
 267    "{ exch pop //systemdict /run get exec }\n\n"
 268    ;; ps-testing wreaks havoc when used with lilypond-book.
 269    ;;  -- is this still true with new modules system?
 270 ;;   (if (defined? 'ps-testing) "\n /testing true def" "")
 271   ;   "\n /testing true def"
 272    ))
 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 (define (no-origin) "")
 283
 284 (define (placebox x y s)
 285   (string-append
 286    (ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
 287
 288 (define (repeat-slash wid slope thick)
 289   (string-append
 290    (numbers->string (list wid slope thick))
 291    " draw_repeat_slash"))
 292
 293 (define (round-filled-box x y width height blotdiam)
 294    (string-append
 295     " "
 296     (numbers->string
 297      (list x y width height blotdiam)) " draw_round_box"))
 298
 299 (define (start-system width height)
 300   (string-append
 301    "\n" (ly:number->string height)
 302    " start-system\n"
 303    "{\n"
 304    "set-ps-scale-to-lily-scale\n"
 305
 306    ;; URG
 307    (if (pair? header-stencils)
 308        (let ((s (output-stencils header-stencils)))
 309          (set! header-stencils '())
 310          (string-append s (stop-system) (start-system width height)))
 311        "")))
 312
 313 (define (stem breapth width depth height)
 314   (string-append
 315    (numbers->string (list breapth width depth height))
 316    " draw_box" ))
 317
 318 (define (stop-last-system)
 319   (stop-system))
 320
 321 (define (stop-system)
 322   "}\nstop-system\n")
 323
 324 (define (text s)
 325   (string-append "(" s ") show "))
 326
 327 (define (unknown)
 328   "\n unknown\n")
 329
 330 ;; top-of-file, wtf?
 331 (define (top-of-file)
 332   (header (string-append "GNU LilyPond (" (lilypond-version) "), ")
 333           (strftime "%c" (localtime (current-time))))
 334   ;;; ugh
 335   (ps-string-def
 336    "lilypond" 'tagline
 337    (string-append "Engraved by LilyPond (" (lilypond-version) ")")))
 338
 339 (define (output-paper-def pd)
 340   (apply
 341    string-append
 342    (module-map
 343     (lambda (sym var)
 344       (let ((val (variable-ref var))
 345             (key (symbol->string sym)))
 346
 347         (cond
 348          ((string? val)
 349           (ps-string-def "lilypondpaper" sym val))
 350          ((number? val)
 351           (ps-number-def "lilypondpaper" sym
 352                          (if (integer? val)
 353                              (number->string val)
 354                              (number->string (exact->inexact val)))))
 355          (else ""))))
 356
 357     (ly:output-def-scope pd))))
 358
 359
 360 (define (ps-string-def a b c)
 361   (string-append "/" a (symbol->string b) " (" c ") def\n"))
 362
 363 (define (ps-number-def a b c)
 364   (string-append "/" a (symbol->string b) " " c " def\n"))
 365
 366
 367 (define (output-scopes paper scopes fields basename)
 368
 369   ;; FIXME: customise/generate these
 370   (let ((props '((;;(linewidth . 120)
 371                   (font-family . roman)
 372                   (word-space . 1)
 373                   (baseline-skip . 2)
 374                   (font-series . medium)
 375                   (font-style . roman)
 376                   (font-shape . upright)
 377                   (font-size . 0)))))
 378
 379     (define (output-scope scope)
 380       (apply
 381        string-append
 382        (module-map
 383         (lambda (sym var)
 384           (let ((val (variable-ref var))
 385                 (tex-key (symbol->string sym)))
 386
 387             (if (memq sym fields)
 388                 (header-to-file basename sym val))
 389
 390             (cond
 391              ;; define strings, for /make-lilypond-title to pick up
 392              ((string? val) (ps-string-def "lilypond" sym val))
 393
 394              ;; output markups ourselves
 395              ((markup? val) (set! header-stencils
 396                                   (append header-stencils
 397                                      (list
 398                                       (ly:stencil-get-expr
 399                                        (interpret-markup paper props val)))))
 400
 401               "")
 402              ((number? val) (ps-number-def
 403                              "lilypond" sym (if (integer? val)
 404                                                 (number->string val)
 405                                                 (number->string
 406                                                  (exact->inexact val)))))
 407              (else ""))))
 408         scope)))
 409
 410     (string-append
 411      (apply string-append (map output-scope scopes)))))
 412
 413 (define (add-offsets a b)
 414   (cons (+ (car a) (car b))
 415         (+ (cdr a) (cdr b))))
 416
 417 (define (input? foe)
 418   #f)
 419
 420 (define header-stencils '())
 421
 422 (define (output-stencils lst)
 423   (apply string-append (map (lambda (x) (output-stencil x '(10 . -10))) lst)))
 424
 425 ;; TODO:
 426 ;; de-urg me
 427 ;; implement ly:input stuff
 428 ;; replace C++ variant
 429 ;; stencil->string?
 430 (define (output-stencil expr o)
 431   (let ((s ""))
 432     (while
 433      (pair? expr)
 434      (let ((head (car expr)))
 435        (cond ((input? head)
 436               (set! s (string-append
 437                        s (define-origin (ly:input-file-string head))))
 438               (set! expr (cadr expr)))
 439              ((eq? head 'no-origin)
 440               (set! s (string-append s (expression->string head)))
 441               (set! expr (cadr expr)))
 442              ((eq? head 'translate-stencil)
 443               (set! o (add-offsets o (cadr expr)))
 444               (set! expr (caddr expr)))
 445              ((eq? head 'combine-stencil)
 446               (set! s (string-append s (output-stencil (cadr expr) o)))
 447               (set! expr (caddr expr)))
 448              (else
 449               (set!
 450                s (string-append
 451                   s
 452                        (placebox (car o) (cdr o)
 453                                  (expression->string expr))))
 454               (set! expr #f)))))
 455   s))