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