[gsharp-cvs] CVS gsharp

[crhodes]

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

Modified Files:
	sdl.lisp 
Log Message:
Implement the large (outsize) tie left and right curves.


--- /project/gsharp/cvsroot/gsharp/sdl.lisp	2006/06/02 12:37:47	1.20
+++ /project/gsharp/cvsroot/gsharp/sdl.lisp	2006/06/02 13:17:35	1.21
@@ -883,6 +883,36 @@
 	  (c (- (- width 1.0)) (- top height)) --
 	  (c (- width) (- top height)) ++ cycle))))
 
+(defun large-tie-up-left (sld slt width-multiplier)
+  (declare (ignore slt))
+  (let* ((thickness (round (* 0.33 sld)))
+	 (height (round (* 1.0 sld)))
+	 (top (round (* 11/6 sld)))
+	 (width (* width-multiplier sld)))
+    (flet ((c (x y) (complex x y)))
+      (climi::close-path
+       (mf (c 0.0 top) left ++
+           (c (- width) (- top height)) --
+           (c (- (- width 1.0)) (- top height)) ++
+           (c (* -0.3 width) (- top thickness)) ++
+           (c 0.0 (- top thickness)) &
+           (c 0.0 (- top thickness)) -- (c 0.0 top))))))
+
+(defun large-tie-up-right (sld slt width-multiplier)
+  (declare (ignore slt))
+  (let* ((thickness (round (* 0.33 sld)))
+	 (height (round (* 1.0 sld)))
+	 (top (round (* 11/6 sld)))
+	 (width (* width-multiplier sld)))
+    (flet ((c (x y) (complex x y)))
+      (climi::close-path
+       (mf (c 0.0 top) right ++
+           (c width (- top height)) --
+           (c (- width 1.0) (- top height)) ++
+           (c (* 0.3 width) (- top thickness)) ++
+           (c 0.0 (- top thickness)) &
+           (c 0.0 (- top thickness)) -- (c 0.0 top))))))
+
 (defmethod compute-design ((font font) (shape (eql :large-tie-1-up)))
   (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
     (large-tie-up sld slt 2.0)))
@@ -923,6 +953,14 @@
   (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
     (large-tie-up sld slt 5.0)))
 
+(defmethod compute-design ((font font) (shape (eql :large-tie-up-left)))
+  (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
+    (large-tie-up-left sld slt 5.0)))
+
+(defmethod compute-design ((font font) (shape (eql :large-tie-up-right)))
+  (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
+    (large-tie-up-right sld slt 5.0)))
+
 (defun large-tie-down (sld slt width-multiplier)
   (let* ((thickness (round (* 0.33 sld)))
 	 (height (round (* 1.0 sld)))
@@ -938,6 +976,34 @@
 	  (c (- (- width 1.0)) (- height bot)) --
 	  (c (- width) (- height bot)) ++ cycle))))
 
+(defun large-tie-down-left (sld slt width-multiplier)
+  (let* ((thickness (round (* 0.33 sld)))
+	 (height (round (* 1.0 sld)))
+	 (bot (- (round(* 11/6 sld)) slt))
+	 (width (* width-multiplier sld)))
+    (flet ((c (x y) (complex x y)))
+      (climi::close-path
+       (mf (c 0.0 (- bot)) left ++
+           (c (- width) (- height bot)) --
+           (c (- (- width 1.0)) (- height bot)) ++
+           (c (* -0.3 width) (- thickness bot)) ++
+           (c 0.0 (- thickness bot)) &
+           (c 0.0 (- thickness bot)) -- (c 0.0 (- bot)))))))
+
+(defun large-tie-down-right (sld slt width-multiplier)
+  (let* ((thickness (round (* 0.33 sld)))
+	 (height (round (* 1.0 sld)))
+	 (bot (- (round(* 11/6 sld)) slt))
+	 (width (* width-multiplier sld)))
+    (flet ((c (x y) (complex x y)))
+      (climi::close-path
+       (mf (c 0.0 (- bot)) right ++
+           (c width (- height bot)) --
+           (c (- width 1.0) (- height bot)) ++
+           (c (* 0.3 width) (- thickness bot)) ++
+           (c 0.0 (- thickness bot)) &
+           (c 0.0 (- thickness bot)) -- (c 0.0 (- bot)))))))
+
 (defmethod compute-design ((font font) (shape (eql :large-tie-1-down)))
   (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
     (large-tie-down sld slt 2.0)))
@@ -978,6 +1044,14 @@
   (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
     (large-tie-down sld slt 5.0)))
 
+(defmethod compute-design ((font font) (shape (eql :large-tie-down-left)))
+  (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
+    (large-tie-down-left sld slt 5.0)))
+
+(defmethod compute-design ((font font) (shape (eql :large-tie-down-right)))
+  (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font
+    (large-tie-down-right sld slt 5.0)))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Accidentals