scm/fret-diagrams.scm

   1 ;;;; fret-diagrams.scm --
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 2004 Carl D. Sorensen <c_sorensen@byu.edu>
   6
   7 (define nil '())
   8 (define (fret-parse-string definition-string)
   9  "parse a fret diagram string and return an alist with the appropriate values"
  10    (let* ((fret-count 4)
  11           (string-count 6)
  12           (thickness 0.05)
  13           (finger-code 0)
  14           (dot-size 0.25)
  15           (position 0.6)
  16           (fret-range (list 1 fret-count))
  17           (barre-list '())
  18           (dot-list '())
  19           (xo-list '())
  20           (output-list '())
  21           (items (string-split definition-string #\;)))
  22       (let parse-item ((myitems items))
  23           (if (not (null?  (cdr myitems)))
  24               (let ((test-string (car myitems)))
  25                  (case (car (string->list (substring test-string 0 1)))
  26                     ((#\f) (set! finger-code (get-numeric-from-key test-string)))
  27                     ((#\t) (set! thickness (get-numeric-from-key test-string)))
  28                     ((#\c) (set! barre-list (cons* (numerify (string-split (substring test-string 2) #\-))
  29                                             barre-list)))
  30                     ((#\h) (set! fret-count (get-numeric-from-key test-string)))
  31                     ((#\w) (set! string-count (get-numeric-from-key test-string)))
  32                     ((#\d) (set! dot-size (get-numeric-from-key test-string)))
  33                     ((#\p) (set! position (get-numeric-from-key test-string)))
  34                     (else
  35                        (let ((this-list (string-split test-string #\-)))
  36                            ;(display this-list)
  37                            (if (string->number (cadr this-list))
  38                               (set! dot-list (cons* (numerify this-list) dot-list))
  39                               (set! xo-list (cons* (numerify this-list) xo-list))))))
  40                  (parse-item (cdr myitems)))))
  41                ; calculate fret-range
  42                (let ((maxfret 0) (minfret 99))
  43                     (let updatemax ((fret-list dot-list))
  44                         (if (null?  fret-list)
  45                            '()
  46                            (let ((fretval (cadar fret-list)))
  47                                (if (> fretval maxfret) (set! maxfret fretval))
  48                                (if (< fretval minfret) (set! minfret fretval))
  49                                (updatemax (cdr fret-list)))))
  50                     (if (> maxfret fret-count)
  51                         (set! fret-range (list minfret
  52                              (let ((upfret (- (+ minfret fret-count) 1)))
  53                                   (if (> maxfret upfret) maxfret upfret)))))
  54                     ; subtract fret from dots
  55                     (set! dot-list (subtract-base-fret (- (car fret-range) 1) dot-list)))
  56                (acons "string-count" string-count
  57                (acons "dot-size" dot-size
  58                (acons "position" position
  59                (acons "finger-code" finger-code
  60                (acons "fret-range" fret-range
  61                (acons "thickness" thickness
  62                (acons "barre-list" barre-list
  63                (acons "dot-list" dot-list
  64                (acons "xo-list" xo-list '())))))))))))
  65
  66 (define (subtract-base-fret base-fret dot-list)
  67
  68   (if (null? dot-list)
  69       '()
  70       (let ((this-list (car dot-list)))
  71       (cons* (list (car this-list) (- (cadr this-list) base-fret) (if (null? (cddr this-list))
  72                                                                     nil
  73                                                                     (caddr this-list)))
  74              (subtract-base-fret base-fret (cdr dot-list))))))
  75
  76 (define (draw-strings string-count fret-range th size)
  77   (let* ((fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
  78          (sl (* (+ fret-count 1) size))
  79          (half-thickness (* th 0.5))
  80          (string-stencil (ly:make-stencil (list 'draw-line th 0 0 0 sl)
  81                          (cons (- half-thickness) half-thickness)
  82                          (cons (- half-thickness) (+ sl half-thickness)))))
  83     (if (= string-count 1)
  84          string-stencil
  85         (ly:stencil-combine-at-edge
  86          (draw-strings (- string-count 1) fret-range th size) 0 1
  87          string-stencil
  88          (- size th) 0))))
  89
  90 (define (draw-fret-lines fret-count string-count th size)
  91     (let* ((fret-length (* (- string-count 1) size))
  92           (half-thickness (* th 0.5))
  93           (fret-line (ly:make-stencil (list 'draw-line th 0 size fret-length size)
  94                           (cons 0 fret-length)
  95                           (cons (- size half-thickness) (+  size half-thickness)))))
  96        (if (= fret-count 1)
  97          fret-line
  98          (ly:stencil-combine-at-edge fret-line Y UP
  99           (draw-fret-lines (- fret-count 1) string-count th size)
 100           (- size th) 0))))
 101
 102 (define (draw-frets paper fret-range string-count th size)
 103   (let* ((fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
 104          (fret-length (* (- string-count 1) size))
 105          (half-thickness (* th 0.5))
 106          (base-fret (car fret-range)))
 107        (ly:stencil-combine-at-edge
 108           (draw-fret-lines fret-count string-count th size) Y UP
 109              (if (= base-fret 1)
 110                  (draw-fret-lines 1 string-count (* th 2) size)
 111                  (draw-fret-lines 1 string-count th size))
 112                  (- size th) 0)))
 113
 114 (define (draw-dots paper string-count fret-range size dot-size position finger-code dot-list)
 115   "Make dots for fret diagram."
 116   (let* ((dot-radius (* size dot-size))
 117          (fret-count (+ (- (cadr fret-range) (car fret-range) 1)))
 118          (mypair (car dot-list))
 119          (restlist (cdr dot-list))
 120          (xpos (* (- string-count (car mypair)) size))
 121          (ypos (* (+ 4 (- fret-count (cadr mypair) position )) size))
 122          (finger (caddr mypair))
 123          (font (ly:paper-get-font paper `(((font-magnification . ,(* 0.8 size))(font-name . "cmss8")
 124                                         (font-encoding Tex-text)))))
 125          (font2 (ly:paper-get-font paper `(((font-magnification . ,(* (* 2 dot-size) size))(font-name . "cmss8")
 126                                         (font-encoding Tex-text)))))
 127          (font3 (ly:paper-get-font paper `(((font-magnification . ,(* (* 3 dot-size) size))(font-name . "cmss8")
 128                                         (font-encoding Tex-text)))))
 129          (extent (cons (- (*  size 0.25)) (*  size 0.25)))
 130          (dotstencil (if (or (eq? finger nil)(eq? finger-code 0))
 131                           (ly:make-stencil (list 'dot xpos ypos dot-radius ) extent extent)
 132                           (if (eq? finger-code 1)
 133   ; TODO -- Get nice circled numbers in the font, instead of this kludge
 134                              (ly:stencil-add
 135                                (ly:stencil-translate-axis
 136                                    (ly:stencil-translate-axis
 137                                        (fontify-text font2 (number->string finger)) (- xpos (* size 0.3)) X)
 138                                    (- ypos (* 1 dot-size size)) Y)
 139                                (ly:stencil-translate-axis
 140                                    (ly:stencil-translate-axis
 141                                        (fontify-text font3 "O") (- xpos (* 2.2 dot-size size)) X)
 142                                    (- ypos (* 1.7 dot-size size)) Y))
 143                           (if (eq? finger-code 2)
 144                               (ly:stencil-add
 145                                    (ly:make-stencil (list 'dot xpos ypos dot-radius ) extent extent)
 146                                    (ly:stencil-translate-axis
 147                                         (ly:stencil-translate-axis
 148                                               (fontify-text font (number->string finger)) (- xpos (* size 0.3)) X)
 149                                         (- size) Y)))))))
 150     (if (null? restlist)
 151         dotstencil
 152         (ly:stencil-add (draw-dots paper string-count fret-range size dot-size position finger-code restlist)
 153                          dotstencil))))
 154
 155 (define (draw-xo paper string-count fret-range size xo-list)
 156 "Put x and o on chord diagram."
 157     (let* ((dot-radius (* size 0.25))
 158            (fret-count (+ (- (cadr fret-range) (car fret-range) 1)))
 159            (font (ly:paper-get-font paper `(((font-size . ,(* -5 (+ 1 (* 2.6 (- 1 size)))))(font-family . music)))))
 160            (mypair (car xo-list))
 161            (restlist (cdr xo-list))
 162 ;TODO -- get better glyphs in font to use for x (mute string) and o (open string)
 163 ;        Perhaps explore just using sans-serif font?
 164            (glyph-name (if (char=? (cadr mypair) #\x) "noteheads-2cross"
 165                          "scripts-open"))
 166            (tmpdot (if (char=? (cadr mypair) #\x) 0 (* size 0.25)))
 167            (xpos (if (char=? (cadr mypair) #\x)
 168                 (- (* (- string-count (car mypair)) size) (* .35 size) )
 169                 (* (- string-count (car mypair)) size)))
 170           (ypos (* (+ 3.5 fret-count) size))
 171           (extent (cons (- (* size 0.25)) (* size 0.25)))
 172           (glyph-stencil (ly:stencil-translate-axis
 173                 (ly:stencil-translate-axis (ly:find-glyph-by-name font glyph-name) ypos Y)
 174                 xpos X)))
 175       (if (null? restlist)
 176           glyph-stencil
 177           (ly:stencil-add
 178             (draw-xo paper string-count fret-range size restlist)
 179             glyph-stencil))))
 180
 181 (define (make-bezier-sandwich-list left right bottom height thickness)
 182    (let* ((width (+ (- right left) 1))
 183           (x1 (+ (* width 0.1) left))
 184           (x2 (- right (* width 0.1)))
 185           (bottom-control-point-height (+ bottom (- height thickness)))
 186           (top-control-point-height (+ bottom height)))
 187 ; order of points is: left cp low, right cp low, right end low, left end low
 188 ;                     right cp high, left cp high, left end high, right end high.
 189        (list (cons x1 bottom-control-point-height) (cons x2 bottom-control-point-height) (cons right bottom) (cons left bottom)
 190              (cons x2 top-control-point-height) (cons x1 top-control-point-height) (cons left bottom) (cons right bottom))))
 191
 192 (define (draw-barre paper string-count fret-range size barre-list)
 193    "Create barre indications for a chord diagram"
 194    (if (not (null? barre-list))
 195      (let* ((string1 (caar barre-list))
 196             (string2 (cadar barre-list))
 197             (fret    (caddar barre-list))
 198             (bottom (* size (+ 1.5 (- (cadr fret-range) fret))))
 199             (left (* size (- string-count string1)))
 200             (right (* size (- string-count string2)))
 201             (bezier-list (make-bezier-sandwich-list left right bottom (* size 0.5) (* size 0.1)))
 202             (sandwich-stencil (ly:make-stencil (list 'bezier-sandwich `(quote ,bezier-list) (* size 0.1) )
 203                                   (cons 0 right)
 204                                   (cons 0 (+ bottom (* size 0.8))))))
 205         (if (not (null? (cdr barre-list)))
 206             (ly:stencil-add sandwich-stencil
 207                  (draw-barre paper string-count fret-range size (cdr barre-list)))
 208             sandwich-stencil ))))
 209
 210 (define (label-fret paper string-count fret-range size)
 211    "Label the base fret on a fret diagram"
 212    (let ((base-fret (car fret-range))
 213          (fret-count (+ (- (cadr fret-range) (car fret-range)) 1))
 214          (font (ly:paper-get-font paper `(((font-magnification . ,(* 0.8 size))(font-name . "cmss8")
 215                                         (font-encoding Tex-text))))))
 216      (ly:stencil-translate-axis
 217         (ly:stencil-translate-axis (fontify-text font (if (> base-fret 1)
 218                                                           (format #f "~(~:@r~)" base-fret)
 219                                                           " ")) (* (- string-count 0.5) size) X)
 220         (* (- fret-count 0.2) size) Y)))
 221
 222 (define (get-numeric-from-key keystring)
 223  "Get the numeric value from a key  of the form k:val"
 224     (string->number (substring keystring 2  (string-length keystring) )))
 225
 226 (define (numerify mylist)
 227  "Convert string values to numeric or character"
 228      (if (null? mylist)
 229          '()
 230          (let ((numeric-value (string->number (car mylist))))
 231              (if numeric-value
 232                 (cons* numeric-value (numerify (cdr mylist)))
 233                 (cons* (car (string->list (car mylist))) (numerify (cdr mylist)))))))
 234
 235
 236 (define (make-fret-diagram paper size definition-string)
 237   "Make a fret diagram"
 238   (let* ((parameters (fret-parse-string definition-string))
 239          (string-count (cdr (assoc "string-count" parameters)))
 240          (fret-range (cdr (assoc "fret-range" parameters)))
 241          (finger-code (cdr (assoc "finger-code" parameters)))
 242          (dot-size (cdr (assoc "dot-size" parameters)))
 243          (position (cdr (assoc "position" parameters)))
 244          (dot-list (cdr (assoc "dot-list" parameters)))
 245          (xo-list (cdr (assoc "xo-list" parameters)))
 246          (line-thickness (cdr (assoc "thickness" parameters)))
 247          (barre-list (cdr (assoc "barre-list" parameters)))
 248          (fret-diagram-stencil (ly:stencil-add
 249                             (draw-strings string-count fret-range line-thickness size)
 250                             (draw-frets paper fret-range string-count line-thickness size))))
 251          (if (not (null? dot-list))
 252              (set! fret-diagram-stencil (ly:stencil-add
 253                                     (draw-dots paper string-count fret-range size dot-size position finger-code dot-list)
 254                                     fret-diagram-stencil)))
 255          (if (not (null? xo-list))
 256              (set! fret-diagram-stencil (ly:stencil-add
 257                                     (draw-xo paper string-count fret-range size xo-list)
 258                                     fret-diagram-stencil)))
 259          (if (not (null? barre-list))
 260              (set! fret-diagram-stencil (ly:stencil-add
 261                                     (draw-barre paper string-count fret-range size barre-list)
 262                                     fret-diagram-stencil)))
 263          (set! fret-diagram-stencil (ly:stencil-add  fret-diagram-stencil (label-fret paper string-count fret-range size)))
 264          (ly:stencil-align-to! fret-diagram-stencil X -.4)
 265          fret-diagram-stencil))
 266
 267 (def-markup-command (fret-diagram paper props size definition-string)
 268   (number? string?)
 269   "Syntax: \\fret-diagram size definition-string
 270    eg: \\markup \\fret-diagram #0.75 #\"6-x;5-x;4-o;3-2;2-3;1-2;\"
 271     for fret spacing 3/4 of staff space, D chord diagram
 272     Syntax rules for @var{definition-string}:
 273       Diagram items are separated by semicolons.
 274       Possible items:
 275       t:number -- set the line thickness (in staff spaces).  Default 0.05
 276       h:number -- set the height of the diagram in frets.  Default 4
 277       w:number -- set the width of the diagram in strings.  Default 6
 278       f:number -- set fingering label type
 279                   (0 = none, 1 = in circle on string, 2 = below string)  Default 0
 280       d:number -- set radius of dot, in terms of fret spacing.  Default 0.25
 281       p:number -- set the position of the dot in the fret space. 0.5 is centered; 1 is on lower fret bar,
 282                   0 is on upper fret bar.  Default 0.6
 283       c:string1-string2-fret -- include a barre mark from string1 to string2 on fret
 284       string-fret -- place a dot on string at fret.  If fret is o, string is identified
 285                      as open.  If fret is x, string is identified as muted.
 286       string-fret-fingering -- place a dot on string at fret, and label with fingering as
 287                                defined by f: code.
 288     Note:  There is no limit to the number of fret indications per string."
 289        (make-fret-diagram paper size definition-string))