view implementations/tabcode/tabcode-import.lisp @ 43:2fd7ebed5b87

basic tabcode amuse implementation

darcs-hash:20070614145209-dc3a5-98b89c451db974b34878aae216e024e2ae38b734.gz

(in-package :amuse-tabcode)

(defun word-duration (word default)
  (if (typep word 'tabcode::rhythmic-word)
      (let ((flag (tabcode::flag word))
            (dots (tabcode::dots word)))
        (if flag
            (* (car (rassoc flag tabcode::*rhythms*))
               (if dots 3/2 1))
            default))
      0))

(defun word-causes-stop-p (word course)
  (or (typep word 'tabcode::rest)
      (typep word 'tabcode::barline)
      (and (typep word 'tabcode::chord)
           (member course (tabcode::playing word) :key #'tabcode::course))))

(defun duration-for-course (course buffer start initial-duration)
  (let ((duration initial-duration)
        (default-duration initial-duration))
    (do ((i start (+ i 1)))
        ((>= i (drei-buffer:size buffer)) duration)
      (let* ((object (drei-buffer:buffer-object buffer i))
             (word (tabcode-syntax::tabword-word object)))
        (when (word-causes-stop-p word course)
          (return-from duration-for-course duration))
        (let ((word-duration (word-duration word default-duration)))
          (incf duration word-duration)
          (when (> word-duration 0)
            (setf default-duration word-duration)))))))

;;; FIXME: like GET-COURSE-TUNING/GET-TUNING only more hardcoded
(defun fret-to-number (char)
  (let ((fret-num (- (char-code char) 97)))
    (cond
      ((> fret-num 20) (- fret-num 2))
      ((> fret-num 8) (- fret-num 1))
      (t fret-num))))
(defun midi-pitch-for-playing (course fret)
  (let ((tuning #(67 62 57 53 48 43)))
    (+ (aref tuning (1- course))
       (fret-to-number fret))))

(defun make-tabcode-composition (tabword-buffer)
  (let ((time 0)
        (notes)
        (result)
        (current-duration 1))
    (dotimes (i (drei-buffer:size tabword-buffer) (setq notes (nreverse result)))
      (let* ((object (drei-buffer:buffer-object tabword-buffer i))
             (tabword (tabcode-syntax::tabword-word object))
             (duration (word-duration tabword current-duration)))
        (when (typep tabword 'tabcode::rhythmic-word) 
          (setf current-duration duration))
        (when (typep tabword 'tabcode::chord)
          (dolist (playing (tabcode::playing tabword))
            (let* ((course (tabcode::course playing))
                   (fret (tabcode::fret playing))
                   (note-duration (duration-for-course course tabword-buffer (1+ i) current-duration)))
              (push (make-instance 'tabcode-pitched-event
                                   :course course
                                   :fret fret
                                   :word tabword ; object?
                                   :number (midi-pitch-for-playing course fret)
                                   :time time
                                   :interval note-duration)
                    result))))
        (incf time duration)))
    (let ((composition (make-instance 'tabcode-composition
                                      :time 0
                                      :interval time)))
      (sequence:adjust-sequence composition (length notes)
                                :initial-contents notes))))

#|
(in-package :clim-user)

(defvar *composition*)

(define-command (com-set-amuse-composition 
                 :name t :command-table tabcode-syntax::tabcode-table)
    ()
  (let* ((window (esa:current-window))
         (buffer (drei-buffer:buffer window))
         (syntax (climacs::syntax buffer))
         (tabwords (slot-value syntax 'tabcode-syntax::tabwords)))
    (setq *composition* (amuse-tabcode::make-tabcode-composition tabwords))))
|#