c@43: (in-package :amuse-tabcode) c@43: c@43: (defun word-duration (word default) d@179: (if (typep word '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) d@179: (typep word 'barline) d@179: (and (typep word 'chord) d@179: (member course (playing word) :key #'course)))) d@179: #+nil 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)))) d@179: (defvar *default-tuning* #(67 -5 -5 -4 -5 -5 -2 -3)) d@179: (defun midi-pitch-with-tuning (course fret current-tuning) d@179: (unless current-tuning d@179: (setf current-tuning *default-tuning*)) d@179: (let ((open-course (aref current-tuning 0))) d@179: (when (= open-course 0) d@179: (case (aref current-tuning 1) d@179: (0 ;; no info d@179: (setf current-tuning *default-tuning* d@179: open-course (aref current-tuning 0))) d@179: (-5 ;; prob renaissance d@179: (setf open-course 67)) d@179: (-3 ;; prob baroque d@179: (setf open-course 65)) d@179: (t ;; probably weird transitional. Just guess. d@179: (setf open-course 67)))) d@179: (do ((i 1 (1+ i))) d@179: ((< course i) (+ (fret-to-number fret) open-course)) d@179: (setf open-course (+ open-course (aref current-tuning i)))))) d@179: d@179: (defparameter *current-tuning* nil) d@179: (defmethod get-composition ((identifier tabcode-file-identifier)) d@179: (get-composition-from-tabwords d@179: (parse-tabcode-file (tabcode-pathname identifier)))) c@43: d@179: (defun get-composition-from-tabwords (tabwords) d@179: (let ((time 0) d@179: (notes) d@179: (result) d@179: (current-duration 1) d@179: (current-tuning (copy-seq *current-tuning*)) d@179: (rules) d@179: (metres) d@179: (bars (list (make-instance 'tabcode-bar :start nil d@179: :time 0 :interval 0)))) d@179: (do* ((tabwords tabwords (cdr tabwords)) d@179: (tabword (car tabwords) (car tabwords))) d@179: ((null tabwords) d@179: (setq notes (nreverse result))) d@179: (let* ((duration (word-duration tabword current-duration))) d@179: (when (typep tabword 'rhythmic-word) d@179: (setf current-duration duration)) d@179: (typecase tabword d@179: (barline d@179: (setf (end-tabword (car bars)) tabword d@179: (duration (car bars)) (- time d@179: (timepoint d@179: (onset d@179: (car bars)))) d@179: bars (cons (make-instance 'tabcode-bar d@179: :start tabword d@179: :time time) d@179: bars))) d@179: (comment d@179: (when (rulep tabword) d@179: (when rules d@179: (setf (duration (car rules)) d@179: (- time d@179: (timepoint (onset (car rules)))))) d@179: (push (make-instance 'tabcode-ruleset d@179: :rules (parse-rules tabword) d@179: :time time) d@179: rules) d@179: (setf current-tuning (update-tuning (ruleset-rules (car rules)) d@179: current-tuning)))) d@179: (metre d@179: (when metres d@179: (setf (duration (car metres)) d@179: (- time (timepoint (onset (car metres)))))) d@179: (push (make-instance 'tabcode-time-signature d@179: :time time d@179: :word tabword) d@179: metres)) d@179: (chord d@179: (dolist (playing (playing tabword)) d@179: (let* ((course (course playing)) d@179: (fret (fret playing)) d@179: (note-duration current-duration)) d@179: (push (make-instance 'tabcode-pitched-event d@179: :course course d@179: :fret fret d@179: :word tabword ; object? d@179: :number (midi-pitch-with-tuning (1- course) fret current-tuning) d@179: :time time d@179: :interval note-duration d@179: :bar (car bars)) d@179: result))))) d@179: (incf time duration))) d@179: (if (= (timepoint (car bars)) time) d@179: (setf bars (cdr bars)) d@179: (setf (duration (car bars)) d@179: (- time (timepoint (onset (car bars)))))) d@179: (when rules d@179: (setf (duration (car rules)) d@179: (- time (timepoint (onset (car rules)))))) d@179: (when metres d@179: (setf (duration (car metres)) d@179: (- time (timepoint (onset (car metres)))))) d@179: (let ((composition (make-instance 'tabcode-composition d@179: :time 0 d@179: :interval time d@179: :bars (reverse bars) d@179: :rules rules d@179: :metres metres))) d@179: (sequence:adjust-sequence composition (length notes) d@179: :initial-contents notes)))) d@179: #+nil 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: d@179: (defun update-tuning (rules current-tuning) d@179: (unless current-tuning d@179: (setf current-tuning (make-array 15 :element-type 'integer))) d@179: ;; First, get reference pitch d@179: (when (assoc "pitch" rules :test #'string=) d@179: (setf (aref current-tuning 0) d@179: (parse-integer (cdr (assoc "pitch" rules :test #'string=)) :junk-allowed t))) d@179: (cond d@179: ((assoc "tuning" rules :test #'string=) d@179: (setf current-tuning d@179: (apply-tuning (cdr (assoc "tuning" rules :test #'string=)) d@179: current-tuning))) d@182: ((or (assoc "tuning-named" rules :test #'string=) d@182: (assoc "tuning_named" rules :test #'string=)) d@179: (setf current-tuning d@182: (apply-tuning (cdr (assoc (string-downcase d@182: (cdr (or (assoc "tuning-named" d@182: rules :test #'string=) d@182: (assoc "tuning_named" d@182: rules :test #'string=)))) d@179: *tuning-names* :test #'string=)) d@179: current-tuning)))) d@179: (cond d@182: ((or (assoc "bass-tuning" rules :test #'string=) d@182: (assoc "bass_tuning" rules :test #'string=)) d@179: (setf current-tuning d@182: (apply-tuning (cdr (or (assoc "bass-tuning" rules :test #'string=) d@182: (assoc "bass_tuning" rules :test #'string=))) d@182: current-tuning 6))) d@182: ((or (assoc "bass-tuning-named" rules :test #'string=) d@182: (assoc "bass_tuning_named" rules :test #'string=)) d@179: (setf current-tuning d@182: (apply-tuning (cdr (assoc (string-downcase d@182: (cdr (or (assoc "bass-tuning-named" d@182: rules :test #'string=) d@182: (assoc "bass_tuning_named" d@182: rules :test #'string=)))) d@179: *tuning-names* :test #'string=)) d@179: current-tuning d@179: 6)))) d@179: current-tuning) d@179: d@179: (defun apply-tuning (interval-string current-tuning &optional (start-course 1)) d@179: (do* ((pointer (1+ (or (position #\( interval-string) d@179: -1)) d@179: (+ 1 pointer (length (princ-to-string interval)))) d@179: (course start-course (1+ course)) d@179: (interval (parse-integer interval-string :start pointer :junk-allowed t) d@179: (parse-integer interval-string :start pointer :junk-allowed t))) d@179: ((not interval) current-tuning) d@179: (when (>= course (length current-tuning)) d@179: (setf current-tuning (adjust-array current-tuning (1+ course)))) d@179: (setf (aref current-tuning course) interval))) d@179: d@179: d@179: 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 "{~A ~(~A~)}~%" name (cadr result)))) csr21@58: (drei-buffer:insert-buffer-sequence buffer 0 string))) csr21@55: |#