[gsharp-cvs] CVS gsharp
rstrandh
rstrandh at common-lisp.net
Tue May 30 02:13:26 UTC 2006
Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv14794
Modified Files:
bezier.lisp sdl.lisp score-pane.lisp
Log Message:
Output recording of Bezier designs seems to be working now.
Clefs are now drawn using the new system. There is still considerable
ugliness in the code, but I intend to work on that incrementally.
Modified the G clef to look a bit better (which is easier to do with
the new system than with the Metafont program).
--- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/05/29 19:55:24 1.1
+++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/05/30 02:13:26 1.2
@@ -63,10 +63,31 @@
;;; define the trampoline method from a sheet to a medium
(def-graphic-op draw-design (design))
-;;; define output records, etc
-(def-grecording draw-design (() design) ()
- (setf (slot-value climi::graphic 'design) design)
- (bounding-rectangle* design))
+(defclass bezier-design-output-record (standard-graphics-displayed-output-record)
+ ((stream :initarg :stream)
+ (design :initarg :design)))
+
+(defmethod initialize-instance :after ((record bezier-design-output-record) &key)
+ (with-slots (design) record
+ (setf (rectangle-edges* record)
+ (bounding-rectangle* design))))
+
+(defmethod medium-draw-design* :around ((stream output-recording-stream) design)
+ (with-sheet-medium (medium stream)
+ (let ((transformed-design (transform-region (medium-transformation medium) design)))
+ (when (stream-recording-p stream)
+ (let ((record (make-instance 'bezier-design-output-record
+ :stream stream
+ :design transformed-design)))
+ (stream-add-output-record stream record)))
+ (when (stream-drawing-p stream)
+ (medium-draw-design* medium design)))))
+
+(defmethod replay-output-record ((record bezier-design-output-record) stream &optional
+ (region +everywhere+) (x-offset 0) (y-offset 0))
+ (declare (ignore x-offset y-offset region))
+ (with-slots (design) record
+ (medium-draw-design* (sheet-medium stream) design)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
--- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/05/29 19:55:24 1.15
+++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/05/30 02:13:26 1.16
@@ -425,7 +425,8 @@
;;;
(defmethod compute-design ((font font) (shape (eql :g-clef)))
- (with-slots ((sld staff-line-distance) staff-line-thickness stem-thickness) font
+ (with-slots ((sld staff-line-distance) staff-line-thickness
+ stem-thickness yoffset) font
(let* ((xf 0.0) (yf (* 0.5 sld))
(xy (max 2.0 (round (* 0.4 sld)))) (yy (* 0.2 sld))
(xb (+ xy (max 2.0 (round (* 0.4 sld))))) (yb (* 0.3 sld))
@@ -433,7 +434,7 @@
(xa (+ xcc (max 1.0 (* 0.2 sld)))) (ya (* -0.4 sld))
(xc (+ xb (round (* 0.7 sld)))) (yc (+ sld (max 1.0 (* 0.15 sld))))
(xd (+ xc sld)) (yd 0.0)
- (xe (* 1.5 sld)) (ye (- (+ staff-line-thickness sld)))
+ (xe (* 1.5 sld)) (ye (- sld))
(xg (round (* 1.8 sld))) (yg (* 3.8 sld))
(xw (- xg (* 2.0 staff-line-thickness))) (yw (round (* 5.0 sld)))
(xh xw) (yh (- yw (max 2.0 (round (* 0.4 sld)))))
@@ -450,7 +451,9 @@
(xl (+ xs stem-thickness)) (yl ys)
(xm (- xp (* 1 staff-line-thickness))) (ym (round (* -2.75 sld)))
(xr xm) (yr (+ ym staff-line-thickness))
- (xz xe) (yz (- staff-line-thickness sld))
+ (xz xe)
+ ;; yz should be slightly above the upper edge of the staff line
+ (yz (+ (- sld) (* 1.2 staff-line-thickness)))
(xaa (- xd (max 1 (round (* 0.3 sld))))) (yaa yd)
(xbb xc) (ybb (- sld staff-line-thickness (max 2 (* 0.3 sld))))
(xdd xp) (ydd (* 2 sld))
@@ -458,36 +461,37 @@
(xff (floor (* 1.4 sld))) (yff sld)
(xgg (+ xff stem-thickness)) (ygg yff))
(flet ((c (x y) (complex x y)))
- (mf (c xa ya) ++ (c xb yb) up ++ (c xc yc) right ++
- (c xd yd) down ++ (c xe ye) left ++ (c xf yf) up ++
- (c xee yee) ++
- (c xg yg) up
- (tensions 1 1.8)
- (c xh yh)
- (tensions 1.8 1)
- (c xi yi)
- (tensions 1.8 1)
- (c xgg ygg) (direction #c(1 -4))
- (tensions 1 20)
- (c xl yl) down ++
- (c xm ym) left ++
- (c xn yn) up ++ (c xo yo) right ++ (c xp yp) down ++
- (c xq yq) &
- (c xq yq) ++ (c xr yr) right ++
- (c xs ys) up
- (tensions 20 1)
- (c xff yff) (direction #c(-1 4))
- (tensions 1 1.8)
- (c xv yv) up
- (tensions 1 1.8)
- (c xw yw) right
- (tensions 1.8 1)
- (c xx yx) down ++
- (c xdd ydd) ++
- (c xy yy) down ++ (c xz yz) right ++
- (c xaa yaa) up ++ (c xbb ybb) left ++
- (c xcc ycc) down ++ (c (+ xa 1) ya) &
- (c (+ xa 1) ya) ++ cycle))))) ; replace ++ by -- one day
+ (translate (mf (c xa ya) ++ (c xb yb) up ++ (c xc yc) right ++
+ (c xd yd) down ++ (c xe ye) left ++ (c xf yf) up ++
+ (c xee yee) ++
+ (c xg yg) up
+ (tensions 1 1.8)
+ (c xh yh)
+ (tensions 1.8 1)
+ (c xi yi)
+ (tensions 1.8 1)
+ (c xgg ygg) (direction #c(1 -4))
+ (tensions 1 20)
+ (c xl yl) down ++
+ (c xm ym) left ++
+ (c xn yn) up ++ (c xo yo) right ++ (c xp yp) down ++
+ (c xq yq) &
+ (c xq yq) ++ (c xr yr) right ++
+ (c xs ys) up
+ (tensions 20 1)
+ (c xff yff) (direction #c(-1 4))
+ (tensions 1 1.8)
+ (c xv yv) up
+ (tensions 1 1.8)
+ (c xw yw) right
+ (tensions 1.8 1)
+ (c xx yx) down ++
+ (c xdd ydd) ++
+ (c xy yy) down ++ (c xz yz) right ++
+ (c xaa yaa) up ++ (c xbb ybb) left ++
+ (c xcc ycc) down ++ (c (+ xa 1) ya) &
+ (c (+ xa 1) ya) ++ cycle)
+ (complex 0 yoffset)))))) ; replace ++ by -- one day
;;;
;;; xa xb
--- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/05/29 19:55:24 1.24
+++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/05/30 02:13:26 1.25
@@ -265,16 +265,14 @@
((:treble :treble8) :g-clef)
(:bass :f-clef)
(:c :c-clef))
- x (staff-step staff-step)))
+ x (staff-step (- staff-step))))
-
-
(define-presentation-type clef () :options (name x staff-step))
(define-presentation-method present
(object (type clef) stream (view score-view) &key)
(with-output-as-presentation (stream object 'clef)
- (draw-clef stream name x staff-step)))
+ (new-draw-clef stream name x staff-step)))
;;;;;;;;;;;;;;;;;; rest
More information about the Gsharp-cvs
mailing list