view implementations/tabcode/tabcode-import.lisp @ 330:2fbff655ba47 tip

Removed cpitch-adj and cents SQL columns

(in-package :amuse-tabcode)

(defun word-duration (word default)
  (if (typep word '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 'barline)
      (and (typep word 'chord)
           (member course (playing word) :key #'course))))
#+nil
(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))))
(defvar *default-tuning* #(67 -5 -5 -4 -5 -5 -2 -3))
(defun midi-pitch-with-tuning (course fret current-tuning)
  (unless current-tuning
    (setf current-tuning *default-tuning*))
  (let ((open-course (aref current-tuning 0)))
    (when (= open-course 0)
      (case (aref current-tuning 1)
	(0 ;; no info
	 (setf current-tuning *default-tuning*
	       open-course (aref current-tuning 0)))       
	(-5 ;; prob renaissance
	 (setf open-course 67))
	(-3 ;; prob baroque
	 (setf open-course 65))
	(t ;; probably weird transitional. Just guess.
	 (setf open-course 67))))
    (do ((i 1 (1+ i)))
	((< course i) (+ (fret-to-number fret) open-course))
      (setf open-course (+ open-course (aref current-tuning i))))))
	 
(defparameter *current-tuning* nil)
(defmethod get-composition ((identifier tabcode-file-identifier))
  (get-composition-from-tabwords
   (parse-tabcode-file (tabcode-pathname identifier))))

(defun get-composition-from-tabwords (tabwords)
  (let ((time 0)
        (notes)
        (result)
        (current-duration 1)
	(current-tuning (copy-seq *current-tuning*))
	(rules)
	(metres)
	(bars (list (make-instance 'tabcode-bar :start nil 
				   :time 0 :interval 0))))
    (do* ((tabwords tabwords (cdr tabwords))
	  (tabword (car tabwords) (car tabwords)))
	 ((null tabwords)
	  (setq notes (nreverse result)))
      (let* ((duration (word-duration tabword current-duration)))
	(when (typep tabword 'rhythmic-word)
	  (setf current-duration duration))
	(typecase tabword
	  (barline
	   (setf (end-tabword (car bars)) tabword
		 (duration (car bars)) (- time
					  (timepoint
					   (onset
					    (car bars))))
		 bars (cons (make-instance 'tabcode-bar
					   :start tabword
					   :time time)
			    bars)))
	  (comment
	   (when (rulep tabword)
	     (when rules
	       (setf (duration (car rules))
		     (- time
			(timepoint (onset (car rules))))))
	     (push (make-instance 'tabcode-ruleset
				  :rules (parse-rules tabword)
				  :time time)
		   rules)
	     (setf current-tuning (update-tuning (ruleset-rules (car rules))
						 current-tuning))))
	  (metre
	   (when metres
	     (setf (duration (car metres))
		   (- time (timepoint (onset (car metres))))))
	   (push (make-instance 'tabcode-time-signature
				:time time
				:word tabword)
		 metres))
	  (chord
	   (dolist (playing (playing tabword))
	     (let* ((course (course playing))
		    (fret (fret playing))
		    (note-duration current-duration))
	       (push (make-instance 'tabcode-pitched-event
				    :course course
				    :fret fret
				    :word tabword ; object?
				    :number (midi-pitch-with-tuning (1- course) fret current-tuning)
				    :time time
				    :interval note-duration
				    :bar (car bars))
		     result)))))
	(incf time duration)))
    (if (= (timepoint (car bars)) time)
	(setf bars (cdr bars))
	(setf (duration (car bars))
	      (- time (timepoint (onset (car bars))))))
    (when rules
      (setf (duration (car rules))
	    (- time (timepoint (onset (car rules))))))
    (when metres
      (setf (duration (car metres))
	    (- time (timepoint (onset (car metres))))))
    (let ((composition (make-instance 'tabcode-composition
                                      :time 0
                                      :interval time
				      :bars (reverse bars)
				      :rules rules
				      :metres metres)))
      (sequence:adjust-sequence composition (length notes)
                                :initial-contents notes))))
#+nil
(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))))

(defun update-tuning (rules current-tuning)
  (unless current-tuning
    (setf current-tuning (make-array 15 :element-type 'integer)))
  ;; First, get reference pitch
  (when (assoc "pitch" rules :test #'string=)
    (setf (aref current-tuning 0)
	  (parse-integer (cdr (assoc "pitch" rules :test #'string=)) :junk-allowed t)))  
  (cond
    ((assoc "tuning" rules :test #'string=)
     (setf current-tuning
	   (apply-tuning (cdr (assoc "tuning" rules :test #'string=))
			 current-tuning)))
    ((or (assoc "tuning-named" rules :test #'string=)
	 (assoc "tuning_named" rules :test #'string=))
     (setf current-tuning
	   (apply-tuning (cdr (assoc (string-downcase
				      (cdr (or (assoc "tuning-named"
						      rules :test #'string=)
					       (assoc "tuning_named"
						      rules :test #'string=))))
				     *tuning-names* :test #'string=))
			 current-tuning))))
  (cond
    ((or (assoc "bass-tuning" rules :test #'string=)
	 (assoc "bass_tuning" rules :test #'string=))
     (setf current-tuning
	   (apply-tuning (cdr (or (assoc "bass-tuning" rules :test #'string=)
				  (assoc "bass_tuning" rules :test #'string=)))
			 current-tuning 6)))
    ((or (assoc "bass-tuning-named" rules :test #'string=)
	 (assoc "bass_tuning_named" rules :test #'string=))
     (setf current-tuning
	   (apply-tuning (cdr (assoc (string-downcase
				      (cdr (or (assoc "bass-tuning-named" 
						      rules :test #'string=)
					       (assoc "bass_tuning_named" 
						      rules :test #'string=))))
				     *tuning-names* :test #'string=))
			 current-tuning
			 6))))
  current-tuning)

(defun apply-tuning (interval-string current-tuning &optional (start-course 1))
  (do* ((pointer (1+ (or (position #\( interval-string)
			 -1))
		 (+ 1 pointer (length (princ-to-string interval))))
	(course start-course (1+ course))
	(interval (parse-integer interval-string :start pointer :junk-allowed t)
		  (parse-integer interval-string :start pointer :junk-allowed t)))
      ((not interval) current-tuning)
    (when (>= course (length current-tuning))
      (setf current-tuning (adjust-array current-tuning (1+ course))))
    (setf (aref current-tuning course) interval)))



#|
(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)))
|#