c@43: (in-package :amuse-tabcode)
c@43: 
c@43: (defun word-duration (word default)
c@43:   (if (typep word 'tabcode::rhythmic-word)
c@43:       (let ((flag (tabcode::flag word))
c@43:             (dots (tabcode::dots word)))
c@43:         (if flag
c@43:             (* (car (rassoc flag tabcode::*rhythms*))
c@43:                (if dots 3/2 1))
c@43:             default))
c@43:       0))
c@43: 
c@43: (defun word-causes-stop-p (word course)
c@43:   (or (typep word 'tabcode::rest)
c@43:       (typep word 'tabcode::barline)
c@43:       (and (typep word 'tabcode::chord)
c@43:            (member course (tabcode::playing word) :key #'tabcode::course))))
c@43: 
c@43: (defun duration-for-course (course buffer start initial-duration)
c@43:   (let ((duration initial-duration)
c@43:         (default-duration initial-duration))
c@43:     (do ((i start (+ i 1)))
c@43:         ((>= i (drei-buffer:size buffer)) duration)
c@43:       (let* ((object (drei-buffer:buffer-object buffer i))
c@43:              (word (tabcode-syntax::tabword-word object)))
c@43:         (when (word-causes-stop-p word course)
c@43:           (return-from duration-for-course duration))
c@43:         (let ((word-duration (word-duration word default-duration)))
c@43:           (incf duration word-duration)
c@43:           (when (> word-duration 0)
c@43:             (setf default-duration word-duration)))))))
c@43: 
c@43: ;;; FIXME: like GET-COURSE-TUNING/GET-TUNING only more hardcoded
c@43: (defun fret-to-number (char)
c@43:   (let ((fret-num (- (char-code char) 97)))
c@43:     (cond
c@43:       ((> fret-num 20) (- fret-num 2))
c@43:       ((> fret-num 8) (- fret-num 1))
c@43:       (t fret-num))))
c@43: (defun midi-pitch-for-playing (course fret)
c@43:   (let ((tuning #(67 62 57 53 48 43)))
c@43:     (+ (aref tuning (1- course))
c@43:        (fret-to-number fret))))
c@43: 
c@43: (defun make-tabcode-composition (tabword-buffer)
c@43:   (let ((time 0)
c@43:         (notes)
c@43:         (result)
c@43:         (current-duration 1))
c@43:     (dotimes (i (drei-buffer:size tabword-buffer) (setq notes (nreverse result)))
c@43:       (let* ((object (drei-buffer:buffer-object tabword-buffer i))
c@43:              (tabword (tabcode-syntax::tabword-word object))
c@43:              (duration (word-duration tabword current-duration)))
c@43:         (when (typep tabword 'tabcode::rhythmic-word) 
c@43:           (setf current-duration duration))
c@43:         (when (typep tabword 'tabcode::chord)
c@43:           (dolist (playing (tabcode::playing tabword))
c@43:             (let* ((course (tabcode::course playing))
c@43:                    (fret (tabcode::fret playing))
c@43:                    (note-duration (duration-for-course course tabword-buffer (1+ i) current-duration)))
c@43:               (push (make-instance 'tabcode-pitched-event
c@43:                                    :course course
c@43:                                    :fret fret
c@43:                                    :word tabword ; object?
c@43:                                    :number (midi-pitch-for-playing course fret)
c@43:                                    :time time
c@43:                                    :interval note-duration)
c@43:                     result))))
c@43:         (incf time duration)))
c@43:     (let ((composition (make-instance 'tabcode-composition
c@43:                                       :time 0
c@43:                                       :interval time)))
c@43:       (sequence:adjust-sequence composition (length notes)
c@43:                                 :initial-contents notes))))
c@43: 
c@43: #|
c@43: (in-package :clim-user)
c@43: 
c@43: (defvar *composition*)
c@43: 
c@43: (define-command (com-set-amuse-composition 
c@43:                  :name t :command-table tabcode-syntax::tabcode-table)
c@43:     ()
c@43:   (let* ((window (esa:current-window))
c@43:          (buffer (drei-buffer:buffer window))
c@43:          (syntax (climacs::syntax buffer))
c@43:          (tabwords (slot-value syntax 'tabcode-syntax::tabwords)))
c@43:     (setq *composition* (amuse-tabcode::make-tabcode-composition tabwords))))
csr21@58: 
csr21@58: (define-command (com-amuse-play
csr21@58: 		 :name t :command-table tabcode-syntax::tabcode-table)
csr21@58:     ()
csr21@58:   (let* ((window (esa:current-window))
csr21@58:          (buffer (drei-buffer:buffer window))
csr21@58:          (syntax (climacs::syntax buffer))
csr21@58:          (tabwords (slot-value syntax 'tabcode-syntax::tabwords))
csr21@58: 	 (composition (amuse-tabcode::make-tabcode-composition tabwords)))
csr21@58:     ;; HACK: emulate background playing.
csr21@58:     (sb-thread:make-thread (lambda () (amuse-utils:play composition)))))
csr21@58: 	 
csr21@58: (define-command (com-infer-key
csr21@58: 		 :name t :command-table tabcode-syntax::tabcode-table)
csr21@58:     ()
csr21@58:   (let* ((window (esa:current-window))
csr21@58:          (buffer (drei-buffer:buffer window))
csr21@58:          (syntax (climacs::syntax buffer))
csr21@58:          (tabwords (slot-value syntax 'tabcode-syntax::tabwords))
csr21@58: 	 (composition (amuse-tabcode::make-tabcode-composition tabwords))
c@94: 	 (result (amuse-harmony:krumhansl-key-finder composition composition))
csr21@58: 	 (name (aref #("C" "C#" "D" "Eb" "E" "F" "F#" "G" "Ab" "A" "Bb" "B") (car result)))
csr21@58: 	 (string (format nil "{<key>~A ~(~A~)</key>}~%" name (cadr result)))) 
csr21@58:     (drei-buffer:insert-buffer-sequence buffer 0 string)))
csr21@55: |#