[gsharp-cvs] CVS gsharp
rstrandh
rstrandh at common-lisp.net
Tue Jan 16 05:06:21 UTC 2007
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))
More information about the Gsharp-cvs
mailing list