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--2003 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8
   9 (debug-enable 'backtrace)
  10
  11
  12 (define-module (scm output-ps))
  13 (define this-module (current-module))
  14
  15 (use-modules
  16  (guile)
  17  (ice-9 regex)
  18  (lily))
  19
  20
  21
  22 ;;; Lily output interface --- cleanup and docme
  23
  24 ;; TODO: fucks up if outputting strings with parentheses.
  25
  26 ;; Module entry
  27 (define-public (ps-output-expression expr port)
  28   (display (eval expr this-module) port))
  29
  30
  31 ;; Global vars
  32
  33 ;; alist containing fontname -> fontcommand assoc (both strings)
  34 (define font-name-alist '())
  35
  36
  37 ;; Interface functions
  38 (define (beam width slope thick)
  39   (string-append
  40    (numbers->string (list slope width thick)) " draw_beam" ))
  41
  42 ;; two beziers
  43 (define (bezier-sandwich l thick)
  44   (string-append
  45    (apply string-append (map number-pair->string l))
  46    (ly:number->string thick)
  47    " draw_bezier_sandwich "))
  48
  49 (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
  50   (string-append
  51    (numbers->string
  52     (list arch_angle arch_width arch_height height arch_thick thick))
  53    " draw_bracket"))
  54
  55 (define (symmetric-x-triangle thick w h)
  56   (string-append
  57    (numbers->string (list h w thick))
  58    " draw_symmetric_x_triangle"))
  59
  60
  61 (define (char i)
  62   (string-append
  63    "(\\" (inexact->string i 8) ") show " ))
  64
  65
  66 (define (comment s)
  67   (string-append "% " s "\n"))
  68
  69
  70 (define (dashed-line thick on off dx dy)
  71   (string-append
  72    (ly:number->string dx)
  73    " "
  74    (ly:number->string dy)
  75    " "
  76    (ly:number->string thick)
  77    " [ "
  78    (ly:number->string on)
  79    " "
  80    (ly:number->string off)
  81    " ] 0 draw_dashed_line"))
  82
  83 ;; what the heck is this interface ?
  84 (define (dashed-slur thick dash l)
  85   (string-append
  86    (apply string-append (map number-pair->string l))
  87    (ly:number->string thick)
  88    " [ "
  89    (ly:number->string dash)
  90    " "
  91    ;;UGH.  10 ?
  92    (ly:number->string (* 10 thick))
  93    " ] 0 draw_dashed_slur"))
  94
  95 (define lily-traced-cm-fonts
  96   (map symbol->string
  97        '(cmbx14
  98          cmbx17
  99          cmbxti12
 100          cmbxti14
 101          cmbxti7
 102          cmbxti8
 103          cmcsc12
 104          cmcsc7
 105          cmtt17)))
 106
 107 (define (define-fonts internal-external-name-mag-pairs)
 108
 109   (define (font-load-command name-mag command)
 110
 111     ;; frobnicate NAME to jibe with external definitions.
 112     (define (possibly-capitalize-font-name name)
 113       (cond
 114        ((and (equal? (substring name 0 2) "cm")
 115              (not (member name lily-traced-cm-fonts)))
 116         (string-upcase name))
 117        ((equal? (substring name 0 4) "feta")
 118         (regexp-substitute/global #f "feta([a-z-]*)([0-9]+)" name 'pre "GNU-LilyPond-feta" 1 "-" 2 'post))
 119        (else name)))
 120
 121     (string-append
 122      "/" command
 123      " { /"
 124      ;; Ugh, the Bluesky type1 fonts for computer modern use capitalized
 125      ;; postscript font names.
 126      (possibly-capitalize-font-name (car name-mag))
 127      " findfont "
 128      "20 " (ly:number->string (cdr name-mag)) " mul "
 129      "output-scale div scalefont setfont } bind def "
 130      "\n"))
 131
 132   (define (ps-encoded-fontswitch name-mag-pair)
 133     (let* ((key (car name-mag-pair))
 134            (value (cdr name-mag-pair)))
 135       (cons key
 136             (cons value
 137                   (string-append "lilyfont"
 138                                  (car value)
 139                                  "-"
 140                                  (number->string (cdr value)))))))
 141
 142   (set! font-name-alist (map ps-encoded-fontswitch
 143                              internal-external-name-mag-pairs))
 144
 145   (apply string-append
 146          (map (lambda (x) (font-load-command (car x) (cdr x)))
 147               (map cdr font-name-alist))))
 148
 149 (define (define-origin file line col) "")
 150
 151 (define (dot x y radius)
 152   (string-append
 153    " "
 154    (numbers->string
 155     (list x y radius)) " draw_dot"))
 156
 157 (define (zigzag-line centre? zzw zzh thick dx dy)
 158   (string-append
 159     (if centre? "true" "false")
 160     " "
 161     (ly:number->string zzw)
 162     " "
 163     (ly:number->string zzh)
 164     " "
 165     (ly:number->string thick)
 166     " 0 0 "
 167     (ly:number->string dx)
 168     " "
 169     (ly:number->string dy)
 170     " draw_zigzag_line "))
 171
 172 (define (draw-line thick x1 y1 x2 y2)
 173   (string-append
 174   "     1 setlinecap
 175         1 setlinejoin "
 176   (ly:number->string thick)
 177         " setlinewidth "
 178    (ly:number->string x1)
 179    " "
 180    (ly:number->string y1)
 181    " moveto "
 182    (ly:number->string x2)
 183    " "
 184    (ly:number->string y2)
 185    " lineto stroke"))
 186
 187 (define (polygon points blotdiameter)
 188   (string-append
 189    " "
 190    (numbers->string points)
 191    (ly:number->string (/ (length points) 2))
 192    (ly:number->string blotdiameter)
 193    " draw_polygon"))
 194
 195 (define (end-output)
 196   "\nend-lilypond-output\n")
 197
 198 (define (ez-ball ch letter-col ball-col)
 199   (string-append
 200    " (" ch ") "
 201    (numbers->string (list letter-col ball-col))
 202    " /Helvetica-Bold " ;; ugh
 203    " draw_ez_ball"))
 204
 205 (define (filledbox breapth width depth height)
 206   (string-append (numbers->string (list breapth width depth height))
 207                  " draw_box"))
 208
 209 (define (horizontal-line x1 x2 th)
 210   (draw-line th x1  0 x2 0))
 211
 212 (define (fontify name-mag-pair exp)
 213
 214   (define (select-font name-mag-pair)
 215     (let* ((c (assoc name-mag-pair font-name-alist)))
 216       (if (eq? c #f)
 217           (begin
 218             (display "FAILED\n")
 219             (display (object-type (car name-mag-pair)))
 220             (display (object-type (caaar font-name-alist)))
 221             (ly:warn (string-append
 222                       "Programming error: No such font known "
 223                       (car name-mag-pair) " "
 224                       (ly:number->string (cdr name-mag-pair))))
 225
 226             ;; Upon error, issue no command
 227             "")
 228           (string-append " " (cddr c) " "))))
 229
 230   (string-append (select-font name-mag-pair) exp))
 231
 232 (define (header creator generate)
 233   (string-append
 234    "%!PS-Adobe-3.0\n"
 235    "%%Creator: " creator generate "\n"))
 236 (define (header-end)
 237   (string-append
 238    ;; URG: now we can't use scm output without Lily
 239    (ly:gulp-file "lilyponddefs.ps")
 240    " {exch pop //systemdict /run get exec} "
 241    (ly:gulp-file "music-drawing-routines.ps")
 242    "{ exch pop //systemdict /run get exec } "
 243    ;; ps-testing wreaks havoc when used with lilypond-book.
 244    ;;  -- is this still true with new modules system?
 245 ;;   (if (defined? 'ps-testing) "\n /testing true def" "")
 246   ;   "\n /testing true def"
 247    ))
 248
 249 (define (lily-def key val)
 250   (let ((prefix "lilypondpaper"))
 251     (if (string=?
 252          (substring key 0 (min (string-length prefix) (string-length key)))
 253          prefix)
 254         (string-append "/" key " {" val "} bind def\n")
 255         (string-append "/" key " (" val ") def\n"))))
 256
 257 (define (no-origin) "")
 258
 259 (define (placebox x y s)
 260   (string-append
 261    (ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
 262
 263 (define (repeat-slash wid slope thick)
 264   (string-append
 265    (numbers->string (list wid slope thick))
 266    " draw_repeat_slash"))
 267
 268 (define (round-filled-box x y width height blotdiam)
 269    (string-append
 270     " "
 271     (numbers->string
 272      (list x y width height blotdiam)) " draw_round_box"))
 273
 274 (define (start-system width height)
 275   (string-append
 276    "\n" (ly:number->string height)
 277    " start-system\n"
 278    "{\n"
 279    "set-ps-scale-to-lily-scale"))
 280
 281 (define (stem breapth width depth height)
 282   (string-append
 283    (numbers->string (list breapth width depth height))
 284    " draw_box" ))
 285
 286 (define (stop-last-system)
 287   (stop-system))
 288
 289 (define (stop-system)
 290   "}\nstop-system\n")
 291
 292 (define (text s)
 293   (string-append "(" s ") show "))
 294
 295 (define (unknown)
 296   "\n unknown\n")
 297