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 (char i)
  79   (string-append
  80    "(\\" (inexact->string i 8) ") show " ))
  81
  82 (define (comment s)
  83   (string-append "% " s "\n"))
  84
  85 (define (dashed-line thick on off dx dy)
  86   (string-append
  87    (ly:number->string dx)
  88    " "
  89    (ly:number->string dy)
  90    " "
  91    (ly:number->string thick)
  92    " [ "
  93    (ly:number->string on)
  94    " "
  95    (ly:number->string off)
  96    " ] 0 draw_dashed_line"))
  97
  98 ;; what the heck is this interface ?
  99 (define (dashed-slur thick dash l)
 100   (string-append
 101    (apply string-append (map number-pair->string l))
 102    (ly:number->string thick)
 103    " [ "
 104    (ly:number->string dash)
 105    " "
 106    ;;UGH.  10 ?
 107    (ly:number->string (* 10 thick))
 108    " ] 0 draw_dashed_slur"))
 109
 110 (define (define-fonts internal-external-name-mag-pairs)
 111
 112   (define (font-load-command name-mag command)
 113
 114     (define (possibly-capitalize-font-name name)
 115       (if (equal? (substring name 0 2) "cm")
 116           (string-upcase name)
 117           name))
 118
 119     (string-append
 120      "/" command
 121      " { /"
 122      ;; Ugh, the Bluesky type1 fonts for computer modern use capitalized
 123      ;; postscript font names.
 124      (possibly-capitalize-font-name (car name-mag))
 125      " findfont "
 126      "20 " (ly:number->string (cdr name-mag)) " mul "
 127      "output-scale div scalefont setfont } bind def "
 128      "\n"))
 129
 130   (define (ps-encoded-fontswitch name-mag-pair)
 131     (let* ((key (car name-mag-pair))
 132            (value (cdr name-mag-pair)))
 133       (cons key
 134             (cons value
 135                   (string-append "lilyfont"
 136                                  (car value)
 137                                  "-"
 138                                  (number->string (cdr value)))))))
 139
 140   (set! font-name-alist (map ps-encoded-fontswitch
 141                              internal-external-name-mag-pairs))
 142
 143   (apply string-append
 144          (map (lambda (x) (font-load-command (car x) (cdr x)))
 145               (map cdr font-name-alist))))
 146
 147 (define (define-origin file line col) "")
 148
 149 (define (dot x y radius)
 150   (string-append
 151    " "
 152    (numbers->string
 153     (list x y radius)) " draw_dot"))
 154
 155 (define (zigzag-line centre? zzw zzh thick dx dy)
 156   (string-append
 157     (if centre? "true" "false")
 158     " "
 159     (ly:number->string zzw)
 160     " "
 161     (ly:number->string zzh)
 162     " "
 163     (ly:number->string thick)
 164     " 0 0 "
 165     (ly:number->string dx)
 166     " "
 167     (ly:number->string dy)
 168     " draw_zigzag_line "))
 169
 170 (define (draw-line thick x1 y1 x2 y2)
 171   (string-append
 172   "     1 setlinecap
 173         1 setlinejoin "
 174   (ly:number->string thick)
 175         " setlinewidth "
 176    (ly:number->string x1)
 177    " "
 178    (ly:number->string y1)
 179    " moveto "
 180    (ly:number->string x2)
 181    " "
 182    (ly:number->string y2)
 183    " lineto stroke"))
 184
 185 (define (end-output)
 186   "\nend-lilypond-output\n")
 187
 188 (define (ez-ball ch letter-col ball-col)
 189   (string-append
 190    " (" ch ") "
 191    (numbers->string (list letter-col ball-col))
 192    " /Helvetica-Bold " ;; ugh
 193    " draw_ez_ball"))
 194
 195 (define (filledbox breapth width depth height)
 196   (string-append (numbers->string (list breapth width depth height))
 197                  " draw_box" ))
 198
 199 (define (fontify name-mag-pair exp)
 200
 201   (define (select-font name-mag-pair)
 202     (let* ((c (assoc name-mag-pair font-name-alist)))
 203       (if (eq? c #f)
 204           (begin
 205             (display "FAILED\n")
 206             (display (object-type (car name-mag-pair)))
 207             (display (object-type (caaar font-name-alist)))
 208             (ly:warn (string-append
 209                       "Programming error: No such font known "
 210                       (car name-mag-pair) " "
 211                       (ly:number->string (cdr name-mag-pair))))
 212
 213             ;; Upon error, issue no command
 214             "")
 215           (string-append " " (cddr c) " "))))
 216
 217   (string-append (select-font name-mag-pair) exp))
 218
 219 (define (header creator generate)
 220   (string-append
 221    "%!PS-Adobe-3.0\n"
 222    "%%Creator: " creator generate "\n"))
 223
 224 (define (header-end)
 225   (string-append
 226    ;; URG: now we can't use scm output without Lily
 227    (ly:gulp-file "lilyponddefs.ps")
 228    " {exch pop //systemdict /run get exec} "
 229    (ly:gulp-file "music-drawing-routines.ps")
 230    "{ exch pop //systemdict /run get exec } "
 231    ;; ps-testing wreaks havoc when used with lilypond-book.
 232    ;;  -- is this still true with new modules system?
 233    ;;   (if (defined? 'ps-testing) "\n /testing true def" "")
 234    ;;   "\n /testing true def"
 235    ))
 236
 237 (define (lily-def key val)
 238   (let ((prefix "lilypondpaper"))
 239     (if (string=?
 240          (substring key 0 (min (string-length prefix) (string-length key)))
 241          prefix)
 242         (string-append "/" key " {" val "} bind def\n")
 243         (string-append "/" key " (" val ") def\n"))))
 244
 245 (define (no-origin) "")
 246
 247 (define (placebox x y s)
 248   (string-append
 249    (ly:number->string x) " " (ly:number->string y) " {" s "} place-box\n"))
 250
 251 (define (repeat-slash wid slope thick)
 252   (string-append
 253    (numbers->string (list wid slope thick))
 254    " draw_repeat_slash"))
 255
 256 (define (roundfilledbox x y width height blotdiam)
 257    (string-append
 258     " "
 259     (numbers->string
 260      (list x y width height blotdiam)) " draw_round_box"))
 261
 262 ;; TODO: use HEIGHT argument
 263 (define (start-system width height)
 264   (string-append
 265    "\n" (ly:number->string height)
 266    " start-system\n"
 267    "{\n"
 268    "set-ps-scale-to-lily-scale"))
 269
 270 (define (stem breapth width depth height)
 271   (string-append
 272    (numbers->string (list breapth width depth height))
 273    " draw_box" ))
 274
 275 (define (stop-last-system)
 276   (stop-system))
 277
 278 (define (stop-system)
 279   "}\nstop-system\n")
 280
 281 (define (text s)
 282   (string-append "(" s ") show "))
 283
 284 (define (unknown)
 285   "\n unknown\n")
 286