scm/output-lib.scm

   1 ;;;; output-lib.scm -- implement Scheme output helper functions
   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 ; Tablature functions, by Jiba (jiba@tuxfamily.org)
   9
  10 ; The TabNoteHead stem attachment function.
  11 (define (tablature-stem-attachment-function style duration)
  12   (cons 0.0 1.0)
  13 )
  14
  15 ; The TabNoteHead molecule callback.
  16 ; Create a text molecule
  17 (define (tablature-molecule-callback grob)
  18   (let ((molecule (fontify-text
  19                    (ly-get-default-font grob)
  20                    (ly-get-grob-property grob 'text)
  21                    )))
  22     molecule ; return the molecule.
  23     )
  24   )
  25
  26 ; The TabNoteHead tablatureFormat callback.
  27 ; Compute the text grob-property
  28 (define (fret-number-tablature-format string tuning pitch)
  29   (number->string
  30    (- (pitch-semitones pitch)
  31       (list-ref tuning
  32                 (- string 1) ; remove 1 because list index starts at 0 and guitar string at 1.
  33                 )
  34       )
  35    )
  36   )
  37
  38 (define (hammer-molecule-callback grob)
  39   (let* ((note-collums (ly-get-grob-property grob 'note-columns))
  40          (note-column1 (cadr note-collums))
  41          (note-column2 (car  note-collums))
  42          (note1        (car (ly-get-grob-property note-column1 'note-heads)))
  43          (note2        (car (ly-get-grob-property note-column2 'note-heads)))
  44          (fret1        (string->number (ly-get-grob-property note1 'text)))
  45          (fret2        (string->number (ly-get-grob-property note2 'text)))
  46          (letter       (if (< fret1 fret2) "H"
  47                        (if (> fret1 fret2) "P"
  48                                            "")))
  49          )
  50     (let ((slur (Slur::brew_molecule grob))
  51           (text (fontify-text (ly-get-default-font grob) letter)))
  52
  53       (let ((x (/ (- (cdr (ly-get-molecule-extent slur 0))
  54                      (/ (cdr (ly-get-molecule-extent text 0)) 2.0)
  55                      )
  56                   -2.0)))
  57
  58         (ly-set-molecule-extent! text 0 (cons x x))
  59         (ly-align-to! text 0 1)
  60         )
  61
  62       (ly-combine-molecule-at-edge slur 1 1 text -0.6)
  63       )
  64     )
  65   )
  66
  67
  68
  69
  70 ; end of tablature functions
  71
  72
  73 (define (arg->string arg)
  74   (cond ((number? arg) (inexact->string arg 10))
  75         ((string? arg) (string-append "\"" arg "\""))
  76         ((symbol? arg) (string-append "\"" (symbol->string arg) "\""))))
  77
  78 ;; ugh: naming.
  79 (define (func name . args)
  80   (string-append
  81    "(" name
  82    (if (null? args)
  83        ""
  84        (apply string-append
  85               (map (lambda (x) (string-append " " (arg->string x))) args)))
  86    ")\n"))
  87
  88
  89 ;;(define (mm-to-pt x)
  90 ;;  (* (/ 72.27 25.40) x))
  91
  92 ;; do nothing in .scm output
  93 (define (comment s) "")
  94
  95 (define (numbers->string l)
  96   (apply string-append (map ly-number->string l)))
  97
  98 ; (define (chop-decimal x) (if (< (abs x) 0.001) 0.0 x))
  99
 100 (define (number->octal-string x)
 101   (let* ((n (inexact->exact x))
 102          (n64 (quotient n 64))
 103          (n8 (quotient (- n (* n64 64)) 8)))
 104     (string-append
 105      (number->string n64)
 106      (number->string n8)
 107      (number->string (remainder (- n (+ (* n64 64) (* n8 8))) 8)))))
 108
 109 (define (inexact->string x radix)
 110   (let ((n (inexact->exact x)))
 111     (number->string n radix)))
 112
 113
 114 (define (control->string c)
 115   (string-append (number->string (car c)) " "
 116                  (number->string (cdr c)) " "))
 117
 118 (define (font i)
 119   (string-append
 120    "font"
 121    (make-string 1 (integer->char (+ (char->integer #\A) i)))))
 122
 123 (define (scm-scm action-name)
 124   1)
 125
 126
 127 ;; silly, use alist?
 128 (define (find-notehead-symbol duration style)
 129   (case style
 130    ((xcircle) (cons "2xcircle" "music"))
 131    ((harmonic) (cons "0neo_mensural" "music"))
 132    ((baroque)
 133     ;; Oops, I actually would not call this "baroque", but, for
 134     ;; backwards compatibility to 1.4, this is supposed to take
 135     ;; brevis, longa and maxima from the neo-mensural font and all
 136     ;; other note heads from the default font.  -- jr
 137     (if (< duration 0)
 138         (cons (string-append (number->string duration) "neo_mensural") "ancient")
 139         (cons (number->string duration) "music")))
 140    ((mensural)
 141     (cons (string-append (number->string duration) (symbol->string style))
 142      "ancient"))
 143    ((neo_mensural)
 144     (cons (string-append (number->string duration) (symbol->string style))
 145      "ancient"))
 146    ((default)
 147     ;; The default font in mf/feta-bolletjes.mf defines a brevis, but
 148     ;; neither a longa nor a maxima.  Hence let us, for the moment,
 149     ;; take these from the neo-mensural font.  TODO: mf/feta-bolletjes
 150     ;; should define at least a longa for the default font.  The longa
 151     ;; should look exactly like the brevis of the default font, but
 152     ;; with a stem exactly like that of the quarter note. -- jr
 153     (if (< duration -1)
 154         (cons (string-append (number->string duration) "neo_mensural") "ancient")
 155         (cons (number->string duration) "music")))
 156    (else
 157     (cons (string-append (number->string (max 0 duration)) (symbol->string style))
 158      "music"))))
 159
 160
 161 (define (note-head-style->attachment-coordinates style duration)
 162   "Return pair (X . Y), containing multipliers for the note head
 163 bounding box, where to attach the stem. e.g.: X==0 means horizontally
 164 centered, X==1 is at the right, X == -1 is at the left."
 165
 166   (case style
 167     ((default)
 168      (if (< duration -1)
 169          '(0.0 . 0.6) ;; neo-mensural
 170          '(1.0 . 0.5) ;; default
 171          ))
 172     ((cross) '(1.0 . 0.75))
 173     ((mensural) '(0.0 . 0.6))
 174     ((neo_mensural) '(0.0 . 0.6))
 175     ((diamond) '(1.0 . 0.8))
 176     ((transparent) '(1.0 . 1.0))
 177     ((slash) '(1.0 . 1.0))
 178     ((harmonic) '(1.0 0.0))
 179     ((triangle) '(0.75 . 0.15))
 180     ((baroque)
 181      (if (< duration 0)
 182          '(0.0 . 0.6) ;; neo-mensural
 183          '(1.0 . 0.5) ;; default
 184          ))
 185     (else
 186
 187      ;; this also works for easy notation.
 188      '(1.0 . 0.0)
 189      )))
 190
 191 (define (find-timesig-symbol nom denom style)
 192   (case style
 193    ((mensural)
 194     (cons (string-append
 195              "mensural"
 196              (number->string nom)
 197              "/"
 198              (number->string denom))
 199           "ancient"))
 200    ((neo_mensural)
 201     (cons (string-append
 202              "neo_mensural"
 203              (number->string nom)
 204              "/"
 205              (number->string denom))
 206           "ancient"))
 207    ((numbered)
 208     (cons (string-append
 209            (number->string nom)
 210            "/"
 211            (number->string denom))
 212           "music"))
 213    (else
 214     ;; default: use "C" style when possible, otherwise return ""
 215     (cons
 216      (case nom
 217        ((2)
 218         (case denom
 219           ((2) "C2/2")
 220           (else "")))
 221        ((4)
 222         (case denom
 223           ((4) "C4/4")
 224           (else "")))
 225        (else ""))
 226      "music"))))
 227
 228 (define (string-encode-integer i)
 229   (cond
 230    ((= i  0) "o")
 231    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 232    (else (string-append
 233           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 234           (string-encode-integer (quotient i 26))))))
 235
 236
 237
 238
 239