LSR/1121
< LSR
 |
Der Inhalt dieser Seite wurde aus dem LilyPond Snippet Repository übernommen und steht unter folgender Lizenz: CC0. See Public Domain Help Pages for more info. | |
Beschreibung
Functions to draw piano keys and piano keyboards
\version "2.18.0"
%------------------------------------------------------------
% list of enharmonic names of the same key, in various languages
%------------------------------------------------------------
% IMPORTANT: do not change the first element of any of these lists
enharmonic-c = #'("c" "bis" "deses" "his" "bs" "dff" "do" "sid" "rebb" "sis" "hiss" "dessess" "sik")
enharmonic-cis = #'("cis" "des" "bisis" "hisis" "cs" "df" "bss" "bx" "dod" "reb" "sidd" "dos" "siss" "ciss" "dess" "hississ" "dok" "sikk")
enharmonic-d = #'("d" "cisis" "eses" "eeses" "css" "cx" "eff" "re" "dodd" "mibb" "doss" "cississ" "essess" "eessess" "dokk")
enharmonic-dis = #'("dis" "es" "ees" "feses" "ds" "ef" "fff" "red" "mib" "fabb" "res" "diss" "ess" "eess" "fessess" "rek")
enharmonic-e = #'("e" "fes" "disis" "ff" "dss" "dx" "mi" "fab" "redd" "ress" "fess" "dississ" "rekk")
enharmonic-f = #'("f" "eis" "geses" "gff" "fa" "mid" "solbb" "mis" "eiss" "gessess" "mik")
enharmonic-fis = #'("fis" "ges" "eisis" "fs" "gf" "ess" "ex" "fad" "solb" "midd" "fas" "miss" "fiss" "gess" "eississ" "fak" "mikk")
enharmonic-g = #'("g" "ases" "fisis" "aeses" "fss" "fx" "aff" "sol" "fadd" "labb" "fass" "assess" "fississ" "aessess" "fakk")
enharmonic-gis = #'("gis" "as" "aes" "gs" "af" "sold" "lab" "sols" "giss" "aess" "solk")
enharmonic-a = #'("a" "gisis" "beses" "gss" "gx" "bff" "la" "soldd" "sibb" "solss" "gississ" "solkk")
enharmonic-ais = #'("ais" "bes" "ceses" "as" "bf" "cff" "sib" "lad" "dobb" "las" "aiss" "cessess" "lak")
enharmonic-b = #'("b" "ces" "aisis" "h" "cf" "ass" "ax" "si" "dob" "ladd" "lass" "aississ" "cess" "lakk")
% to enter english "es" (e sharp) must set english-notename to #t
% to enter german "bes" (b double flat) must set german-notename to #t
% to enter german "b" (b flat) must set german-notename to #t
%------------------------------------------------------------
% markup commands definitions
%------------------------------------------------------------
#(define-markup-command (piano-key layout props key-name) (markup?)
#:properties ((bottom-padding 0)
; all key dimensions are proportional to this variable
(white-key-base 7)
; if german or english notenames are used, this variable has to be overriden
(german-notenames #f)
(english-notenames #f)
(is-first? #f)
(is-last? #f)
(is-marked? #f)
(is-upmarked? #f))
"Draw a piano key, depending on his name
usage:
\\piano-key key-name (note name)
example:
\\piano-key c
or:
\\override #'(white-key-base . 5)
\\concat \\piano-key {c des d es e f}
or:
\\override #'(german-notenames . #f)
\\concat \\piano-key {bes b h c}
if the notename begin with \"*\", the key will be marked
\\concat \\piano-key {*c cis d dis *e f fis *g }
if the notename begin with \"^\", the key will be upmarked
\\concat \\piano-key {*c cis d dis *e f fis *g }
key names must be in order to get a correct piano keyboard
"
(interpret-markup layout props
; base dimension of key
(let ((base (exact->inexact white-key-base))) ;to send variables to postscript, this has to be inexact
; if the notename begin with "*" the key will be marked
(if (char=? (string-ref key-name 0) #\*)
(begin
(set! key-name (substring key-name 1 (string-length key-name)))
(set! is-marked? #t)))
; if the notename begin with "^" the key will be upmarked
(if (char=? (string-ref key-name 0) #\^)
(begin
(set! key-name (substring key-name 1 (string-length key-name)))
(set! is-marked? #t)
(set! is-upmarked? #t)))
; german and english notenames substitutions
(if german-notenames (cond
((equal? key-name "bes") (set! key-name "beses"))
((equal? key-name "b") (set! key-name "bes"))))
(if (and english-notenames (equal? key-name "es")) (set! key-name "dis"))
(let ((is-white? ; is a white key?
(list?
(member key-name
(append enharmonic-c enharmonic-d enharmonic-e
enharmonic-f enharmonic-g enharmonic-a enharmonic-b))))
(is-black? ; is black key?
(list?
(member key-name
(append enharmonic-cis enharmonic-dis
enharmonic-fis enharmonic-gis enharmonic-ais))))
(head ; head dimension of key
(cond
; for keys from c to e (white or black)
((list? (member key-name (append enharmonic-c enharmonic-cis
enharmonic-d enharmonic-dis enharmonic-e)))
(* base 3/5))
; for keys from f to b (white or black)
((list? (member key-name (append enharmonic-f enharmonic-fis enharmonic-g
enharmonic-gis enharmonic-a enharmonic-ais enharmonic-b)))
(* base 4/7))
(else 0)))
(s-left ; left shoulder dimension of key
(cond
((list? (member key-name enharmonic-c)) 0)
((list? (member key-name enharmonic-d)) (* base 1/5))
((list? (member key-name enharmonic-e)) (* base 2/5))
((list? (member key-name enharmonic-f)) 0)
((list? (member key-name enharmonic-g)) (* base 1/7))
((list? (member key-name enharmonic-a)) (* base 2/7))
((list? (member key-name enharmonic-b)) (* base 3/7))
(else 0)))
(neck (* base 3)) ; neck dimension of key
)
(let ((s-right (if is-white? (- base s-left head) 0 )) ;right shoulder dimension of key
(foot (if is-white? (* base 2) 0))) ; foot dimension of key
#{\markup \column {
\concat {
\postscript #(string-append ;variables are sent to postscript
"/base " (number->string base) " def"
"/head " (number->string head) " def"
"/foot " (number->string foot) " def"
"/neck " (number->string neck) " def"
"/s-left " (number->string s-left) " def"
"/s-right " (number->string s-right) " def"
"/radius base 5 div def"
" 0 neck neg rlineto"
(if is-first? "" " s-left neg 0 rlineto")
" 0 foot neg rlineto"
" s-left head s-right add add 0 rlineto" ;base of key
" 0 foot rlineto"
(if is-last? "" " s-right neg 0 rlineto")
" 0 neck rlineto"
" closepath"
(if is-black? " gsave fill grestore" "")
" stroke"
(if is-marked? (string-append
" head s-right add s-left sub 2 div"
" neck foot add base"
(if is-upmarked? " .7" " 2")
" div sub neg"
" radius"
" 0 360 arc"
" closepath"
" gsave"
" 0.7 setgray"
" fill"
" grestore"
" stroke ")
"")
)
\hspace #(+
head
(if is-first? s-left 0)
(if is-last? s-right 0))
}
\vspace #(if
(or is-black? is-white?)
(+ bottom-padding(/(+ neck foot)3))
0)
}
#})))))
#(define-markup-command (keyboard layout props start-key number) (markup? number?)
#:properties (
; if german notenames are used, this variable has to be overriden
(english-notenames #f)
(german-notenames #f))
"Draw a piano keyboard
usage:
\\keyboard start-key (note name) length (number)
example:
\\keyboard c #24
or:
\\override #'(white-key-base . 3)
\\override #'(german-notenames . #t)
\\keyboard b #36
"
(interpret-markup layout props
(let ((one-octave '("c" "cis" "d" "dis" "e" "f" "fis" "g" "gis" "a" "ais" "b")))
(let ((many-octaves (append one-octave one-octave one-octave one-octave one-octave one-octave one-octave one-octave one-octave one-octave)))
; german notenames substitutions
(if german-notenames (cond
((equal? start-key "bes") (set! start-key "beses"))
((equal? start-key "b") (set! start-key "bes"))))
(if (and english-notenames (equal? key-name "es")) (set! key-name "dis"))
(cond
((list? (member start-key enharmonic-c )) (set! start-key (car enharmonic-c )))
((list? (member start-key enharmonic-cis)) (set! start-key (car enharmonic-cis)))
((list? (member start-key enharmonic-d )) (set! start-key (car enharmonic-d )))
((list? (member start-key enharmonic-dis)) (set! start-key (car enharmonic-dis)))
((list? (member start-key enharmonic-e )) (set! start-key (car enharmonic-e )))
((list? (member start-key enharmonic-f )) (set! start-key (car enharmonic-f )))
((list? (member start-key enharmonic-fis)) (set! start-key (car enharmonic-fis)))
((list? (member start-key enharmonic-g )) (set! start-key (car enharmonic-g )))
((list? (member start-key enharmonic-gis)) (set! start-key (car enharmonic-gis)))
((list? (member start-key enharmonic-a )) (set! start-key (car enharmonic-a )))
((list? (member start-key enharmonic-ais)) (set! start-key (car enharmonic-ais)))
((list? (member start-key enharmonic-b )) (set! start-key (car enharmonic-b )))
)
(let ((start-list (member start-key many-octaves)))
(let ((complete-list (reverse (list-tail (reverse start-list) (- (length start-list) number)))))
(let ((first-key (car complete-list))
(last-key (car (reverse complete-list)))
(trunked-list (cdr (reverse (cdr (reverse complete-list))))))
#{\markup
% at this point german or english notenames modifies have already been set,
% so the variable is set to false
\override #'(german-notenames . #f)
\override #'(english-notenames . #f)
\concat {
\override #'(is-first? . #t) \piano-key #first-key
\piano-key #trunked-list
\override #'(is-last? . #t) \piano-key #last-key
}
#}
)))))))
\markup \center-column{
"GrandPiano keyboard"
\override #'(white-key-base . 2)
\keyboard a #88
\vspace #1
"standard 41 keys Accordion"
\override #'(white-key-base . 3)
\keyboard f #41
\vspace #1
"26 keys Accordion"
\override #'(white-key-base . 4)
\keyboard b #26
\vspace #1
"keys marked for didactic purpose"
\concat{
\piano-key {*b c *cis d *dis *e f *fis g *gis a *ais *b}
}
\vspace #1
\concat{
\piano-key {*c cis ^d dis ^e *f fis ^g gis ^a ais ^b *c}
}
}
\version "2.18.0"
%------------------------------------------------------------
% list of enharmonic names of the same key, in various languages
%------------------------------------------------------------
% IMPORTANT: do not change the first element of any of these lists
enharmonic-c = #'("c" "bis" "deses" "his" "bs" "dff" "do" "sid" "rebb" "sis" "hiss" "dessess" "sik")
enharmonic-cis = #'("cis" "des" "bisis" "hisis" "cs" "df" "bss" "bx" "dod" "reb" "sidd" "dos" "siss" "ciss" "dess" "hississ" "dok" "sikk")
enharmonic-d = #'("d" "cisis" "eses" "eeses" "css" "cx" "eff" "re" "dodd" "mibb" "doss" "cississ" "essess" "eessess" "dokk")
enharmonic-dis = #'("dis" "es" "ees" "feses" "ds" "ef" "fff" "red" "mib" "fabb" "res" "diss" "ess" "eess" "fessess" "rek")
enharmonic-e = #'("e" "fes" "disis" "ff" "dss" "dx" "mi" "fab" "redd" "ress" "fess" "dississ" "rekk")
enharmonic-f = #'("f" "eis" "geses" "gff" "fa" "mid" "solbb" "mis" "eiss" "gessess" "mik")
enharmonic-fis = #'("fis" "ges" "eisis" "fs" "gf" "ess" "ex" "fad" "solb" "midd" "fas" "miss" "fiss" "gess" "eississ" "fak" "mikk")
enharmonic-g = #'("g" "ases" "fisis" "aeses" "fss" "fx" "aff" "sol" "fadd" "labb" "fass" "assess" "fississ" "aessess" "fakk")
enharmonic-gis = #'("gis" "as" "aes" "gs" "af" "sold" "lab" "sols" "giss" "aess" "solk")
enharmonic-a = #'("a" "gisis" "beses" "gss" "gx" "bff" "la" "soldd" "sibb" "solss" "gississ" "solkk")
enharmonic-ais = #'("ais" "bes" "ceses" "as" "bf" "cff" "sib" "lad" "dobb" "las" "aiss" "cessess" "lak")
enharmonic-b = #'("b" "ces" "aisis" "h" "cf" "ass" "ax" "si" "dob" "ladd" "lass" "aississ" "cess" "lakk")
% to enter english "es" (e sharp) must set english-notename to #t
% to enter german "bes" (b double flat) must set german-notename to #t
% to enter german "b" (b flat) must set german-notename to #t
%------------------------------------------------------------
% markup commands definitions
%------------------------------------------------------------
#(define-markup-command (piano-key layout props key-name) (markup?)
#:properties ((bottom-padding 0)
; all key dimensions are proportional to this variable
(white-key-base 7)
; if german or english notenames are used, this variable has to be overriden
(german-notenames #f)
(english-notenames #f)
(is-first? #f)
(is-last? #f)
(is-marked? #f)
(is-upmarked? #f))
"Draw a piano key, depending on his name
usage:
\\piano-key key-name (note name)
example:
\\piano-key c
or:
\\override #'(white-key-base . 5)
\\concat \\piano-key {c des d es e f}
or:
\\override #'(german-notenames . #f)
\\concat \\piano-key {bes b h c}
if the notename begin with \"*\", the key will be marked
\\concat \\piano-key {*c cis d dis *e f fis *g }
if the notename begin with \"^\", the key will be upmarked
\\concat \\piano-key {*c cis d dis *e f fis *g }
key names must be in order to get a correct piano keyboard
"
(interpret-markup layout props
; base dimension of key
(let ((base (exact->inexact white-key-base))) ;to send variables to postscript, this has to be inexact
; if the notename begin with "*" the key will be marked
(if (char=? (string-ref key-name 0) #\*)
(begin
(set! key-name (substring key-name 1 (string-length key-name)))
(set! is-marked? #t)))
; if the notename begin with "^" the key will be upmarked
(if (char=? (string-ref key-name 0) #\^)
(begin
(set! key-name (substring key-name 1 (string-length key-name)))
(set! is-marked? #t)
(set! is-upmarked? #t)))
; german and english notenames substitutions
(if german-notenames (cond
((equal? key-name "bes") (set! key-name "beses"))
((equal? key-name "b") (set! key-name "bes"))))
(if (and english-notenames (equal? key-name "es")) (set! key-name "dis"))
(let ((is-white? ; is a white key?
(list?
(member key-name
(append enharmonic-c enharmonic-d enharmonic-e
enharmonic-f enharmonic-g enharmonic-a enharmonic-b))))
(is-black? ; is black key?
(list?
(member key-name
(append enharmonic-cis enharmonic-dis
enharmonic-fis enharmonic-gis enharmonic-ais))))
(head ; head dimension of key
(cond
; for keys from c to e (white or black)
((list? (member key-name (append enharmonic-c enharmonic-cis
enharmonic-d enharmonic-dis enharmonic-e)))
(* base 3/5))
; for keys from f to b (white or black)
((list? (member key-name (append enharmonic-f enharmonic-fis enharmonic-g
enharmonic-gis enharmonic-a enharmonic-ais enharmonic-b)))
(* base 4/7))
(else 0)))
(s-left ; left shoulder dimension of key
(cond
((list? (member key-name enharmonic-c)) 0)
((list? (member key-name enharmonic-d)) (* base 1/5))
((list? (member key-name enharmonic-e)) (* base 2/5))
((list? (member key-name enharmonic-f)) 0)
((list? (member key-name enharmonic-g)) (* base 1/7))
((list? (member key-name enharmonic-a)) (* base 2/7))
((list? (member key-name enharmonic-b)) (* base 3/7))
(else 0)))
(neck (* base 3)) ; neck dimension of key
)
(let ((s-right (if is-white? (- base s-left head) 0 )) ;right shoulder dimension of key
(foot (if is-white? (* base 2) 0))) ; foot dimension of key
#{\markup \column {
\concat {
\postscript #(string-append ;variables are sent to postscript
"/base " (number->string base) " def"
"/head " (number->string head) " def"
"/foot " (number->string foot) " def"
"/neck " (number->string neck) " def"
"/s-left " (number->string s-left) " def"
"/s-right " (number->string s-right) " def"
"/radius base 5 div def"
" 0 neck neg rlineto"
(if is-first? "" " s-left neg 0 rlineto")
" 0 foot neg rlineto"
" s-left head s-right add add 0 rlineto" ;base of key
" 0 foot rlineto"
(if is-last? "" " s-right neg 0 rlineto")
" 0 neck rlineto"
" closepath"
(if is-black? " gsave fill grestore" "")
" stroke"
(if is-marked? (string-append
" head s-right add s-left sub 2 div"
" neck foot add base"
(if is-upmarked? " .7" " 2")
" div sub neg"
" radius"
" 0 360 arc"
" closepath"
" gsave"
" 0.7 setgray"
" fill"
" grestore"
" stroke ")
"")
)
\hspace #(+
head
(if is-first? s-left 0)
(if is-last? s-right 0))
}
\vspace #(if
(or is-black? is-white?)
(+ bottom-padding(/(+ neck foot)3))
0)
}
#})))))
#(define-markup-command (keyboard layout props start-key number) (markup? number?)
#:properties (
; if german notenames are used, this variable has to be overriden
(english-notenames #f)
(german-notenames #f))
"Draw a piano keyboard
usage:
\\keyboard start-key (note name) length (number)
example:
\\keyboard c #24
or:
\\override #'(white-key-base . 3)
\\override #'(german-notenames . #t)
\\keyboard b #36
"
(interpret-markup layout props
(let ((one-octave '("c" "cis" "d" "dis" "e" "f" "fis" "g" "gis" "a" "ais" "b")))
(let ((many-octaves (append one-octave one-octave one-octave one-octave one-octave one-octave one-octave one-octave one-octave one-octave)))
; german notenames substitutions
(if german-notenames (cond
((equal? start-key "bes") (set! start-key "beses"))
((equal? start-key "b") (set! start-key "bes"))))
(if (and english-notenames (equal? key-name "es")) (set! key-name "dis"))
(cond
((list? (member start-key enharmonic-c )) (set! start-key (car enharmonic-c )))
((list? (member start-key enharmonic-cis)) (set! start-key (car enharmonic-cis)))
((list? (member start-key enharmonic-d )) (set! start-key (car enharmonic-d )))
((list? (member start-key enharmonic-dis)) (set! start-key (car enharmonic-dis)))
((list? (member start-key enharmonic-e )) (set! start-key (car enharmonic-e )))
((list? (member start-key enharmonic-f )) (set! start-key (car enharmonic-f )))
((list? (member start-key enharmonic-fis)) (set! start-key (car enharmonic-fis)))
((list? (member start-key enharmonic-g )) (set! start-key (car enharmonic-g )))
((list? (member start-key enharmonic-gis)) (set! start-key (car enharmonic-gis)))
((list? (member start-key enharmonic-a )) (set! start-key (car enharmonic-a )))
((list? (member start-key enharmonic-ais)) (set! start-key (car enharmonic-ais)))
((list? (member start-key enharmonic-b )) (set! start-key (car enharmonic-b )))
)
(let ((start-list (member start-key many-octaves)))
(let ((complete-list (reverse (list-tail (reverse start-list) (- (length start-list) number)))))
(let ((first-key (car complete-list))
(last-key (car (reverse complete-list)))
(trunked-list (cdr (reverse (cdr (reverse complete-list))))))
#{\markup
% at this point german or english notenames modifies have already been set,
% so the variable is set to false
\override #'(german-notenames . #f)
\override #'(english-notenames . #f)
\concat {
\override #'(is-first? . #t) \piano-key #first-key
\piano-key #trunked-list
\override #'(is-last? . #t) \piano-key #last-key
}
#}
)))))))
\markup \center-column{
"GrandPiano keyboard"
\override #'(white-key-base . 2)
\keyboard a #88
\vspace #1
"standard 41 keys Accordion"
\override #'(white-key-base . 3)
\keyboard f #41
\vspace #1
"26 keys Accordion"
\override #'(white-key-base . 4)
\keyboard b #26
\vspace #1
"keys marked for didactic purpose"
\concat{
\piano-key {*b c *cis d *dis *e f *fis g *gis a *ais *b}
}
\vspace #1
\concat{
\piano-key {*c cis ^d dis ^e *f fis ^g gis ^a ais ^b *c}
}
}