Basic undo implemented for simple operations.
[gsharp.git] / beaming.lisp
blobfec922c6160d189bd2ba25b72319b73499958dc3
1 (in-package :gsharp-beaming)
3 ;;; The beaming function takes a list of the form:
4 ;;; ((p1 x1) (p2 x2) ... (pn xn))
5 ;;; where p1 through pn are staff positions (bottom line is 0,
6 ;;; increas upwards by 1 for each staff step) and x1 through xn
7 ;;; are x positions for the clusters given in the same unit as the
8 ;;; positions, i.e., staff steps
10 ;;; The result of the computation is a VALID BEAMING. Such a beaming
11 ;;; is represented as a list of two elements representing the left and
12 ;;; the right end of the primary beam, respectively. Each element is
13 ;;; a cons of two integers, the fist representing the staff line where
14 ;;; the lower line is numbered 0, and so on in steps of two so that
15 ;;; the upper one is numbered 8. The second of the two integers
16 ;;; represents the position of the beam with respect to the staff
17 ;;; line, where 0 means straddle, 1 means sit and -1 means hang. This
18 ;;; representation makes it easy to transform the constellation by
19 ;;; reflection.
21 ;;; Take two vertical positions and compute the beam slant and beam
22 ;;; position for the beam connecting them. A position of zero means
23 ;;; the bottom of the staff. Positive integers count up 1/2 space so
24 ;;; that C on a staff with a G-clef gets to have number -2. Negative
25 ;;; numbers go the other way. This function assumes that pos2 >= pos1,
26 ;;; and that the two notes are sufficiently far apart that the slant
27 ;;; is going to be acceptably small.
28 (defun beaming-single-stemsup-rising-twonotes (pos1 pos2)
29 (let ((d (- pos2 pos1))
30 (s1 (+ pos2 1))
31 (s2 (+ pos2 2))
32 (s3 (+ pos2 3))
33 (s4 (+ pos2 4))
34 (s5 (+ pos2 5))
35 (s6 (+ pos2 6)))
36 (cond ((<= pos2 -3) (case d
37 (0 `((4 . -1) (4 . -1)))
38 (1 `((4 . -1) (4 . 0)))
39 (t `((4 . -1) (4 . 1)))))
40 ((= pos2 -2) (case d
41 (0 `((4 . 0) (4 . 0)))
42 (1 `((4 . -1) (4 . 0)))
43 (t `((4 . -1) (4 . 1)))))
44 ((= pos2 -1) (case d
45 (0 `((6 . -1) (6 . -1)))
46 (1 `((4 . 0) (4 . 1)))
47 (t `((4 . -1) (4 . 1)))))
48 ((<= pos2 8) (if (evenp pos2)
49 (list (case d
50 (0 `(,s6 . 0))
51 (1 `(,s6 . -1))
52 (2 `(,s4 . 0))
53 (t `(,s4 . -1)))
54 `(,s6 . 0))
55 (list (case d
56 (0 `(,s5 . 1))
57 (1 `(,s5 . 0))
58 (2 `(,s5 . -1))
59 (t `(,s3 . 0)))
60 `(,s5 . 1))))
61 ((evenp pos2) (list (case d
62 (0 `(,s4 . 1))
63 (1 `(,s4 . 0))
64 (2 `(,s4 . -1))
65 ((3 4 5) `(,s2 . 0))
66 (t `(,s2 . -1)))
67 `(,s4 . 1)))
68 (t (list (case d
69 (0 `(,s5 . 0))
70 (1 `(,s5 . -1))
71 (2 `(,s3 . 0))
72 ((3 4 5 6) `(,s3 . -1))
73 (t `(,s1 . 0)))
74 `(,s5 . 0))))))
76 (defun beaming-double-stemsup-rising-twonotes (pos1 pos2)
77 (let ((d (- pos2 pos1))
78 (s4 (+ pos2 4))
79 (s5 (+ pos2 5))
80 (s6 (+ pos2 6))
81 (s7 (+ pos2 7)))
82 (cond ((<= pos2 -3) (case d
83 (0 `((4 . -1) (4 . -1)))
84 (t `((4 . -1) (4 . 0)))))
85 ((= pos2 -2) (case d
86 (0 `((4 . 0) (4 . 0)))
87 (t `((4 . -1) (4 . 0)))))
88 ((evenp pos2) (list (case d
89 (0 `(,s6 . 0))
90 (1 `(,s6 . -1))
91 (2 `(,s4 . 0))
92 (t `(,s4 . -1)))
93 `(,s6 . 0)))
94 (t (case d
95 (0 `((,s7 . -1) (,s7 . -1)))
96 (1 `((,s7 . -1) (,s7 . 0)))
97 (2 `((,s5 . -1) (,s7 . -1)))
98 (t `((,s5 . -1) (,s7 . 0))))))))
100 (defun reflect-pos (pos)
101 (destructuring-bind (p x b) pos
102 (list (- 8 p) x b)))
104 (defun reflect-bpos (pos)
105 (cons (- 8 (car pos)) (- (cdr pos))))
107 ;;; take two points of the form (pos x b), where pos is a vertical
108 ;;; position (in staff-steps), x is a horizontal position (also in
109 ;;; staff-steps), and b is the number of beams at that position and
110 ;;; compute a valid beaming for the two points. To do so, first call
111 ;;; the function passed as an argument on the two vertical positions.
112 ;;; If the slant thus obtained is too high, repeat with a slightly
113 ;;; higher vertical position of the first point.
114 (defun beaming-two-points (p1 p2 fun)
115 (let* ((beaming (funcall fun (car p1) (car p2)))
116 (left (car beaming))
117 (right (cadr beaming))
118 (x1 (cadr p1))
119 (x2 (cadr p2))
120 (y1 (+ (car left) (* 0.5 (cdr left))))
121 (y2 (+ (car right) (* 0.5 (cdr right))))
122 (slant (/ (- y2 y1) (abs (- x2 x1)))))
123 (if (> slant #.(tan (/ (* 18 pi) 180)))
124 (progn (incf (car p1)) (beaming-two-points p1 p2 fun))
125 beaming)))
127 ;;; main entry
129 ;;; Take a list of the form ((p1 x1 b1) (p2 x2 b2) ... (pn xn bn)),
130 ;;; (where pi is a vertical position, xi is a horizontal position
131 ;;; (both measured in staff-steps), and bi is the number of stems at
132 ;;; that position), a stem direction, and a function to compute a
133 ;;; valid slant of two notes sufficiently far apart, compute a valid
134 ;;; beaming. First reflect the positions vertically and horizontally
135 ;;; until the last note is higher than the first and the stems are up.
136 ;;; Then compute a valid beaming using only the first and last
137 ;;; elements of the list. Finally, move the beaming up vertically
138 ;;; until each stem it as least 2.5 staff steps long.
139 (defun beaming-general (positions stem-direction fun)
140 (let* ((first (car positions))
141 (last (car (last positions)))
142 (x1 (cadr first))
143 (x2 (cadr last)))
144 (cond ((> (car first) (car last))
145 (reverse (beaming-general (reverse positions) stem-direction fun)))
146 ((eq stem-direction :down)
147 (mapcar #'reflect-bpos (beaming-general (mapcar #'reflect-pos positions) :up fun)))
148 (t (let* ((beaming (beaming-two-points first last fun))
149 (left (car beaming))
150 (right (cadr beaming))
151 (y1 (+ (car left) (* 0.5 (cdr left))))
152 (y2 (+ (car right) (* 0.5 (cdr right))))
153 (slope (/ (- y2 y1) (- x2 x1)))
154 (minstem (reduce #'min positions
155 :key (lambda (pos)
156 (destructuring-bind (p x b) pos
157 (- (+ y1 (* (- x x1) slope)) p (* 2 (1- b)))))))
158 (increment (* 2 (ceiling (/ (max 0 (- 5 minstem)) 2)))))
159 `((,(+ (car left) increment) . ,(cdr left))
160 (,(+ (car right) increment) . ,(cdr right))))))))
162 (defun beaming-single (positions stem-direction)
163 (beaming-general positions stem-direction #'beaming-single-stemsup-rising-twonotes))
165 (defun beaming-double (positions stem-direction)
166 (beaming-general positions stem-direction #'beaming-double-stemsup-rising-twonotes))