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