[gsharp-cvs] CVS gsharp
rstrandh
rstrandh at common-lisp.net
Wed Jun 7 04:55:08 UTC 2006
Update of /project/gsharp/cvsroot/gsharp
In directory clnet:/tmp/cvs-serv7687
Modified Files:
score-pane.lisp sdl.lisp
Log Message:
Implemented a new beam drawing system.
There are still some magic + and - 1s in there that I don't have
time to look into right now.
However, it should now be possible to draw a beam as a polygon
from the output record (the output record was wrong before).
--- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/06 20:47:42 1.30
+++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/07 04:55:07 1.31
@@ -472,20 +472,40 @@
(defclass downward-beam-output-record (beam-output-record)
())
+(defun medium-draw-downward-beam* (medium x1 y1 x2 y2 thickness)
+ (let ((inverse-slope (abs (/ (- x2 x1) (- y2 y1)))))
+ (loop for y from y1 below y2
+ for x from x1 by inverse-slope do
+ (let ((upper (sdl::ensure-beam-segment-design :down :upper (- (round (+ x inverse-slope)) (round x))))
+ (upper-tr (make-translation-transformation (round x) (1+ y))) ; don't know why the 1 is neccesary
+ (lower (sdl::ensure-beam-segment-design :down :lower (- (round (+ x inverse-slope)) (round x))))
+ (lower-tr (make-translation-transformation (round x) (+ y thickness 1)))) ; don't know why the 1 is neccesary
+ (climi::medium-draw-bezier-design* medium (transform-region upper-tr upper))
+ (climi::medium-draw-bezier-design* medium (transform-region lower-tr lower))
+ (medium-draw-rectangle* medium (round x) (1+ y) (round (+ x inverse-slope)) (+ y thickness) t)))))
+
+(defun medium-draw-upward-beam* (medium x1 y1 x2 y2 thickness)
+ (let ((inverse-slope (abs (/ (- x2 x1) (- y2 y1)))))
+ (loop for y from y1 above y2
+ for x from x1 by inverse-slope do
+ (let ((upper (sdl::ensure-beam-segment-design :up :upper (- (round (+ x inverse-slope)) (round x))))
+ (upper-tr (make-translation-transformation (round x) (1- y))) ; don't know why the -1 is necessary
+ (lower (sdl::ensure-beam-segment-design :up :lower (- (round (+ x inverse-slope)) (round x))))
+ (lower-tr (make-translation-transformation (round x) (+ y thickness)))) ; don't know why +1 is not neccesary
+ (climi::medium-draw-bezier-design* medium (transform-region upper-tr upper))
+ (climi::medium-draw-bezier-design* medium (transform-region lower-tr lower))
+ (medium-draw-rectangle* medium (round x) y (round (+ x inverse-slope)) (1- (+ y thickness)) t)))))
+
(defmethod replay-output-record ((record downward-beam-output-record) (stream score-pane)
&optional (region +everywhere+)
(x-offset 0) (y-offset 0))
(declare (ignore x-offset y-offset region))
(with-bounding-rectangle* (x1 y1 x2 y2) record
- (with-slots (thickness ink clipping-region light-glyph-p) record
+ (with-slots (thickness ink clipping-region) record
(let ((medium (sheet-medium stream)))
- (let ((*light-glyph* light-glyph-p))
- (with-drawing-options
- (medium :ink ink :clipping-region clipping-region)
- (let ((*lighter-gray-progressions* (lighter-gray-progressions stream))
- (*darker-gray-progressions* (darker-gray-progressions stream)))
- (draw-downward-beam medium x1 y1 y2 thickness
- (/ (- x2 x1) (- y2 y1))))))))))
+ (with-drawing-options
+ (medium :ink ink :clipping-region clipping-region)
+ (medium-draw-downward-beam* medium x1 y1 x2 (- y2 thickness) thickness))))))
(defclass upward-beam-output-record (beam-output-record)
())
@@ -495,22 +515,17 @@
(x-offset 0) (y-offset 0))
(declare (ignore x-offset y-offset region))
(with-bounding-rectangle* (x1 y1 x2 y2) record
- (with-slots (thickness ink clipping-region light-glyph-p) record
+ (with-slots (thickness ink clipping-region) record
(let ((medium (sheet-medium stream)))
- (let ((*light-glyph* light-glyph-p))
- (with-drawing-options
- (medium :ink ink :clipping-region clipping-region)
- (let ((*lighter-gray-progressions* (lighter-gray-progressions stream))
- (*darker-gray-progressions* (darker-gray-progressions stream)))
- (draw-upward-beam medium x1 y2 y1 thickness
- (/ (- x2 x1) (- y2 y1))))))))))
+ (with-drawing-options
+ (medium :ink ink :clipping-region clipping-region)
+ (medium-draw-upward-beam* medium x1 (- y2 thickness) x2 y1 thickness))))))
;;; draw a sloped beam. The vertical reference points
;;; of the two end points are indicated by y1 and y2.
(defun draw-sloped-beam (medium x1 y1 x2 y2)
(multiple-value-bind (down up) (beam-offsets *font*)
(let ((transformation (medium-transformation *pane*))
- (inverse-slope (abs (/ (- x2 x1) (- y2 y1))))
(thickness (- down up)))
(cond ((< y1 y2)
(when (stream-recording-p *pane*)
@@ -520,12 +535,11 @@
(transform-position transformation x2 y2)
(stream-add-output-record
*pane* (make-instance 'downward-beam-output-record
- :x1 xx1 :y1 yy1 :x2 xx2 :y2 yy2
- :light-glyph-p *light-glyph*
+ :x1 xx1 :y1 (+ yy1 up) :x2 xx2 :y2 (+ yy2 down)
:thickness thickness :ink (medium-ink medium)
:clipping-region (medium-clipping-region medium))))))
(when (stream-drawing-p *pane*)
- (draw-downward-beam medium x1 y1 y2 thickness inverse-slope)))
+ (medium-draw-downward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness)))
(t
(when (stream-recording-p *pane*)
(multiple-value-bind (xx1 yy1)
@@ -534,13 +548,12 @@
(transform-position transformation x2 y2)
(stream-add-output-record
*pane* (make-instance 'upward-beam-output-record
- :x1 xx1 :y1 yy2 :x2 xx2 :y2 yy1
- :light-glyph-p *light-glyph*
+ :x1 xx1 :y1 (+ yy2 up) :x2 xx2 :y2 (+ yy1 down)
:thickness thickness
:ink (medium-ink medium)
:clipping-region (medium-clipping-region medium))))))
(when (stream-drawing-p *pane*)
- (draw-upward-beam medium x1 y1 y2 thickness inverse-slope)))))))
+ (medium-draw-upward-beam* medium x1 (+ y1 up) x2 (+ y2 up) thickness)))))))
;;; an offset of -1 means hang, 0 means straddle and 1 means sit
(defun draw-beam (pane x1 staff-step-1 offset1 x2 staff-step-2 offset2)
--- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/06 20:52:32 1.28
+++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/07 04:55:07 1.29
@@ -108,9 +108,11 @@
(beam-offset-down)
(beam-offset-up)
(beam-hang-sit-offset :reader beam-hang-sit-offset)
- (designs :initform (make-hash-table :test #'eq))
- (beam-designs :initform (make-hash-table :test #'eql))))
+ (designs :initform (make-hash-table :test #'eq))))
+
+(defparameter *beam-designs* (make-hash-table :test #'equal))
+
(defmethod initialize-instance :after ((font font) &rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(with-slots (staff-line-distance
@@ -298,20 +300,18 @@
;;;
;;; Beams
-(defun ensure-beam-segment-design (font direction width)
- (with-slots ((sld staff-line-distance)) font
- (let* ((key (* (if (eq direction :down) 1 -1) width))
- (thickness (/ sld 2)))
- (or (gethash key (slot-value font 'beam-designs))
- (setf (gethash width (slot-value font 'beam-designs))
- (climi::close-path
- (if (eq direction :down)
- (mf #c(0 0) -- (complex width 1) --
- (complex width (+ thickness 1)) --
- (complex 0 thickness) -- #c(0 0))
- (mf #c(0 0) -- (complex width -1) --
- (complex width (- (- thickness) 1)) --
- (complex 0 (- thickness)) -- #c(0 0)))))))))
+(defun ensure-beam-segment-design (direction position width)
+ (let* ((key (list direction position width)))
+ (or (gethash key *beam-designs*)
+ (setf (gethash key *beam-designs*)
+ (climi::close-path
+ (if (eq direction :down)
+ (if (eq position :upper)
+ (mf #c(0 0) -- (complex width -1) -- (complex 0 -1) -- #c(0 0))
+ (mf #c(0 0) -- (complex width 0) -- (complex width -1) -- #c(0 0)))
+ (if (eq position :upper)
+ (mf #c(0 0) -- (complex width 1) -- (complex width 0) -- #c(0 0))
+ (mf #c(0 0) -- (complex width 0) -- (complex 0 -1) -- #c(0 0)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -1407,3 +1407,18 @@
-1)
xoffset))))))
+(defmethod compute-design ((font font) (shape (eql :beam-down-upper)))
+ (climi::close-path
+ (mf #c(0 0) -- (complex 16 -1) -- (complex 0 -1) -- #c(0 0))))
+
+(defmethod compute-design ((font font) (shape (eql :beam-down-lower)))
+ (climi::close-path
+ (mf #c(0 0) -- (complex 16 0) -- (complex 16 -1) -- #c(0 0))))
+
+(defmethod compute-design ((font font) (shape (eql :beam-up-upper)))
+ (climi::close-path
+ (mf #c(0 0) -- (complex 16 1) -- (complex 16 0) -- #c(0 0))))
+
+(defmethod compute-design ((font font) (shape (eql :beam-up-lower)))
+ (climi::close-path
+ (mf #c(0 0) -- (complex 16 0) -- (complex 0 -1) -- #c(0 0))))
More information about the Gsharp-cvs
mailing list