OLD | NEW |
1 ;;;; This file is part of LilyPond, the GNU music typesetter. | 1 ;;;; This file is part of LilyPond, the GNU music typesetter. |
2 ;;;; | 2 ;;;; |
3 ;;;; (c) 1998--2015 Han-Wen Nienhuys <hanwen@xs4all.nl> | 3 ;;;; (c) 1998--2015 Han-Wen Nienhuys <hanwen@xs4all.nl> |
4 ;;;; Jan Nieuwenhuizen <janneke@gnu.org> | 4 ;;;; Jan Nieuwenhuizen <janneke@gnu.org> |
5 ;;;; | 5 ;;;; |
6 ;;;; LilyPond is free software: you can redistribute it and/or modify | 6 ;;;; LilyPond is free software: you can redistribute it and/or modify |
7 ;;;; it under the terms of the GNU General Public License as published by | 7 ;;;; it under the terms of the GNU General Public License as published by |
8 ;;;; the Free Software Foundation, either version 3 of the License, or | 8 ;;;; the Free Software Foundation, either version 3 of the License, or |
9 ;;;; (at your option) any later version. | 9 ;;;; (at your option) any later version. |
10 ;;;; | 10 ;;;; |
(...skipping 254 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
265 @code{defaultStrings} will be used as a list of defined strings. | 265 @code{defaultStrings} will be used as a list of defined strings. |
266 Will look for predefined fretboards if @code{predefinedFretboardTable} | 266 Will look for predefined fretboards if @code{predefinedFretboardTable} |
267 is not @code {#f}. If @var{rest} is present, it contains the | 267 is not @code {#f}. If @var{rest} is present, it contains the |
268 @code{FretBoard} grob, and a fretboard will be | 268 @code{FretBoard} grob, and a fretboard will be |
269 created. Otherwise, a list of @code{(string fret finger)} lists will | 269 created. Otherwise, a list of @code{(string fret finger)} lists will |
270 be returned. | 270 be returned. |
271 If the context-property @code{supportNonIntegerFret} is set @code{#t}, | 271 If the context-property @code{supportNonIntegerFret} is set @code{#t}, |
272 micro-tones are supported for TabStaff, but not not for FretBoards." | 272 micro-tones are supported for TabStaff, but not not for FretBoards." |
273 | 273 |
274 ;; helper functions | 274 ;; helper functions |
| 275 (define (barre-list string-frets) |
| 276 "Create a barre-list that reflects the string, fret, and finger |
| 277 entries in @var{string-frets}." |
| 278 (let* ((finger-range '(0 4)) ; range of possible finger numbers |
| 279 (barre-elements 4) ; 4 elements per barre entry: |
| 280 ; 'barre |
| 281 ; highest string number |
| 282 ; lowest string number |
| 283 ; finger (seems redundant, but makes it |
| 284 ; easy to convert from array to list |
| 285 (barres (make-array 0 finger-range barre-elements)) |
| 286 (add-string-fret |
| 287 (lambda(sf) |
| 288 (let ((string (car sf)) |
| 289 (fret (cadr sf)) |
| 290 (finger (if (null? (caddr sf)) 0 (caddr sf)))) |
| 291 (if (and (not (= fret 0)) (not (= finger 0))) |
| 292 (begin |
| 293 (array-set! barres 'barre finger 0) |
| 294 (array-set! barres fret finger 3) |
| 295 (if (or (< (array-ref barres finger 1) string) |
| 296 (= 0 (array-ref barres finger 1))) |
| 297 (array-set! barres string finger 1)) |
| 298 (if (or (> (array-ref barres finger 2) string) |
| 299 (= 0 (array-ref barres finger 2))) |
| 300 (array-set! barres string finger 2))))))) |
| 301 (barre-list (begin |
| 302 (map add-string-fret string-frets) |
| 303 (array->list barres)))) |
| 304 (begin |
| 305 (display barre-list) |
| 306 (filter (lambda(l) (and (eq? (car l) 'barre) |
| 307 (not (= (fourth l) 0)) |
| 308 (> (second l) (third l)))) |
| 309 barre-list)))) |
| 310 |
275 | 311 |
276 (define (string-frets->placement-list string-frets string-count) | 312 (define (string-frets->placement-list string-frets string-count) |
277 "Convert @var{string-frets} to @code{fret-diagram-verbose} | 313 "Convert @var{string-frets} to @code{fret-diagram-verbose} |
278 dot placement entries." | 314 dot placement entries." |
279 (let* ((placements (list->vector | 315 (let* ((placements (list->vector |
280 (map (lambda (x) (list 'mute x)) | 316 (map (lambda (x) (list 'mute x)) |
281 (iota string-count 1))))) | 317 (iota string-count 1)))) |
282 | 318 (no-fingers (null? (filter (lambda (sf) |
| 319 (not (null? (caddr sf)))) |
| 320 string-frets))) |
| 321 (b-list (barre-list string-frets))) |
283 (for-each (lambda (sf) | 322 (for-each (lambda (sf) |
284 (let* ((string (car sf)) | 323 (let* ((string (car sf)) |
285 (fret (cadr sf)) | 324 (fret (cadr sf)) |
286 (finger (caddr sf))) | 325 (finger (caddr sf))) |
287 (vector-set! | 326 (vector-set! |
288 placements | 327 placements |
289 (1- string) | 328 (1- string) |
290 (if (= 0 fret) | 329 (if (= 0 fret) |
291 (list 'open string) | 330 (list 'open string) |
292 (if finger | 331 (if (null? finger) |
293 (list 'place-fret string fret finger) | 332 (list 'place-fret string fret) |
294 (list 'place-fret string fret)))))) | 333 (list 'place-fret string fret finger)))))) |
295 string-frets) | 334 string-frets) |
296 (vector->list placements))) | 335 (if (or (null? b-list) no-fingers) |
| 336 (vector->list placements) |
| 337 (append (vector->list placements) b-list)))) |
297 | 338 |
298 (define (placement-list->string-frets placement-list) | 339 (define (placement-list->string-frets placement-list) |
299 "Convert @var{placement-list} to string-fret list." | 340 "Convert @var{placement-list} to string-fret list." |
300 (map (lambda (x) (if (eq? (car x) 'place-fret) | 341 (map (lambda (x) (if (eq? (car x) 'place-fret) |
301 (cdr x) | 342 (cdr x) |
302 (list (cadr x) 0))) | 343 (list (cadr x) 0))) |
303 (filter (lambda (l) (or (eq? (car l) 'place-fret) | 344 (filter (lambda (l) (or (eq? (car l) 'place-fret) |
304 (eq? (car l) 'open))) | 345 (eq? (car l) 'open))) |
305 placement-list))) | 346 placement-list))) |
306 | 347 |
(...skipping 89 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
396 string | 437 string |
397 tuning))) | 438 tuning))) |
398 (if (< this-fret 0) | 439 (if (< this-fret 0) |
399 (ly:warning (_ "Negative fret for pitch ~a on string ~a") | 440 (ly:warning (_ "Negative fret for pitch ~a on string ~a") |
400 (car pitch-entry) string) | 441 (car pitch-entry) string) |
401 (if (and | 442 (if (and |
402 (not (integer? this-fret)) | 443 (not (integer? this-fret)) |
403 (not (ly:context-property context 'supportNonIntegerFret #f))) | 444 (not (ly:context-property context 'supportNonIntegerFret #f))) |
404 (ly:warning (_ "Missing fret for pitch ~a on string ~a") | 445 (ly:warning (_ "Missing fret for pitch ~a on string ~a") |
405 (car pitch-entry) string))) | 446 (car pitch-entry) string))) |
| 447 (if (and (= this-fret 0) |
| 448 (and finger |
| 449 (not (null? finger)))) |
| 450 (ly:warning (_ "Open fret on string ~a has finger of ~a") |
| 451 string finger)) |
406 (delete-free-string string) | 452 (delete-free-string string) |
407 (set! specified-frets (cons this-fret specified-frets)) | 453 (set! specified-frets (cons this-fret specified-frets)) |
408 (list-set! string-fret-fingers | 454 (list-set! string-fret-fingers |
409 (cdr pitch-entry) | 455 (cdr pitch-entry) |
410 (list string this-fret finger)))) | 456 (list string this-fret finger)))) |
411 | 457 |
412 (define (kill-note! string-fret-fingers note-index) | 458 (define (kill-note! string-fret-fingers note-index) |
413 (list-set! string-fret-fingers note-index (list #f #t))) | 459 (list-set! string-fret-fingers note-index (list #f #t))) |
414 | 460 |
415 (define string-fret-fingers | 461 (define string-fret-fingers |
(...skipping 401 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
817 (define ((shift-semitone->pitch key semitone->pitch) semitone) | 863 (define ((shift-semitone->pitch key semitone->pitch) semitone) |
818 "Given a function @var{semitone->pitch} converting a semitone number | 864 "Given a function @var{semitone->pitch} converting a semitone number |
819 into a note value for a lookup table created in relation to@tie{}C, | 865 into a note value for a lookup table created in relation to@tie{}C, |
820 returns a corresponding function in relation to @var{key}. The note | 866 returns a corresponding function in relation to @var{key}. The note |
821 values returned by this function differ only enharmonically from the | 867 values returned by this function differ only enharmonically from the |
822 original @var{semitone->pitch} function." | 868 original @var{semitone->pitch} function." |
823 (ly:pitch-transpose (semitone->pitch (- semitone (* 2 (ly:pitch-tones key)))) | 869 (ly:pitch-transpose (semitone->pitch (- semitone (* 2 (ly:pitch-tones key)))) |
824 key)) | 870 key)) |
825 | 871 |
826 (export shift-semitone->pitch) | 872 (export shift-semitone->pitch) |
OLD | NEW |