Left: | ||
Right: |
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--2011 Han-Wen Nienhuys <hanwen@xs4all.nl> | 3 ;;;; (c) 1998--2011 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 222 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... | |
233 dot placement entries." | 233 dot placement entries." |
234 (let* ((placements (list->vector | 234 (let* ((placements (list->vector |
235 (map (lambda (x) (list 'mute (1+ x))) | 235 (map (lambda (x) (list 'mute (1+ x))) |
236 (iota string-count))))) | 236 (iota string-count))))) |
237 | 237 |
238 (for-each (lambda (sf) | 238 (for-each (lambda (sf) |
239 (let* ((string (car sf)) | 239 (let* ((string (car sf)) |
240 (fret (cadr sf)) | 240 (fret (cadr sf)) |
241 (finger (caddr sf))) | 241 (finger (caddr sf))) |
242 (vector-set! | 242 (vector-set! |
243 placements (1- string) | 243 placements |
244 » » (if (= 0 fret) | 244 » » (1- string) |
245 (list 'open string) | 245 » » (if (= 0 fret) |
246 » » » (if finger | 246 (list 'open string) |
247 » » » (list 'place-fret string fret finger) | 247 » » » (if finger |
248 » » » (list 'place-fret string fret)))))) | 248 » » » (list 'place-fret string fret finger) |
249 » » » (list 'place-fret string fret)))))) | |
249 string-frets) | 250 string-frets) |
250 (vector->list placements))) | 251 (vector->list placements))) |
251 | 252 |
252 (define (placement-list->string-frets placement-list) | 253 (define (placement-list->string-frets placement-list) |
253 "Convert @var{placement-list} to string-fret list." | 254 "Convert @var{placement-list} to string-fret list." |
254 (map (lambda (x) (if (eq? (car x) 'place-fret) | 255 (map (lambda (x) (if (eq? (car x) 'place-fret) |
255 (cdr x) | 256 (cdr x) |
256 (list (cadr x) 0))) | 257 (list (cadr x) 0))) |
257 (filter (lambda (l) (or (eq? (car l) 'place-fret) | 258 (filter (lambda (l) (or (eq? (car l) 'place-fret) |
258 (eq? (car l) 'open))) | 259 (eq? (car l) 'open))) |
259 placement-list))) | 260 placement-list))) |
260 | 261 |
261 (define (entry-count art-list) | 262 (define (entry-count art-list) |
263 "Count the number of entries in a list of articulations." | |
262 (length (filter (lambda (x) (not (null? x))) | 264 (length (filter (lambda (x) (not (null? x))) |
263 art-list))) | 265 art-list))) |
264 | 266 |
265 (define (determine-frets-and-strings | 267 (define (determine-frets-and-strings |
266 notes | 268 notes |
267 defined-strings | 269 defined-strings |
268 defined-fingers | 270 defined-fingers |
269 minimum-fret | 271 minimum-fret |
270 maximum-stretch | 272 maximum-stretch |
271 tuning) | 273 tuning) |
274 "Determine the frets and strings used to play the notes in | |
275 @var{notes}, given @var{defined-strings} and @var{defined-fingers} | |
276 along with @var{minimum-fret}, @var{maximum-stretch}, and | |
277 @var{tuning}. Returns a list of @code{(string fret finger) lists." | |
278 | |
279 (define specified-frets '()) | |
280 (define free-strings (map 1+ (iota (length tuning)))) | |
Neil Puttock
2011/05/09 18:53:48
could use srfi-1 iota here:
(iota (length tuning)
| |
272 | 281 |
273 (define (calc-fret pitch string tuning) | 282 (define (calc-fret pitch string tuning) |
283 "Calculate the fret to play @var{pitch} on @var{string} with | |
284 @var{tuning}." | |
274 (- (ly:pitch-semitones pitch) (ly:pitch-semitones (list-ref tuning (1- str ing))))) | 285 (- (ly:pitch-semitones pitch) (ly:pitch-semitones (list-ref tuning (1- str ing))))) |
275 | 286 |
276 (define (note-pitch a) | 287 (define (note-pitch note) |
277 (ly:event-property a 'pitch)) | 288 "Get the pitch (in semitones) from @var{note}." |
278 | 289 (ly:event-property note 'pitch)) |
279 (define (note-pitch>? a b) | |
280 (ly:pitch<? (note-pitch b) | |
281 » » (note-pitch a))) | |
282 | 290 |
283 (define (note-finger ev) | 291 (define (note-finger ev) |
292 "Get the fingering from @var{ev}. Return @var{#f} | |
293 if no fingering is present." | |
284 (let* ((articulations (ly:event-property ev 'articulations)) | 294 (let* ((articulations (ly:event-property ev 'articulations)) |
285 (finger-found #f)) | 295 (finger-found #f)) |
286 | |
287 (map (lambda (art) | 296 (map (lambda (art) |
288 (let* ((num (ly:event-property art 'digit))) | 297 (let* ((num (ly:event-property art 'digit))) |
289 | 298 |
290 (if (and (eq? 'fingering-event (ly:event-property art 'class)) | 299 (if (and (eq? 'fingering-event (ly:event-property art 'class)) |
291 (number? num) | 300 (number? num) |
292 (> num 0)) | 301 (> num 0)) |
293 (set! finger-found num)))) | 302 (set! finger-found num)))) |
294 articulations) | 303 articulations) |
295 | |
296 finger-found)) | 304 finger-found)) |
297 | 305 |
298 (define (string-number event) | 306 (define (string-number event) |
307 "Get the string-number from @var{event}. Return @var{#f} | |
308 if no string-number is present." | |
299 (let ((num (ly:event-property event 'string-number))) | 309 (let ((num (ly:event-property event 'string-number))) |
300 (if (number? num) | 310 (if (number? num) |
301 num | 311 num |
302 #f))) | 312 #f))) |
303 | 313 |
304 (define (delete-free-string string) | 314 (define (delete-free-string string) |
305 (if (number? string) | 315 (if (number? string) |
306 (set! free-strings | 316 (set! free-strings |
307 (delete string free-strings)))) | 317 (delete string free-strings)))) |
308 | 318 |
309 (define free-strings '()) | |
310 (define unassigned-notes '()) | |
311 (define specified-frets '()) | |
312 | |
313 (define (close-enough fret) | 319 (define (close-enough fret) |
320 "Decide if @var{fret} is acceptable, given the already used frets." | |
314 (if (null? specified-frets) | 321 (if (null? specified-frets) |
315 #t | 322 #t |
316 (reduce | 323 (reduce |
317 (lambda (x y) | 324 (lambda (x y) |
318 (and x y)) | 325 (and x y)) |
319 #t | 326 #t |
320 (map (lambda (specced-fret) | 327 (map (lambda (specced-fret) |
321 (or (eq? 0 specced-fret) | 328 (or (eq? 0 specced-fret) |
322 (>= maximum-stretch (abs (- fret specced-fret))))) | 329 (>= maximum-stretch (abs (- fret specced-fret))))) |
323 specified-frets)))) | 330 specified-frets)))) |
324 | 331 |
325 (define (string-qualifies string pitch) | 332 (define (string-qualifies string pitch) |
333 "Can @var{pitch} be played on @var{string}, given already placed | |
334 notes?" | |
326 (let* ((fret (calc-fret pitch string tuning))) | 335 (let* ((fret (calc-fret pitch string tuning))) |
327 (and (>= fret minimum-fret) | 336 (and (>= fret minimum-fret) |
328 (close-enough fret)))) | 337 (close-enough fret)))) |
329 | 338 |
330 (define (open-string string pitch) | 339 (define (open-string string pitch) |
340 "Is @var{pitch} and open-string note on @var{string}, given | |
341 the current tuning?" | |
331 (let* ((fret (calc-fret pitch string tuning))) | 342 (let* ((fret (calc-fret pitch string tuning))) |
332 (eq? fret 0))) | 343 (eq? fret 0))) |
333 | 344 |
334 (define string-fret-fingering-tuples '()) | 345 (define (set-fret! pitch-entry string finger) |
335 | 346 (let ((this-fret (calc-fret (car pitch-entry) |
336 (define (set-fret note string) | |
337 (let ((this-fret (calc-fret (ly:event-property note 'pitch) | |
338 string | 347 string |
339 tuning))) | 348 tuning))) |
340 (if (< this-fret 0) | 349 (if (< this-fret 0) |
341 (ly:warning (_ "Negative fret for pitch ~a on string ~a") | 350 (ly:warning (_ "Negative fret for pitch ~a on string ~a") |
342 (note-pitch note) string)) | 351 (note-pitch note) string)) |
Keith
2011/05/26 03:26:32
(car pitch-entry) string))
`make check` was crashi
| |
343 (set! string-fret-fingering-tuples | |
344 (cons (list string | |
345 this-fret | |
346 (note-finger note)) | |
347 string-fret-fingering-tuples)) | |
348 (delete-free-string string) | 352 (delete-free-string string) |
349 » (set! specified-frets (cons this-fret specified-frets)))) | 353 (set! specified-frets (cons this-fret specified-frets)) |
354 (list-set! string-fret-fingers | |
355 (cdr pitch-entry) | |
356 (list string this-fret finger)))) | |
350 | 357 |
351 (define (pad-list target template) | 358 (define string-fret-fingers |
352 (while (< (length target) (length template)) | 359 (map (lambda (string finger) |
353 » (set! target (if (null? target) | 360 (if (null? finger) |
354 » » » '(()) | 361 (list string #f) |
355 » » » (append target '(())))))) | 362 (list string #f finger))) |
363 defined-strings defined-fingers)) | |
356 | 364 |
357 ;;; body of determine-frets-and-strings | 365 ;;; body of determine-frets-and-strings |
358 (set! free-strings (map 1+ (iota (length tuning)))) | 366 (let* ((pitch-alist (apply (lambda (mylist) |
367 (let ((index -1)) | |
368 (map (lambda (note) | |
369 (begin | |
370 (set! index (1+ index)) | |
371 (cons (note-pitch note) | |
372 index))) | |
373 mylist))) | |
374 notes '())) | |
375 (pitches (map note-pitch notes))) | |
359 | 376 |
360 ;; get defined-strings same length as notes | 377 ;; handle notes with strings assigned and fingering of 0 |
361 (pad-list defined-strings notes) | 378 (for-each |
362 | 379 (lambda (pitch-entry string-fret-finger) |
363 ;; get defined-fingers same length as notes | 380 » (let* ((string (list-ref string-fret-finger 0)) |
364 (pad-list defined-fingers notes) | 381 (finger (if (eq? (length string-fret-finger) 3) |
365 | 382 (list-ref string-fret-finger 2) |
366 ;; handle notes with strings assigned and fingering of 0 | 383 '())) |
384 (pitch (car pitch-entry)) | |
385 (digit (if (null? finger) | |
386 » » #f | |
387 » » finger))) | |
388 » (if (or (not (null? string)) | |
389 » » (eq? digit 0)) | |
390 » (if (eq? digit 0) | |
391 ;; here we handle fingers of 0 -- open strings | |
392 » (let ((fit-string | |
393 » » (find (lambda (string) | |
394 » » » (open-string string pitch)) | |
395 » » » free-strings))) | |
396 » » (if fit-string | |
397 (set-fret! pitch-entry fit-string #f) | |
398 » » (ly:warning (_ "No open string for pitch ~a") | |
399 » » » » pitch))) | |
400 ;; here we handle assigned strings | |
401 » (let ((this-fret | |
402 (calc-fret pitch string tuning)) | |
403 » » (handle-negative | |
404 » » (ly:context-property context | |
405 » » » » » 'handleNegativeFrets | |
406 » » » » » 'recalculate))) | |
407 » » (cond ((or (>= this-fret 0) | |
408 » » » (eq? handle-negative 'include)) | |
409 (set-fret! pitch-entry string finger)) | |
410 » » ((eq? handle-negative 'recalculate) | |
411 » » » (begin | |
412 (ly:warning | |
413 (_ "Requested string for pitch requires negativ e fret: string ~a pitch ~a") | |
414 string | |
415 pitch) | |
416 » » » (ly:warning (_ "Ignoring string request.")) | |
417 (list-set! string-fret-fingers | |
418 (cdr pitch-entry) | |
419 (if (null? finger) | |
420 (list '() #f) | |
421 (list '() #f finger))))))))))) | |
422 pitch-alist string-fret-fingers) | |
423 ;; handle notes without strings assigned -- sorted by pitch, so | |
424 ;; we need to use the alist to have the note number available | |
367 (for-each | 425 (for-each |
368 (lambda (note string finger) | 426 (lambda (pitch-entry) |
369 » (let ((digit (if (null? finger) | 427 » (let* ((string-fret-finger (list-ref string-fret-fingers |
370 » » #f | 428 (cdr pitch-entry))) |
371 » » finger))) | 429 (string (list-ref string-fret-finger 0)) |
372 » (if (and (null? string) | 430 (finger (if (eq? (length string-fret-finger) 3) |
373 » » (not (eq? digit 0))) | 431 (list-ref string-fret-finger 2) |
374 » (set! unassigned-notes (cons note unassigned-notes)) | 432 '())) |
375 » (if (eq? digit 0) | 433 (pitch (car pitch-entry)) |
376 » (let ((fit-string | 434 (fit-string |
377 » » (find (lambda (string) | 435 » (find (lambda (string) |
378 » » » (open-string string (note-pitch note))) | 436 » » (string-qualifies string pitch)) |
379 » » » free-strings))) | 437 » » free-strings))) |
380 » » (if fit-string | 438 (if (not (list-ref string-fret-finger 1)) |
381 » » (begin | 439 » (if fit-string |
382 » » (delete-free-string fit-string) | 440 (set-fret! pitch-entry fit-string finger) |
383 » » (set-fret note fit-string)) | 441 » (ly:warning (_ "No string for pitch ~a (given frets ~a)") |
384 » » (begin | 442 » » pitch |
385 » » (ly:warning (_ "No open string for pitch ~a") | 443 specified-frets))))) |
386 » » » » (note-pitch note)) | 444 (sort pitch-alist (lambda (pitch-entry-a pitch-entry-b) |
387 » » (set! unassigned-notes (cons note unassigned-notes))))) | 445 (ly:pitch<? (car pitch-entry-b) |
388 » (let ((this-fret (calc-fret (note-pitch note) string tuning)) | 446 (car pitch-entry-a))))) |
389 » » (handle-negative | 447 string-fret-fingers)) ;; end of determine-frets-and-strings |
390 » » (ly:context-property context | |
391 » » » » » 'handleNegativeFrets | |
392 » » » » » 'recalculate))) | |
393 » » (cond ((or (>= this-fret 0) | |
394 » » » (eq? handle-negative 'include)) | |
395 » » (begin | |
396 » » » (delete-free-string string) | |
397 » » » (set-fret note string))) | |
398 » » ((eq? handle-negative 'recalculate) | |
399 » » (begin | |
400 » » » (ly:warning (_ "Requested string for pitch requires neg ative fret: string ~a pitch ~a") string (note-pitch note)) | |
401 » » » (ly:warning (_ "Ignoring string request.")) | |
402 » » (set! unassigned-notes (cons note unassigned-notes))))) ))))) | |
403 notes defined-strings defined-fingers) | |
404 | |
405 ;; handle notes without strings assigned | |
406 (for-each | |
407 (lambda (note) | |
408 » (let ((fit-string | |
409 » » (find (lambda (string) | |
410 » » » (string-qualifies string (note-pitch note))) | |
411 » » free-strings))) | |
412 » (if fit-string | |
413 » (set-fret note fit-string) | |
414 » (ly:warning (_ "No string for pitch ~a (given frets ~a)") | |
415 » » » (note-pitch note) | |
416 » » » specified-frets)))) | |
417 (sort unassigned-notes note-pitch>?)) | |
418 | |
419 string-fret-fingering-tuples) ;; end of determine-frets-and-strings | |
420 | 448 |
421 (define (get-predefined-fretboard predefined-fret-table tuning pitches) | 449 (define (get-predefined-fretboard predefined-fret-table tuning pitches) |
422 "Search through @var{predefined-fret-table} looking for a predefined | 450 "Search through @var{predefined-fret-table} looking for a predefined |
423 fretboard with a key of @var{(tuning . pitches)}. The search will check | 451 fretboard with a key of @var{(tuning . pitches)}. The search will check |
424 both up and down an octave in order to accomodate transposition of the | 452 both up and down an octave in order to accomodate transposition of the |
425 chords. Returns a placement-list." | 453 chords. Returns a placement-list." |
426 | 454 |
427 (define (get-fretboard key) | 455 (define (get-fretboard key) |
428 (let ((hash-handle | 456 (let ((hash-handle |
429 (hash-get-handle predefined-fret-table key))) | 457 (hash-get-handle predefined-fret-table key))) |
430 (if hash-handle | 458 (if hash-handle |
431 (cdr hash-handle) ; return table entry | 459 (cdr hash-handle) ; return table entry |
432 '()))) | 460 '()))) |
433 | 461 |
434 | |
435 | |
436 ;; body of get-predefined-fretboard | 462 ;; body of get-predefined-fretboard |
437 (let ((test-fretboard (get-fretboard (cons tuning pitches)))) | 463 (let ((test-fretboard (get-fretboard (cons tuning pitches)))) |
438 (if (not (null? test-fretboard)) | 464 (if (not (null? test-fretboard)) |
439 test-fretboard | 465 test-fretboard |
440 (let ((test-fretboard | 466 (let ((test-fretboard |
441 (get-fretboard | 467 (get-fretboard |
442 (cons tuning (map (lambda (x) (shift-octave x 1)) pitches))))) | 468 (cons tuning (map (lambda (x) (shift-octave x 1)) pitches))))) |
443 (if (not (null? test-fretboard)) | 469 (if (not (null? test-fretboard)) |
444 test-fretboard | 470 test-fretboard |
445 (get-fretboard | 471 (get-fretboard |
(...skipping 125 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... | |
571 (define-public (all-bar-numbers-visible barnum) #t) | 597 (define-public (all-bar-numbers-visible barnum) #t) |
572 | 598 |
573 | 599 |
574 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | 600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
575 ;; percent repeat counters | 601 ;; percent repeat counters |
576 | 602 |
577 (define-public ((every-nth-repeat-count-visible n) count context) | 603 (define-public ((every-nth-repeat-count-visible n) count context) |
578 (= 0 (modulo count n))) | 604 (= 0 (modulo count n))) |
579 | 605 |
580 (define-public (all-repeat-counts-visible count context) #t) | 606 (define-public (all-repeat-counts-visible count context) #t) |
OLD | NEW |