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))))