Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv18442

Modified Files: beaming.lisp Log Message: Untabify to make it easier to work with Climacs.

--- /project/gsharp/cvsroot/gsharp/beaming.lisp 2005/12/07 03:38:27 1.3 +++ /project/gsharp/cvsroot/gsharp/beaming.lisp 2007/01/16 05:06:20 1.4 @@ -27,75 +27,75 @@ ;;; is going to be acceptably small. (defun beaming-single-stemsup-rising-twonotes (pos1 pos2) (let ((d (- pos2 pos1)) - (s1 (+ pos2 1)) - (s2 (+ pos2 2)) - (s3 (+ pos2 3)) - (s4 (+ pos2 4)) - (s5 (+ pos2 5)) - (s6 (+ pos2 6))) + (s1 (+ pos2 1)) + (s2 (+ pos2 2)) + (s3 (+ pos2 3)) + (s4 (+ pos2 4)) + (s5 (+ pos2 5)) + (s6 (+ pos2 6))) (cond ((<= pos2 -3) (case d - (0 `((4 . -1) (4 . -1))) - (1 `((4 . -1) (4 . 0))) - (t `((4 . -1) (4 . 1))))) - ((= pos2 -2) (case d - (0 `((4 . 0) (4 . 0))) - (1 `((4 . -1) (4 . 0))) - (t `((4 . -1) (4 . 1))))) - ((= pos2 -1) (case d - (0 `((6 . -1) (6 . -1))) - (1 `((4 . 0) (4 . 1))) - (t `((4 . -1) (4 . 1))))) - ((<= pos2 8) (if (evenp pos2) - (list (case d - (0 `(,s6 . 0)) - (1 `(,s6 . -1)) - (2 `(,s4 . 0)) - (t `(,s4 . -1))) - `(,s6 . 0)) - (list (case d - (0 `(,s5 . 1)) - (1 `(,s5 . 0)) - (2 `(,s5 . -1)) - (t `(,s3 . 0))) - `(,s5 . 1)))) - ((evenp pos2) (list (case d - (0 `(,s4 . 1)) - (1 `(,s4 . 0)) - (2 `(,s4 . -1)) - ((3 4 5) `(,s2 . 0)) - (t `(,s2 . -1))) - `(,s4 . 1))) - (t (list (case d - (0 `(,s5 . 0)) - (1 `(,s5 . -1)) - (2 `(,s3 . 0)) - ((3 4 5 6) `(,s3 . -1)) - (t `(,s1 . 0))) - `(,s5 . 0)))))) + (0 `((4 . -1) (4 . -1))) + (1 `((4 . -1) (4 . 0))) + (t `((4 . -1) (4 . 1))))) + ((= pos2 -2) (case d + (0 `((4 . 0) (4 . 0))) + (1 `((4 . -1) (4 . 0))) + (t `((4 . -1) (4 . 1))))) + ((= pos2 -1) (case d + (0 `((6 . -1) (6 . -1))) + (1 `((4 . 0) (4 . 1))) + (t `((4 . -1) (4 . 1))))) + ((<= pos2 8) (if (evenp pos2) + (list (case d + (0 `(,s6 . 0)) + (1 `(,s6 . -1)) + (2 `(,s4 . 0)) + (t `(,s4 . -1))) + `(,s6 . 0)) + (list (case d + (0 `(,s5 . 1)) + (1 `(,s5 . 0)) + (2 `(,s5 . -1)) + (t `(,s3 . 0))) + `(,s5 . 1)))) + ((evenp pos2) (list (case d + (0 `(,s4 . 1)) + (1 `(,s4 . 0)) + (2 `(,s4 . -1)) + ((3 4 5) `(,s2 . 0)) + (t `(,s2 . -1))) + `(,s4 . 1))) + (t (list (case d + (0 `(,s5 . 0)) + (1 `(,s5 . -1)) + (2 `(,s3 . 0)) + ((3 4 5 6) `(,s3 . -1)) + (t `(,s1 . 0))) + `(,s5 . 0))))))

(defun beaming-double-stemsup-rising-twonotes (pos1 pos2) (let ((d (- pos2 pos1)) - (s4 (+ pos2 4)) - (s5 (+ pos2 5)) - (s6 (+ pos2 6)) - (s7 (+ pos2 7))) + (s4 (+ pos2 4)) + (s5 (+ pos2 5)) + (s6 (+ pos2 6)) + (s7 (+ pos2 7))) (cond ((<= pos2 -3) (case d - (0 `((4 . -1) (4 . -1))) - (t `((4 . -1) (4 . 0))))) - ((= pos2 -2) (case d - (0 `((4 . 0) (4 . 0))) - (t `((4 . -1) (4 . 0))))) - ((evenp pos2) (list (case d - (0 `(,s6 . 0)) - (1 `(,s6 . -1)) - (2 `(,s4 . 0)) - (t `(,s4 . -1))) - `(,s6 . 0))) - (t (case d - (0 `((,s7 . -1) (,s7 . -1))) - (1 `((,s7 . -1) (,s7 . 0))) - (2 `((,s5 . -1) (,s7 . -1))) - (t `((,s5 . -1) (,s7 . 0)))))))) + (0 `((4 . -1) (4 . -1))) + (t `((4 . -1) (4 . 0))))) + ((= pos2 -2) (case d + (0 `((4 . 0) (4 . 0))) + (t `((4 . -1) (4 . 0))))) + ((evenp pos2) (list (case d + (0 `(,s6 . 0)) + (1 `(,s6 . -1)) + (2 `(,s4 . 0)) + (t `(,s4 . -1))) + `(,s6 . 0))) + (t (case d + (0 `((,s7 . -1) (,s7 . -1))) + (1 `((,s7 . -1) (,s7 . 0))) + (2 `((,s5 . -1) (,s7 . -1))) + (t `((,s5 . -1) (,s7 . 0))))))))

(defun reflect-pos (pos) (destructuring-bind (p x b) pos @@ -113,16 +113,16 @@ ;;; higher vertical position of the first point. (defun beaming-two-points (p1 p2 fun) (let* ((beaming (funcall fun (car p1) (car p2))) - (left (car beaming)) - (right (cadr beaming)) - (x1 (cadr p1)) - (x2 (cadr p2)) - (y1 (+ (car left) (* 0.5 (cdr left)))) - (y2 (+ (car right) (* 0.5 (cdr right)))) - (slant (/ (- y2 y1) (abs (- x2 x1))))) + (left (car beaming)) + (right (cadr beaming)) + (x1 (cadr p1)) + (x2 (cadr p2)) + (y1 (+ (car left) (* 0.5 (cdr left)))) + (y2 (+ (car right) (* 0.5 (cdr right)))) + (slant (/ (- y2 y1) (abs (- x2 x1))))) (if (> slant #.(tan (/ (* 18 pi) 180))) - (progn (incf (car p1)) (beaming-two-points p1 p2 fun)) - beaming))) + (progn (incf (car p1)) (beaming-two-points p1 p2 fun)) + beaming)))

;;; main entry

@@ -138,26 +138,26 @@ ;;; until each stem it as least 2.5 staff steps long. (defun beaming-general (positions stem-direction fun) (let* ((first (car positions)) - (last (car (last positions))) - (x1 (cadr first)) - (x2 (cadr last))) + (last (car (last positions))) + (x1 (cadr first)) + (x2 (cadr last))) (cond ((> (car first) (car last)) - (reverse (beaming-general (reverse positions) stem-direction fun))) - ((eq stem-direction :down) - (mapcar #'reflect-bpos (beaming-general (mapcar #'reflect-pos positions) :up fun))) - (t (let* ((beaming (beaming-two-points first last fun)) - (left (car beaming)) - (right (cadr beaming)) - (y1 (+ (car left) (* 0.5 (cdr left)))) - (y2 (+ (car right) (* 0.5 (cdr right)))) - (slope (/ (- y2 y1) (- x2 x1))) - (minstem (reduce #'min positions - :key (lambda (pos) - (destructuring-bind (p x b) pos - (- (+ y1 (* (- x x1) slope)) p (* 2 (1- b))))))) - (increment (* 2 (ceiling (/ (max 0 (- 5 minstem)) 2))))) - `((,(+ (car left) increment) . ,(cdr left)) - (,(+ (car right) increment) . ,(cdr right)))))))) + (reverse (beaming-general (reverse positions) stem-direction fun))) + ((eq stem-direction :down) + (mapcar #'reflect-bpos (beaming-general (mapcar #'reflect-pos positions) :up fun))) + (t (let* ((beaming (beaming-two-points first last fun)) + (left (car beaming)) + (right (cadr beaming)) + (y1 (+ (car left) (* 0.5 (cdr left)))) + (y2 (+ (car right) (* 0.5 (cdr right)))) + (slope (/ (- y2 y1) (- x2 x1))) + (minstem (reduce #'min positions + :key (lambda (pos) + (destructuring-bind (p x b) pos + (- (+ y1 (* (- x x1) slope)) p (* 2 (1- b))))))) + (increment (* 2 (ceiling (/ (max 0 (- 5 minstem)) 2))))) + `((,(+ (car left) increment) . ,(cdr left)) + (,(+ (car right) increment) . ,(cdr right))))))))

(defun beaming-single (positions stem-direction) (beaming-general positions stem-direction #'beaming-single-stemsup-rising-twonotes))