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          cmbxti7
 103          cmbxti8
 104          cmcsc12
 105          cmcsc7
 106          cmtt17
 107
 108          ;;; FIXME: added
 109          cmbx8)))
 110
 111 (define (define-fonts internal-external-name-mag-pairs)
 112
 113   (define (font-load-command name-mag command)
 114
 115     ;; frobnicate NAME to jibe with external definitions.
 116     (define (possibly-capitalize-font-name name)
 117       (cond
 118        ((and (equal? (substring name 0 2) "cm")
 119              (not (member name lily-traced-cm-fonts)))
 120         (string-upcase name))
 121        ((equal? (substring name 0 4) "feta")
 122         (regexp-substitute/global #f "feta([a-z-]*)([0-9]+)" name 'pre "GNU-LilyPond-feta" 1 "-" 2 'post))
 123        (else name)))
 124
 125     ;;(format (current-error-port) "DEFINE-FONTS: ~S\n" internal-external-name-mag-pairs)
 126
 127     (string-append
 128      "/" command
 129      " { /"
 130      ;; Ugh, the Bluesky type1 fonts for computer modern use capitalized
 131      ;; postscript font names.
 132      (possibly-capitalize-font-name (car name-mag))
 133      " findfont "
 134      "20 " (ly:number->string (cdr name-mag)) " mul "
 135      "output-scale div scalefont setfont } bind def "
 136      "\n"))
 137
 138   (define (ps-encoded-fontswitch name-mag-pair)
 139     (let* ((key (car name-mag-pair))
 140            (value (cdr name-mag-pair)))
 141       (cons key
 142             (cons value
 143                   (string-append "lilyfont"
 144                                  (car value)
 145                                  "-"
 146                                  (number->string (cdr value)))))))
 147
 148   (set! font-name-alist (map ps-encoded-fontswitch
 149                              internal-external-name-mag-pairs))
 150
 151   (apply string-append
 152          (map (lambda (x) (font-load-command (car x) (cdr x)))
 153               (map cdr font-name-alist))))
 154
 155 (define (define-origin file line col) "")
 156
 157 (define (dot x y radius)
 158   (string-append
 159    " "
 160    (numbers->string
 161     (list x y radius)) " draw_dot"))
 162
 163 (define (zigzag-line centre? zzw zzh thick dx dy)
 164   (string-append
 165     (if centre? "true" "false")
 166     " "
 167     (ly:number->string zzw)
 168     " "
 169     (ly:number->string zzh)
 170     " "
 171     (ly:number->string thick)
 172     " 0 0 "
 173     (ly:number->string dx)
 174     " "
 175     (ly:number->string dy)
 176     " draw_zigzag_line "))
 177
 178 (define (draw-line thick x1 y1 x2 y2)
 179   (string-append
 180   "     1 setlinecap
 181         1 setlinejoin "
 182   (ly:number->string thick)
 183         " setlinewidth "
 184    (ly:number->string x1)
 185    " "
 186    (ly:number->string y1)
 187    " moveto "
 188    (ly:number->string x2)
 189    " "
 190    (ly:number->string y2)
 191    " lineto stroke"))
 192
 193 (define (polygon points blotdiameter)
 194   (string-append
 195    " "
 196    (numbers->string points)
 197    (ly:number->string (/ (length points) 2))
 198    (ly:number->string blotdiameter)
 199    " draw_polygon"))
 200
 201 (define (end-output)
 202   "\nend-lilypond-output\n")
 203
 204 (define (ez-ball ch letter-col ball-col)
 205   (string-append
 206    " (" ch ") "
 207    (numbers->string (list letter-col ball-col))
 208    " /Helvetica-Bold " ;; ugh
 209    " draw_ez_ball"))
 210
 211 (define (filledbox breapth width depth height)
 212   (string-append (numbers->string (list breapth width depth height))
 213                  " draw_box"))
 214
 215 (define (horizontal-line x1 x2 th)
 216   (draw-line th x1  0 x2 0))
 217
 218 (define (fontify name-mag-pair exp)
 219
 220   (define (select-font name-mag-pair)
 221     (let ((c (assoc name-mag-pair font-name-alist)))
 222
 223       (if c
 224           (string-append " " (cddr c) " ")
 225           (begin
 226             (ly:warn
 227              (format "Programming error: No such font: ~S" name-mag-pair))
 228
 229             (display "FAILED\n" (current-error-port))
 230             (if #f ;(pair? name-mag-pair))
 231                 (display (object-type (car name-mag-pair)) (current-error-port))
 232                 (write name-mag-pair (current-error-port)))
 233             (if #f ;  (pair? font-name-alist)
 234                 (display
 235                  (object-type (caaar font-name-alist)) (current-error-port))
 236                 (write font-name-alist (current-error-port)))
 237
 238             ;; (format #f "\n%FAILED: (select-font ~S)\n" name-mag-pair))
 239             ""))))
 240
 241   (string-append (select-font name-mag-pair) exp))
 242
 243 (define (header creator generate)
 244   (string-append
 245    "%!PS-Adobe-3.0\n"
 246    "%%Creator: " creator generate "\n"))
 247
 248 (define (header-end)
 249   (string-append
 250    ;; URG: now we can't use scm output without Lily
 251    (ly:gulp-file "lilyponddefs.ps")
 252    "{exch pop //systemdict /run get exec}\n\n"
 253    (ly:gulp-file "music-drawing-routines.ps")
 254    "{ exch pop //systemdict /run get exec }\n\n"
 255    ;; ps-testing wreaks havoc when used with lilypond-book.
 256    ;;  -- is this still true with new modules system?
 257 ;;   (if (defined? 'ps-testing) "\n /testing true def" "")
 258   ;   "\n /testing true def"
 259    ))
 260
 261 (define (lily-def key val)
 262   (let ((prefix "lilypondpaper"))
 263     (if (string=?
 264          (substring key 0 (min (string-length prefix) (string-length key)))
 265          prefix)
 266         (string-append "/" key " {" val "} bind def\n")
 267         (string-append "/" key " (" val ") def\n"))))
 268
 269 (define (no-origin) "")
 270
 271 (define (placebox x y s)
 272   (string-append
 273    (ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
 274
 275 (define (repeat-slash wid slope thick)
 276   (string-append
 277    (numbers->string (list wid slope thick))
 278    " draw_repeat_slash"))
 279
 280 (define (round-filled-box x y width height blotdiam)
 281    (string-append
 282     " "
 283     (numbers->string
 284      (list x y width height blotdiam)) " draw_round_box"))
 285
 286 (define (start-system width height)
 287   (string-append
 288    "\n" (ly:number->string height)
 289    " start-system\n"
 290    "{\n"
 291    "set-ps-scale-to-lily-scale"))
 292
 293 (define (stem breapth width depth height)
 294   (string-append
 295    (numbers->string (list breapth width depth height))
 296    " draw_box" ))
 297
 298 (define (stop-last-system)
 299   (stop-system))
 300
 301 (define (stop-system)
 302   "}\nstop-system\n")
 303
 304 (define (text s)
 305   (string-append "(" s ") show "))
 306
 307 (define (unknown)
 308   "\n unknown\n")
 309
 310 ;; top-of-file, wtf?
 311 (define (top-of-file)
 312   (header (string-append "GNU LilyPond (" (lilypond-version) "), ")
 313           (strftime "%c" (localtime (current-time))))
 314   ;;; ugh
 315   (ps-string-def
 316    "lilypond" 'tagline
 317    (string-append "Engraved by LilyPond (" (lilypond-version) ")")))
 318
 319 (define (output-paper-def pd)
 320   (apply
 321    string-append
 322    (module-map
 323     (lambda (sym var)
 324       (let ((val (variable-ref var))
 325             (key (symbol->string sym)))
 326
 327         (cond
 328          ((string? val)
 329           (ps-string-def "lilypondpaper" sym val))
 330          ((number? val)
 331           (ps-number-def "lilypondpaper" sym
 332                          (if (integer? val)
 333                              (number->string val)
 334                              (number->string (exact->inexact val)))))
 335          (else ""))))
 336
 337     (ly:output-def-scope pd))))
 338
 339
 340 (define (ps-string-def a b c)
 341   (string-append "/" a (symbol->string b) " (" c ") def\n"))
 342
 343 (define (ps-number-def a b c)
 344   (string-append "/" a (symbol->string b) " " c " def\n"))
 345
 346
 347 (define (output-scopes paper scopes fields basename)
 348
 349   ;; FIXME: customise/generate these
 350   (let ((nmp '((("feta20"  . 0.569055118110236) "feta20" . 1.0)
 351                (("cmbx10"  . 0.569055118110236) "cmbx10" . 1.0)
 352                (("cmr10"   . 0.569055118110236) "cmr10" . 1.0)
 353                (("cmr10"   . 0.638742773474948) "cmr10" . 1.0)
 354                (("cmcsc10" . 0.451659346558038) "cmcs10" . 1.0)
 355                (("cmcsc10" . 0.638742773474948) "cmcs10" . 1.0)
 356                (("cmbx8"   . 0.564574183197548) "cmbx8" . 1.0)))
 357
 358         (props '(((font-family . roman)
 359                   (word-space . 1)
 360                   (font-shape . upright)
 361                   (font-size . -2)))))
 362
 363
 364     (define (output-scope scope)
 365       (apply
 366        string-append
 367        (module-map
 368         (lambda (sym var)
 369           (let ((val (variable-ref var))
 370                 (tex-key (symbol->string sym)))
 371
 372             (if (memq sym fields)
 373                 (header-to-file basename sym val))
 374
 375             (cond
 376              ;; define strings, for /make-lilypond-title to pick up
 377              ((string? val) (ps-string-def "lilypond" sym val))
 378
 379              ;; output markups ourselves
 380              ((markup? val) (string-append
 381                              (expression->string
 382                               (ly:stencil-get-expr
 383                                (interpret-markup paper props val)))
 384                              "\n"))
 385              ((number? val) (ps-number-def
 386                              "lilypond" sym (if (integer? val)
 387                                                 (number->string val)
 388                                                 (number->string
 389                                                  (exact->inexact val)))))
 390              (else ""))))
 391         scope)))
 392
 393     (string-append
 394      ;; urg
 395      " 0 0 moveto\n"
 396      (define-fonts nmp)
 397      (apply string-append (map output-scope scopes)))))