Mercurial > hg > amuse
changeset 183:5b2d0e5a99f1
More tabcode, plus fixes for gsharp key-sigs and some new restart symbols in amuse
darcs-hash:20080721130227-40ec0-858017ddbc42513731d0119e704926768906dbc6.gz
| author | d.lewis <d.lewis@gold.ac.uk> |
|---|---|
| date | Mon, 21 Jul 2008 14:02:27 +0100 |
| parents | 470e83242576 |
| children | 94803c723ccd |
| files | base/package.lisp implementations/tabcode/amuse-tabcode.asd implementations/tabcode/classes.lisp implementations/tabcode/ecolm.lisp implementations/tabcode/methods.lisp implementations/tabcode/package.lisp tools/gsharp-output.lisp tools/midi-output.lisp tools/package.lisp |
| diffstat | 9 files changed, 219 insertions(+), 108 deletions(-) [+] |
line wrap: on
line diff
--- a/base/package.lisp Thu Jul 10 12:48:05 2008 +0100 +++ b/base/package.lisp Mon Jul 21 14:02:27 2008 +0100 @@ -150,4 +150,8 @@ #:diatonic-pitch-mp #:current-beat #:current-bar + ;; condition restart options + #:use-whole-bar + #:use-crotchet-beat + #:guess ))
--- a/implementations/tabcode/amuse-tabcode.asd Thu Jul 10 12:48:05 2008 +0100 +++ b/implementations/tabcode/amuse-tabcode.asd Mon Jul 21 14:02:27 2008 +0100 @@ -1,8 +1,7 @@ (asdf:defsystem amuse-tabcode - :depends-on (amuse tabcode) + :depends-on (amuse tabcode amuse-harmony) :components ((:file "package") (:file "classes" :depends-on ("package")) (:file "methods" :depends-on ("package" "classes")) - (:file "tabcode-import" :depends-on ("package" "classes")) - (:file "ecolm" :depends-on ("tabcode-import" "methods" "classes" "package")))) \ No newline at end of file + (:file "tabcode-import" :depends-on ("package" "classes")))) \ No newline at end of file
--- a/implementations/tabcode/classes.lisp Thu Jul 10 12:48:05 2008 +0100 +++ b/implementations/tabcode/classes.lisp Mon Jul 21 14:02:27 2008 +0100 @@ -16,6 +16,10 @@ (defclass tabcode-time-signature (standard-anchored-period tabcode-object) ((word :initarg :word :reader word) (ul)(ll)(ur)(lr))) +(defgeneric ul (timesig)) +(defgeneric ll (timesig)) +(defgeneric ur (timesig)) +(defgeneric lr (timesig)) (defmethod ul ((timesig tabcode-time-signature)) (unless (slot-boundp timesig 'ul) (let ((ul (tabcode::ul (word timesig))))
--- a/implementations/tabcode/ecolm.lisp Thu Jul 10 12:48:05 2008 +0100 +++ b/implementations/tabcode/ecolm.lisp Mon Jul 21 14:02:27 2008 +0100 @@ -1,4 +1,4 @@ -(in-package #:amuse-tabcode) +(in-package #:amuse-ecolm) (defun get-ecolm-connection () (clsql:connect (list "127.0.0.1" "ecolm" "basicuser" "basicuser" "29183") @@ -11,8 +11,9 @@ (tabcode :initarg :code :accessor %tabcode))) (defclass ecolm-search () - ((piece-title :initarg :p-title :reader piece-title) - (source-title :initarg :s-title :reader source-title))) + ((piece-title :initarg :piece :reader piece-title) + (source-title :initarg :source :reader source-title) + (cluster-name :initarg :cluster :reader cluster-name))) (defun edition-text-id (ecolm-id) (unless (or (slot-boundp ecolm-id 'edition-text-id) @@ -51,5 +52,64 @@ (%tabcode identifier)))) (defmethod get-composition ((identifier ecolm-identifier)) - (get-composition-from-tabwords - (tabcode::parse-tabcode-string (tabcode identifier)))) \ No newline at end of file + (amuse-tabcode::get-composition-from-tabwords + (tabcode::parse-tabcode-string (tabcode identifier)))) + +(defun make-ecolm-search (&key (piece-title nil) (source-title nil) (cluster-name nil)) + (make-instance 'ecolm-search + :piece piece-title + :source source-title + :cluster cluster-name)) + +(defun ecolm-search (&key (piece-title nil) (source-title nil) (cluster-name nil)) + (get-ecolm-search-results (make-ecolm-search :piece-title piece-title + :source-title source-title + :cluster-name cluster-name))) + +(defun get-ecolm-search-results (ecolm-search) + (let ((prefixes '("SELECT DISTINCT p.`Piece ID` FROM Pieces p")) + (where-clauses '("WHERE 1")) + (results) + (query-string "") (sourcep)) + (when (and (slot-boundp ecolm-search 'piece-title) + (piece-title ecolm-search)) + (push " LEFT JOIN Piece_Names pn USING (`Piece ID`) " + prefixes) + (push (format nil " AND (`Piece Title` LIKE '~D' OR `PieceName Alias` LIKE '~D') " + (piece-title ecolm-search) (piece-title ecolm-search)) + where-clauses)) + (when (and (slot-boundp ecolm-search 'source-title) + (source-title ecolm-search)) + (setf sourcep t) + (push " LEFT JOIN Sources s ON p.`Source ID`=s.`Source ID` + LEFT JOIN Source_Names sn ON s.`Source ID`=sn.`Source ID` " + prefixes) + (push (format nil " AND (`Source Title` LIKE '~D' OR `SourceName Alias` LIKE '~D') " + (source-title ecolm-search) (source-title ecolm-search)) + where-clauses)) + (when (and (slot-boundp ecolm-search 'cluster-name) + (cluster-name ecolm-search)) + (push (if sourcep + " LEFT JOIN Cluster_Pieces cp ON p.`Piece ID`=cp.`Piece ID` + LEFT JOIN Clusters c1 ON cp.`Cluster ID`=c1.`Cluster ID` + LEFT JOIN Cluster_Sources cs on s.`Source ID`=cs.`Source ID` + LEFT JOIN Clusters c2 ON cs.`Cluster ID`=c2.`Cluster ID` " + " LEFT JOIN Cluster_Pieces cp ON p.`Piece ID`=cp.`Piece ID` + LEFT JOIN Clusters c1 ON cp.`Cluster ID`=c1.`Cluster ID` ") + prefixes) + (push (format nil " AND (c1.`Cluster Name` LIKE '~D'~D)" + (cluster-name ecolm-search) + (if sourcep + (format nil "OR c2.`Cluster Name` LIKE '~D'" + (cluster-name ecolm-search)) + "")) + + where-clauses)) + (setf query-string (concatenate 'string + (apply #'concatenate + 'string (reverse prefixes)) + (apply #'concatenate + 'string (reverse where-clauses))) + results (clsql:query query-string)) + (remove-if-not #'edition-text-id (mapcar #'(lambda (x) (make-instance 'ecolm-identifier :p-id x)) results)))) +
--- a/implementations/tabcode/methods.lisp Thu Jul 10 12:48:05 2008 +0100 +++ b/implementations/tabcode/methods.lisp Mon Jul 21 14:02:27 2008 +0100 @@ -4,9 +4,21 @@ ()) (defmethod time-signatures ((composition tabcode-composition)) (metrical-signs composition)) - +(defmethod amuse-tools:get-patch-for-midi ((event tabcode-object)) + 24) +(defmethod amuse-tools:get-velocity-for-midi ((event tabcode-object)) + 70) +(defmethod amuse-tools:default-tempo-for-midi ((tab-comp tabcode-composition)) + (make-standard-tempo-period 60 (timepoint tab-comp) (duration tab-comp))) (defmethod get-applicable-key-signatures (object (composition tabcode-composition)) - ()) + (restart-case + (error 'insufficient-information + :operation 'beat-period + :datatype (class-of composition)) + (amuse:guess () (multiple-value-bind (x key) + (amuse-harmony:krumhansl-key-finder composition composition) + (declare (ignore x)) + (list key))))) (defmethod crotchet ((object tabcode-object)) (make-standard-period 1)) @@ -18,68 +30,82 @@ (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)) - (unless (>= proportion 1/4) - (setf beat-duration (round (/ (duration bar) - beats-in-bar))) - (return)))) - ((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))) - ;; clearly wrong, but for the time being try this (better is - ;; work out for the whole piece - (do ((proportion 4 (/ proportion 2))) - ((= (rem (/ (duration bar) proportion) - beats-in-bar) 0) - (setf beat-duration proportion)) - (unless (>= proportion 2) - (setf beat-duration 2) - (return))))) - (unless (= (rem (duration bar) - (* beat-duration beats-in-bar)) - 0) - (print "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 + (let ((bar (current-bar moment composition))) + (restart-case + (let ((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. Better errors would be a gould start. + (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)) + (unless (>= proportion 1/4) + (setf beat-duration (round (/ (duration bar) + beats-in-bar))) + (return)))) + ((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))) + ;; clearly wrong, but for the time being try this (better is + ;; work out for the whole piece + (do ((proportion 4 (/ proportion 2))) + ((= (rem (/ (duration bar) proportion) + beats-in-bar) 0) + (setf beat-duration proportion)) + (unless (>= proportion 2) + (setf beat-duration 2) + (return))))) + (unless (= (rem (duration bar) + (* beat-duration beats-in-bar)) + 0) + (print "Bar length doesn't match metrical symbol, I think")) + (find-current-beat-with-bar-start-and-constant-beat + moment bar beat-duration))) + (amuse:use-whole-bar () :report "Use whole bar" bar) + (amuse:use-crotchet-beat () :report "Use crotchet as beat" + (find-current-beat-with-bar-start-and-constant-beat + moment bar 1)) + (use-value-for-beat (new-beat) :report "Supply beat" + :interactive (lambda () + (format t "Beat value:") + (list (eval (read)))) + (find-current-beat-with-bar-start-and-constant-beat + moment bar new-beat))))) + +(defun find-current-beat-with-bar-start-and-constant-beat (current-moment bar-period beat-duration) + (let ((beat-period (make-standard-anchored-period + (timepoint bar-period) beat-duration))) + (do () + ((time> (cut-off beat-period) current-moment) beat-period) + (setf (timepoint beat-period) + (timepoint (cut-off beat-period)))))) \ No newline at end of file
--- a/implementations/tabcode/package.lisp Thu Jul 10 12:48:05 2008 +0100 +++ b/implementations/tabcode/package.lisp Mon Jul 21 14:02:27 2008 +0100 @@ -1,5 +1,5 @@ (cl:defpackage "AMUSE-TABCODE" (:use "CL" "AMUSE" "AMUSE-UTILS" "TABCODE") - (:export "COURSE" "WORD" "TABCODE-PITCHED-EVENT" "TABCODE-COMPOSITION" - "TABCODE-TIME-SIGNATURE" "TABCODE-FILE-IDENTIFIER" - "ECOLM-IDENTIFIER" "GET-ECOLM-CONNECTION")) + (:export "TABCODE-OBJECT" "COURSE" "WORD" "TABCODE-PITCHED-EVENT" + "TABCODE-COMPOSITION" + "TABCODE-TIME-SIGNATURE" "TABCODE-FILE-IDENTIFIER"))
--- a/tools/gsharp-output.lisp Thu Jul 10 12:48:05 2008 +0100 +++ b/tools/gsharp-output.lisp Mon Jul 21 14:02:27 2008 +0100 @@ -98,7 +98,11 @@ ;; FIXME: Throughout this, I assume that ;; get-applicable-time-signatures isn't '() (let ((time-signatures (get-applicable-time-signatures composition composition)) - (key-signatures (get-applicable-key-signatures composition composition)) + (key-signatures (handler-bind ((insufficient-information + #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'guess)))) + (get-applicable-key-signatures composition composition))) (layers)) (multiple-value-bind (layer-events layer-scores) ;; Get hash-tables of events by layer and counts of events @@ -166,33 +170,39 @@ ;; :crotchet crotchet-beats)) ;; (bar-starts (mapcar #'car beat-starts)) (bar-starts (let ((starts)) - (do ((bar-period (amuse::current-bar (make-standard-moment 0) composition) - (amuse::current-bar (cut-off bar-period) composition))) + (do ((bar-period (current-bar (make-standard-moment 0) composition) + (current-bar (cut-off bar-period) composition))) ((time>= (cut-off bar-period) (cut-off composition)) (reverse (cons (timepoint bar-period) starts))) (push (timepoint bar-period) starts)))) (beat-starts (if time-signatures - (let ((starts) (current)) - (do* ((bars bar-starts) - (beat-period (amuse::current-beat (make-standard-moment 0) composition) - (amuse::current-beat (cut-off beat-period) composition)) - (beat-time (timepoint beat-period) (timepoint beat-period))) - ((time>= (cut-off beat-period) (cut-off composition)) - (progn - (when (and (cdr bars) - (>= beat-time (second bars))) - (push (reverse current) starts) - (setf current nil - bars (cdr bars))) - (push beat-time current) - (reverse (cons (reverse current) starts)))) - (when (and (cdr bars) - (>= beat-time (second bars))) - (push (reverse current) starts) - (setf current nil - bars (cdr bars))) - (push beat-time current))) - (mapcar #'list bar-starts))) + (handler-bind + ((insufficient-information + #'(lambda (c) + (declare (ignore c)) + (invoke-restart 'use-whole-bar)))) + (let ((starts) (current)) + (do* ((bars bar-starts) + (beat-period (current-beat (make-standard-moment 0) composition) + (current-beat (cut-off beat-period) composition)) + (beat-time (timepoint beat-period) (timepoint beat-period))) + ((time>= (cut-off beat-period) (cut-off composition)) + (progn + (when (and (cdr bars) + (>= beat-time (second bars))) + (push (reverse current) starts) + (setf current nil + bars (cdr bars))) + (push beat-time current) + (reverse (cons (reverse current) starts)))) + (when (and (cdr bars) + (>= beat-time (second bars))) + (push (reverse current) starts) + (setf current nil + bars (cdr bars))) + (push beat-time current)))) + + (mapcar #'list bar-starts))) (ons) (position) (clusters) (bar) (bar-no 0) (body (gsharp::body layer))) @@ -232,7 +242,7 @@ (gsharp::add-bar bar body bar-no) (incf bar-no) (setf position 0)) - (when (and key-signatures +#+nil (when (and key-signatures (<= (timepoint (car key-signatures)) (caar ons))) (gsharp::add-element (make-gsharp-key-signature (car key-signatures) layer) @@ -334,7 +344,7 @@ (defgeneric make-gsharp-key-signature (key-signature layer)) (defmethod make-gsharp-key-signature ((key-signature standard-key-signature) layer) - (let ((alterations (make-array 7)) + (let ((alterations (make-array 7 :initial-element :natural)) (order-of-sharps #(3 0 4 1 5 2 6)) (order-of-flats #(6 2 5 1 4 0 3))) (if (< (key-signature-sharps key-signature) 0)
--- a/tools/midi-output.lisp Thu Jul 10 12:48:05 2008 +0100 +++ b/tools/midi-output.lisp Mon Jul 21 14:02:27 2008 +0100 @@ -96,6 +96,10 @@ patch-list) (setf (aref patches channel) patch))))) +(defgeneric default-tempo-for-midi (anchored-period) + (:method ((o standard-anchored-period)) + (make-standard-tempo-period *default-tempo* (timepoint o) (duration o)))) +(defparameter *default-tempo* 80) (defgeneric global-messages (sequence) (:method (s) (declare (ignore s)) nil)) @@ -106,10 +110,13 @@ (temp) (time-sigs (time-signatures sequence)) (events)) - (dolist (tempo tempi) - (setf temp (tempo-message tempo)) - (when temp - (push temp events))) + (if tempi + (dolist (tempo tempi) + (setf temp (tempo-message tempo)) + (when temp + (push temp events))) + (push (tempo-message (default-tempo-for-midi sequence)) + events)) (dolist (time-sig time-sigs events) (setf temp (time-sig-message time-sig)) (when temp