[gsharp-cvs] CVS update: gsharp/drawing.lisp gsharp/elasticity.lisp

[Robert Strandh]

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))