(define (set-mml trk . mmls)
  (let ((Q 384) ;pulse per quater-note
        (time 0)
        (octave 4)
        (length 4)
        (channel 0)
        (program 0) ;grand piano
        (panpot 64)
        (volume 127)
        (quantize 100)
        (tempo 100)
        (velocity 100)
        (velocity-gap 4)
        (key-signature '())
        (un-noted-offs '()))
    (define (store-key-signature ls)
      (if (null? ls) #t
          (let loop ((offset 0)
                     (pitch (if (and (char<=? #\a (car ls)) (char<=? (car ls) #\g))
                                (car ls)
                                (error "illegal declaration in {}:" (car ls))))
                     (ls (cdr ls)))
            (cond ((null? ls)
                   (set! key-signature (cons (cons pitch offset) key-signature))
                   #t)
                  ((char=? (car ls) #\+)
                   (loop (+ offset 1) pitch (cdr ls)))
                  ((char=? (car ls) #\-)
                   (loop (- offset 1) pitch (cdr ls)))
                  (else
                   (set! key-signature (cons (cons pitch offset) key-signature))
                   (store-key-signature ls))))))
    (define (pitch-val-with-key-signature char)
      (cond ((assv char key-signature)
             => (lambda (pair) (+ (cdr pair) (pitch-val char))))
            (else
             (pitch-val char))))
    (define (pitch-val char)
      (cond ((char=? char #\c)
             (* 12 (+ octave 1)))
            ((char=? char #\d)
             (+ 2 (* 12 (+ octave 1))))
            ((char=? char #\e)
             (+ 4 (* 12 (+ octave 1))))
            ((char=? char #\f)
             (+ 5 (* 12 (+ octave 1))))
            ((char=? char #\g)
             (+ 7 (* 12 (+ octave 1))))
            ((char=? char #\a)
             (+ 9 (* 12 (+ octave 1))))
            ((char=? char #\b)
             (+ 11 (* 12 (+ octave 1))))
            ((char=? char #\r) -9999)))
    (define (set-note p-val len vlc)
      (if (= len 0) ;chord?
          (let ((msg (short-message)))
            (if (< p-val 0) (error "length of 'r' must not be zero"))
            (set-message msg 'note-on channel p-val vlc)
            (add-event trk (midi-event msg time))
            (set! un-noted-offs (cons (cons p-val vlc) un-noted-offs)))
          (let ((msg1 (short-message))
                (msg2 (short-message))
                (l-val (/ (* Q 4) len)))
            (if (< p-val 0)
                (set! time (+ time l-val))
                (begin
                  (set-message msg1 'note-on channel p-val vlc)
                  (add-event trk (midi-event msg1 time))
                  (set! time (+ time l-val))
                  (set-message msg2 'note-off channel p-val vlc)
                  (add-event trk (midi-event msg2 (- time (/ (* l-val (- 100 quantize)) 100))))
                  (clear-un-noted-offs l-val))))))
    (define (clear-un-noted-offs l-val)
      (if (not (null? un-noted-offs))
          (let ((msg (short-message)))
            (set-message msg 'note-off channel (caar un-noted-offs) (cdar un-noted-offs))
            (add-event trk (midi-event msg (- time (/ (* l-val (- 100 quantize)) 100))))
            (set! un-noted-offs (cdr un-noted-offs))
            (clear-un-noted-offs l-val))))
    (define (set-length-return-rest ls val)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! length val) ls)
            (else
             (set-length-return-rest (cdr ls)
                                     (+ (* 10 val)
                                        (string->number (string (car ls))))))))
    (define (set-program-return-rest ls val)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! program val)
             (let ((msg (short-message)))
               (set-message msg 'program-change channel program 0)
               (add-event trk (midi-event msg time))
               ls))
            (else
             (set-program-return-rest (cdr ls)
                                      (+ (* 10 val)
                                         (string->number (string (car ls))))))))
    (define (set-channel-return-rest ls val)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! channel val) ls)
            (else
             (set-channel-return-rest (cdr ls)
                                      (+ (* 10 val)
                                         (string->number (string (car ls))))))))
    (define (set-velocity-gap-return-rest ls val)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! velocity-gap val) ls)
            (else
             (set-velocity-gap-return-rest (cdr ls)
                                           (+ (* 10 val)
                                              (string->number (string (car ls))))))))
    (define (set-velocity-return-rest ls val)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! velocity val) ls)
            (else
             (set-velocity-return-rest (cdr ls)
                                       (+ (* 10 val)
                                          (string->number (string (car ls))))))))
    (define (set-velocity-weaker-return-rest ls val)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! velocity (- velocity val)) ls)
            (else
             (set-velocity-weaker-return-rest (cdr ls)
                                              (+ (* 10 val)
                                                 (string->number (string (car ls))))))))
    (define (set-velocity-stronger-return-rest ls val)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! velocity (+ velocity val)) ls)
            (else
             (set-velocity-stronger-return-rest (cdr ls)
                                                (+ (* 10 val)
                                                   (string->number (string (car ls))))))))
    (define (set-tempo-return-rest ls val offset-op)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! tempo (offset-op val))
             (if (<= tempo 0) (error "tempo must be more than zero"))
             (add-event trk (midi-event (set-tempo-message tempo) time))
             ls)
            (else
             (set-tempo-return-rest (cdr ls)
                                    (+ (* 10 val)
                                       (string->number (string (car ls))))
                                    offset-op))))
    (define (set-panpot-return-rest ls val)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! panpot val)
             (let ((msg (short-message)))
               (set-message msg 'control-change channel 10 panpot)
               (add-event trk (midi-event msg time))
               ls))
            (else
             (set-panpot-return-rest (cdr ls)
                                     (+ (* 10 val)
                                        (string->number (string (car ls))))))))
    (define (set-volume-return-rest ls val)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! volume val)
             (let ((msg (short-message)))
               (set-message msg 'control-change channel 7 volume)
               (add-event trk (midi-event msg time))
               ls))
            (else
             (set-volume-return-rest (cdr ls)
                                     (+ (* 10 val)
                                        (string->number (string (car ls))))))))
    (define (set-quantize-return-rest ls val)
      (cond ((or (null? ls) (not (char-numeric? (car ls))))
             (set! quantize val)
             ls)
            (else
             (set-quantize-return-rest (cdr ls)
                                       (+ (* 10 val)
                                          (string->number (string (car ls))))))))
    (define (set-octave-return-rest ls val offset-op)
      (cond ((null? ls)
             (set! octave (offset-op val)) ls)
            ((char-numeric? (car ls))
             (set-octave-return-rest (cdr ls)
                                     (+ (* 10 val)
                                        (string->number (string (car ls))))
                                     offset-op))
            (else
             (set! octave (offset-op val))
             ls)))
    (define (set-key-signature-return-rest ls)
      (let ((rest #f))
        (define (sub lst)
          (cond ((null? lst)
                 (error "There is no '}' after '{'"))
                ((char=? (car lst) #\})
                 (set! rest (cdr lst))
                 '())
                (else
                 (cons (car lst) (sub (cdr lst))))))
        (store-key-signature (sub ls))
        rest))
    (define (set-note-return-rest p-val ls)
      (let loop1 ((p-val p-val) (ls ls))
        (cond ((null? ls)
               (set-note p-val length velocity) ls)
              ((char=? (car ls) #\+)
               (loop1 (+ p-val 1) (cdr ls)))
              ((char=? (car ls) #\-)
               (loop1 (- p-val 1) (cdr ls)))
              (else
               (let loop2 ((exp '())
                           (ls  ls))
                 (cond ((null? ls)
                        (set-note p-val
                                  (exp2len (complement (char2num (reverse exp))))
                                  velocity)
                        ls)
                       ((or (char-numeric? (car ls))
                            (char=? (car ls) #\^)
                            (char=? (car ls) #\-)
                            (char=? (car ls) #\.))
                        (loop2 (cons (car ls) exp) (cdr ls)))
                       ((char=? (car ls) #\&)
                        (set-note p-val 0 velocity)
                        (set-note -9999
                                  (exp2len (complement (char2num (reverse exp))))
                                  velocity)
                        (cdr ls))
                       ((not (char=? (car ls) #\,))
                        (set-note p-val
                                  (exp2len (complement (char2num (reverse exp))))
                                  velocity)
                        ls)
                       (else
                        (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                            (error "no number after ','.")
                            (let loop3 ((vlc (string->number (string (cadr ls))))
                                        (ls (cddr ls)))
                              (cond ((null? ls)
                                     (set-note p-val
                                              (exp2len (complement (char2num (reverse exp))))
                                              vlc)
                                     ls)
                                    ((char-numeric? (car ls))
                                     (loop3 (+ (* 10 vlc)
                                               (string->number (string (car ls))))
                                            (cdr ls)))
                                    ((char=? (car ls) #\&)
                                     (set-note p-val 0 vlc)
                                     (set-note -9999
                                               (exp2len (complement (char2num (reverse exp))))
                                               0)
                                     (cdr ls))
                                    (else
                                     (set-note p-val
                                               (exp2len (complement (char2num (reverse exp))))
                                               vlc)
                                     ls)))))))))))
    (define (char2num ls)
      (cond ((null? ls) ls)
            ((not (char-numeric? (car ls)))
             (if (char=? (car ls) #\.)
                 (if (and (not (null? (cdr ls))) (char=? (cadr ls) #\.))
                     (cons (/ (* length 4) 7) (char2num (cddr ls)))
                     (cons (/ (* length 2) 3) (char2num (cdr ls))))
             (cons (car ls) (char2num (cdr ls)))))
            (else
             (let loop ((val (string->number (string (car ls))))
                        (ls  (cdr ls)))
               (cond ((null? ls) (list val))
                     ((char-numeric? (car ls))
                      (loop (+ (* val 10) (string->number (string (car ls))))
                            (cdr ls)))
                     ((char=? (car ls) #\.)
                      (if (and (not (null? (cdr ls))) (char=? (cadr ls) #\.))
                          (cons (/ (* val 4) 7) (char2num (cddr ls)))
                          (cons (/ (* val 2) 3) (char2num (cdr ls)))))
                     (else
                      (cons val (char2num ls))))))))
    (define (complement exp)
      (let ((exp (cons 'dummy (append exp '(dummy)))))
        (define (sub ls)
          (cond ((eq? (cadr ls) 'dummy)
                 (if (number? (car ls))
                     (list (car ls))
                     (list (car ls) length)))
                ((and (not (number? (car  ls)))
                      (not (number? (cadr ls))))
                 (cons (car ls)
                       (cons length (sub (cdr ls)))))
                (else
                 (cons (car ls) (sub (cdr ls))))))
        (cdr (sub exp))))
    (define (exp2len exp)
      (if (null? (cdr exp))
          (car exp)
          (let ((x  (car exp))
                (op (cadr exp))
                (y  (exp2len (cddr exp))))
            (cond ((char=? op #\^)
                   (/ (* x y) (+ y x)))
                  ((char=? op #\-)
                   (if (= x y) (error "length becomes zero by '-'."))
                   (/ (* x y) (- y x)))
                  (else
                   (error "elegular token:" op))))))
    (define (analyze ls)
      (if (null? ls) #t
          (let ((c (car ls)))
            (cond ((or (and (char<=? #\a c) (char<=? c #\g))
                       (char=? #\r c))
                   (if (or (null? (cdr ls)) (not (char=? #\* (cadr ls))))
                       (analyze (set-note-return-rest (pitch-val-with-key-signature c) (cdr ls)))
                       (analyze (set-note-return-rest (pitch-val c) (cddr ls)))))
                  ((char=? c #\>)
                   (set! octave (+ octave 1))
                   (analyze (cdr ls)))
                  ((char=? c #\<)
                   (set! octave (- octave 1))
                   (analyze (cdr ls)))
                  ((char=? c #\l)
                   (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                       (error "no argument after l"))
                   (analyze (set-length-return-rest (cdr ls) 0)))
                  ((char=? c #\o)
                   (if (null? (cdr ls)) (error "no argument after o"))
                   (cond ((char=? (cadr ls) #\+)
                          (if (or (null? (cddr ls)) (not (char-numeric? (caddr ls))))
                              (error "no argument after o+"))
                          (analyze (set-octave-return-rest (cddr ls) 0 (lambda (x) (+ octave x)))))
                         ((char=? (cadr ls) #\-)
                          (if (or (null? (cddr ls)) (not (char-numeric? (caddr ls))))
                              (error "no argument after o-"))
                          (analyze (set-octave-return-rest (cddr ls) 0 (lambda (x) (- octave x)))))
                         (else
                          (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                              (error "no argument after o"))
                          (analyze (set-octave-return-rest (cdr ls) 0 (lambda (x) x))))))
                  ((char=? c #\{)
                   (analyze (set-key-signature-return-rest (cdr ls))))
                  ((char=? c #\@)
                   (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                       (error "no argument after @"))
                   (analyze (set-program-return-rest (cdr ls) 0)))
                  ((char=? c #\k)
                   (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                       (error "no argument after k"))
                   (analyze (set-velocity-return-rest (cdr ls) 0)))
                  ((char=? c #\()
                   (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                       (begin
                         (set! velocity (- velocity velocity-gap))
                         (analyze (cdr ls)))
                       (analyze (set-velocity-weaker-return-rest (cdr ls) 0))))
                  ((char=? c #\))
                   (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                       (begin
                         (set! velocity (+ velocity velocity-gap))
                         (analyze (cdr ls)))
                       (analyze (set-velocity-stronger-return-rest (cdr ls) 0))))
                  ((char=? c #\t)
                   (if (null? (cdr ls)) (error "no argument after t"))
                   (cond ((char=? (cadr ls) #\+)
                          (if (or (null? (cddr ls)) (not (char-numeric? (caddr ls))))
                              (error "no argument after t+"))
                          (analyze (set-tempo-return-rest (cddr ls) 0 (lambda (x) (+ tempo x)))))
                         ((char=? (cadr ls) #\-)
                          (if (or (null? (cddr ls)) (not (char-numeric? (caddr ls))))
                              (error "no argument after t-"))
                          (analyze (set-tempo-return-rest (cddr ls) 0 (lambda (x) (- tempo x)))))
                         (else
                          (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                              (error "no argument after t"))
                          (analyze (set-tempo-return-rest (cdr ls) 0 (lambda (x) x))))))
                  ((char=? c #\p)
                   (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                       (error "no argument after p"))
                   (analyze (set-panpot-return-rest (cdr ls) 0)))
                  ((char=? c #\v)
                   (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                       (error "no argument after v"))
                   (analyze (set-volume-return-rest (cdr ls) 0)))
                  ((char=? c #\q)
                   (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                       (error "no argument after q"))
                   (analyze (set-quantize-return-rest (cdr ls) 0)))
                  ((char=? c #\C)
                   (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                       (error "no argument after C"))
                   (analyze (set-channel-return-rest (cdr ls) 0)))
                  ((char=? c #\V)
                   (if (or (null? (cdr ls)) (not (char-numeric? (cadr ls))))
                       (error "no argument after V"))
                   (analyze (set-velocity-gap-return-rest (cdr ls) 0)))
                  ((char-whitespace? c)
                   (analyze (cdr ls)))
                  (else
                   (error "illegal occurrence:" c))))))
    (define (remove-comments ls)
      (cond ((null? ls) ls)
            ((and (char=? (car ls) #\/) (not (null? (cdr ls))) (char=? (cadr ls) #\*))
             (let loop ((ls (cddr ls)))
               (cond ((null? ls)
                      (error "There is no */ after /*."))
                     ((and (char=? (car ls) #\*) (not (null? (cdr ls))) (char=? (cadr ls) #\/))
                      (remove-comments (cddr ls)))
                     (else
                      (loop (cdr ls))))))
            (else
             (cons (car ls) (remove-comments (cdr ls))))))
    (define (expand-repeat lis)
      (cond ((null? lis) '())
            ((not (char=? (car lis) #\[))
             (cons (car lis) (expand-repeat (cdr lis))))
            (else
             (let loop1 ((inside '())
                         (rest (cdr lis)))
               (cond ((null? rest)
                      (error "no ']' after '['."))
                     ((char=? (car rest) #\[) ;nest
                      (set! rest (expand-repeat rest))
                      (loop1 inside rest))
                     ((not (char=? (car rest) #\]))
                      (loop1 (append inside (list (car rest))) (cdr rest)))
                     (else
                      (if (or (null? (cdr rest)) (not (char-numeric? (cadr rest))))
                          (error "no number after ']'.")
                          (let loop2 ((n (string->number (string (cadr rest))))
                                      (rest (cddr rest)))
                            (cond ((null? rest)
                                   (expand-sub inside n))
                                  ((not (char-numeric? (car rest)))
                                   (append (expand-sub inside n)
                                           (expand-repeat rest)))
                                  (else
                                   (loop2 (+ (* 10 n)
                                             (string->number (string (car rest))))
                                          (cdr rest))))))))))))
    (define (expand-sub lis n)
      (define (sub before-: after-: n)
        (if (= n 1)
            before-:
            (append before-: after-: (sub before-: after-: (- n 1)))))
      (if (<= n 0) (error "number after ']' must be more than 0."))
      (let loop ((before-colon '())
                 (rest lis))
        (cond ((null? rest)
               (sub before-colon rest n))
              ((char=? (car rest) #\:)
               (sub before-colon (cdr rest) n))
              (else
               (loop (append before-colon (list (car rest))) (cdr rest))))))
    (define (sub ls)
      (if (null? ls) 'ok
          (begin
            (analyze (expand-repeat (remove-comments (string->list (car ls)))))
            (sub (cdr ls)))))
    (sub mmls)))


(define (play-mml . mmls)
  (let* ((synth (get-synthesizer))
         (seqr  (get-sequencer))
         (seq   (sequence 384))
         (trk (create-track seq)))
    (apply set-mml (cons trk mmls))
    (set-sequence seqr seq)
    (start-sequencer seqr)
    (close-device seqr)
    (close-device synth)
    'done))


(define (rhythm als . s)
  (define (replace ls)
    (let loop ((done "")
               (rest ls))
      (cond ((null? rest) done)
            ((char-alphabetic? (car rest))
             (cond ((assq (string->symbol (string (car rest))) als)
                    => (lambda (x)
                         (loop (string-append done (convert (cadr x)))
                               (cdr rest))))
                   (else
                    (loop (string-append done (string (car rest)))
                          (cdr rest)))))
            (else
             (loop (string-append done (string (car rest)))
                   (cdr rest))))))
  (define (convert x)
    (let* ((o (- (quotient x 12) 1))
           (r (remainder x 12))
           (n (cond ((eq? r 0) "c")
                    ((eq? r 1) "c+")
                    ((eq? r 2) "d")
                    ((eq? r 3) "d+")
                    ((eq? r 4) "e")
                    ((eq? r 5) "f")
                    ((eq? r 6) "f+")
                    ((eq? r 7) "g")
                    ((eq? r 8) "g+")
                    ((eq? r 9) "a")
                    ((eq? r 10) "a+")
                    ((eq? r 11) "b"))))
      (string-append "o" (number->string o) n)))
  (replace (string->list (apply string-append s))))