Mercurial > hg > amuse

changeset 179:88089258e08d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
initial tabcode work darcs-hash:20080708152042-40ec0-f6bf9befa5dc8d6eaf51dd1cbff68c78a09de896.gz
author d.lewis <d.lewis@gold.ac.uk>
date Tue, 08 Jul 2008 16:20:42 +0100
parents 057e8ab413f9
children 1a2b876b5587
files base/package.lisp implementations/tabcode/amuse-tabcode.asd implementations/tabcode/classes.lisp implementations/tabcode/methods.lisp implementations/tabcode/package.lisp implementations/tabcode/tabcode-import.lisp
diffstat 6 files changed, 283 insertions(+), 11 deletions(-) [+]
line wrap: on
line diff
--- a/base/package.lisp	Mon Jun 30 10:10:21 2008 +0100
+++ b/base/package.lisp	Tue Jul 08 16:20:42 2008 +0100
@@ -148,4 +148,6 @@
            #:crotchet
            #:diatonic-pitch-cp
            #:diatonic-pitch-mp
+	   #:current-beat
+	   #:current-bar
 	   ))
--- a/implementations/tabcode/amuse-tabcode.asd	Mon Jun 30 10:10:21 2008 +0100
+++ b/implementations/tabcode/amuse-tabcode.asd	Tue Jul 08 16:20:42 2008 +0100
@@ -1,5 +1,5 @@
 (asdf:defsystem amuse-tabcode
-  :depends-on (amuse tabcode-gui)
+  :depends-on (amuse tabcode)
   :components
   ((:file "package")
    (:file "classes" :depends-on ("package"))
--- a/implementations/tabcode/classes.lisp	Mon Jun 30 10:10:21 2008 +0100
+++ b/implementations/tabcode/classes.lisp	Tue Jul 08 16:20:42 2008 +0100
@@ -1,9 +1,62 @@
 (cl:in-package #:amuse-tabcode) 
 
-(defclass tabcode-composition (amuse:standard-composition)
-  ())
+(defclass tabcode-object (amuse-object) ())
 
-(defclass tabcode-pitched-event (standard-chromatic-pitched-event)
+(defclass tabcode-composition (standard-composition tabcode-object)
+  ((bars :initarg :bars :reader tabcode-bars)
+   (rules :initarg :rules :reader tabcode-rules)
+   (metres :initarg :metres :reader metrical-signs)))
+
+(defclass tabcode-pitched-event (standard-chromatic-pitched-event tabcode-object)
   ((course :initarg :course :reader course)
    (fret :initarg :fret :reader fret)
-   (word :initarg :word :reader word)))
+   (word :initarg :word :reader word)
+   (bar :initarg :bar :reader in-bar)))
+
+(defclass tabcode-time-signature (standard-anchored-period tabcode-object)
+  ((word :initarg :word :reader word)
+   (ul)(ll)(ur)(lr)))
+(defmethod ul ((timesig tabcode-time-signature))
+  (unless (slot-boundp timesig 'ul)
+    (let ((ul (tabcode::ul (word timesig))))
+      (setf (slot-value timesig 'ul)
+	    (when ul
+	      (or (parse-integer ul :junk-allowed t)
+		  ul)))))
+  (slot-value timesig 'ul))
+(defmethod ll ((timesig tabcode-time-signature))
+  (unless (slot-boundp timesig 'll)
+    (let ((ll (tabcode::ll (word timesig))))
+      (setf (slot-value timesig 'll)
+	    (when ll
+	      (or (parse-integer ll :junk-allowed t)
+		  ll)))))
+  (slot-value timesig 'll))
+(defmethod ur ((timesig tabcode-time-signature))
+  (unless (slot-boundp timesig 'ur)
+    (let ((ur (tabcode::ur (word timesig))))
+      (setf (slot-value timesig 'ur)
+	    (when ur
+	      (or (parse-integer ur :junk-allowed t)
+		  ur)))))
+  (slot-value timesig 'ur))
+(defmethod lr ((timesig tabcode-time-signature))
+  (unless (slot-boundp timesig 'lr)
+    (let ((lr (tabcode::lr (word timesig))))
+      (setf (slot-value timesig 'lr)
+	    (when lr
+	      (or (parse-integer lr :junk-allowed t)
+		  lr)))))
+  (slot-value timesig 'lr))
+
+(defclass tabcode-file-identifier (identifier tabcode-object)
+  ((pathname :initarg :pathname :reader tabcode-pathname)))
+
+(defclass tabcode-bar (standard-anchored-period tabcode-object)
+  ((start :initarg :start :accessor start-tabword)
+   (end :initarg :end :accessor end-tabword)))
+
+(defclass tabcode-ruleset (standard-anchored-period tabcode-object)
+  ((rules :initarg :rules :accessor ruleset-rules)
+   (tuning :initarg :tuning :accessor ruleset-tuning :initform nil)))
+
--- a/implementations/tabcode/methods.lisp	Mon Jun 30 10:10:21 2008 +0100
+++ b/implementations/tabcode/methods.lisp	Tue Jul 08 16:20:42 2008 +0100
@@ -5,3 +5,68 @@
 (defmethod time-signatures ((composition tabcode-composition))
   ())
 
+(defmethod get-applicable-key-signatures (object (composition tabcode-composition))
+ ())
+
+(defmethod crotchet ((object tabcode-object))
+  (make-standard-period 1))
+
+(defmethod current-bar ((moment standard-moment) (composition tabcode-composition))
+  (find-if #'(lambda (x) (and (time< moment (cut-off x))
+			      (time>= moment (onset x))))
+	   (tabcode-bars composition)))
+
+(defmethod current-beat ((moment standard-moment) (composition tabcode-composition))
+  ;; clearly broken, but can unbreak unusual cases as they arise (?!)
+  (let ((bar (current-bar moment composition))
+	(metre (find-if #'(lambda (x) (and (time< moment (cut-off x))
+					   (time>= moment (onset x))))
+			(metrical-signs composition))))
+    (unless (and bar metre)
+      (error 'insufficient-information
+	     :operation 'beat-period
+	     :datatype (class-of composition)))
+    (let ((beats-in-bar) (beat-duration))
+      (cond
+	((ur metre)
+	 ;; we have a weird compound signature, goodness knows what to
+	 ;; do. This probably means that one of them is a proportion
+	 ;; sign.
+	 (error 'insufficient-information
+		:operation 'beat-period
+		:datatype (class-of composition)))
+	((and (ll metre)
+	      (numberp (ll metre)) ;; we have a `standard
+	      (numberp (ul metre)));; time sig'
+	 (setf beats-in-bar (ul metre)
+	       beat-duration (/ 4 (ll metre)))
+	 (when (and (> beats-in-bar 3)
+		    (= (rem beats-in-bar 3) 0))
+	   (setf beats-in-bar (/ beats-in-bar 3)
+		 beat-duration (* beat-duration 3))))
+	((and (null (ll metre))
+	      (numberp (ul metre)))
+	 (setf beats-in-bar (ul metre))
+	 (do ((proportion 4 (/ proportion 2)))
+	     ((= (rem (/ (duration bar) proportion)
+		      beats-in-bar) 0)
+	      (setf beat-duration proportion))))
+	((null (ll metre))
+	 (cond
+	   ((string= (ul metre) "C")
+	    (setf beats-in-bar 4)
+	    (setf beat-duration 1))
+	   ((string= (ul metre) "C/")
+	    (setf beats-in-bar 2)
+	    (setf beat-duration 2)))))
+      (unless (= (rem (duration bar)
+		      (* beat-duration beats-in-bar))
+		 0)
+	(error "Bar length doesn't match metrical symbol, I think"))
+      (let ((beat-period (make-standard-anchored-period
+			  (timepoint bar) beat-duration)))
+	(do ()
+	    ((time> (cut-off beat-period) moment) beat-period)
+	  (setf (timepoint beat-period)
+		(timepoint (cut-off beat-period))))))))
+	
\ No newline at end of file
--- a/implementations/tabcode/package.lisp	Mon Jun 30 10:10:21 2008 +0100
+++ b/implementations/tabcode/package.lisp	Tue Jul 08 16:20:42 2008 +0100
@@ -1,3 +1,3 @@
 (cl:defpackage "AMUSE-TABCODE"
-  (:use "CL" "AMUSE" "AMUSE-UTILS")
+  (:use "CL" "AMUSE" "AMUSE-UTILS" "TABCODE")
   (:export "COURSE" "WORD" "TABCODE-PITCHED-EVENT" "TABCODE-COMPOSITION"))
--- a/implementations/tabcode/tabcode-import.lisp	Mon Jun 30 10:10:21 2008 +0100
+++ b/implementations/tabcode/tabcode-import.lisp	Tue Jul 08 16:20:42 2008 +0100
@@ -1,7 +1,7 @@
 (in-package :amuse-tabcode)
 
 (defun word-duration (word default)
-  (if (typep word 'tabcode::rhythmic-word)
+  (if (typep word 'rhythmic-word)
       (let ((flag (tabcode::flag word))
             (dots (tabcode::dots word)))
         (if flag
@@ -12,10 +12,10 @@
 
 (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))))
-
+      (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))
@@ -41,7 +41,113 @@
   (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)
@@ -73,6 +179,52 @@
       (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)))
+    ((assoc "tuning-named" rules :test #'string=)
+     (setf current-tuning
+	   (apply-tuning (cdr (assoc (string-downcase (cdr (assoc "tuning-named"
+								  rules :test #'string=)))
+				     *tuning-names* :test #'string=))
+			 current-tuning))))
+  (cond
+    ((assoc "bass-tuning" rules :test #'string=)
+     (setf current-tuning
+	   (apply-tuning (cdr (assoc "bass-tuning" rules :test #'string=))
+			      current-tuning 6)))
+    ((assoc "bass-tuning-named" rules :test #'string=)
+     (setf current-tuning
+	   (apply-tuning (cdr (assoc (string-downcase (cdr (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)