Update of /project/gsharp/cvsroot/gsharp In directory common-lisp.net:/tmp/cvs-serv24865
Modified Files: drawing.lisp elasticity.lisp Log Message: Fixed a few bugs in the elasticity library.
Added computation of elasticity functions for each measure.
Date: Wed Nov 30 01:23:03 2005 Author: rstrandh
Index: gsharp/drawing.lisp diff -u gsharp/drawing.lisp:1.37 gsharp/drawing.lisp:1.38 --- gsharp/drawing.lisp:1.37 Tue Nov 29 05:22:20 2005 +++ gsharp/drawing.lisp Wed Nov 30 01:22:54 2005 @@ -198,6 +198,18 @@ ;; whose corresponding timeline is not the last one in the meaure do (compute-gaps-separated-timelines (measure-bars measure) method pane)))
+(defun compute-elasticity-functions (measures method) + (loop for measure in measures + do (loop with result = (make-elementary-elasticity (min-width method) 0.0001) + with timelines = (timelines measure) + for i from 0 below (flexichain:nb-elements timelines) + for timeline = (flexichain:element* timelines i) + do (setf result + (add-elasticities + result + (make-elementary-elasticity (smallest-gap timeline) (elasticity timeline)))) + finally (setf (elasticity-function measure) result)))) + (defun draw-measure (pane measure min-dist compress x method draw-cursor) (let* ((width (/ (nat-width method (measure-coeff measure) min-dist) compress)) @@ -258,6 +270,7 @@ (lambda (measures) (compute-elasticities measures method) (compute-gaps measures method pane) + (compute-elasticity-functions measures method) (let ((widths (compute-widths measures method))) (score-pane:with-vertical-score-position (pane yy) (draw-system pane measures (+ x (left-offset buffer) timesig-offset)
Index: gsharp/elasticity.lisp diff -u gsharp/elasticity.lisp:1.1 gsharp/elasticity.lisp:1.2 --- gsharp/elasticity.lisp:1.1 Mon Nov 28 20:34:17 2005 +++ gsharp/elasticity.lisp Wed Nov 30 01:22:54 2005 @@ -56,6 +56,11 @@ ((zero-force-size :initarg :zero-force-size :reader zero-force-size) (elements :initform '() :initarg :elements :reader elements)))
+(defmethod print-object ((e elasticity) stream) + (print-unreadable-object (e stream :type t :identity t) + (format stream "zero-size: ~a elements:~s" + (zero-force-size e) (elements e)))) + (defun make-zero-elasticity (size) "create an elasticity function that is constant for all values of the force" @@ -67,38 +72,41 @@ have a size smaller than the zero-force-size given" (make-instance 'elasticity :zero-force-size zero-force-size - :elements `(,(/ zero-force-size slope) . ,slope))) + :elements `((,(/ zero-force-size slope) . ,slope))))
(defmethod add-elasticities ((e1 elasticity) (e2 elasticity)) (let ((l1 (elements e1)) (l2 (elements e2)) (s1 0) (s2 0) - (result (list (+ (zero-force-size e1) (zero-force-size e2))))) + (zero-force-size (+ (zero-force-size e1) (zero-force-size e2))) + (elements '())) (loop until (and (null l1) (null l2)) do (cond ((null l1) (setf s2 (cdar l2)) - (push (cons (caar l2) (+ s1 s2)) result) + (push (cons (caar l2) (+ s1 s2)) elements) (pop l2)) ((null l2) (setf s1 (cdar l1)) - (push (cons (caar l1) (+ s1 s2)) result) + (push (cons (caar l1) (+ s1 s2)) elements) (pop l1)) - ((< 0.99999 (/ (caar l1) (caar l2)) 1.00001) + ((< 0.99999 (/ (+ (caar l1) 0.00001) (+ (caar l2) .00001)) 1.00001) (setf s1 (cdar l1) s2 (cdar l2)) - (push (cons (/ (+ (caar l1) (caar l2)) 2) (+ s1 s2)) result) + (push (cons (/ (+ (caar l1) (caar l2)) 2) (+ s1 s2)) elements) (pop l1) (pop l2)) ((< (caar l1) (caar l2)) (setf s1 (cdar l1)) - (push (cons (caar l1) (+ s1 s2)) result) + (push (cons (caar l1) (+ s1 s2)) elements) (pop l1)) (t (setf s2 (cdar l2)) - (push (cons (caar l2) (+ s1 s2)) result) + (push (cons (caar l2) (+ s1 s2)) elements) (pop l2)))) - (make-instance 'elasticity :elements (nreverse result)))) + (make-instance 'elasticity + :zero-force-size zero-force-size + :elements (nreverse elements))))
(defmethod force-at-size ((e elasticity) size) (let ((l (elements e))