/[gsharp]/gsharp/sdl.lisp
ViewVC logotype

Contents of /gsharp/sdl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.44 - (show annotations)
Mon Nov 17 10:45:22 2008 UTC (5 years, 5 months ago) by rstrandh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.43: +80 -1 lines
Time signature digit 8.
1 (in-package :sdl)
2
3 (defgeneric staff-line-distance (font))
4 (defgeneric staff-line-offsets (font))
5 (defgeneric stem-offsets (font))
6 (defgeneric ledger-line-x-offsets (font))
7 (defgeneric ledger-line-y-offsets (font))
8 (defgeneric notehead-right-offsets (font))
9 (defgeneric notehead-left-offsets (font))
10 (defgeneric bar-line-offsets (font))
11 (defgeneric suspended-note-offset (font)
12 (:documentation "the x offset of a suspended note compared to that
13 of a normal note. This function always returns a positive value"))
14 (defgeneric beam-offsets (font)
15 (:documentation "return two values, both to be added to the
16 vertical reference point in order to obtain the
17 bottom and top of the beam (in that order)"))
18 (defgeneric beam-hang-sit-offset (font)
19 (:documentation "return a positive value to be added to (hang) or
20 subtracted from (sit) the vertical reference point
21 of a staff line, in order to obtain the reference
22 point of a hanging or sitting beam respectively"))
23
24 (defclass font ()
25 (;; The distance in pixels between the upper edge of two
26 ;; adjacent staff lines.
27 (staff-line-distance :initarg :staff-line-distance :reader staff-line-distance)
28 ;; An integer value indicating how many non-white pixels are
29 ;; used to draw a staff line.
30 (staff-line-thickness)
31 ;; An integer value indicating how many non-white pixels are
32 ;; used to draw a stem
33 (stem-thickness)
34 ;; The width of filled and half-note noteheads is always 1.5 times the
35 ;; staff line distance. Since the staff line distance is an even
36 ;; number, this width is always an integer. This is important, because
37 ;; we need to position stems very precisely with respect to noteheads.
38 ;; and we want the left and right edges of noteheads to fall on integer
39 ;; pixel borders. Moreover, by having a fixed proportion, these
40 ;; noteheads will have the same proportional width no matter what the
41 ;; staff line distance is, which makes the characters look similar at
42 ;; different sizes. However, this means that we cannot make the
43 ;; heights of these characters integers. That is OK, though, since we
44 ;; count on anti-aliasing to give the impression of proportional
45 ;; sizes.
46 (notehead-width)
47 ;; While the rule above guarantees that the width of noteheads is an
48 ;; integer, it sometimes creates an even integer and sometimes an odd
49 ;; integer. When the width is even, the x-coordinate of the middle of
50 ;; the character is between two pixels, which is fine because that is
51 ;; how the MetaFont coordinate system works. When it is odd, however,
52 ;; the middle of the character is in the middle of a pixel. If we were
53 ;; to leave it like that, the left and right edges of the character
54 ;; would be in the middle of a pixel, which defeats the purpose. For
55 ;; that reason, when the width is odd, we put the reference point of
56 ;; the character one half pixel to the left of its middle.
57 ;;
58 ;; A similar rule holds for vertical reference points. For instance,
59 ;; the reference point of a staff line is the middle of the line if its
60 ;; thickness is even and one half pixel below that if it is odd.
61 ;;
62 ;; We do this consistently for stems, staff lines, etc. Thus, the
63 ;; client program can pretend that the reference point is always in the
64 ;; middle of the object. When the object has an odd size the effect is
65 ;; simply that everything appears to be off by half a pixel. We just
66 ;; have to watch out with attach points between stems and noteheads.
67 ;; In fact, in general, the noteheads may have a different distance
68 ;; from the reference point to the left attach point from the distance
69 ;; from the reference point to the right attach point.
70
71 ;; Characters are positioned vertically in multiples of half a staff
72 ;; line distance. An even multiple indicates that the symbol will be
73 ;; placed ON A STAFF LINE, and an odd multiple a symbol BETWEEN TWO
74 ;; STAFF LINES. The bottom staff line of a staff has a multiple of
75 ;; zero, and the multiple is positive towards the upper edge of the
76 ;; page and negative towards the lower edge of the page.
77 ;;
78 ;; When the staff line thickness is even, the reference point for
79 ;; placing characters is the middle of the staff line or half way
80 ;; between two adjacent middles of staff lines. When the staff line
81 ;; thickness is odd, the reference point is located half a pixel lower
82 ;; down.
83
84 ;; A certain number of characters are rotationally symmetric. But the
85 ;; center of the character is usually not the reference point. Since
86 ;; the reference point is (0, 0), we must draw these characters at an
87 ;; offset.
88 (xoffset)
89 ;; The vertical offset from the reference point to the middle of the
90 ;; staff line. This is zero for even staff line thicknesses and 0.5
91 ;; otherwise.
92 (yoffset)
93 (dot-diameter)
94 (staff-line-offset-down)
95 (staff-line-offset-up)
96 (ledger-line-offset-down)
97 (ledger-line-offset-up)
98 (ledger-line-offset-left)
99 (ledger-line-offset-right)
100 (stem-offset-left)
101 (stem-offset-right)
102 (bar-line-offset-left)
103 (bar-line-offset-right)
104 (notehead-right-x-offset)
105 (notehead-right-y-offset)
106 (notehead-left-x-offset)
107 (notehead-left-y-offset)
108 (beam-offset-down)
109 (beam-offset-up)
110 (beam-hang-sit-offset :reader beam-hang-sit-offset)
111 (designs :initform (make-hash-table :test #'eq))))
112
113
114 (defparameter *beam-designs* (make-hash-table :test #'equal))
115
116 (defmethod initialize-instance :after ((font font) &rest initargs &key &allow-other-keys)
117 (declare (ignore initargs))
118 (with-slots (staff-line-distance
119 staff-line-thickness
120 stem-thickness
121 notehead-width
122 xoffset
123 yoffset
124 dot-diameter
125 staff-line-offset-down
126 staff-line-offset-up
127 ledger-line-offset-down
128 ledger-line-offset-up
129 ledger-line-offset-left
130 ledger-line-offset-right
131 stem-offset-left
132 stem-offset-right
133 bar-line-offset-left
134 bar-line-offset-right
135 notehead-right-x-offset
136 notehead-right-y-offset
137 notehead-left-x-offset
138 notehead-left-y-offset
139 beam-offset-down
140 beam-offset-up
141 beam-hang-sit-offset) font
142 (setf staff-line-thickness (round (/ (staff-line-distance font) 10)))
143 (setf xoffset
144 (if (oddp (round (* 1.5 staff-line-distance))) 0.5 0))
145 (setf yoffset
146 (if (oddp staff-line-thickness) 0.5 0))
147 (setf dot-diameter
148 (min (- staff-line-distance staff-line-thickness 2)
149 (round (/ staff-line-distance 3))))
150 (setf staff-line-offset-down
151 (floor (/ staff-line-thickness 2))
152 staff-line-offset-up
153 (- staff-line-offset-down staff-line-thickness))
154 ;; we can't use 12 here, because Lisp rounds 0.5 to 0 which
155 ;; happens for the smallest staff-line-distance = 6
156 (setf stem-thickness (round (/ staff-line-distance 11.999)))
157 (setf stem-offset-left
158 (- (floor (/ stem-thickness 2)))
159 stem-offset-right
160 (+ stem-thickness stem-offset-left))
161 (let ((bar-line-thickness (round (/ (staff-line-distance font) 8))))
162 (setf bar-line-offset-left
163 (- (floor (/ bar-line-thickness 2)))
164 bar-line-offset-right
165 (+ bar-line-thickness bar-line-offset-left)))
166 (let ((ledger-line-thickness (round (/ (staff-line-distance font) 10))))
167 (setf ledger-line-offset-down
168 (- (floor (/ ledger-line-thickness 2)))
169 ledger-line-offset-up
170 (+ ledger-line-thickness ledger-line-offset-down)))
171 (let ((ledger-line-width (* 5/2 staff-line-distance)))
172 (setf ledger-line-offset-left
173 (- (floor (/ ledger-line-width 2)))
174 ledger-line-offset-right
175 (ceiling (/ ledger-line-width 2))))
176 (setf notehead-width (* 3/2 staff-line-distance))
177 (setf notehead-right-x-offset
178 (- (ceiling (/ notehead-width 2)) stem-offset-right))
179 (setf notehead-left-x-offset
180 (- (+ (floor (/ notehead-width 2)) stem-offset-left)))
181 (setf notehead-right-y-offset
182 (round (+ (* 0.25 staff-line-distance) yoffset)))
183 (setf notehead-left-y-offset
184 (- (round (- (* 0.25 staff-line-distance) yoffset))))
185 (setf beam-offset-down
186 (floor (/ staff-line-distance 2) 2))
187 (setf beam-offset-up
188 (- (+ beam-offset-down staff-line-thickness)))
189 (setf beam-hang-sit-offset
190 (let ((beam-thickness (- beam-offset-down beam-offset-up)))
191 (/ (- beam-thickness staff-line-thickness) 2)))))
192
193 ;;; the DOWN staff line offset is a nonnegative integer, and the UP
194 ;;; staff line offset is a negative integer. This way, both of them
195 ;;; should be ADDED to a reference y value to obtain the lower and
196 ;;; upper y coordinates of the staff line. If the staff line has a
197 ;;; thickness which is an even number of pixels, then the two values
198 ;;; returned have the same magnitude (but opposite signs). Otherwise
199 ;;; the first value (DOWN) has a magnitude which is one smaller than
200 ;;; that of the second value (UP). This implies that the y-value of the
201 ;;; reference point for a staff line is either in the middle of the
202 ;;; staff line (if the thickness is even) or half a pixel BELOW the
203 ;;; middle (if the thickness is odd).
204 (defmethod staff-line-offsets ((font font))
205 (with-slots (staff-line-offset-down staff-line-offset-up) font
206 (values staff-line-offset-down staff-line-offset-up)))
207
208 (defmethod stem-offsets ((font font))
209 (with-slots (stem-offset-left stem-offset-right) font
210 (values stem-offset-left stem-offset-right)))
211
212 (defmethod ledger-line-x-offsets ((font font))
213 (with-slots (ledger-line-offset-left ledger-line-offset-right) font
214 (values ledger-line-offset-left ledger-line-offset-right)))
215
216 (defmethod bar-line-offsets ((font font))
217 (with-slots (bar-line-offset-left bar-line-offset-right) font
218 (values bar-line-offset-left bar-line-offset-right)))
219
220 (defmethod ledger-line-y-offsets ((font font))
221 (with-slots (ledger-line-offset-down ledger-line-offset-up) font
222 (values ledger-line-offset-down ledger-line-offset-up)))
223
224 (defmethod notehead-right-offsets ((font font))
225 (with-slots (notehead-right-x-offset notehead-right-y-offset) font
226 (values notehead-right-x-offset notehead-right-y-offset)))
227
228 (defmethod notehead-left-offsets ((font font))
229 (with-slots (notehead-left-x-offset notehead-left-y-offset) font
230 (values notehead-left-x-offset notehead-left-y-offset)))
231
232 (defmethod suspended-note-offset ((font font))
233 (with-slots (notehead-left-x-offset notehead-right-x-offset) font
234 (- notehead-right-x-offset notehead-left-x-offset)))
235
236 (defmethod beam-offsets ((font font))
237 (with-slots (beam-offset-down beam-offset-up) font
238 (values beam-offset-down beam-offset-up)))
239
240 (defun make-font (staff-line-distance)
241 (make-instance 'font :staff-line-distance staff-line-distance))
242
243 (defgeneric xyscale (thing kx ky))
244
245 (defmethod xyscale ((point number) kx ky)
246 (complex (* (realpart point) kx)
247 (* (imagpart point) ky)))
248
249 (defmethod xyscale ((region clim:region) kx ky)
250 (let ((tr (clim:make-scaling-transformation kx ky)))
251 (clim:transform-region tr region)))
252
253 (defun scale (thing k)
254 (xyscale thing k k))
255
256 (defun xscale (thing k)
257 (xyscale thing k 1.0))
258
259 (defun yscale (thing k)
260 (xyscale thing 1.0 k))
261
262 (defgeneric translate (thing z))
263
264 (defmethod translate ((region clim:region) z)
265 (let ((tr (clim:make-translation-transformation (realpart z) (imagpart z))))
266 (clim:transform-region tr region)))
267
268 (defgeneric rotate (thing angle))
269
270 (defmethod rotate ((region clim:region) angle)
271 (let ((tr (clim:make-rotation-transformation angle)))
272 (clim:transform-region tr region)))
273
274 (defgeneric slant (thing slant))
275
276 (defmethod slant ((region clim:region) slant)
277 (let ((tr (climi::make-slanting-transformation slant)))
278 (clim:transform-region tr region)))
279
280 (defgeneric compute-design (font shape))
281
282 (defun ensure-design (font shape)
283 (or (gethash shape (slot-value font 'designs))
284 (setf (gethash shape (slot-value font 'designs))
285 (yscale (compute-design font shape) -1))))
286
287 (defgeneric draw-shape (sheet font shape x y))
288
289 (defmethod draw-shape (sheet (font font) shape x y)
290 (let ((design (ensure-design font shape))
291 (tr (clim:make-translation-transformation x y)))
292 (clim:draw-design sheet (clim:transform-region tr design))))
293
294 ;;; default method
295 (defmethod compute-design ((font font) shape)
296 (with-slots (staff-line-distance) font
297 (scale +unit-square+ staff-line-distance)))
298
299 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
300 ;;;
301 ;;; Beams
302
303 (defun ensure-beam-segment-design (direction position width)
304 (let* ((key (list direction position width)))
305 (or (gethash key *beam-designs*)
306 (setf (gethash key *beam-designs*)
307 (climi::close-path
308 (if (eq direction :down)
309 (if (eq position :upper)
310 (mf #c(0 0) -- (complex width 1) -- (complex 0 1) -- #c(0 0))
311 (mf #c(0 0) -- (complex width 0) -- (complex width 1) -- #c(0 0)))
312 (if (eq position :upper)
313 (mf #c(0 0) -- (complex width -1) -- (complex width 0) -- #c(0 0))
314 (mf #c(0 0) -- (complex width 0) -- (complex 0 1) -- #c(0 0)))))))))
315
316 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
317 ;;;
318 ;;; Clefs
319
320 ;;; w
321 ;;; |
322 ;;; **
323 ;;; ****
324 ;;; *****
325 ;;; ** | **
326 ;;; ** h **
327 ;;; ** **
328 ;;; ** g-**
329 ;;; v-**-i **
330 ;;; ** ***
331 ;;; * ***
332 ;;; * ***-x
333 ;;; * ****
334 ;;; * ****
335 ;;; * ****
336 ;;;*************************************************************************
337 ;;; * ******
338 ;;; * ******
339 ;;; * ******
340 ;;; ******
341 ;;; ******
342 ;;; ee\ ******/dd
343 ;;;*************************************************************************
344 ;;; ********
345 ;;; ******* *
346 ;;; ******* *
347 ;;; ******* *
348 ;;; ******* *
349 ;;; ****** ff\*/gg/c
350 ;;;*************************************************************************
351 ;;; ****** ************
352 ;;; ***** ****************
353 ;;; f ***** ******************
354 ;;; \***** ***** * | ***
355 ;;; **** b-**** * bb **
356 ;;; (0, 0)\ ****/y ***/cc * aa\**/d
357 ;;;*************************************************************************
358 ;;; **** ** * **
359 ;;; *** * * **
360 ;;; ** | * **
361 ;;; ** a z ) * **
362 ;;; *** | * **
363 ;;; ***************
364 ;;;*************************************************************************
365 ;;; |e *
366 ;;; o *
367 ;;; | *
368 ;;; *** *
369 ;;; ******* *
370 ;;; ********* *
371 ;;; n-*********-p *
372 ;;; ****** s-*-l
373 ;;; ****-q r *
374 ;;; **** / **
375 ;;; *******
376 ;;; |
377 ;;; m
378 ;;;
379 ;;;
380
381 (defmethod compute-design ((font font) (shape (eql :g-clef)))
382 (with-slots ((sld staff-line-distance) staff-line-thickness
383 stem-thickness yoffset) font
384 (let* ((xf 0.0) (yf (* 0.5 sld))
385 (xy (max 2.0 (round (* 0.4 sld)))) (yy (* 0.2 sld))
386 (xb (+ xy (max 2.0 (round (* 0.4 sld))))) (yb (* 0.3 sld))
387 (xcc (+ xb (max 2.0 (round (* 0.4 sld))))) (ycc 0)
388 (xa (+ xcc (max 1.0 (* 0.2 sld)))) (ya (* -0.4 sld))
389 (xc (+ xb (round (* 0.7 sld)))) (yc (+ sld (max 1.0 (* 0.15 sld))))
390 (xd (+ xc sld)) (yd 0.0)
391 (xe (* 1.5 sld)) (ye (+ (- sld) (- (* 0.5 staff-line-thickness))))
392 (xg (round (* 1.8 sld))) (yg (* 3.8 sld))
393 (xw (- xg (* 2.0 staff-line-thickness))) (yw (round (* 5.0 sld)))
394 (xh xw) (yh (- yw (max 2.0 (round (* 0.4 sld)))))
395 (xv (round (* 1.0 sld))) (yv (* 3.5 sld))
396 (xi (+ xv (max 2.0 (* 0.2 sld)))) (yi yv)
397 (xx (+ xg (max 2.0 (round (* 0.3 sld))))) (yx (* 3.5 sld))
398 (bigdot-diameter sld)
399 (yo (- (+ sld (round (* 0.5 sld)))))
400 (xn (round (* 0.5 sld))) (yn (- yo (* 0.5 bigdot-diameter)))
401 (xo (+ xn (* 0.5 bigdot-diameter)))
402 (xp (+ xn bigdot-diameter)) (yp yn)
403 (xq xo) (yq (- yo bigdot-diameter))
404 (xs (+ xp (max 1 (floor (* 0.4 sld))))) (ys yp)
405 (xl (+ xs stem-thickness)) (yl ys)
406 (xm (- xp (* 1 staff-line-thickness))) (ym (round (* -2.75 sld)))
407 (xr xm) (yr (+ ym staff-line-thickness))
408 (xz xe)
409 ;; yz should be slightly above the upper edge of the staff line
410 (yz (+ (- sld) (* 0.7 staff-line-thickness)))
411 (xaa (- xd (max 1 (round (* 0.3 sld))))) (yaa yd)
412 (xbb xc) (ybb (- sld staff-line-thickness (max 2 (* 0.3 sld))))
413 (xdd xp) (ydd (* 2 sld))
414 (xee xn) (yee ydd)
415 (xff (floor (* 1.4 sld))) (yff sld)
416 (xgg (+ xff stem-thickness)) (ygg yff))
417 (flet ((c (x y) (complex x y)))
418 (translate (mf (c xa ya) ++ (c xb yb) up ++ (c xc yc) right ++
419 (c xd yd) down ++ (c xe ye) left ++ (c xf yf) up ++
420 (c xee yee) ++
421 (c xg yg) up
422 (tensions 1 1.8)
423 (c xh yh)
424 (tensions 1.8 1)
425 (c xi yi)
426 (tensions 1.8 1)
427 (c xgg ygg) (direction #c(1 -4))
428 (tensions 1 20)
429 (c xl yl) down ++
430 (c xm ym) left ++
431 (c xn yn) up ++ (c xo yo) right ++ (c xp yp) down ++
432 (c xq yq) &
433 (c xq yq) ++ (c xr yr) right ++
434 (c xs ys) up
435 (tensions 20 1)
436 (c xff yff) (direction #c(-1 4))
437 (tensions 1 1.8)
438 (c xv yv) up
439 (tensions 1 1.8)
440 (c xw yw) right
441 (tensions 1.8 1)
442 (c xx yx) down ++
443 (c xdd ydd) ++
444 (c xy yy) down ++ (c xz yz) right ++
445 (c xaa yaa) up ++ (c xbb ybb) left ++
446 (c xcc ycc) down ++ (c (+ xa 1) ya) &
447 (c (+ xa 1) ya) ++ cycle)
448 (complex 0 yoffset)))))) ; replace ++ by -- one day
449
450 ;;;
451 ;;; xa xb
452 ;;; ||
453 ;;; || xc xf
454 ;;; || | |
455 ;;; (0, top) ********* ** ****************
456 ;;; ********* ** ********************
457 ;;; ********* ** **** | **********
458 ;;; ********* ** *** | ********
459 ;;; ********* ** *** (xg,yg) *******
460 ;;; ********* ** ***** ********
461 ;;; ********* ** ******* ********
462 ;;; ********* ** ******** ********
463 ;;; ********* ** ******** ********
464 ;;; ********* ** | ****** ********
465 ;;; ********* ** | **___yd ********
466 ;;; ********* ** xd ********
467 ;;; ********* ** (xj,yj)-- ********
468 ;;; ********* ** ********
469 ;;; ********* ** (xe,ye) ********
470 ;;; ********* ** | ********--(xk,yk)
471 ;;; ********* ** ** ********
472 ;;; ********* ** **** ********
473 ;;; ********* ** **** (xh,yh) ********
474 ;;; ********* ** ****** | *******
475 ;;; ********* ** ******* | ******
476 ;;; ********* ** ***** *************
477 ;;; ********* ** **** |_____
478 ;;; ********* ** ****** (xl,yl)
479 ;;; (0, 0) ********* ***********--xi
480 ;;; ********* ***********
481 ;;; ********* ** *******
482 ;;; ********* ** ****
483 ;;; ********* ** ***** *************
484 ;;; ********* ** ******* ******
485 ;;; ********* ** ****** *******
486 ;;; ********* ** **** ********
487 ;;; ********* ** **** ********
488 ;;; ********* ** ** ********
489 ;;; ********* ** ********
490 ;;; ********* ** ********
491 ;;; ********* ** ********
492 ;;; ********* ** ********
493 ;;; ********* ** ** ********
494 ;;; ********* ** ****** ********
495 ;;; ********* ** ******** ********
496 ;;; ********* ** ******** ********
497 ;;; ********* ** ******* ********
498 ;;; ********* ** ***** ********
499 ;;; ********* ** *** *******
500 ;;; ********* ** *** ********
501 ;;; ********* ** **** **********
502 ;;; ********* ** ********************
503 ;;; ********* ** ****************
504
505
506 ;;; The x coordinate of the reference point is always on the left edge
507 ;;; of the character. The y coordinate of the reference point is the
508 ;;; top edge of the staff line on which the character sits.
509
510 ;;; since the character is symmetric around the staff line, we only
511 ;;; have to define the upper curve, then we draw it both unmodified and
512 ;;; reflected + shifted the thickness of the staff line.
513
514 (defmethod compute-design ((font font) (shape (eql :c-clef)))
515 (with-slots ((sld staff-line-distance) staff-line-thickness yoffset) font
516 (flet ((c (x y) (complex x y)))
517 (let* ( ;; define some x coordinates
518 (xa (ceiling (* 0.5 sld)))
519 (xb (+ xa (max 2 (round (* 0.25 sld)))))
520 (xc (+ xb (max 1 (round (* 0.20 sld)))))
521 (xd (+ xc (max 2 (round (* 0.25 sld)))))
522 (dot-width (floor (* 0.5 sld)))
523 (xe (+ xd (round (* 0.5 dot-width))))
524 (xf (+ xd dot-width))
525 (xg (+ xd (* 1.5 dot-width)))
526 (xj (+ xd sld))
527 (xh (* 0.5 (+ xe xj)))
528 (xi xe)
529 (xk (+ xj (ceiling (* 0.5 sld))))
530 (xl (+ xe (round staff-line-thickness)))
531 ;; define some y coordinates
532 (ystart (* 0.5 staff-line-thickness))
533 (top (+ (* 2 sld) (* 0.5 staff-line-thickness)))
534 (yd (+ sld (max 1 (round (* 0.1 sld)))))
535 (ye sld)
536 (yg (- top (* 2 staff-line-thickness)))
537 (yh (round (* 0.4 sld)))
538 (yj ye)
539 (yk yj)
540 (yl yh)
541 (p (mf (c xc ystart) (direction #c(2 1)) ++
542 (direction #c(1 2)) (c xe ye) &
543 (c xe ye) -- (c (1+ xe) ye) &
544 (c (1+ xe) ye) (direction #c(1 -2)) ++
545 (c xh yh) right ++ (c xj yj) up ++
546 (c xg yg) left ++
547 (direction #c(-1 -2)) (c (+ xd (* 0.5 dot-width)) (+ yd dot-width)) &
548 (c (+ xd (* 0.5 dot-width)) (+ yd dot-width)) right ++
549 (c (+ xd dot-width) (+ yd (* 0.5 dot-width))) down ++
550 (c (+ xd (* 0.5 dot-width)) yd) left ++
551 (c xd (+ yd (* 0.5 dot-width))) up ++ (c xf top) right ++
552 (c xk yk) down ++ (c xh (- yh staff-line-thickness)) ++
553 (c xl yl) & (c xl yl) ++ down (c xi 0)))
554 (q (yscale p -1))
555 (r (climi::close-path
556 (reduce #'clim:region-union
557 (list p
558 (climi::reverse-path q)
559 (mf (c xc (- ystart)) -- (c xc ystart)))))))
560 (translate
561 (clim:region-union
562 (climi::close-path (mf (c 0 top) -- (c xa top) --
563 (c xa (- top)) --
564 (c 0 (- top)) -- (c 0 top)))
565 (clim:region-union
566 (climi::close-path (mf (c xb top) -- (c xc top) --
567 (c xc (- top)) --
568 (c xb (- top)) -- (c xb top)))
569 r))
570 (c 0 yoffset))))))
571
572 ;;;
573 ;;;
574 ;;; i
575 ;;; |
576 ;;;***********************************************************************
577 ;;; ********* |xj
578 ;;; ** | ** ***
579 ;;; ** e *** *****_yj
580 ;;; ** *** *****
581 ;;; *** |d *** ***
582 ;;; (0,0)\** *** ***
583 ;;;***********************************************************************
584 ;;; ********* ***
585 ;;; a-*********-c **** ***
586 ;;; ********* **** *****_yk
587 ;;; ******* f-****-h *****
588 ;;; *** **** ***
589 ;;; |b ****
590 ;;;***********************************************************************
591 ;;; ****
592 ;;; ****
593 ;;; ****
594 ;;; ****
595 ;;; ***
596 ;;; ***
597 ;;;***********************************************************************
598 ;;; ***
599 ;;; ***
600 ;;; ***
601 ;;; ***
602 ;;; g-***
603 ;;; |
604 ;;; g + (0, -1)
605 ;;;***********************************************************************
606 ;;;
607 ;;;
608 ;;;
609
610 (defmethod compute-design ((font font) (shape (eql :f-clef)))
611 (with-slots ((sld staff-line-distance) staff-line-thickness dot-diameter) font
612 (flet ((c (x y) (complex x y)))
613 (let* ((bigdot-diameter sld)
614 (yd (round (* 0.2 sld)))
615 (xa 0.0) (ya (- yd (* 0.5 bigdot-diameter)))
616 (xb (+ xa (* 0.5 bigdot-diameter))) (yb (- yd bigdot-diameter))
617 (xc (+ xa bigdot-diameter)) (yc ya)
618 (xd xb)
619 (xe (* 0.85 sld)) (ye (- sld (* 2.0 staff-line-thickness)))
620 (xf (round (* 1.5 sld))) (yf (- 0.3 sld))
621 (xg 0.0) (yg (* -2.5 sld))
622 (xh (+ xf (round (* 0.5 sld)))) (yh yf)
623 (xi sld) (yi sld)
624 (xj (+ xh (max 1.0 (round (* 0.2 sld))) (* 0.5 dot-diameter)))
625 (yj (round (* 0.5 (- sld staff-line-thickness))))
626 (yk (- (- staff-line-thickness) yj))
627 (p (mf (c xa ya) down ++
628 (c xb yb) right ++
629 (c xc yc) up ++
630 left (c xd yd) &
631 (c xd yd) ++
632 (c xe ye) right ++
633 (c xf yf) (direction #c(-0.2 -1)) ++ (curl 3)
634 (c xg yg) &
635 (c xg yg) --
636 (c xg (1- yg)) &
637 (c xg (1- yg)) (curl 3) ++
638 (c xh yh) (direction #c(0.2 1)) ++
639 (c xi yi) left ++ cycle)))
640 (clim:region-union
641 (translate p (c 0 staff-line-thickness))
642 (clim:region-union
643 (translate (scale +full-circle+ dot-diameter)
644 (c xj (+ yj staff-line-thickness)))
645 (translate (scale +full-circle+ dot-diameter)
646 (c xj (+ yk staff-line-thickness)))))))))
647
648 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
649 ;;;
650 ;;; Noteheads
651
652 (defparameter *filled-path*
653 (mf #c(-0.75 -0.25) up ++ #c(0.33 0.53) right ++
654 #c(0.75 0.25) down ++ #c(-0.33 -0.53) left ++ cycle))
655
656 (defparameter *half-path*
657 (mf #c(-0.75 -0.25) up (tension 0.8) #c(0.33 0.53) right ++
658 #c(0.75 0.25) down (tension 0.8) #c(-0.33 -0.53) left ++ cycle))
659
660 (defmethod compute-design ((font font) (shape (eql :filled-notehead)))
661 (with-slots (xoffset yoffset staff-line-distance) font
662 (translate (scale *filled-path* staff-line-distance)
663 (complex xoffset yoffset))))
664
665 (defmethod compute-design ((font font) (shape (eql :breve-notehead)))
666 (with-slots (xoffset yoffset (sld staff-line-distance) stem-thickness) font
667 (let ((top (translate (xyscale (translate +unit-square+ #c(0 0.5))
668 (* sld 1.5) (* sld (- 0.53 0.25)))
669 (* sld #c(0 0.25))))
670 (bot (translate (xyscale (translate +unit-square+ #c(0 -0.5))
671 (* sld 1.5) (* sld (- 0.53 0.25)))
672 (* sld #c(0 -0.25))))
673 (left (translate (xyscale +unit-square+ stem-thickness (* 1.3 sld))
674 (+ (* sld #c(-0.75 0)) (/ stem-thickness 2))))
675 (right (translate (xyscale +unit-square+ stem-thickness (* 1.3 sld))
676 (- (* sld #c(0.75 0)) (/ stem-thickness 2)))))
677 (translate
678 (reduce #'clim:region-union
679 (list top bot left right))
680 (complex xoffset yoffset)))))
681
682 (defmethod compute-design ((font font) (shape (eql :whole-notehead)))
683 (with-slots (xoffset yoffset (sld staff-line-distance)) font
684 (let ((op (scale (superellipse #c(0.75 0.0) #c(0.0 0.53)
685 #c(-0.75 0.0) #c(0.0 -0.53) 0.7)
686 sld))
687 (ip (scale (slant (superellipse #c(0.3 0.0) #c(0.0 0.32)
688 #c(-0.3 0.0) #c(0.0 -0.32) 0.8)
689 -0.3)
690 sld)))
691 (translate (clim:region-difference op (climi::reverse-path ip))
692 (complex xoffset yoffset)))))
693
694 (defmethod compute-design ((font font) (shape (eql :half-notehead)))
695 (with-slots (xoffset yoffset (sld staff-line-distance)) font
696 (clim:region-difference
697 (translate (scale *half-path* sld) (complex xoffset yoffset))
698 (translate
699 (scale
700 (rotate
701 (superellipse #c(0.6 0) #c(0 0.2) #c(-0.6 0) #c(0 -0.2) 0.707)
702 (/ pi 6))
703 sld)
704 (complex xoffset yoffset)))))
705
706 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
707 ;;;
708 ;;; Dot
709
710 ;;; The dot is complicated, because there are several contradicting
711 ;;; constraints that it must satisfy. For one thing, it is rotationally
712 ;;; symmetric. For that reason, we cannot use a different xoffset and
713 ;;; yoffset for the dot. Also, the dot is used for several different
714 ;;; purposes. When used in a dotted note, it is aligned in the middle
715 ;;; of the space between two staff lines, and must thus be aligned
716 ;;; vertically the same way as a notehead is. But it is also used as a
717 ;;; staccato dot, in which case it must be horizontally aligned the same
718 ;;; way as the noteheads are. This restriction is more important the
719 ;;; lower the resolution is.
720
721 ;;; Let us see how this works. For a staff line distance of 6 (the
722 ;;; smallest), vertical and horizontal alignments are the same: the
723 ;;; space between staff lines is 5 pixels and the note is 9 pixels wide;
724 ;;; both odd values. For a staff line distance of 8, it does not work.
725 ;;; The space is 7 pixels, so odd, but noteheads are 12 pixels wide so
726 ;;; even. We think it is more important that the dot be aligned
727 ;;; vertically, and that half a pixel of horizontal offset is not a
728 ;;; problem for the staccato dot. We thus use yoffset for the alignment
729 ;;; both vertically and horizontally.
730
731 ;;; Ross says the dot should be roughly a third of the staff line
732 ;;; distance, but in his examples, it is closer to half a staff line
733 ;;; distance. Compromise by using 0.4. We count on anti aliasing to
734 ;;; save us from too ugly a result when the edges do not fall on pixel
735 ;;; boundaries.
736
737 (defmethod compute-design ((font font) (shape (eql :dot)))
738 (with-slots (yoffset staff-line-distance) font
739 (let ((diameter (* 0.4 staff-line-distance)))
740 (translate (scale +full-circle+ diameter)
741 (complex (+ yoffset (/ diameter 2)) yoffset)))))
742
743 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
744 ;;;
745 ;;; Ties
746
747 (defun small-tie-up (sld slt width)
748 (let* ((thickness (round (* 0.33 sld)))
749 (height (* 0.5 sld))
750 (top (* 0.5 (+ sld slt height))))
751 (flet ((c (x y) (complex x y)))
752 (mf (c 0 top) right ++
753 (c width (- top height)) --
754 (c (- width 1.0) (- top height)) ++
755 (c (* 0.5 width) (- top thickness)) ++
756 (c 0.0 (- top thickness)) ++
757 (c (* -0.5 width) (- top thickness)) ++
758 (c (- (- width 1)) (- top height)) --
759 (c (- width) (- top height)) ++ cycle))))
760
761 (defmethod compute-design ((font font) (shape (eql :small-tie-1-up)))
762 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
763 (small-tie-up sld slt (round (* 0.33 sld)))))
764
765 (defmethod compute-design ((font font) (shape (eql :small-tie-2-up)))
766 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
767 (small-tie-up sld slt (round (* 0.67 sld)))))
768
769 (defmethod compute-design ((font font) (shape (eql :small-tie-3-up)))
770 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
771 (small-tie-up sld slt (round (* 1.0 sld)))))
772
773 (defmethod compute-design ((font font) (shape (eql :small-tie-4-up)))
774 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
775 (small-tie-up sld slt (round (* 1.33 sld)))))
776
777 (defmethod compute-design ((font font) (shape (eql :small-tie-5-up)))
778 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
779 (small-tie-up sld slt (round (* 1.67 sld)))))
780
781 (defmethod compute-design ((font font) (shape (eql :small-tie-6-up)))
782 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
783 (small-tie-up sld slt (round (* 2.0 sld)))))
784
785 (defmethod compute-design ((font font) (shape (eql :small-tie-7-up)))
786 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
787 (small-tie-up sld slt (round (* 2.33 sld)))))
788
789 (defmethod compute-design ((font font) (shape (eql :small-tie-8-up)))
790 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
791 (small-tie-up sld slt (round (* 2.67 sld)))))
792
793
794 (defun small-tie-down (sld slt width)
795 (let* ((thickness (round (* 0.33 sld)))
796 (height (* 0.5 sld))
797 (bot (* 0.5 (+ (- sld slt) height))))
798 (flet ((c (x y) (complex x y)))
799 (mf (c 0 (- bot)) right ++
800 (c width (- height bot)) --
801 (c (- width 1) (- height bot)) ++
802 (c (* 0.5 width) (- thickness bot)) ++
803 (c 0 (- thickness bot)) ++
804 (c (* -0.5 width) (- thickness bot)) ++
805 (c (- (- width 1.0)) (- height bot)) --
806 (c (- width) (- height bot)) ++ cycle))))
807
808 (defmethod compute-design ((font font) (shape (eql :small-tie-1-down)))
809 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
810 (small-tie-down sld slt (round (* 0.33 sld)))))
811
812 (defmethod compute-design ((font font) (shape (eql :small-tie-2-down)))
813 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
814 (small-tie-down sld slt (round (* 0.67 sld)))))
815
816 (defmethod compute-design ((font font) (shape (eql :small-tie-3-down)))
817 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
818 (small-tie-down sld slt (round (* 1.0 sld)))))
819
820 (defmethod compute-design ((font font) (shape (eql :small-tie-4-down)))
821 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
822 (small-tie-down sld slt (round (* 1.33 sld)))))
823
824 (defmethod compute-design ((font font) (shape (eql :small-tie-5-down)))
825 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
826 (small-tie-down sld slt (round (* 1.67 sld)))))
827
828 (defmethod compute-design ((font font) (shape (eql :small-tie-6-down)))
829 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
830 (small-tie-down sld slt (round (* 2.0 sld)))))
831
832 (defmethod compute-design ((font font) (shape (eql :small-tie-7-down)))
833 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
834 (small-tie-down sld slt (round (* 2.33 sld)))))
835
836 (defmethod compute-design ((font font) (shape (eql :small-tie-8-down)))
837 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
838 (small-tie-down sld slt (round (* 2.67 sld)))))
839
840 (defun large-tie-up (sld slt width-multiplier)
841 (declare (ignore slt))
842 (let* ((thickness (round (* 0.33 sld)))
843 (height (round (* 1.0 sld)))
844 (top (round (* 11/6 sld)))
845 (width (* width-multiplier sld)))
846 (flet ((c (x y) (complex x y)))
847 (mf (c 0.0 top) right ++
848 (c width (- top height)) --
849 (c (- width 1.0) (- top height)) ++
850 (c (* 0.3 width) (- top thickness)) ++
851 (c 0.0 (- top thickness)) ++
852 (c (* -0.3 width) (- top thickness)) ++
853 (c (- (- width 1.0)) (- top height)) --
854 (c (- width) (- top height)) ++ cycle))))
855
856 (defun large-tie-up-left (sld slt width-multiplier)
857 (declare (ignore slt))
858 (let* ((thickness (round (* 0.33 sld)))
859 (height (round (* 1.0 sld)))
860 (top (round (* 11/6 sld)))
861 (width (* width-multiplier sld)))
862 (flet ((c (x y) (complex x y)))
863 (climi::close-path
864 (mf (c 0.0 top) left ++
865 (c (- width) (- top height)) --
866 (c (- (- width 1.0)) (- top height)) ++
867 (c (* -0.3 width) (- top thickness)) ++
868 (c 0.0 (- top thickness)) &
869 (c 0.0 (- top thickness)) -- (c 0.0 top))))))
870
871 (defun large-tie-up-right (sld slt width-multiplier)
872 (declare (ignore slt))
873 (let* ((thickness (round (* 0.33 sld)))
874 (height (round (* 1.0 sld)))
875 (top (round (* 11/6 sld)))
876 (width (* width-multiplier sld)))
877 (flet ((c (x y) (complex x y)))
878 (climi::close-path
879 (mf (c 0.0 top) right ++
880 (c width (- top height)) --
881 (c (- width 1.0) (- top height)) ++
882 (c (* 0.3 width) (- top thickness)) ++
883 (c 0.0 (- top thickness)) &
884 (c 0.0 (- top thickness)) -- (c 0.0 top))))))
885
886 (defmethod compute-design ((font font) (shape (eql :large-tie-1-up)))
887 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
888 (large-tie-up sld slt 2.0)))
889
890 (defmethod compute-design ((font font) (shape (eql :large-tie-2-up)))
891 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
892 (large-tie-up sld slt 2.33)))
893
894 (defmethod compute-design ((font font) (shape (eql :large-tie-3-up)))
895 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
896 (large-tie-up sld slt 2.67)))
897
898 (defmethod compute-design ((font font) (shape (eql :large-tie-4-up)))
899 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
900 (large-tie-up sld slt 3.0)))
901
902 (defmethod compute-design ((font font) (shape (eql :large-tie-5-up)))
903 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
904 (large-tie-up sld slt 3.33)))
905
906 (defmethod compute-design ((font font) (shape (eql :large-tie-6-up)))
907 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
908 (large-tie-up sld slt 3.67)))
909
910 (defmethod compute-design ((font font) (shape (eql :large-tie-7-up)))
911 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
912 (large-tie-up sld slt 4.0)))
913
914 (defmethod compute-design ((font font) (shape (eql :large-tie-8-up)))
915 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
916 (large-tie-up sld slt 4.33)))
917
918 (defmethod compute-design ((font font) (shape (eql :large-tie-9-up)))
919 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
920 (large-tie-up sld slt 4.67)))
921
922 (defmethod compute-design ((font font) (shape (eql :large-tie-10-up)))
923 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
924 (large-tie-up sld slt 5.0)))
925
926 (defmethod compute-design ((font font) (shape (eql :large-tie-up-left)))
927 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
928 (large-tie-up-left sld slt 5.0)))
929
930 (defmethod compute-design ((font font) (shape (eql :large-tie-up-right)))
931 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
932 (large-tie-up-right sld slt 5.0)))
933
934 (defun large-tie-down (sld slt width-multiplier)
935 (let* ((thickness (round (* 0.33 sld)))
936 (height (round (* 1.0 sld)))
937 (bot (- (round(* 11/6 sld)) slt))
938 (width (* width-multiplier sld)))
939 (flet ((c (x y) (complex x y)))
940 (mf (c 0.0 (- bot)) right ++
941 (c width (- height bot)) --
942 (c (- width 1.0) (- height bot)) ++
943 (c (* 0.3 width) (- thickness bot)) ++
944 (c 0.0 (- thickness bot)) ++
945 (c (* -0.3 width) (- thickness bot)) ++
946 (c (- (- width 1.0)) (- height bot)) --
947 (c (- width) (- height bot)) ++ cycle))))
948
949 (defun large-tie-down-left (sld slt width-multiplier)
950 (let* ((thickness (round (* 0.33 sld)))
951 (height (round (* 1.0 sld)))
952 (bot (- (round(* 11/6 sld)) slt))
953 (width (* width-multiplier sld)))
954 (flet ((c (x y) (complex x y)))
955 (climi::close-path
956 (mf (c 0.0 (- bot)) left ++
957 (c (- width) (- height bot)) --
958 (c (- (- width 1.0)) (- height bot)) ++
959 (c (* -0.3 width) (- thickness bot)) ++
960 (c 0.0 (- thickness bot)) &
961 (c 0.0 (- thickness bot)) -- (c 0.0 (- bot)))))))
962
963 (defun large-tie-down-right (sld slt width-multiplier)
964 (let* ((thickness (round (* 0.33 sld)))
965 (height (round (* 1.0 sld)))
966 (bot (- (round(* 11/6 sld)) slt))
967 (width (* width-multiplier sld)))
968 (flet ((c (x y) (complex x y)))
969 (climi::close-path
970 (mf (c 0.0 (- bot)) right ++
971 (c width (- height bot)) --
972 (c (- width 1.0) (- height bot)) ++
973 (c (* 0.3 width) (- thickness bot)) ++
974 (c 0.0 (- thickness bot)) &
975 (c 0.0 (- thickness bot)) -- (c 0.0 (- bot)))))))
976
977 (defmethod compute-design ((font font) (shape (eql :large-tie-1-down)))
978 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
979 (large-tie-down sld slt 2.0)))
980
981 (defmethod compute-design ((font font) (shape (eql :large-tie-2-down)))
982 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
983 (large-tie-down sld slt 2.33)))
984
985 (defmethod compute-design ((font font) (shape (eql :large-tie-3-down)))
986 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
987 (large-tie-down sld slt 2.67)))
988
989 (defmethod compute-design ((font font) (shape (eql :large-tie-4-down)))
990 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
991 (large-tie-down sld slt 3.0)))
992
993 (defmethod compute-design ((font font) (shape (eql :large-tie-5-down)))
994 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
995 (large-tie-down sld slt 3.33)))
996
997 (defmethod compute-design ((font font) (shape (eql :large-tie-6-down)))
998 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
999 (large-tie-down sld slt 3.67)))
1000
1001 (defmethod compute-design ((font font) (shape (eql :large-tie-7-down)))
1002 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
1003 (large-tie-down sld slt 4.0)))
1004
1005 (defmethod compute-design ((font font) (shape (eql :large-tie-8-down)))
1006 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
1007 (large-tie-down sld slt 4.33)))
1008
1009 (defmethod compute-design ((font font) (shape (eql :large-tie-9-down)))
1010 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
1011 (large-tie-down sld slt 4.67)))
1012
1013 (defmethod compute-design ((font font) (shape (eql :large-tie-10-down)))
1014 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
1015 (large-tie-down sld slt 5.0)))
1016
1017 (defmethod compute-design ((font font) (shape (eql :large-tie-down-left)))
1018 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
1019 (large-tie-down-left sld slt 5.0)))
1020
1021 (defmethod compute-design ((font font) (shape (eql :large-tie-down-right)))
1022 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
1023 (large-tie-down-right sld slt 5.0)))
1024
1025 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1026 ;;;
1027 ;;; Accidentals
1028
1029 (defmethod compute-design ((font font) (shape (eql :semisharp)))
1030 (with-slots ((sld staff-line-distance)
1031 (slt staff-line-thickness)
1032 stem-thickness
1033 yoffset) font
1034 (let* (;; A factor that determines the space between the vertical
1035 ;; bars and the outer edge of the character as a fraction of
1036 ;; the staff line distance
1037 (edge-distance-multiplier 0.2)
1038 ;; A factor that determines the height of the thin part as a
1039 ;; fraction of the staff line distance
1040 (height-multiplier 2.5)
1041 ;; A factor that determines the width of the hole as a fraction of the
1042 ;; staff line distance.
1043 (hole-width-multiplier 0.33)
1044 (hole-width (round (* hole-width-multiplier sld)))
1045 ;; Hope that half a pixel will not be visible and will not influence
1046 ;; the required distance to the noteheads.
1047 ;;
1048 ;; FIXME: this is the only real difference between the
1049 ;; :semisharp and :sesquisharp glyph calculations, and the
1050 ;; :sharp glyph. Find a way to unify the glyph
1051 ;; computations in a proper metafonty way.
1052 (xoffset (if (oddp hole-width) 0.5 0.5))
1053 (edge-distance (* edge-distance-multiplier sld))
1054 (width (+ hole-width (* 2 stem-thickness) (* 2 edge-distance)))
1055 ;; FIXME: this leads to a blurry glyph at most sizes:
1056 ;; choose a coordinate which lies on a pixel boundary in
1057 ;; preference.
1058 (xleft (* -0.25 width))
1059 (xright (- xleft))
1060 (yleft (* -0.15 width))
1061 (yright (- yleft))
1062 ;; The path for the thick part symmetric around (0, 0)
1063 (thickpart (mf (complex xleft yleft) -- (complex xright yright)))
1064 ;; Determine the y coordinate of the previous path at the
1065 ;; cross point of the thin part. Use congruent triangles.
1066 (height (* height-multiplier sld))
1067 ;; The path for the thin part symmetric around (0, 0)
1068 (thinpart (mf (complex 0 (* 0.5 height)) -- (complex 0 (* -0.5 height)))))
1069 (clim:region-union
1070 (with-pen (rotate (scale +razor+ (* 0.4 sld)) (/ pi 2))
1071 (clim:region-union (draw-path (translate thickpart
1072 (complex xoffset (+ yoffset (* 0.5 sld)))))
1073 (draw-path (translate thickpart
1074 (complex xoffset (+ yoffset (* -0.5 sld)))))))
1075 (with-pen (scale +razor+ stem-thickness)
1076 (draw-path (translate thinpart (complex xoffset yoffset))))))))
1077
1078 (defmethod compute-design ((font font) (shape (eql :sharp)))
1079 (with-slots ((sld staff-line-distance)
1080 (slt staff-line-thickness)
1081 stem-thickness
1082 yoffset) font
1083 (let* (;; A factor that determines the space between the vertical
1084 ;; bars and the outer edge of the character as a fraction of
1085 ;; the staff line distance
1086 (edge-distance-multiplier 0.2)
1087 ;; A factor that determines the height of the thin part as a
1088 ;; fraction of the staff line distance
1089 (height-multiplier 2.5)
1090 ;; A factor that determines the width of the hole as a fraction of the
1091 ;; staff line distance.
1092 (hole-width-multiplier 0.33)
1093 (hole-width (round (* hole-width-multiplier sld)))
1094 ;; Hope that half a pixel will not be visible and will not influence
1095 ;; the required distance to the noteheads.
1096 (xoffset (if (oddp hole-width) 0.5 0))
1097 (edge-distance (* edge-distance-multiplier sld))
1098 (width (+ hole-width (* 2 stem-thickness) (* 2 edge-distance)))
1099 (xleft (* -0.5 width))
1100 (xright (- xleft))
1101 (yleft (* -0.15 width))
1102 (yright (- yleft))
1103 ;; The path for the thick part symmetric around (0, 0)
1104 (thickpart (mf (complex xleft yleft) -- (complex xright yright)))
1105 ;; Determine the y coordinate of the previous path at the
1106 ;; cross point of the thin part. Use congruent triangles.
1107 (ythin (/ (* (- xright edge-distance) yright) xright))
1108 (height (* height-multiplier sld))
1109 ;; The path for the thin part symmetric around (0, 0)
1110 (thinpart (mf (complex 0 (* 0.5 height)) -- (complex 0 (* -0.5 height)))))
1111 (clim:region-union
1112 (with-pen (rotate (scale +razor+ (* 0.4 sld)) (/ pi 2))
1113 (clim:region-union (draw-path (translate thickpart
1114 (complex xoffset (+ yoffset (* 0.5 sld)))))
1115 (draw-path (translate thickpart
1116 (complex xoffset (+ yoffset (* -0.5 sld)))))))
1117 (with-pen (scale +razor+ stem-thickness)
1118 (clim:region-union (draw-path (translate thinpart
1119 (complex (- xoffset
1120 (* 0.5 hole-width)
1121 (* 0.5 stem-thickness))
1122 (- yoffset ythin))))
1123 (draw-path (translate thinpart
1124 (complex (+ xoffset
1125 (* 0.5 hole-width)
1126 (* 0.5 stem-thickness))
1127 (+ yoffset ythin))))))))))
1128
1129 (defmethod compute-design ((font font) (shape (eql :sesquisharp)))
1130 (with-slots ((sld staff-line-distance)
1131 (slt staff-line-thickness)
1132 stem-thickness
1133 yoffset) font
1134 (let* (;; A factor that determines the space between the vertical
1135 ;; bars and the outer edge of the character as a fraction of
1136 ;; the staff line distance
1137 (edge-distance-multiplier 0.2)
1138 ;; A factor that determines the height of the thin part as a
1139 ;; fraction of the staff line distance
1140 (height-multiplier 2.5)
1141 ;; A factor that determines the width of the hole as a fraction of the
1142 ;; staff line distance.
1143 (hole-width-multiplier 0.33)
1144 (hole-width (round (* hole-width-multiplier sld)))
1145 ;; Hope that half a pixel will not be visible and will not
1146 ;; influence the required distance to the noteheads.
1147 ;;
1148 ;; FIXME: see note in :semisharp glyph at this point
1149 (xoffset (if (oddp hole-width) 0.5 0.5))
1150 (edge-distance (* edge-distance-multiplier sld))
1151 (width (+ hole-width (* 2 stem-thickness) (* 2 edge-distance)))
1152 (xleft (* -0.75 width))
1153 (xright (- xleft))
1154 (yleft (* -0.15 width))
1155 (yright (- yleft))
1156 ;; The path for the thick part symmetric around (0, 0)
1157 (thickpart (mf (complex xleft yleft) -- (complex xright yright)))
1158 ;; Determine the y coordinate of the previous path at the
1159 ;; cross point of the thin part. Use congruent triangles.
1160 (ythin (/ (* (- xright edge-distance) yright) xright))
1161 (height (* height-multiplier sld))
1162 ;; The path for the thin part symmetric around (0, 0)
1163 (thinpart (mf (complex 0 (* 0.5 height)) -- (complex 0 (* -0.5 height)))))
1164 (clim:region-union
1165 (with-pen (rotate (scale +razor+ (* 0.4 sld)) (/ pi 2))
1166 (clim:region-union (draw-path (translate thickpart
1167 (complex xoffset (+ yoffset (* 0.5 sld)))))
1168 (draw-path (translate thickpart
1169 (complex xoffset (+ yoffset (* -0.5 sld)))))))
1170 (with-pen (scale +razor+ stem-thickness)
1171 (clim:region-union
1172 (clim:region-union
1173 (draw-path (translate thinpart
1174 (complex (- xoffset hole-width (* 1 stem-thickness))
1175 (- yoffset ythin))))
1176 (draw-path (translate thinpart (complex (- xoffset (* 0 stem-thickness)) yoffset))))
1177 (draw-path (translate thinpart
1178 (complex (+ xoffset hole-width (* 1 stem-thickness))
1179 (+ yoffset ythin))))))))))
1180
1181 (defmethod compute-design ((font font) (shape (eql :double-sharp)))
1182 (with-slots ((sld staff-line-distance) xoffset yoffset) font
1183 (flet ((c (x y) (complex x y)))
1184 (let* ((offset (ceiling (* 0.1 sld)))
1185 (leg (climi::close-path (mf (c 0 0) -- (c offset 0) (direction #c(1 1)) ++
1186 right (c (* 0.5 sld) offset) --
1187 (* 0.55 sld (c 1 1)) --
1188 (c offset (* 0.5 sld)) down ++
1189 (direction #c(-1 -1)) (c 0 offset) -- (c 0 0)))))
1190 (reduce #'clim:region-union
1191 (list (translate leg (c xoffset yoffset))
1192 (translate (rotate leg (* pi 0.5)) (c xoffset yoffset))
1193 (translate (rotate leg (* pi 1.0)) (c xoffset yoffset))
1194 (translate (rotate leg (* pi 1.5)) (c xoffset yoffset))))))))
1195
1196 (defmethod compute-design ((font font) (shape (eql :semiflat)))
1197 (with-slots ((sld staff-line-distance) stem-thickness) font
1198 (flet ((c (x y) (complex x y)))
1199 (let* ((outer (xyscale (translate (rotate +half-circle+ pi) #c(-0.5 0))
1200 (* 1 sld) (* 1 sld)))
1201 ;; FIXME: 1.2 here (and in the :sesquiflat glyph, below)
1202 ;; represents the difference in width between the
1203 ;; :semiflat bulge and the regular :flat bulge. Find a
1204 ;; way to share code between the glyphs.
1205 (inner (xyscale (translate (rotate +half-circle+ pi) #c(-0.6 0))
1206 (* 0.75 sld) (* (/ 0.75 1.2) sld)))
1207 (middle (mf (climi::path-end outer) -- (climi::path-end inner)))
1208 (finish (mf (climi::path-start inner) -- (climi::path-start outer)))
1209 (combined (climi::close-path
1210 (reduce #'clim:region-union
1211 (list outer middle (climi::reverse-path inner) finish)))))
1212 (clim:region-union (translate (rotate (slant combined 0.6) (- (/ pi 2)))
1213 (c (round (- (* -0.2 sld) stem-thickness)) (* -0.5 sld)))
1214 (with-pen (scale +razor+ stem-thickness)
1215 (draw-path (mf (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
1216 (* 1.5 sld))
1217 --
1218 (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
1219 (* -0.5 sld))))))))))
1220
1221 (defmethod compute-design ((font font) (shape (eql :flat)))
1222 (with-slots ((sld staff-line-distance) stem-thickness) font
1223 (flet ((c (x y) (complex x y)))
1224 (let* ((outer (xyscale (translate +half-circle+ #c(-0.5 0))
1225 sld (* 1.2 sld)))
1226 (inner (scale (translate +half-circle+ #c(-0.6 0))
1227 (* 0.75 sld)))
1228 (middle (mf (climi::path-end outer) -- (climi::path-end inner)))
1229 (finish (mf (climi::path-start inner) -- (climi::path-start outer)))
1230 (combined (climi::close-path
1231 (reduce #'clim:region-union
1232 (list outer middle (climi::reverse-path inner) finish)))))
1233 (clim:region-union (translate (rotate (slant combined -0.6) (- (/ pi 2)))
1234 (c (round (* -0.2 sld)) (* -0.5 sld)))
1235 (with-pen (scale +razor+ stem-thickness)
1236 (draw-path (mf (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
1237 (* 1.5 sld))
1238 --
1239 (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
1240 (* -0.5 sld))))))))))
1241
1242 (defmethod compute-design ((font font) (shape (eql :sesquiflat)))
1243 (with-slots ((sld staff-line-distance) stem-thickness) font
1244 (flet ((c (x y) (complex x y)))
1245 (let* ((outer (xyscale (translate (rotate +half-circle+ pi) #c(-0.5 0))
1246 (* 1 sld) (* 1 sld)))
1247 (inner (xyscale (translate (rotate +half-circle+ pi) #c(-0.6 0))
1248 (* 0.75 sld) (* (/ 0.75 1.2) sld)))
1249 (middle (mf (climi::path-end outer) -- (climi::path-end inner)))
1250 (finish (mf (climi::path-start inner) -- (climi::path-start outer)))
1251 (combined (climi::close-path
1252 (reduce #'clim:region-union
1253 (list outer middle (climi::reverse-path inner) finish))))
1254 (outer1 (xyscale (translate +half-circle+ #c(-0.5 0))
1255 sld (* 1.2 sld)))
1256 (inner1 (scale (translate +half-circle+ #c(-0.6 0))
1257 (* 0.75 sld)))
1258 (middle1 (mf (climi::path-end outer1) -- (climi::path-end inner1)))
1259 (finish1 (mf (climi::path-start inner1) -- (climi::path-start outer1)))
1260 (combined1 (climi::close-path
1261 (reduce #'clim:region-union
1262 (list outer1 middle1 (climi::reverse-path inner1) finish1)))))
1263 (clim:region-union (clim:region-union (translate (rotate (slant combined (* 0.6 1.2)) (- (/ pi 2)))
1264 (c (round (- (* -0.2 sld) stem-thickness)) (* -0.5 sld)))
1265 (translate (rotate (slant combined1 -0.6) (- (/ pi 2)))
1266 (c (round (* -0.2 sld)) (* -0.5 sld))))
1267 (with-pen (scale +razor+ stem-thickness)
1268 (draw-path (mf (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
1269 (* 1.5 sld))
1270 --
1271 (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
1272 (* -0.5 sld))))))))))
1273
1274 (defmethod compute-design ((font font) (shape (eql :double-flat)))
1275 (with-slots ((sld staff-line-distance) stem-thickness) font
1276 (flet ((c (x y) (complex x y)))
1277 (let* ((outer (xyscale (translate +half-circle+ #c(-0.5 0))
1278 sld (* 1.2 sld)))
1279 (inner (scale (translate +half-circle+ #c(-0.6 0))
1280 (* 0.8 sld)))
1281 (middle (mf (climi::path-end outer) -- (climi::path-end inner)))
1282 (finish (mf (climi::path-start inner) -- (climi::path-start outer)))
1283 (combined (climi::close-path
1284 (reduce #'clim:region-union
1285 (list outer middle (climi::reverse-path inner) finish)))))
1286 (clim:region-union
1287 (clim:region-union (translate (rotate (slant combined -0.6) (- (/ pi 2)))
1288 (c (round (* -0.2 sld)) (* -0.5 sld)))
1289 (translate (rotate (slant combined -0.6) (- (/ pi 2)))
1290 (c (round (* -0.85 sld)) (* -0.5 sld))))
1291 (clim:region-union (with-pen (scale +razor+ stem-thickness)
1292 (draw-path (mf (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
1293 (* 1.5 sld))
1294 --
1295 (c (- (round (* -0.2 sld)) (* 0.5 stem-thickness))
1296 (* -0.5 sld)))))
1297 (with-pen (scale +razor+ stem-thickness)
1298 (draw-path (mf (c (- (round (* -0.85 sld)) (* 0.5 stem-thickness))
1299 (* 1.5 sld))
1300 --
1301 (c (- (round (* -0.85 sld)) (* 0.5 stem-thickness))
1302 (* -0.5 sld)))))))))))
1303 ;;; The width of a natural sign is slightly less than 2/3s of the
1304 ;;; staff line distance of that font.
1305 (defmethod compute-design ((font font) (shape (eql :natural)))
1306 (with-slots ((sld staff-line-distance)
1307 (slt staff-line-thickness)
1308 stem-thickness
1309 yoffset) font
1310 (flet ((c (x y) (complex x y)))
1311 (let* (;; A factor that determines the width of the hole as a fraction of the
1312 ;; staff line distance.
1313 (hole-width-multiplier 0.33)
1314 (hole-width (round (* hole-width-multiplier sld)))
1315 ;; Hope that half a pixel will not be visible and will not influence
1316 ;; the required distance to the noteheads.
1317 (xoffset (if (oddp hole-width) 0.5 0))
1318 (width (+ hole-width (* 2 stem-thickness)))
1319 (xleft (* -0.5 width))
1320 (xright (- xleft))
1321 ;; The left part of the character is right in the middle of the
1322 ;; staff line and the lower edge of the right part touches the upper
1323 ;; edge of the staff line
1324 (yleft (* -0.5 slt))
1325 (yright (- yleft))
1326 ;; The path for the thick part
1327 (thickpart (mf (c xleft yleft) -- (c xright yright))))
1328 (clim:region-union
1329 (clim:region-union
1330 (with-pen (rotate (scale +razor+ (* 0.4 sld)) (/ pi 2))
1331 (draw-path (translate thickpart
1332 (c xoffset (+ yoffset (* 0.5 sld))))))
1333 (with-pen (rotate (scale +razor+ (* 0.4 sld)) (/ pi 2))
1334 (draw-path (translate thickpart
1335 (c xoffset (- yoffset (* 0.5 sld)))))))
1336 (clim:region-union
1337 (with-pen (scale +razor+ stem-thickness)
1338 (draw-path (translate (mf (c (+ xleft (* 0.5 stem-thickness))
1339 (* 1.5 sld))
1340 --
1341 (c (+ xleft (* 0.5 stem-thickness))
1342 (* -0.5 sld)))
1343 (c xoffset yoffset))))
1344 (with-pen (scale +razor+ stem-thickness)
1345 (draw-path (translate (mf (c (- xright (* 0.5 stem-thickness))
1346 (* -1.5 sld))
1347 --
1348 (c (- xright (* 0.5 stem-thickness))
1349 (* 0.5 sld)))
1350 (c xoffset yoffset))))))))))
1351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1352 ;;;
1353 ;;; Rests
1354
1355 (defmethod compute-design ((font font) (shape (eql :long-rest)))
1356 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)
1357 notehead-width xoffset yoffset) font
1358 (translate (xyscale +unit-square+ (/ notehead-width 2) (* 2 sld))
1359 (complex xoffset (+ yoffset (- (* 0.5 slt)))))))
1360
1361 (defmethod compute-design ((font font) (shape (eql :breve-rest)))
1362 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)
1363 notehead-width xoffset yoffset) font
1364 (translate (xyscale +unit-square+ (/ notehead-width 2) sld)
1365 (complex xoffset (+ yoffset (+ (* 0.5 sld)) (- (* 0.5 slt)))))))
1366
1367 (defmethod compute-design ((font font) (shape (eql :whole-rest)))
1368 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)
1369 notehead-width xoffset yoffset) font
1370 (flet ((c (x y) (complex x y)))
1371 (translate (xyscale +unit-square+
1372 notehead-width (* 0.5 sld))
1373 (c xoffset (+ yoffset sld (- (* 0.25 sld)) (- (* 0.5 slt))))))))
1374
1375 (defmethod compute-design ((font font) (shape (eql :half-rest)))
1376 (with-slots ((sld staff-line-distance) (slt staff-line-thickness)
1377 notehead-width xoffset yoffset) font
1378 (flet ((c (x y) (complex x y)))
1379 (translate (xyscale +unit-square+
1380 notehead-width (* 0.5 sld))
1381 (c xoffset (+ yoffset (* 0.25 sld) (* 0.5 slt)))))))
1382
1383 (defmethod compute-design ((font font) (shape (eql :quarter-rest)))
1384 (with-slots ((sld staff-line-distance) stem-thickness) font
1385 (let ((pen (rotate (xyscale +full-circle+ (* 0.4 sld) stem-thickness) (* -50 (/ pi 180)))))
1386 (multiple-value-bind (pen-left pen-bot pen-right pen-top)
1387 (clim:bounding-rectangle* pen)
1388 (let ((upper (+ (* #c(0 1.5) sld)
1389 (complex (- pen-left) (- pen-top))))
1390 (second (+ (* #c(0.5 0.9) sld)
1391 (complex (- pen-right) (- pen-bot))))
1392 (third (* #c(0.0 0.0) sld))
1393 (fourth (+ (* #c(0.5 -1) sld)
1394 (complex (- pen-right) (- pen-bot))))
1395 (fifth (* #c(-0.1 -0.8) sld))
1396 (sixth (+ (* #c(-0.1 -1.3) sld)
1397 (complex (- pen-right) (- pen-bot)))))
1398 (with-pen pen
1399 (draw-path (mf upper -- second -- third -- fourth ++ fifth ++ sixth))))))))
1400
1401 (defun rest-part (font pos)
1402 (with-slots ((sld staff-line-distance) stem-thickness yoffset) font
1403 (flet ((c (x y) (complex x y)))
1404 (let* ((hoffset (round (* 0.4 sld)))
1405 (dot-diameter (round (* 0.5 sld)))
1406 (dot (scale +full-circle+ dot-diameter))
1407 (hook (mf (c (+ (- sld) (* 0.5 dot-diameter))
1408 (+ (* -0.5 dot-diameter) (* 0.5 stem-thickness)))
1409 right ++ (direction #c(1 1)) #c(0.0 0.0)))
1410 (leg (mf #c(0.0 0.0) -- (c (* -1.5 hoffset) (* -1.5 sld)))))
1411 (clim:region-union
1412 (translate dot (+ pos (- sld) (* 0.5 dot-diameter) (c 0 yoffset)))
1413 (with-pen (scale +full-circle+ stem-thickness)
1414 (clim:region-union (draw-path (translate hook (+ pos (c 0 yoffset))))
1415 (draw-path (translate leg (+ pos (c 0 yoffset)))))))))))
1416
1417 (defmethod compute-design ((font font) (shape (eql :8th-rest)))
1418 (with-slots ((sld staff-line-distance)) font
1419 (rest-part font (complex (* 0.5 sld) (* 0.5 sld)))))
1420
1421 (defmethod compute-design ((font font) (shape (eql :16th-rest)))
1422 (with-slots ((sld staff-line-distance)) font
1423 (let ((hoffset (round (* 0.4 sld))))
1424 (reduce #'clim:region-union
1425 (list (rest-part font (complex (* 0.5 sld) (* 0.5 sld)))
1426 (rest-part font (- (complex (* 0.5 sld) (* 0.5 sld))
1427 (complex hoffset sld))))))))
1428
1429 (defmethod compute-design ((font font) (shape (eql :32nd-rest)))
1430 (with-slots ((sld staff-line-distance)) font
1431 (let ((hoffset (round (* 0.4 sld))))
1432 (reduce #'clim:region-union
1433 (list (rest-part font (complex (* 0.5 sld) (* 0.5 sld)))
1434 (rest-part font (- (complex (* 0.5 sld) (* 0.5 sld))
1435 (complex hoffset sld)))
1436 (rest-part font (+ (complex (* 0.5 sld) (* 0.5 sld))
1437 (complex hoffset sld))))))))
1438
1439 (defmethod compute-design ((font font) (shape (eql :64th-rest)))
1440 (with-slots ((sld staff-line-distance)) font
1441 (let ((hoffset (round (* 0.4 sld))))
1442 (reduce #'clim:region-union
1443 (list (rest-part font (complex (* 0.5 sld) (* 0.5 sld)))
1444 (rest-part font (- (complex (* 0.5 sld) (* 0.5 sld))
1445 (complex hoffset sld)))
1446 (rest-part font (+ (complex (* 0.5 sld) (* 0.5 sld))
1447 (complex hoffset sld)))
1448 (rest-part font (- (complex (* 0.5 sld) (* 0.5 sld))
1449 (* 2 (complex hoffset sld)))))))))
1450
1451 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1452 ;;;
1453 ;;; Flags
1454
1455 (defun first-flag (sld st extreme-point)
1456 (flet ((c (x y) (complex x y)))
1457 (climi::close-path (mf (c 0 0) ++
1458 (c (* 0.2 sld) (* -0.8 sld)) ++
1459 (c (round (* 0.88 sld)) (* -2.5 sld)) down ++
1460 extreme-point &
1461 extreme-point ++
1462 (c (- (round (* 0.88 sld)) st) (* -2.5 sld)) up ++
1463 (c 0 (* -1.3 sld)) &
1464 (c 0 (* -1.3 sld)) -- (c 0 0)))))
1465
1466 (defun second-flag (sld st extreme-point)
1467 (flet ((c (x y) (complex x y)))
1468 (climi::close-path (mf (c 0 (* -1.4 sld)) (direction #c(1 -2)) ++
1469 (c (round (* 0.88 sld)) (* -2.6 sld)) down ++
1470 extreme-point &
1471 extreme-point ++
1472 (c (- (round (* 0.88 sld)) st) (* -2.5 sld)) up ++
1473 (direction #c(-1 2)) (c 0 (* (- -1.3 0.625) sld)) &
1474 (c 0 (* (- -1.3 0.625) sld)) --
1475 (c 0 (* -1.4 sld))))))
1476
1477 (defmethod compute-design ((font font) (shape (eql :flags-down-1)))
1478 (with-slots ((sld staff-line-distance) stem-thickness) font
1479 (let ((xoffset (ceiling (* 0.5 stem-thickness)))
1480 (extreme-point-1 (complex (* 0.5 sld) (* -3.5 sld))))
1481 (translate (first-flag sld stem-thickness extreme-point-1) xoffset))))
1482
1483 (defmethod compute-design ((font font) (shape (eql :flags-down-2)))
1484 (with-slots ((sld staff-line-distance) (st stem-thickness)) font
1485 (let ((xoffset (ceiling (* 0.5 st)))
1486 (extreme-point-1 (complex (* 0.5 sld) (* -3.5 sld)))
1487 (extreme-point-2 (complex (* 0.75 sld) (* -3.0 sld))))
1488 (clim:region-union
1489 (translate (first-flag sld st extreme-point-1) xoffset)
1490 (translate (second-flag sld st extreme-point-2) xoffset)))))
1491
1492 (defmethod compute-design ((font font) (shape (eql :flags-down-3)))
1493 (with-slots ((sld staff-line-distance) (st stem-thickness)) font
1494 (let ((xoffset (ceiling (* 0.5 st)))
1495 (extreme-point-1 (complex (* 0.5 sld) (* -3.5 sld)))
1496 (extreme-point-2 (complex (* 0.75 sld) (* -3.0 sld))))
1497 (reduce #'clim:region-union
1498 (list (translate (first-flag sld st extreme-point-2) xoffset)
1499 (translate (second-flag sld st extreme-point-2) xoffset)
1500 (translate (second-flag sld st extreme-point-1)
1501 (complex xoffset (* -0.626 sld))))))))
1502
1503 (defmethod compute-design ((font font) (shape (eql :flags-down-4)))
1504 (with-slots ((sld staff-line-distance) (st stem-thickness)) font
1505 (let ((xoffset (ceiling (* 0.5 st)))
1506 (extreme-point-1 (complex (* 0.5 sld) (* -3.5 sld)))
1507 (extreme-point-2 (complex (* 0.75 sld) (* -3.0 sld))))
1508 (reduce #'clim:region-union
1509 (list (translate (first-flag sld st extreme-point-2) xoffset)
1510 (translate (second-flag sld st extreme-point-2) xoffset)
1511 (translate (second-flag sld st extreme-point-2)
1512 (complex xoffset (* -0.626 sld)))
1513 (translate (second-flag sld st extreme-point-1)
1514 (complex xoffset (* -1.25 sld))))))))
1515
1516 (defmethod compute-design ((font font) (shape (eql :flags-down-5)))
1517 (with-slots ((sld staff-line-distance) (st stem-thickness)) font
1518 (let ((xoffset (ceiling (* 0.5 st)))
1519 (extreme-point-1 (complex (* 0.5 sld) (* -3.5 sld)))
1520 (extreme-point-2 (complex (* 0.75 sld) (* -3.0 sld))))
1521 (reduce #'clim:region-union
1522 (list (translate (first-flag sld st extreme-point-2) xoffset)
1523 (translate (second-flag sld st extreme-point-2) xoffset)
1524 (translate (second-flag sld st extreme-point-2)
1525 (complex xoffset (* -0.626 sld)))
1526 (translate (second-flag sld st extreme-point-2)
1527 (complex xoffset (* -1.25 sld)))
1528 (translate (second-flag sld st extreme-point-1)
1529 (complex xoffset (* -1.875 sld))))))))
1530
1531 (defmethod compute-design ((font font) (shape (eql :flags-up-1)))
1532 (with-slots ((sld staff-line-distance) stem-thickness) font
1533 (let ((xoffset (ceiling (* 0.5 stem-thickness)))
1534 (extreme-point-1 (complex (* 0.5 sld) (* -3.5 sld))))
1535 (translate (yscale (first-flag sld stem-thickness extreme-point-1) -1) xoffset))))
1536
1537 (defmethod compute-design ((font font) (shape (eql :flags-up-2)))
1538 (with-slots ((sld staff-line-distance) (st stem-thickness)) font
1539 (let ((xoffset (ceiling (* 0.5 st)))
1540 (extreme-point-1 (complex (* 0.5 sld) (* -3.5 sld)))
1541 (extreme-point-2 (complex (* 0.75 sld) (* -3.0 sld))))
1542 (clim:region-union
1543 (translate (yscale (first-flag sld st extreme-point-1) -1) xoffset)
1544 (translate (yscale (second-flag sld st extreme-point-2) -1) xoffset)))))
1545
1546 (defmethod compute-design ((font font) (shape (eql :flags-up-3)))
1547 (with-slots ((sld staff-line-distance) (st stem-thickness)) font
1548 (let ((xoffset (ceiling (* 0.5 st)))
1549 (extreme-point-1 (complex (* 0.5 sld) (* -3.5 sld)))
1550 (extreme-point-2 (complex (* 0.75 sld) (* -3.0 sld))))
1551 (reduce #'clim:region-union
1552 (list (translate (yscale (first-flag sld st extreme-point-2) -1) xoffset)
1553 (translate (yscale (second-flag sld st extreme-point-2) -1) xoffset)
1554 (translate (yscale (translate (second-flag sld st extreme-point-1)
1555 (complex 0 (* -0.625 sld)))
1556 -1)
1557 xoffset))))))
1558
1559 (defmethod compute-design ((font font) (shape (eql :flags-up-4)))
1560 (with-slots ((sld staff-line-distance) (st stem-thickness)) font
1561 (let ((xoffset (ceiling (* 0.5 st)))
1562 (extreme-point-1 (complex (* 0.5 sld) (* -3.5 sld)))
1563 (extreme-point-2 (complex (* 0.75 sld) (* -3.0 sld))))
1564 (reduce #'clim:region-union
1565 (list (translate (yscale (first-flag sld st extreme-point-2) -1) xoffset)
1566 (translate (yscale (second-flag sld st extreme-point-2) -1) xoffset)
1567 (translate (yscale (translate (second-flag sld st extreme-point-2)
1568 (complex 0 (* -0.626 sld)))
1569 -1)
1570 xoffset)
1571 (translate (yscale (translate (second-flag sld st extreme-point-1)
1572 (complex 0 (* -1.25 sld)))
1573 -1)
1574 xoffset))))))
1575
1576 (defmethod compute-design ((font font) (shape (eql :flags-up-5)))
1577 (with-slots ((sld staff-line-distance) (st stem-thickness)) font
1578 (let ((xoffset (ceiling (* 0.5 st)))
1579 (extreme-point-1 (complex (* 0.5 sld) (* -3.5 sld)))
1580 (extreme-point-2 (complex (* 0.75 sld) (* -3.0 sld))))
1581 (reduce #'clim:region-union
1582 (list (translate (yscale (first-flag sld st extreme-point-2) -1) xoffset)
1583 (translate (yscale (second-flag sld st extreme-point-2) -1) xoffset)
1584 (translate (yscale (translate (second-flag sld st extreme-point-2)
1585 (complex 0 (* -0.626 sld)))
1586 -1)
1587 xoffset)
1588 (translate (yscale (translate (second-flag sld st extreme-point-2)
1589 (complex 0 (* -1.25 sld)))
1590 -1)
1591 xoffset)
1592 (translate (yscale (translate (second-flag sld st extreme-point-1)
1593 (complex 0 (* -1.875 sld)))
1594 -1)
1595 xoffset))))))
1596
1597 (defmethod compute-design ((font font) (shape (eql :beam-down-upper)))
1598 (climi::close-path
1599 (mf #c(0 0) -- (complex 16 -1) -- (complex 0 -1) -- #c(0 0))))
1600
1601 (defmethod compute-design ((font font) (shape (eql :beam-down-lower)))
1602 (climi::close-path
1603 (mf #c(0 0) -- (complex 16 0) -- (complex 16 -1) -- #c(0 0))))
1604
1605 (defmethod compute-design ((font font) (shape (eql :beam-up-upper)))
1606 (climi::close-path
1607 (mf #c(0 0) -- (complex 16 1) -- (complex 16 0) -- #c(0 0))))
1608
1609 (defmethod compute-design ((font font) (shape (eql :beam-up-lower)))
1610 (climi::close-path
1611 (mf #c(0 0) -- (complex 16 0) -- (complex 0 -1) -- #c(0 0))))
1612
1613 ;;; w3
1614 ;;; ___________
1615 ;;; | |
1616 ;;;
1617 ;;; 9 *** 10 ** -11 -
1618 ;;; ********** -12 |
1619 ;;; *********** |
1620 ;;; 8- ************ |
1621 ;;; ************* |
1622 ;;; ************** |
1623 ;;; *************** |
1624 ;;; ***6/ ********** |
1625 ;;; ** / ********** |
1626 ;;; 7 5 ********** |
1627 ;;; ********** | h2
1628 ;;; ********** |
1629 ;;; ********** |
1630 ;;; ********** |
1631 ;;; ********** |
1632 ;;; ********** |
1633 ;;; ********** |
1634 ;;; 4 -**********- 13 |
1635 ;;; 3 ********** 14 - |
1636 ;;; \ **************** / | |
1637 ;;; 2 -**********************- 15 | h1 |
1638 ;;; ********************** _| _|
1639 ;;; | | |
1640 ;;; 1 0 16
1641 ;;;
1642 ;;;
1643 ;;; |___|
1644 ;;; w1
1645 ;;;
1646 ;;; |_________|
1647 ;;; w2
1648
1649 (defmethod compute-design ((font font) (shape (eql :time-signature-1)))
1650 (with-slots ((sld staff-line-distance)
1651 (slt staff-line-thickness)
1652 yoffset)
1653 font
1654 (flet ((c (x y) (complex x y)))
1655 (let* (;; This symbol should sit on top of a staff line
1656 (y0 (+ (/ slt 2) yoffset))
1657 (p0 (c 0 y0))
1658 ;; if the little notch is to be visible, the top
1659 ;; of this character should hang below the upper staff line.
1660 (h2 (- (* 2 sld) slt))
1661 ;; w1 and w2 should be integers in to avoid fuzziness
1662 (w1 (round (* 0.14 h2)))
1663 (w2 (round (* 0.25 h2)))
1664 (h1 (* 0.5 w2))
1665 (p1 (- p0 (* 0.9 w2)))
1666 (p2 (c (- w2) (+ y0 (* h1 0.25))))
1667 (p3 (+ p1 (c 0 (+ y0 (* h1 0.5)))))
1668 (p4 (c (- w1) (+ y0 (* h1 1.2))))
1669 (p5 (c (- w1) (+ y0 (* h2 0.62))))
1670 (p6 (c (- (* w1 1.09)) (+ y0 (* h2 0.65))))
1671 (p7 (c (- (* w2 1.3)) (+ y0 (* h2 0.52))))
1672 (p8 (c (- (* w1 1.23)) (+ y0 (* h2 0.85))))
1673 (p9 (c (- (* w1 0.91)) (+ y0 h2)))
1674 (p10 (c (* w1 0.18) (+ y0 (* h2 0.97))))
1675 (p11 (c w1 (+ y0 (* h2 0.98))))
1676 (p12 (c w1 (+ y0 (* h2 0.96))))
1677 (p13 (c w1 (imagpart p4)))
1678 (p14 (c (- (realpart p3)) (imagpart p3)))
1679 (p15 (c w2 (imagpart p2)))
1680 (p16 (c (- (realpart p1)) (imagpart p1))))
1681 (mf p0 -- p1 left ++ p2 up ++ p3 ++ up p4 -- p5 up ++
1682 p6 (tensions 2 3) p7 (tensions 4 1)
1683 p8 (tensions 1 2)
1684 p9 (tensions 2 2) p10 ++ p11 ++ down p12 -- p13 down ++
1685 p14 ++ p15 down ++ left p16 -- cycle)))))
1686
1687
1688 ;;;
1689 ;;; w2
1690 ;;; __________
1691 ;;; | |
1692 ;;; 10
1693 ;;; | _
1694 ;;; ********* |
1695 ;;; ************** |
1696 ;;; ****************** |
1697 ;;; ****-6 | ********** |
1698 ;;; 9 -****** 5 ********** |
1699 ;;; *******-7 4-*********-11 |
1700 ;;; ****** ********* |
1701 ;;; *** ********* |
1702 ;;; | ******** |
1703 ;;; 8 ******* |
1704 ;;; ***** 14 |
1705 ;;; ***** | | h1
1706 ;;; *****-12 13 * |
1707 ;;; ******* | ** _ |
1708 ;;; ********************** | |
1709 ;;; *********************** | |
1710 ;;; _ *********************** | |
1711 ;;; | **** | ************* | h2 |
1712 ;;; | 3 -*** 1 *********** | |
1713 ;;; h3 | ** ******** | |
1714 ;;; |_ \ ***** _| _|
1715 ;;; 2 |
1716 ;;; 0
1717 ;;;
1718 ;;;
1719 ;;;
1720 ;;; |__________|
1721 ;;; w1
1722 ;;;
1723
1724 (defmethod compute-design ((font font) (shape (eql :time-signature-2)))
1725 (with-slots ((sld staff-line-distance)
1726 (slt staff-line-thickness)
1727 yoffset)
1728 font
1729 (flet ((c (x y) (complex x y)))
1730 (let* (;; This symbol should sit have its lowest point
1731 ;; at the bottom of the staff line
1732 (y0 (+ (- (/ slt 2)) yoffset))
1733 ;; it should have its top at the lower edge of the staff line
1734 (h1 (* 2 sld))
1735 (h2 (round (* 0.20 h1)))
1736 (h3 (* 0.14 h1))
1737 (h4 (* 0.65 h1))
1738 (w1 (round (* 0.38 h1)))
1739 (w2 (round (* 0.33 h1)))
1740 (w3 (round (* 0.6 w2)))
1741 (p0 (c (* 0.1 w1) y0))
1742 (p1 (c (- (* 0.5 w1)) (+ y0 h3)))
1743 (p2 (c (- (* 0.9 w1)) (+ y0 slt)))
1744 (p3 (c (- w1) (+ y0 (* 0.5 h3))))
1745 (p4 (c (round (* 0.2 w1)) (+ y0 h4)))
1746 (p5 (c (- (* 0.1 w1)) (+ y0 (round (* 0.88 h1)))))
1747 (p6 (c (- w3) (+ y0 (* 0.78 h1))))
1748 (p7 (c (- (* 0.2 w1)) (+ y0 h4)))
1749 (p8 (c (- w3) (+ y0 (round (* 0.53 h1)))))
1750 (p9 (c (- w2) (+ y0 (* 0.7 h1))))
1751 (p10 (c 0 (+ y0 h1)))
1752 (p11 (c w2 h4))
1753 (p12 (c (- (* 0.01 w1)) (* 0.3 h1)))
1754 (p13 (c (* 0.5 w1) h2))
1755 (p14 (c w1 (* 0.3 h1))))
1756 (mf p0 left ++ p1 left ++ p2 left ++ p3 up ++ p4 up (tensions 3 1)
1757 p5 left ++ p6 down (tensions 3 1) p7 down ++ p8 left ++ p9 up ++
1758 p10 right ++ p11 down (tensions 1 3) p12 down (tensions 3 1) p13 right (tensions 1 3)
1759 p14 (tensions 3 1) cycle)))))
1760
1761 ;;;
1762 ;;; w2
1763 ;;; _________
1764 ;;; | |
1765 ;;; q _
1766 ;;; ********** |
1767 ;;; ************** |
1768 ;;; *****m l ******** |
1769 ;;; ******* ******* |
1770 ;;; p*********n k********r |
1771 ;;; ******* ******** |
1772 ;;; *** j ******* |
1773 ;;; o | ******** |
1774 ;;; ii-*************s |
1775 ;;; ************* | h1
1776 ;;; c | ******** |
1777 ;;; *** h ******* |
1778 ;;; ******* ******** |
1779 ;;; ********* ********* |
1780 ;;; b - ***********d g********* t |
1781 ;;; ********* f ******** |
1782 ;;; ******- e| ******** |
1783 ;;; **************** |
1784 ;;; ************ _|
1785 ;;; |
1786 ;;; a
1787 ;;;
1788 ;;; |___________|
1789 ;;; w1
1790 ;;;
1791 ;;;
1792 ;;;
1793
1794 (defmethod compute-design ((font font) (shape (eql :time-signature-3)))
1795 (with-slots ((sld staff-line-distance)
1796 (slt staff-line-thickness)
1797 yoffset)
1798 font
1799 (flet ((c (x y) (complex x y)))
1800 (let* (;; This symbol should have its lowest point
1801 ;; at the bottom of the staff line
1802 (ya (+ (- (/ slt 2)) yoffset))
1803 ;; it should have its top at the lower edge of the staff line
1804 (h1 (* 2 sld))
1805 (h2 (* 0.25 h1))
1806 (h3 (* 0.75 h1))
1807 (w1 (round (* 0.38 h1)))
1808 (w2 (round (* 0.33 h1)))
1809 (pa (c (* -0.1 w1) ya))
1810 (pb (c (- w1) (+ ya h2)))
1811 (pc (c (* -0.6 w1) (+ ya (min (1- sld) (round (* 0.4 h1))))))
1812 (pd (c (round (* -0.2 w1)) (+ ya h2)))
1813 (pe (c (* -0.5 w1) (+ ya (* 2.1 slt))))
1814 (pf (c (* -0.1 w1) (+ ya slt)))
1815 (pg (c (* 0.2 w1) (+ ya h2)))
1816 (ph (c (* -0.1 w1) (+ ya sld)))
1817 (pii (c (* -0.7 w1) (+ ya sld (* 0.5 slt))))
1818 (pj (+ ph (c 0 slt)))
1819 (pk (c (* 0.18 w1) (+ ya h3)))
1820 (pl (c (* -0.1 w1) (+ ya (round (* 0.88 h1)))))
1821 (pm (c (* -0.3 w1) (+ ya (round (* 0.85 h1)))))
1822 (pn (c (round (* -0.2 w1)) (+ ya h3)))
1823 (po (c (* -0.55 w1) (+ ya (max (1+ sld) (* 0.6 h1)))))
1824 (pp (c (- w2) (+ ya h3)))
1825 (pq (c 0 (+ ya h1)))
1826 (pr (c w2 h3))
1827 (ps (c (* 0.5 w1) (+ ya sld (* 0.5 slt))))
1828 (pt (c w1 (+ ya h2))))
1829 (mf pa left ++ pb up ++ pc right ++ pd down ++ pe down ++
1830 pf right ++ pg up ++ ph left (tensions 1 5) pii up (tensions 5 1)
1831 pj right ++ pk up ++ pl left ++ pm down ++ pn down ++
1832 po left ++ pp up ++ pq right ++ pr down (tensions 0.75 10)
1833 ps down (tensions 10 0.75) pt down ++ cycle)))))
1834
1835 ;;;
1836 ;;;
1837 ;;;
1838 ;;; k l
1839 ;;; ************* -
1840 ;;; j*************m |
1841 ;;; ************* |
1842 ;;; ************* |
1843 ;;; ************ |
1844 ;;; ************ |
1845 ;;; *********** *** |
1846 ;;; **********n t****v |
1847 ;;; ********* ****** |
1848 ;;; ******** ******** |
1849 ;;; i******* s********** | h2
1850 ;;; ****** ********** |
1851 ;;; ***** ********** |
1852 ;;; ***** r**********w |
1853 ;;; ******o p ********** |
1854 ;;; ****************************** |
1855 ;;; h*********************************x |
1856 ;;; ****************************** - |
1857 ;;; g f e**********y | |
1858 ;;; d**************** | |
1859 ;;; c -**********************z | h1 |
1860 ;;; ********************** _| _|
1861 ;;; b a aa
1862 ;;;
1863 ;;; |_ _|
1864 ;;; w2
1865 ;;; |_________|
1866 ;;; w1
1867 ;;;
1868
1869 (defmethod compute-design ((font font) (shape (eql :time-signature-4)))
1870 (with-slots ((sld staff-line-distance)
1871 (slt staff-line-thickness)
1872 yoffset)
1873 font
1874 (flet ((c (x y) (complex x y)))
1875 (let* (;; This symbol should sit on top of a staff line
1876 (ya (+ (/ slt 2) yoffset))
1877 ;; Its top should hang under the staff line
1878 (h2 (- (* 2 sld) slt))
1879 (xa (round (* 0.02 h2)))
1880 (h1 (round (* 0.15 h2)))
1881 (w1 (round (* 0.25 h2)))
1882 (w2 (round (* 0.14 h2)))
1883 (pa (c xa ya))
1884 (pb (c (- xa (* 0.90 w1)) ya))
1885 (pc (c (- xa w1) (+ ya (* 0.25 h1))))
1886 (pd (+ pb (c 0 (* 1/2 h1))))
1887 (pe (c (- xa w2) (+ ya (* 0.75 h1))))
1888 (pf (+ pd (c 0 (* 1/2 h1))))
1889 (pg (c (* -0.45 h2) (+ ya h1)))
1890 (ph (c (* -0.47 h2) (+ ya (* 1.1 h1))))
1891 (ppi (c (* -0.38 h2) (+ ya (* 0.5 h2))))
1892 (pj (c (* -0.20 h2) (+ ya (* 0.95 h2))))
1893 (pk (c (* -0.12 h2) (+ ya h2)))
1894 (pl (c (* 0.17 h2) (+ ya h2)))
1895 (pm (c (* 0.17 h2) (+ ya (* 0.9 h2))))
1896 (pn (c (* -0.1 h2) (+ ya (* 0.55 h2))))
1897 (po (c (* -0.35 h2) (+ ya (* 1.75 h1))))
1898 (pp (c (* -0.3 h2) (+ ya (* 1.5 h1))))
1899 (pr (c (- xa w2) (+ ya (* 2.2 h1))))
1900 (ps (c (- xa w2) (+ ya (* 2.5 h1))))
1901 (pt (c (+ xa (* 0.70 w2)) (+ ya (* 0.65 h2))))
1902 (pv (c (+ xa w2) (+ ya (* 0.65 h2))))
1903 (pw (c (+ xa w2) (+ ya (* 2.0 h1))))
1904 (px (c (+ xa w1) (+ ya (* 1.1 h1))))
1905 (py (c (+ xa w2) (+ ya (* 0.75 h1))))
1906 (pz (c (+ xa w1) (+ ya (* 0.25 h1))))
1907 (paa (c (+ xa (* 0.90 w1)) ya)))
1908 (mf pa -- pb left ++ pc up ++ pd right ++ pe up ++ left pf --
1909 pg left ++ ph ++ ppi (tensions 1 3) pj ++ right pk -- pl right ++ pm ++
1910 pn (tensions 1 5) po down ++ pp right ++ pr up ++ up ps -- pt
1911 (direction (- pt ps)) ++ down pv -- pw down ++ px down ++
1912 py down ++ pz down ++ left paa -- cycle)))))
1913
1914 ;;;
1915 ;;; w2
1916 ;;; _______
1917 ;;; | |
1918 ;;;
1919 ;;; l n _
1920 ;;; ******* m *****o |
1921 ;;; k******************** |
1922 ;;; ******************* |
1923 ;;; ****************** |
1924 ;;; *****q********** |
1925 ;;; **** **p** |
1926 ;;; ****r |
1927 ;;; **** s **t** - |
1928 ;;; *************** | |
1929 ;;; ****************** | | h1
1930 ;;; j**** h ********** | |
1931 ;;; i ********* | |
1932 ;;; c ********* | |
1933 ;;; - ***** g*********u | |
1934 ;;; | ********* ********* | h2 |
1935 ;;; | *********** ********* | |
1936 ;;; - | b************d ********* | |
1937 ;;; | h4| ********** ********* | |
1938 ;;; h3| | ******e f ********* | |
1939 ;;; | | ************** | |
1940 ;;; |_ |_ ******** _| _|
1941 ;;; a
1942 ;;;
1943 ;;; |___________|
1944 ;;; w1
1945 ;;;
1946 ;;;
1947
1948 (defmethod compute-design ((font font) (shape (eql :time-signature-5)))
1949 (with-slots ((sld staff-line-distance)
1950 (slt staff-line-thickness)
1951 yoffset)
1952 font
1953 (flet ((c (x y) (complex x y)))
1954 (let* (;; This symbol should have its lowest point
1955 ;; at the bottom of the staff line
1956 (ya (+ (- (/ slt 2)) yoffset))
1957 ;; it should have its top at the lower edge of the staff line
1958 (h1 (* 2 sld))
1959 (h2 (round (* 0.62 h1)))
1960 (h3 (* 0.30 h1))
1961 (h4 (round (* 0.44 h1)))