(define (write-me message x)
"Return X. Display MESSAGE and write X. Handy for debugging, possibly turned off."
- (display message) (write x) (newline) x)
-;; x)
+;; (display message) (write x) (newline) x)
+ x)
(define (tail lst)
"Return tail element of LST."
a)
'()))
+
+
(define (first-n n lst)
"Return first N elements of LST"
(if (and (pair? lst)
(if entry (cdr entry) default)))
+(define (split-at predicate l)
+ "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
+into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k)
+Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
+L1 is copied, L2 not.
+
+(split-at (lambda (x y) (= (- y x) 2)) '(1 3 5 9 11) (cons '() '()))"
+;; "
+
+;; KUT EMACS MODE.
+
+ (define (inner-split predicate l acc)
+ (cond
+ ((null? l) acc)
+ ((null? (cdr l))
+ (set-car! acc (cons (car l) (car acc)))
+ acc)
+ ((predicate (car l) (cadr l))
+ (set-car! acc (cons (car l) (car acc)))
+ (inner-split predicate (cdr l) acc))
+ (else
+ (set-car! acc (cons (car l) (car acc)))
+ (set-cdr! acc (cdr l))
+ acc)
+
+ ))
+ (let*
+ ((c (cons '() '()))
+ )
+ (inner-split predicate l c)
+ (set-car! c (reverse! (car c)))
+ c)
+)
+
;; MARKUP functions
(define (markup-join markups sep)
"Return line-markup of MARKUPS, joining them with markup SEP"
(if (pair? markups)
- (make-line-markup (reduce-list markups sep))
+ (make-line-markup (list-insert-separator markups sep))
empty-markup))
(define (markup-or-empty-markup markup)
ROOT == (ly:pitch-transpose root delta)."
- ;; a little kludgy? Do this in C++ ? --hwn
+ ;; kludgy. Do this in C++ ? --hwn
(let ((simple-octave (- (ly:pitch-octave pitch) (ly:pitch-octave root)))
(simple-notename
(ly:pitch-semitones (ly:make-pitch octave notename 0)))))
(ly:make-pitch octave notename alteration)))))
+
+(define (conditional-kern-before markup bool amount)
+ "Add AMOUNT of space before MARKUP if BOOL is true."
+ (if bool
+ (make-line-markup
+ (list (make-hspace-markup amount)
+ markup))
+ markup
+ ))
+
(define (accidental->markup alteration)
"Return accidental markup for ALTERATION."
(if (= alteration 0)
(make-line-markup (list empty-markup))
- (make-smaller-markup
- (make-musicglyph-markup
- (string-append "accidentals-" (number->string alteration))))))
+ (conditional-kern-before
+ (make-smaller-markup
+ (make-raise-markup
+ (if (= alteration -1)
+ 0.3
+ 0.6)
+ (make-musicglyph-markup
+ (string-append "accidentals-" (number->string alteration)))))
+ (= alteration -1) 0.2
+ )))
(define (pitch->markup pitch)
"Return pitch markup for PITCH."
;;
;; after Klaus Ignatzek, Die Jazzmethode fuer Klavier 1.
;;
-
+;; The idea is: split chords into
+;;
+;; ROOT PREFIXES MAIN-NAME ALTERATIONS SUFFIXES ADDITIONS
+;;
+;; and put that through a layout routine.
+;;
+;; the split is a procedural process , with lots of set!.
+;;
(define natural-chord-alterations
'(
(define natural-7-up-alterations
(butfirst-n 5 natural-chord-alterations) )
+
+
(define-public (ignatzek-chord-names
in-pitches bass inversion options)
- (let*
- (
- (root (car in-pitches))
- (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
- (suffixes '())
- (add-steps '())
- (body '())
- (7-and-up '())
- (sequential-7-to-13 '())
- (sequential-count 0)
- (alterations '())
- (unaltered-count 0)
- )
+ (define maj7-markup
+ (make-simple-markup "maj7")
+ )
(define (get-step x ps)
"Does PS have the X step? Return that step if it does."
(- (ly:pitch-alteration pitch)
(assoc-get-default (+ 1 (ly:pitch-steps pitch)) natural-chord-alterations 0))
)
+ (let*
+ (
+ (num-markup (make-simple-markup
+ (number->string (pitch-step pitch))))
+ (args (list num-markup))
+ (total (if (= (ly:pitch-alteration pitch) 0)
+ (if (= (pitch-step pitch) 7)
+ (list maj7-markup)
+ args)
+ (cons (accidental->markup (step-alteration pitch)) args)
+ ))
+
+ )
- (make-line-markup
- (list
- (accidental->markup (step-alteration pitch))
- (make-simple-markup (number->string (+ 1 (ly:pitch-steps pitch)))))))
-
-
- (define (count-leading-true bs)
- "For the list of booleans BS, count with how many #t's it starts."
- (if (null? bs)
- 0
- (if (car bs)
- (+ 1 (count-leading-true (cdr bs)))
- 0)
- ))
+ (make-line-markup total)))
(define (remove-step x ps)
"Copy PS, but leave out the Xth step."
)
)
+ (define (pitch-step p)
+ "Musicological notation for an interval. Eg. C to D is 2."
+ (+ 1 (ly:pitch-steps p)))
+
+ (define (glue-word-to-step word x)
+ (make-line-markup
+ (list
+ (make-simple-markup word)
+ (name-step x)))
+ )
+
+ (define (is-natural-alteration? p)
+ (= (assoc-get-default (pitch-step p) natural-chord-alterations 0) (ly:pitch-alteration p))
+ )
+
+ (define (filter-main-name p)
+ "The main name: don't print anything for natural 5 or 3."
+ (if
+ (and (is-natural-alteration? p)
+ (or (= (pitch-step p) 5)
+ (= (pitch-step p) 3)))
+ '()
+ (list (name-step p))
+ ))
- (write-me "*****************\nchord " in-pitches)
+ (define (ignatzek-format-chord-name
+ root
+ prefix-modifiers
+ main-name
+ alteration-pitches
+ addition-pitches
+ suffix-modifiers
+ )
+
+
+ (define (suffix-modifier->markup mod)
+ (if (or (= 4 (pitch-step mod))
+ (= 2 (pitch-step mod)))
+ (glue-word-to-step "sus" mod)
+ (glue-word-to-step "huh" mod)
+ ))
+
+ (define (prefix-modifier->markup mod)
+ (if (and (= 3 (pitch-step mod))
+ (= -1 (ly:pitch-alteration mod)))
+ (make-simple-markup "m")
+ (make-simple-markup "huh")
+ ))
+
+
+ (define (filter-alterations alters)
+ (define (altered? p)
+ (not (is-natural-alteration? p)))
+
+ (if
+ (null? alters)
+ '()
+ (let*
+ (
+ (l (filter-list altered? alters))
+ (lp (last-pair alters))
+ )
+
+ ;; we want the highest also if unaltered
+ (if (and (not (altered? (car lp)))
+ (> (pitch-step (car lp)) 5))
+ (append l (last-pair alters))
+ l)
+ )))
+
+ (let*
+ (
+ (sep (make-simple-markup "/"))
+ (root-markup (pitch->markup root))
+ (add-markups (map (lambda (x)
+ (glue-word-to-step "add" x))
+ addition-pitches))
+ (filtered-alterations (filter-alterations alteration-pitches))
+ (alterations (map name-step filtered-alterations))
+ (suffixes (map suffix-modifier->markup suffix-modifiers))
+ (prefixes (map prefix-modifier->markup prefix-modifiers))
+ (prefix-markup (markup-join prefixes sep))
+ (main-markups (filter-main-name main-name))
+ (to-be-raised-stuff (markup-join
+ (append
+ main-markups
+ alterations
+ suffixes
+ add-markups) sep))
+ )
+ (make-line-markup
+ (list
+ root-markup
+ prefix-markup
+ (make-super-markup to-be-raised-stuff))
+ )))
+
+ (let*
+ (
+ (root (car in-pitches))
+ (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
+ (prefixes '())
+ (suffixes '())
+ (add-steps '())
+ (main-name #f)
+ (alterations '())
+ )
+
;; handle sus4 suffix.
(if (get-step 4 pitches)
(begin
(set! add-steps (cons (get-step 3 pitches) add-steps))
(set! pitches (remove-step 3 pitches))
))
- (set! suffixes (cons "sus4" suffixes))
+ (set! suffixes (cons (get-step 4 pitches) suffixes))
)
)
;; handle sus2 suffix.
+ ;; ugh - dup, should use loop.
(if (get-step 2 pitches)
(begin
(if (get-step 3 pitches)
(set! add-steps (cons (get-step 3 pitches) add-steps))
(set! pitches (remove-step 3 pitches))
))
- (set! suffixes (cons "sus2" suffixes))
+ (set! suffixes (cons (get-step 2 pitches) suffixes))
)
)
(if (and (get-step 3 pitches)
(= (ly:pitch-alteration (get-step 3 pitches)) -1))
- (set! body (cons "m" body))
- )
-
- (if (get-step 6 pitches)
- (set! body (cons "6" body ))
+ (set! prefixes (cons (get-step 3 pitches) prefixes))
)
- (if (>= (ly:pitch-steps (tail pitches)) 6)
- (begin
-
- ;; TODO: filter 6, 8, 10, 12, 14
- (set! 7-and-up (remove-uptil-step 7 pitches))
- (set! sequential-count
- (count-leading-true
- (map
- (lambda (x)
- (get-step (car x) 7-and-up))
- natural-7-up-alterations
- )
- ))
-
- (set! sequential-7-to-13
- (first-n sequential-count 7-and-up))
-
- (set! add-steps (append add-steps
- (butfirst-n sequential-count 7-and-up)))
-
- (set! unaltered-count
- (count-leading-true
- (map (lambda (x)
- (= (ly:pitch-alteration (get-step (car x) sequential-7-to-13))
- (cdr x)))
- (first-n (length sequential-7-to-13) natural-7-up-alterations)
- )))
- (write-me "sequential-7-to-13 " sequential-7-to-13)
- (if (pair? sequential-7-to-13)
- (set! body
- (cons (name-step
- (list-ref sequential-7-to-13 (max 0 (- unaltered-count 1))))
- body)))
+ ;; lazy bum. Should write loop.
+ (cond
+ ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
+ ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
+ ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
+ ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
+ ((get-step 3 pitches) (set! main-name (get-step 3 pitches)))
+ )
- (set! alterations (butfirst-n unaltered-count sequential-7-to-13))
+ (let*
+ (
+ (3-diff? (lambda (x y)
+ (= (- (pitch-step y) (pitch-step x)) 2)))
+ (split (split-at 3-diff? (remove-uptil-step 5 pitches)))
+ )
+ (set! alterations (append alterations (car split)))
+ (set! add-steps (append add-steps (cdr split)))
+
+ (set! alterations (delq main-name alterations))
+ (set! add-steps (delq main-name add-steps))
+
+
+ ;; natural 5 7 9 11 13 etc. are named by the top pitch, without
+ ;; any alterations.
+ (if (and
+ (= 7 (pitch-step main-name))
+ (is-natural-alteration? main-name)
+ (pair? (remove-uptil-step 7 alterations))
+ (reduce (lambda (x y) (and x y))
+ (map is-natural-alteration? alterations)))
+ (begin
+ (set! main-name (tail alterations))
+ (set! alterations '())
))
-
- (write-me "alterations " alterations)
- (write-me "add-steps " add-steps)
- (write-me "body " body)
- (write-me "suffixes " suffixes)
-
- (make-simple-markup "bla")
+
+ (ignatzek-format-chord-name root prefixes main-name alterations add-steps suffixes)
+
+ )
))
projects / lilypond.git / commitdiff