scm/output-tex.scm

   1 ;;;; tex.scm -- implement Scheme output routines for TeX
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c)  1998--2004 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;;                  Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8
   9 ;; (debug-enable 'backtrace)
  10 (define-module (scm output-tex)
  11   #:re-export (quote)
  12   #:export (define-fonts
  13              font-command
  14              unknown
  15              output-paper-def
  16              output-scopes
  17              blank
  18              dot
  19              beam
  20              bracket
  21              dashed-slur
  22              char
  23              dashed-line
  24              zigzag-line
  25              symmetric-x-triangle
  26              ez-ball
  27              comment
  28              end-output
  29              experimental-on
  30              repeat-slash
  31              header-end
  32              header
  33              placebox
  34              bezier-sandwich
  35              horizontal-line
  36              filledbox
  37              round-filled-box
  38              text
  39              tuplet
  40              polygon
  41              draw-line
  42              define-origin
  43              no-origin
  44              ))
  45
  46 (use-modules (ice-9 regex)
  47              (ice-9 string-fun)
  48              (ice-9 format)
  49              (guile)
  50              (srfi srfi-13)
  51              (lily))
  52
  53 ;;;;;;;;
  54 ;;;;;;;; DOCUMENT ME!
  55 ;;;;;;;;
  56
  57
  58 (define (font-command font)
  59   (string-append
  60    "magfont"
  61    (string-encode-integer
  62     (hashq (ly:font-filename font) 1000000))
  63    "m"
  64    (string-encode-integer
  65     (inexact->exact (round (* 1000 (ly:font-magnification font)))))))
  66
  67 (define (unknown)
  68   "%\n\\unknown\n")
  69
  70 (define-public (symbol->tex-key sym)
  71   (regexp-substitute/global
  72    #f "_" (output-tex-string (symbol->string sym)) 'pre "X" 'post) )
  73
  74 (define (string->param string)
  75   (string-append "{" string "}"))
  76
  77 (define (number->param number)
  78   (string->param (ly:number->string number)))
  79
  80 (define (number-pair->param o)
  81   (string-append (number->param (car o)) (number->param (cdr o))))
  82
  83 (define-public (tex-number-def prefix key number)
  84   (string-append
  85    "\\def\\" prefix (symbol->tex-key key) (string->param number) "%\n"))
  86
  87
  88 (define (blank)
  89   "")
  90
  91 (define (dot x y radius)
  92   (embedded-ps (list 'dot x y radius)))
  93
  94 (define (beam width slope thick blot)
  95   (embedded-ps (list 'beam  width slope thick blot)))
  96
  97 (define (bracket arch_angle arch_width arch_height height arch_thick thick)
  98   (embedded-ps (list 'bracket  arch_angle arch_width arch_height height arch_thick thick)))
  99
 100 (define (dashed-slur thick dash l)
 101   (embedded-ps (list 'dashed-slur thick dash `(quote ,l))))
 102
 103 (define (char font i)
 104   (string-append "\\" (font-command font)
 105                  "\\char" (ly:inexact->string i 10) " "))
 106
 107 (define (dashed-line thick on off dx dy)
 108   (embedded-ps (list 'dashed-line  thick on off dx dy)))
 109
 110 (define (zigzag-line centre? zzw zzh thick dx dy)
 111   (embedded-ps (list 'zigzag-line centre? zzw zzh thick dx dy)))
 112
 113 (define (symmetric-x-triangle t w h)
 114   (embedded-ps (list 'symmetric-x-triangle t w h)))
 115
 116 (define-public (font-load-command bookpaper font)
 117   (string-append
 118    "\\font\\" (font-command font) "="
 119    (ly:font-filename font)
 120    " scaled "
 121    (ly:number->string (inexact->exact
 122                        (round (* 1000
 123                           (ly:font-magnification font)
 124                           (ly:bookpaper-outputscale bookpaper)))))
 125    "\n"))
 126
 127 (define (ez-ball c l b)
 128   (embedded-ps (list 'ez-ball  c  l b)))
 129
 130 (define (header-to-file fn key val)
 131   (set! key (symbol->string key))
 132   (if (not (equal? "-" fn))
 133       (set! fn (string-append fn "." key))
 134       )
 135   (display
 136    (format "Writing header field `~a' to `~a'..."
 137            key
 138            (if (equal? "-" fn) "<stdout>" fn)
 139            )
 140    (current-error-port))
 141   (if (equal? fn "-")
 142       (display val)
 143       (display val (open-file fn "w"))
 144   )
 145   (display "\n" (current-error-port))
 146   ""
 147   )
 148
 149 (define (embedded-ps expr)
 150   (let ((ps-string
 151          (with-output-to-string
 152            (lambda () (ps-output-expression expr (current-output-port))))))
 153     (string-append "\\embeddedps{" ps-string "}")))
 154
 155 (define (comment s)
 156   (string-append "% " s "\n"))
 157
 158 (define (end-output)
 159   (begin
 160     ;; uncomment for some stats about lily memory
 161     ;; (display (gc-stats))
 162     (string-append
 163      "\\lilypondend\n"
 164      ;; Put GC stats here.
 165      )))
 166
 167 (define (repeat-slash w a t)
 168   (embedded-ps (list 'repeat-slash  w a t)))
 169
 170
 171 (define-public (output-tex-string s) ;; todo: rename
 172    (if (ly:get-option 'safe)
 173       (regexp-substitute/global #f "\\\\"
 174                                 (regexp-substitute/global #f "([{}])" "bla{}" 'pre  "\\" 1 'post )
 175                                 'pre "$\\backslash$" 'post)
 176
 177       s))
 178
 179 (define (lily-def key val)
 180   (let ((tex-key
 181          (regexp-substitute/global
 182               #f "_" (output-tex-string key) 'pre "X" 'post))
 183
 184         (tex-val (output-tex-string val)))
 185     (if (equal? (sans-surrounding-whitespace tex-val) "")
 186         (string-append "\\let\\" tex-key "\\undefined\n")
 187         (string-append "\\def\\" tex-key "{" tex-val "}%\n"))))
 188
 189 (define (number->dim x)
 190   (string-append
 191    ;;ugh ly:* in backend needs compatibility func for standalone output
 192    (ly:number->string x) " \\outputscale "))
 193
 194 (define (placebox x y s)
 195   (string-append
 196    "\\lyitem" (number->param x) (number->param y) (string->param s) "%\n"))
 197
 198 (define (bezier-sandwich l thick)
 199   (embedded-ps (list 'bezier-sandwich  `(quote ,l) thick)))
 200
 201 ;; WTF is this in every backend?
 202 (define (horizontal-line x1 x2 th)
 203   (filledbox (- x1) (- x2 x1) (* .5 th) (* .5 th)))
 204
 205 (define (filledbox breapth width depth height)
 206   (if (and #f (defined? 'ps-testing))
 207       (embedded-ps
 208        (string-append (ly:numbers->string (list breapth width depth height))
 209                       " draw_box" ))
 210       (string-append "\\lyvrule{"
 211                      (ly:number->string (- breapth)) "}{"
 212                      (ly:number->string (+ breapth width)) "}{"
 213                      (ly:number->string depth) "}{"
 214                      (ly:number->string height) "}")))
 215
 216 (define (round-filled-box x y width height blotdiam)
 217   (embedded-ps (list 'round-filled-box  x y width height blotdiam)))
 218
 219 (define (text font s)
 220   (let*
 221       ((mapping #f)       ;; (assoc-get  'char-mapping (ly:font-encoding-alist font))))
 222
 223
 224        ;; TODO: we'd better do this for PS only
 225        ;; LaTeX gets in the way, and we need to remap
 226        ;; nonprintable chars.
 227
 228
 229        (input-enc-name #f) ;; (assoc-get 'input-name (ly:font-encoding-alist font) ))
 230        )
 231
 232     (string-append "\\hbox{\\" (font-command font)
 233                    (if (string? input-enc-name)
 234                        (string-append "\\inputencoding{" input-enc-name "}")
 235                        "{}")
 236                    (output-tex-string
 237                     (if (vector? mapping)
 238                         (reencode-string mapping s)
 239                         s))
 240                    "}")))
 241
 242
 243 (define (tuplet ht gapx dx dy thick dir)
 244   (embedded-ps (list 'tuplet  ht gapx dx dy thick dir)))
 245
 246 (define (polygon points blotdiameter)
 247   (embedded-ps (list 'polygon `(quote ,points) blotdiameter)))
 248
 249 (define (draw-line thick fx fy tx ty)
 250   (embedded-ps (list 'draw-line thick fx fy tx ty)))
 251
 252 (define (define-origin file line col)
 253   (if (procedure? point-and-click)
 254       (string-append "\\special{src:" ;;; \\string ?
 255                      (point-and-click line col file)
 256                      "}" )
 257       ""))
 258
 259 ;; no-origin not yet supported by Xdvi
 260 (define (no-origin) "")
 261