view implementations/tabcode/tabcode-import.lisp @ 108:b445959f4cc1

MIPS generic functions and methods for diatonic pitches

Define and implement DIATONIC-PITCH-MP and DIATONIC-PITCH-CP for mips-pitches
(soon to be diatonic-pitches).  Supersedes MEREDITH-FOO

darcs-hash:20070726131018-dc3a5-3421fb2c4beceae2370932768fefa1115050cfdd.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))))

(define-command (com-amuse-play
		 :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))
	 (composition (amuse-tabcode::make-tabcode-composition tabwords)))
    ;; HACK: emulate background playing.
    (sb-thread:make-thread (lambda () (amuse-utils:play composition)))))
	 
(define-command (com-infer-key
		 :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))
	 (composition (amuse-tabcode::make-tabcode-composition tabwords))
	 (result (amuse-harmony:krumhansl-key-finder composition composition))
	 (name (aref #("C" "C#" "D" "Eb" "E" "F" "F#" "G" "Ab" "A" "Bb" "B") (car result)))
	 (string (format nil "{<key>~A ~(~A~)</key>}~%" name (cadr result)))) 
    (drei-buffer:insert-buffer-sequence buffer 0 string)))
|#