Akkorde zeichnen/scheme
Zur Navigation springen
Zur Suche springen
#(define (naturalize-pitch p)
;; reduces alteration greater than a half tone step
;; #(display (naturalize-pitch #{ fes #}))
;; #<Pitch e >
(let ((o (ly:pitch-octave p))
(a (* 4 (ly:pitch-alteration p)))
;; alteration, a, in quarter tone steps,
;; for historical reasons
(n (ly:pitch-notename p)))
(cond
((and (> a 1)
(or (eq? n 6)
(eq? n 2)))
(set! a (- a 2))
(set! n (+ n 1)))
((and (< a -1)
(or (eq? n 0) (eq? n 3)))
(set! a (+ a 2))
(set! n (- n 1))))
(cond
((> a 2) (set! a (- a 4)) (set! n (+ n 1)))
((< a -2) (set! a (+ a 4)) (set! n (- n 1))))
(ly:make-pitch o n (/ a 4))))
#(define (all-pitches-from-music music)
"Return a list of all pitches from @var{music}."
;; Opencoded for efficiency.
(reverse!
(let loop ((music music) (pitches '()))
(let ((p (ly:music-property music 'pitch)))
(if (ly:pitch? p)
(cons (naturalize-pitch p) pitches)
(let ((elt (ly:music-property music 'element)))
(fold loop
(if (ly:music? elt)
(loop elt pitches)
pitches)
(ly:music-property music 'elements))))))))
#(define (low-pitch music)
;; returns the lowest pitch from music
(car (sort (all-pitches-from-music music) ly:pitch<?)))
%%
#(define (high-pitch music)
;; returns the highest pitch from music
(car (reverse (sort (all-pitches-from-music music) ly:pitch<?))))
#(define (pitch-between? p p1 p2)
(and (not (ly:pitch<? p p1)) (not (ly:pitch<? p2 p))))
#(define (pitch-equals? p1 p2)
;(write-me "pitch-equals? ----------------------------> " (list p1 p2))
(and
(= (ly:pitch-alteration p1) (ly:pitch-alteration p2))
(= (ly:pitch-notename p1) (ly:pitch-notename p2))))
#(define (standardize-pitch p)
;; make pitches with SHARPs or no alteration
;; standardize-pitch c ==> c
;; standardize-pitch cis ==> cis
;; standardize-pitch des ==> cis
(let* ((p1 (naturalize-pitch p))
(a (ly:pitch-alteration p1))
(n (ly:pitch-notename p1))
(o (ly:pitch-octave p1))
(a1 (- a 0.5))
(n1 (inexact->exact (+ n a1))))
;procedure body
(if (= a 0)
p1
(ly:make-pitch o n1 SHARP))))
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% pitchlist functions and creating a complete pitchlist for keyboard
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% definitions for the measures of the keyboard keys
#(define white-key-width 23.5) %% the width of a white piano key
%%#(define white-key-height 150) %% the height of a white piano key
%%#(define black-key-width 15) %% the width of a black piano key
%%#(define black-key-height 95) %% the height of a black piano key
#(define white-key-height (* (/ white-key-width 23.5) 150))
#(define black-key-width (/ white-key-height 10)) %% the width of a black piano key
#(define black-key-height (* (/ white-key-width 23.5) 95)) %% the height of a black piano key
#(define black-key-y-start (- white-key-height black-key-height)) %% the y-coordinate of black keys
%% left coordinate of black keys cis/des fis/ges
%% n=0 oder n=3 (index number of global default scale)
#(define black-key-cis-start (* (/ white-key-width 23.5) 13))
%% left coordinate of centered black keys gis/as
%% n=4 (index number of global default scale)
#(define black-key-gis-start (* (/ white-key-width 23.5) 16))
%% left coordinate of right black keys dis/es ais/b
%% n=1 oder n=5 (index number of global default scale)
#(define black-key-dis-start (* (/ white-key-width 23.5) 19))
#(define octav-distance (* 7 white-key-width))
%% define circle diameter for the dots
%% just try what looks fine
#(define kreis-dm (* black-key-width 0.5)) %% circle diameter
%% create complete pitchlist for a specific octave
#(define (pitch-list o)
;(display o)(newline)
(list
(ly:make-pitch o 0 0) ; c
(ly:make-pitch o 0 SHARP) ; cis
;(ly:make-pitch o 1 FLAT) ; des
(ly:make-pitch o 1 0) ; d
(ly:make-pitch o 1 SHARP) ; dis
;(ly:make-pitch o 2 FLAT) ; es
(ly:make-pitch o 2 0) ; e
(ly:make-pitch o 3 0) ; f
(ly:make-pitch o 3 SHARP) ; fis
;(ly:make-pitch o 4 FLAT) ; ges
(ly:make-pitch o 4 0) ; g
(ly:make-pitch o 4 SHARP) ; gis
;(ly:make-pitch o 5 FLAT) ; as
(ly:make-pitch o 5 0) ; a
(ly:make-pitch o 5 SHARP) ; ais
;(ly:make-pitch o 6 FLAT) ; b
(ly:make-pitch o 6 0) ; h
))
%% all pitches that occor on a keyboard as a list
#(define all-pitches
(append-map (lambda (o) (pitch-list o))
(iota 8 -4)))
%% add all octaves to one pitch
#(define (all-octaves p)
;(display "all-octaves p: ") (display p)(newline)
(map (lambda (o) (ly:make-pitch o (ly:pitch-notename p) (ly:pitch-alteration p)))
(iota 8 -4)))
#(define (white-key? p)
(let
((a (ly:pitch-alteration (naturalize-pitch p))))
(if (= a 0)
#t
#f)))
#(define (black-key? p)
(not (white-key? p)))
%% removes all pitches without alteration, leaves only black keys
#(define (bl-filter p-list)
(remove white-key? p-list))
#(define (pitches-in-interval p1 p2)
;; returns a pitchlist of all pitches
;; between p1 and p2
(filter
(lambda (p) (pitch-between? p p1 p2))
all-pitches))
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% stencil functions
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%calculation the starting point of a key
#(define (start-point-key p)
;; calculation the starting point of a key
;; depending on the pitch p
;; result is a pair of coordinates (x . y)
(let*
((m (naturalize-pitch p))
(o (ly:pitch-octave m))
(a (ly:pitch-alteration m))
;; we must naturalize pitch otherwise wrong result for eis e.g.
;; we subtract the alteration from the notename and add a half
;; so we end up at the same note despite flat oder sharp
;; cis is drawn the same as des e.g.
(n (ly:pitch-notename m))
(n1 (+ n a -0.5))
(x-shift (* o 7 white-key-width))
)
(cond
((eq? a 0)
;; alteration eq 0
;; no alteration ==> white key
(cons (+ (* n white-key-width) x-shift) 0 ))
((or (= n1 0) (= n1 3))
;; "left" black keys cis/des and fis/ges
;; notename=0 or 3 and alteration
;; n=0 oder n=3
(cons (+ (* n1 white-key-width) black-key-cis-start x-shift ) black-key-y-start ))
((or (= n1 1) (= n1 5))
;; "right" black keys dis/es and ais/b
;; notename=0 or 3 and alteration
;, n=1 oder n=5
(cons (+ (* n1 white-key-width) black-key-dis-start x-shift ) black-key-y-start ))
(else
;; only one left, the centered black key gis/as
(cons (+ (* n1 white-key-width) black-key-gis-start x-shift) black-key-y-start )))))
%% alist for key coordinates of all pitches
%% the key is the pitch
#(define coord-pitches
(map (lambda (x) (cons x (start-point-key x))) all-pitches))
#(define (x-koord p)
;; retrieving x-coordinate of pitch p
(car (assoc-get (standardize-pitch p) coord-pitches)))
#(define (y-koord p)
;; retrieving y-coordinate of pitch p
(cdr (assoc-get (standardize-pitch p) coord-pitches)))
#(define (draw-key p xshift w-color b-bolor)
;; draws either a white key or a black key
;; the distance from origin depends on the pitch
;; you may shift the key
;; w-color: Farbe der weißen Tasten
;; b-color: Farbe der schwarzen Tasten
(let*
((p1 (naturalize-pitch p))
(wh-key (ly:stencil-add
(ly:stencil-in-color
(make-connected-path-stencil
;; wir zeichnen einfach ein Quadrat
;; das mit Höhe und Breite verformt wird
'((0 0) (1 0) (1 1) (0 1))
0.1 ;; thickness
white-key-width
white-key-height
#t ;; close path
#t ;; fill path
)
(first w-color) (second w-color) (third w-color))
(make-connected-path-stencil
;; die Umrahmung zeichnen
'((0 0) (1 0) (1 1) (0 1))
0.1 ;; thickness
white-key-width
white-key-height
#t ;; close path
#f ;; do not fill path
)))
(bl-key (ly:stencil-in-color
(make-connected-path-stencil
'((0 0) (1 0) (1 1) (0 1) )
0.5
black-key-width black-key-height
#t ;; close path
#t ;; fill path
)
(first b-bolor) (second b-bolor) (third b-bolor) ))
(x-start (- (x-koord p1) xshift)))
(if (white-key? p)
(begin
(ly:stencil-translate-axis wh-key x-start X)
;(write-me "wh-key------------------------------- " wh-key)
;(write-me "x-start------------------------------- " x-start)
;(write-me "X------------------------------- " X)
)
(ly:stencil-translate bl-key (cons x-start (y-koord p1)))
)))
%% einen Punkt erzeugen
%% w-color wird auf die weißen Tasten gezeichnet
%% es empfiehlt sich, eine Kontrastfarbe zu wählen
#(define (draw-dot p xshift b-color w-color)
(let ((x-start (- (x-koord p) xshift))
(y-start (y-koord p)))
(if (white-key? p) ;; Punkt für eine weiße Taste erzeugen
(ly:stencil-in-color
(ly:stencil-translate
(make-circle-stencil kreis-dm 0 #t)
(cons
(+ x-start (/ white-key-width 2))
(+ y-start (/ (- white-key-height black-key-height) 1.5))))
(first w-color) (second w-color) (third w-color))
(ly:stencil-in-color ;; Punkt für eine schwarze Taste erzeugen
(ly:stencil-translate
(make-circle-stencil kreis-dm 0 #t)
(cons
(+ x-start (/ black-key-width 2 ))
(+ y-start (/ black-key-height 5))))
(first b-color) (second b-color) (third b-color))
)))
#(define (draw-keyboard p1 p2 music w-color b-color w-mus-color b-mus-color)
;; wir zeichnen eine Tastatur von p1-p2
;; die Tasten, die in music enthalten sind, werden in den Farben w-mus-color b-mus-color gefärbt
;; es wird außerdem überprüft, ob die Musik komplett innerhalb des Bereiches liegt
;, wenn nicht, wird das Zeichenintervall ausgedehnt
;; zeichnet die Tastatur von p1 nach p2
;; music sollte Musik enthalten
;; zunächst wird die Grundlage gezeichnet
;; die weißen und die schwarzen Tasten
;; Farbe w-key-color und
(let*
((l-p (low-pitch music)) ;; lowest pitch of music
(u-p (high-pitch music)) ;; highest pitch of music
(lowp (if (ly:pitch<? l-p p1) l-p p1)) ;; leftmost key of keyboard
(upp (if (ly:pitch<? p2 u-p) u-p p2)) ;; rightmost key of keyboard
(start-low-x (x-koord lowp)) ;; we shift the whole stencil
(pi-int (pitches-in-interval lowp upp)) ;; interval of pitches of the keyboard
(mu-pi (all-pitches-from-music music)) ;; pitchlist from music
(mu-pi-single (sort (delete-duplicates mu-pi) ly:pitch<?)) ;; sorted without doubles
)
;; procedure body
;(display "music list: ")(display mu-pi) (newline)
;(write-me "start-low-x------------------------------- " start-low-x)
(ly:stencil-add
;; drawing all keys in the range pi-int
;; zuerst alle Tasten der Grundlage zeichnen
(apply ly:stencil-add
empty-stencil
(map (lambda (p) (draw-key p start-low-x w-color b-color))
pi-int))
;; die weißen Tasten der überlagerten Musik zeichnen
(apply ly:stencil-add
empty-stencil
(map (lambda (p) (draw-key p start-low-x w-mus-color b-mus-color))
( remove black-key? mu-pi-single)))
;; nochmals die schwazren Tasten über alles zeichnen
(apply ly:stencil-add
empty-stencil
(map (lambda (p) (draw-key p start-low-x w-color b-color))
(bl-filter pi-int)))
;; zum Schluss die schwarzen Tasten der Überlagerten Musik
(apply ly:stencil-add
empty-stencil
(map (lambda (p) (draw-key p start-low-x w-mus-color b-mus-color))
(bl-filter mu-pi-single))))))
#(define (expand-music music)
;; expand music to all pitches between p1 and p2
;; we remove all duplicates and sort the output
(sort
(delete-duplicates
(append-map
(lambda (o) (all-octaves (standardize-pitch o)))
(all-pitches-from-music music))) ly:pitch<?))
#(define (expand-music-between music p1 p2)
;; expand music to all pitches between p1 and p2
;; we remove all duplicates and sort the output
(let ((mypitches (expand-music music)))
(filter (lambda (o) (pitch-between? o p1 p2))
mypitches)))
#(define (music-elts x)
(if (not (ly:music? x))
'()
(ly:music-property x 'elements)))
#(define (music-name x)
(if (not (ly:music? x))
#f
(ly:music-property x 'name)))
#(define (list-all-chords-from-music music)
;; each element of the list is ly:music
(reverse!
(let loop ((music music) (pitches '()))
(let ((p (music-name music)))
(if (eq? p 'EventChord)
(cons music pitches)
(let ((elt (ly:music-property music 'element)))
(fold loop
(if (ly:music? elt)
(loop elt pitches)
pitches)
(music-elts music))))))))
#(define (draw-dotted-chords p1 p2 the-chord w-color b-color)
;; chose the interval the keyboard should span
;; at least music must be contained
;; das Keyboard muss wenigstens die angegebenen Akkordnoten fassen
;; unabhängig von den eingegebenen Grenzen
;; wir starten eine unabhängige Vergleichskette
;; der tiefste Ton des Akkords wird mit dem angegebenen Grenzwert
;; verglichen und ersetzt ihn ggfs
;, grundsätzbrauchen wird die Grenzangaben nicht
;; wegen vermehrter Flexibilität
(let*
(
(u-c (high-pitch the-chord)) ;; highest pitch of chord
(l-c (low-pitch the-chord)) ;;lowest pitch of chord
(pu (if (ly:pitch<? p2 u-c) u-c p2)) ;; highest pitch of chord/music
(pl (if (ly:pitch<? p1 l-c) p1 l-c)) ;; highest pitch of chord/music
(lowp (if (ly:pitch<? l-c p1) l-c p1)) ;; leftmost key of keyboard
(upp1 (if (ly:pitch<? p2 u-c) u-c p2)) ;; rightmost key of keyboard
(upp (if (and (= (ly:pitch-notename upp1) 0) (<= (ly:pitch-alteration upp1) 0))
upp1
(ly:make-pitch (+ (ly:pitch-octave upp1) 1) 0 0)))
(start-low-x (x-koord lowp)) ;; we shift the whole stencil
(pi-int (pitches-in-interval lowp upp)) ;; interval of pitches of the keyboard
;(mu-pi (expand-music-between music lowp upp)) ;; pitchlist from music
(chord-pi (all-pitches-from-music the-chord)) ;; all pitches from the chord
(chord-pi-single (sort (delete-duplicates chord-pi) ly:pitch<?)) ;; sorted without doubles
)
;; procedure body
;(display "lowpitch ")(display lowp)(newline)
;(display "the chord ") (display the-chord) (newline)
;(display "hight pitch ")(display upp)(newline)
;(display "chord-pi ")(display chord-pi)(newline)
;(display "chord-pi-single ")(display chord-pi-single)(newline)
;(display "all pitches ")(display pi-int)(newline)
;(write-me "high pitch------------------------------- " upp)
;(write-me "high pitch chord ----------------------- " u-c)
(ly:stencil-add
;; drawing all keys in the range pi-int
(apply ly:stencil-add
empty-stencil
(map (lambda (p) (draw-key p start-low-x w-color b-color))
pi-int))
;; drawing black keys again
(apply ly:stencil-add
empty-stencil
(map (lambda (p) (draw-key p start-low-x w-color b-color))
(bl-filter pi-int)))
;; drawing the dots at last
(apply ly:stencil-add
empty-stencil
(map (lambda (p) (draw-dot p start-low-x w-color b-color))
chord-pi-single))
)))
#(define-markup-command
(keyboard-with-chords layout props p1 p2 scale-factor the-chord)
(ly:pitch? ly:pitch? number? ly:music?)
(ly:stencil-scale
(draw-dotted-chords p1 p2 the-chord (x11-color 'ivory) (x11-color 'blue4))
scale-factor scale-factor))
ChordKeyboard=
#(define-music-function
(the-low the-high the-factor the-chord)
(ly:pitch? ly:pitch? number? ly:music?)
#{ <>^\markup \keyboard-with-chords
#the-low #the-high #the-factor #the-chord
$the-chord
#}
)
MapChords=
#(define-music-function
;; make-sequential-music macht aus Liste von Musikausdrücken
;; Musik
(the-low the-high the-factor the-chordlist)
(ly:pitch? ly:pitch? number? ly:music?)
;(display the-chordlist)
(make-sequential-music
(map
(lambda (m)
#{
\ChordKeyboard #the-low #the-high #the-factor $m
#})
(list-all-chords-from-music the-chordlist))))