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)) (* (- y1 y2) (- y1 y2)))) 2)))
  56        " draw_dot")))
  57
  58   (string-append
  59    (apply string-append (map number-pair->string l))
  60    (ly:number->string thick)
  61    " draw_bezier_sandwich "
  62    (bezier-ending (list-ref l 3) (list-ref l 0) (list-ref l 5))
  63    (bezier-ending (list-ref l 7) (list-ref l 0) (list-ref l 5))))
  64
  65 ;; two beziers
  66 (define (bezier-sandwich l thick)
  67   (string-append
  68    (apply string-append (map number-pair->string l))
  69    (ly:number->string thick)
  70    " draw_bezier_sandwich "))
  71
  72 (define (bracket arch_angle arch_width arch_height  height arch_thick thick)
  73   (string-append
  74    (numbers->string
  75     (list arch_angle arch_width arch_height height arch_thick thick))
  76    " draw_bracket"))
  77
  78 (define (symmetric-x-triangle thick w h)
  79   (string-append
  80    (numbers->string (list h w thick))
  81    " draw_symmetric_x_triangle"))
  82
  83
  84 (define (char i)
  85   (string-append
  86    "(\\" (inexact->string i 8) ") show " ))
  87
  88
  89 (define (comment s)
  90   (string-append "% " s "\n"))
  91
  92
  93 (define (dashed-line thick on off dx dy)
  94   (string-append
  95    (ly:number->string dx)
  96    " "
  97    (ly:number->string dy)
  98    " "
  99    (ly:number->string thick)
 100    " [ "
 101    (ly:number->string on)
 102    " "
 103    (ly:number->string off)
 104    " ] 0 draw_dashed_line"))
 105
 106 ;; what the heck is this interface ?
 107 (define (dashed-slur thick dash l)
 108   (string-append
 109    (apply string-append (map number-pair->string l))
 110    (ly:number->string thick)
 111    " [ "
 112    (ly:number->string dash)
 113    " "
 114    ;;UGH.  10 ?
 115    (ly:number->string (* 10 thick))
 116    " ] 0 draw_dashed_slur"))
 117
 118 (define (define-fonts internal-external-name-mag-pairs)
 119
 120   (define (font-load-command name-mag command)
 121
 122     (define (possibly-capitalize-font-name name)
 123       (if (equal? (substring name 0 2) "cm")
 124           (string-upcase name)
 125           name))
 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 (fontify name-mag-pair exp)
 216
 217   (define (select-font name-mag-pair)
 218     (let* ((c (assoc name-mag-pair font-name-alist)))
 219       (if (eq? c #f)
 220           (begin
 221             (display "FAILED\n")
 222             (display (object-type (car name-mag-pair)))
 223             (display (object-type (caaar font-name-alist)))
 224             (ly:warn (string-append
 225                       "Programming error: No such font known "
 226                       (car name-mag-pair) " "
 227                       (ly:number->string (cdr name-mag-pair))))
 228
 229             ;; Upon error, issue no command
 230             "")
 231           (string-append " " (cddr c) " "))))
 232
 233   (string-append (select-font name-mag-pair) exp))
 234
 235 (define (header creator generate)
 236   (string-append
 237    "%!PS-Adobe-3.0\n"
 238    "%%Creator: " creator generate "\n"))
 239
 240 (define (header-end)
 241   (string-append
 242    ;; URG: now we can't use scm output without Lily
 243    (ly:gulp-file "lilyponddefs.ps")
 244    " {exch pop //systemdict /run get exec} "
 245    (ly:gulp-file "music-drawing-routines.ps")
 246    "{ exch pop //systemdict /run get exec } "
 247    ;; ps-testing wreaks havoc when used with lilypond-book.
 248    ;;  -- is this still true with new modules system?
 249    ;;   (if (defined? 'ps-testing) "\n /testing true def" "")
 250    ;;   "\n /testing true def"
 251    ))
 252
 253 (define (lily-def key val)
 254   (let ((prefix "lilypondpaper"))
 255     (if (string=?
 256          (substring key 0 (min (string-length prefix) (string-length key)))
 257          prefix)
 258         (string-append "/" key " {" val "} bind def\n")
 259         (string-append "/" key " (" val ") def\n"))))
 260
 261 (define (no-origin) "")
 262
 263 (define (placebox x y s)
 264   (string-append
 265    (ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
 266
 267 (define (repeat-slash wid slope thick)
 268   (string-append
 269    (numbers->string (list wid slope thick))
 270    " draw_repeat_slash"))
 271
 272 (define (roundfilledbox x y width height blotdiam)
 273    (string-append
 274     " "
 275     (numbers->string
 276      (list x y width height blotdiam)) " draw_round_box"))
 277
 278 ;; TODO: use HEIGHT argument
 279 (define (start-system width height)
 280   (string-append
 281    "\n" (ly:number->string height)
 282    " start-system\n"
 283    "{\n"
 284    "set-ps-scale-to-lily-scale"))
 285
 286 (define (stem breapth width depth height)
 287   (string-append
 288    (numbers->string (list breapth width depth height))
 289    " draw_box" ))
 290
 291 (define (stop-last-system)
 292   (stop-system))
 293
 294 (define (stop-system)
 295   "}\nstop-system\n")
 296
 297 (define (text s)
 298   (string-append "(" s ") show "))
 299
 300 (define (unknown)
 301   "\n unknown\n")
 302