%------------------------------------------------------------
% 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}
  }
}