Mercurial > hg > amuse
changeset 230:32b40c50075e
Add some base methods for searching and sorting events.
Ignore-this: 4906722dfd6d1cfb91df8b85591f8b46
darcs-hash:20091020091537-16a00-1efcd0569b9a242be75bf99908b9117dc5946762.gz
committer: Jamie Forth <j.forth@gold.ac.uk>
| author | j.forth <j.forth@gold.ac.uk> |
|---|---|
| date | Thu, 24 Feb 2011 11:23:18 +0000 |
| parents | c9573d61b1b9 |
| children | 7a5618d334e4 |
| files | base/generics.lisp base/methods.lisp base/package.lisp |
| diffstat | 3 files changed, 82 insertions(+), 5 deletions(-) [+] |
line wrap: on
line diff
--- a/base/generics.lisp Thu Feb 24 11:23:18 2011 +0000 +++ b/base/generics.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -463,11 +463,28 @@ (defgeneric get-applicable-clefs (anchored-period constituent)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Copying events in time +;;;======================================================================== +;;; Copying events in time +;;;======================================================================== -(defgeneric move-to-first-bar (composition)) ;;this shouldn't be here +(defgeneric move-to-first-bar (composition)) (defgeneric copy-event (event)) (defgeneric voice (event)) + + +;;;======================================================================== +;;; Searching for events +;;;======================================================================== + +(defgeneric find-next-event (source-event &key predicate test + break-test search-list)) + +;;;======================================================================== +;;; Sorting Compositions +;;;======================================================================== + +(defgeneric event< (event1 event2 attribute-list)) + +(defgeneric sort-composition (composition attribute-list))
--- a/base/methods.lisp Thu Feb 24 11:23:18 2011 +0000 +++ b/base/methods.lisp Thu Feb 24 11:23:18 2011 +0000 @@ -568,8 +568,9 @@ (error 'insufficient-information :operation 'beat-period :datatype (class-of composition))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Copying events in time +;;;======================================================================== +;;; Copying events in time +;;;======================================================================== (defmethod move-to-first-bar ((composition composition)) (let ((offset (floor (timepoint (elt composition 0))))) @@ -580,3 +581,58 @@ (- (timepoint event) offset)) collect event into shifted-events finally (return shifted-events)))) + + +;;;======================================================================== +;;; Searching for events +;;;======================================================================== + +(defmethod find-next-event ((source-event event) &key predicate test + break-test search-list) + "Ideally a sorted search list that begins with the first event after +the source-event should be provided, otherwise, the search will begin +from the beginning." + (unless search-list (setf search-list (composition source-event))) + (cond + ((and test predicate) + (error "Supplied both a test and a predicate.")) + (test + (sequence:dosequence (e search-list nil) + (when (and (time> (onset e) (onset source-event)) + (funcall test source-event e)) + (return e)) + (when break-test + (when (funcall break-test source-event e) + (return nil))))) + (predicate + (sequence:dosequence (e search-list nil) + (when (and (time> (onset e) (onset source-event)) + (funcall predicate e)) + (return e)) + (when break-test + (when (funcall break-test source-event e) + (return nil))))))) + + +;;;======================================================================== +;;; Sorting Compositions +;;;======================================================================== + +(defmethod event< ((event1 event) (event2 event) attribute-list) + (dolist (attribute attribute-list nil) ;nil if equal + (if (< (funcall attribute event1) (funcall attribute event2)) + (return t) + (if (> (funcall attribute event1) (funcall attribute event2)) + (return nil))))) + +(defun make-event< (attribute-list) + (lambda (event1 event2) + (funcall #'event< event1 event2 attribute-list))) + +(defmethod sort-composition ((composition composition) dimension-spec) + (sequence:make-sequence-like composition + (length composition) + :initial-contents + (stable-sort + (copy-seq composition) + (make-event< dimension-spec))))