comparison 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))))
+|#