gsharp-cvs June 2006

gsharp-cvs@common-lisp.net

2 participants
49 discussions

[gsharp-cvs] CVS gsharp
by rstrandh 02 Jun '06

02 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv25428 Modified Files: bezier.lisp fontview.lisp Log Message: Fixed a minor bug in bezier.lisp (reference to an undefined variable). Improved the font viewer so that it now takes an optional argument indicating which shape to render. --- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/02 14:54:16 1.5 +++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/02 21:49:10 1.6 @@ -751,7 +751,7 @@ (climi::with-medium-options (sheet options) (medium-draw-bezier-design* sheet design))) -(defmethod draw-design (medium (design bezier-design) &rest args &key &allow-other-keys) +(defmethod draw-design (medium (design bezier-design) &rest options &key &allow-other-keys) (apply #'draw-bezier-design* medium design options)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/01 18:57:40 1.3 +++ /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/02 21:49:10 1.4 @@ -7,7 +7,7 @@ (define-application-frame fontview () ((font :initform (make-instance 'sdl::font :staff-line-distance 6)) - (shape :initform :g-clef) + (shape :initarg :shape :initform :g-clef) (grid :initform t) (staff :initform t) (staff-offset :initform 0) @@ -99,8 +99,8 @@ (display-antialiased-view frame pane) (display-pixel-view frame pane)))) -(defun fontview () - (let ((frame (make-application-frame 'fontview))) +(defun fontview (&optional (shape :g-clef)) + (let ((frame (make-application-frame 'fontview :shape shape))) (run-frame-top-level frame))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

[gsharp-cvs] CVS gsharp
by crhodes 02 Jun '06

02 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv3551 Modified Files: bezier.lisp Log Message: Implement postscript methods for drawing bezier stuff. * new superclass bezier-design; * new functions {,medium-}draw-bezier-design* * translated-region -> translated-bezier-design * zap medium-draw-design*. We preserve the translated-bezier-design because (it turns out) otherwise the X11 backend is slow as molasses. No gtkairo methods yet, because of the strange jumping designs (and also because it's not clear how to manage the dependency). Now code of the form (in-package :gsharp) (define-gsharp-command (com-hacky-print :name t) () (with-open-file (ps "/tmp/foo.ps" :direction :output :if-exists :supersede) (with-output-to-postscript-stream (s ps) (setf (stream-default-view s) (make-instance 'orchestra-view :buffer (current-buffer *application-frame*) :cursor (current-cursor))) (setf (medium-transformation s) (compose-scaling-with-transformation (medium-transformation s) 0.5 0.5)) (draw-buffer s (current-buffer *application-frame*) (current-cursor) (left-margin (current-buffer *application-frame*)) 100)))) draws a buffer to /tmp/foo.ps. --- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/01 18:57:40 1.4 +++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/02 14:54:16 1.5 @@ -56,12 +56,9 @@ (- (* (realpart z) (point-y v)) (* (imagpart z) (point-x v)))) -;;; the CLIM spec does not mention the existence of -;;; medium-draw-design*, but I assume it has to exist -;;; RS 2006-05-27 +(defclass bezier-design (design) ()) -;;; define the trampoline method from a sheet to a medium -(def-graphic-op draw-design (design)) +(defgeneric medium-draw-bezier-design* (stream design)) (defclass bezier-design-output-record (standard-graphics-displayed-output-record) ((stream :initarg :stream) @@ -72,7 +69,7 @@ (setf (rectangle-edges* record) (bounding-rectangle* design)))) -(defmethod medium-draw-design* :around ((stream output-recording-stream) design) +(defmethod medium-draw-bezier-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) @@ -81,13 +78,13 @@ :design transformed-design))) (stream-add-output-record stream record))) (when (stream-drawing-p stream) - (medium-draw-design* medium design))))) + (medium-draw-bezier-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))) + (medium-draw-bezier-design* (sheet-medium stream) design))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -193,11 +190,11 @@ (call-next-method)))) ;;; A region that translates a different region -(defclass translated-region (region) +(defclass translated-bezier-design (region bezier-design) ((%translation :initarg :translation :reader translation) (%region :initarg :region :reader original-region))) -(defmethod bounding-rectangle* ((region translated-region)) +(defmethod bounding-rectangle* ((region translated-bezier-design)) (let ((translation (translation region))) (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* (original-region region)) @@ -210,7 +207,7 @@ (defgeneric really-transform-region (transformation region)) ;;; an area defined as a closed path of Bezier curve segments -(defclass bezier-area (area segments-mixin bounding-rectangle-mixin) ()) +(defclass bezier-area (area bezier-design segments-mixin bounding-rectangle-mixin) ()) (defgeneric close-path (path)) @@ -243,7 +240,7 @@ (defmethod transform-region (transformation (area bezier-area)) (if (translation-transformation-p transformation) - (make-instance 'translated-region + (make-instance 'translated-bezier-design :translation transformation :region area) (really-transform-region transformation area))) @@ -253,7 +250,7 @@ ;;; Special cases of combined Bezier areas ;;; A union of bezier areas. This is not itself a bezier area. -(defclass bezier-union (area) +(defclass bezier-union (area bezier-design) ((%areas :initarg :areas :initform '() :reader areas))) (defmethod really-transform-region (transformation (area bezier-union)) @@ -264,7 +261,7 @@ (defmethod transform-region (transformation (area bezier-union)) (if (translation-transformation-p transformation) - (make-instance 'translated-region + (make-instance 'translated-bezier-design :translation transformation :region area) (really-transform-region transformation area))) @@ -300,7 +297,7 @@ (make-instance 'bezier-union :areas (append (areas r1) (areas r2)))) -(defclass bezier-difference (area) +(defclass bezier-difference (area bezier-design) ((%positive-areas :initarg :positive-areas :initform '() :reader positive-areas) (%negative-areas :initarg :negative-areas :initform '() :reader negative-areas))) @@ -315,7 +312,7 @@ (defmethod transform-region (transformation (area bezier-difference)) (if (translation-transformation-p transformation) - (make-instance 'translated-region + (make-instance 'translated-bezier-design :translation transformation :region area) (really-transform-region transformation area))) @@ -732,19 +729,6 @@ (copy-from-pixmap pixmap 0 0 (pixmap-width pixmap) (pixmap-height pixmap) (medium-sheet medium) (+ *x* min-x) (+ *y* min-y))))) -(defmethod medium-draw-design* (medium (design bezier-area)) - (render-through-pixmap design medium (list design) '())) - -(defmethod medium-draw-design* (medium (design bezier-union)) - (render-through-pixmap design medium (areas design) '())) - -(defmethod medium-draw-design* (medium (design bezier-difference)) - (render-through-pixmap design medium (positive-areas design) (negative-areas design))) - -(defmethod medium-draw-design* (medium (design translated-region)) - (multiple-value-bind (*x* *y*) (transform-position (translation design) 0 0) - (medium-draw-design* medium (original-region design)))) - (defgeneric render-design-to-array (design)) (defmethod render-design-to-array ((design bezier-area)) @@ -756,76 +740,134 @@ (defmethod render-design-to-array ((design bezier-difference)) (render-to-array (positive-areas design) (negative-areas design))) -(defmethod render-design-to-array ((design translated-region)) +(defmethod render-design-to-array ((design translated-bezier-design)) (render-design-to-array (original-region design))) -(defmethod draw-design (sheet design &rest args &key &allow-other-keys) - (climi::with-medium-options (sheet args) - (medium-draw-design* medium design))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Generic drawing + +(defun draw-bezier-design* (sheet design &rest options) + (climi::with-medium-options (sheet options) + (medium-draw-bezier-design* sheet design))) + +(defmethod draw-design (medium (design bezier-design) &rest args &key &allow-other-keys) + (apply #'draw-bezier-design* medium design options)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Drawing bezier designs to screen + + +;;; Fallback methods (suitable for CLX) +(defmethod medium-draw-bezier-design* (medium (design bezier-area)) + (render-through-pixmap design medium (list design) '())) +(defmethod medium-draw-bezier-design* (medium (design bezier-union)) + (render-through-pixmap design medium (areas design) '())) +(defmethod medium-draw-bezier-design* (medium (design bezier-difference)) + (render-through-pixmap design medium (positive-areas design) (negative-areas design))) +(defmethod medium-draw-bezier-design* (medium (design translated-bezier-design)) + (multiple-value-bind (*x* *y*) (transform-position (translation design) 0 0) + (medium-draw-bezier-design* medium (original-region design)))) + +;;; Postscript methods +(defmethod medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design bezier-area)) + (let ((stream (clim-postscript::postscript-medium-file-stream medium)) + (clim-postscript::*transformation* (sheet-native-transformation (medium-sheet medium)))) + (clim-postscript::postscript-actualize-graphics-state stream medium :color) + (format stream "newpath~%") + (let ((p0 (slot-value (car (segments design)) 'p0))) + (clim-postscript::write-coordinates stream (point-x p0) (point-y p0)) + (format stream "moveto~%")) + (loop for segment in (segments design) + do (with-slots (p1 p2 p3) segment + (clim-postscript::write-coordinates stream (point-x p1) (point-y +p1)) + (clim-postscript::write-coordinates stream (point-x p2) (point-y +p2)) + (clim-postscript::write-coordinates stream (point-x p3) (point-y +p3)) + (format stream "curveto~%"))) + (format stream "fill~%"))) +(defmethod medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design bezier-union)) + (dolist (area (areas design)) + (medium-draw-bezier-design* medium area))) +(defmethod medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design bezier-difference)) + (dolist (area (positive-areas design)) + (medium-draw-bezier-design* medium area)) + (with-drawing-options (medium :ink +background-ink+) + (dolist (area (negative-areas design)) + (medium-draw-bezier-design* medium area)))) +(defmethod medium-draw-bezier-design* + ((medium clim-postscript::postscript-medium) (design translated-bezier-design)) + (medium-draw-bezier-design* medium (really-transform-region (translation design) (original-region design)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Special cases on region-union and region-intersection -(defmethod region-union ((r1 translated-region) (r2 bezier-curve)) +(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-curve)) (region-union (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-union ((r1 translated-region) (r2 bezier-area)) +(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-area)) (region-union (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-union ((r1 translated-region) (r2 bezier-union)) +(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-union)) (region-union (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-union ((r1 translated-region) (r2 bezier-difference)) +(defmethod region-union ((r1 translated-bezier-design) (r2 bezier-difference)) (region-union (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-union ((r1 bezier-curve) (r2 translated-region)) +(defmethod region-union ((r1 bezier-curve) (r2 translated-bezier-design)) (region-union r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-union ((r1 bezier-area) (r2 translated-region)) +(defmethod region-union ((r1 bezier-area) (r2 translated-bezier-design)) (region-union r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-union ((r1 bezier-union) (r2 translated-region)) +(defmethod region-union ((r1 bezier-union) (r2 translated-bezier-design)) (region-union r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-union ((r1 bezier-difference) (r2 translated-region)) +(defmethod region-union ((r1 bezier-difference) (r2 translated-bezier-design)) (region-union r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-union ((r1 translated-region) (r2 translated-region)) +(defmethod region-union ((r1 translated-bezier-design) (r2 translated-bezier-design)) (region-union (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-difference ((r1 translated-region) (r2 bezier-curve)) +(defmethod region-difference ((r1 translated-bezier-design) (r2 bezier-curve)) (region-difference (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-difference ((r1 translated-region) (r2 bezier-area)) +(defmethod region-difference ((r1 translated-bezier-design) (r2 bezier-area)) (region-difference (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-difference ((r1 translated-region) (r2 bezier-union)) +(defmethod region-difference ((r1 translated-bezier-design) (r2 bezier-union)) (region-difference (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-difference ((r1 translated-region) (r2 bezier-difference)) +(defmethod region-difference ((r1 translated-bezier-design) (r2 bezier-difference)) (region-difference (really-transform-region (translation r1) (original-region r1)) r2)) -(defmethod region-difference ((r1 bezier-curve) (r2 translated-region)) +(defmethod region-difference ((r1 bezier-curve) (r2 translated-bezier-design)) (region-difference r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-difference ((r1 bezier-area) (r2 translated-region)) +(defmethod region-difference ((r1 bezier-area) (r2 translated-bezier-design)) (region-difference r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-difference ((r1 bezier-union) (r2 translated-region)) +(defmethod region-difference ((r1 bezier-union) (r2 translated-bezier-design)) (region-difference r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-difference ((r1 bezier-difference) (r2 translated-region)) +(defmethod region-difference ((r1 bezier-difference) (r2 translated-bezier-design)) (region-difference r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod region-difference ((r1 translated-region) (r2 translated-region)) +(defmethod region-difference ((r1 translated-bezier-design) (r2 translated-bezier-design)) (region-difference r1 (really-transform-region (translation r2) (original-region r2)))) -(defmethod transform-region (transformation (region translated-region)) +(defmethod transform-region (transformation (region translated-bezier-design)) (let ((combined-transformation (compose-transformations transformation (translation region)))) (if (translation-transformation-p transformation) - (make-instance 'translated-region + (make-instance 'translated-bezier-design :translation combined-transformation :region (original-region region)) (transform-region combined-transformation (original-region region)))))

1 0

[gsharp-cvs] CVS gsharp
by crhodes 02 Jun '06

02 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv30880 Modified Files: score-pane.lisp Log Message: Use the new code for all the pixmap-recording things (noteheads, rests, ties, flags, accidentals). Some degradation in output as a result * misalignments between stems and noteheads; * whole and half rests do not line up with staff lines; * flag has a discontinuity near the extreme point on the inside. (Possibly others. On the other hand, this means that with my local modifications I can produce things like <http://www-jcsu.jesus.cam.ac.uk/~csr21/gsharp-cris.ps>) --- /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/05/30 02:13:26 1.25 +++ /project/gsharp/cvsroot/gsharp/score-pane.lisp 2006/06/02 14:11:10 1.26 @@ -211,6 +211,8 @@ ;;;;;;;;;;;;;;;;;; helper macro +;;; This macro is currently not used. (And probably never will be +;;; used, now that we raster our own bezier curves.) (defmacro define-pixmap-recording ((draw-name args) &body body) `(defun ,draw-name (pane ,@args x staff-step) (let* ((extra (if *light-glyph* 1 0)) @@ -222,14 +224,16 @@ ;;;;;;;;;;;;;;;;;; notehead -(define-pixmap-recording (draw-notehead (name)) - (ecase name - (:whole +glyph-whole+) - (:half +glyph-half+) - (:filled +glyph-filled+))) - (define-presentation-type notehead () :options (name x staff-step)) +(defun draw-notehead (stream name x staff-step) + (sdl::draw-shape stream *font* + (ecase name + (:whole :whole-notehead) + (:half :half-notehead) + (:filled :filled-notehead)) + x (staff-step (- staff-step)))) + (define-presentation-method present (object (type notehead) stream (view score-view) &key) (with-output-as-presentation (stream object 'notehead) @@ -237,31 +241,19 @@ ;;;;;;;;;;;;;;;;;; accidental -(define-pixmap-recording (draw-accidental (name)) - (ecase name - (:natural +glyph-natural+) - (:flat +glyph-flat+) - (:double-flat +glyph-double-flat+) - (:sharp +glyph-sharp+) - (:double-sharp +glyph-double-sharp+))) +(defun draw-accidental (stream name x staff-step) + (sdl::draw-shape stream *font* name x (staff-step (- staff-step)))) ;;;;;;;;;;;;;;;;;; clef -(define-pixmap-recording (draw-clef (name)) - (ecase name - ;; FIXME: while using the same glyph for :TREBLE and :TREBLE8 is - ;; fine from a musical point of view, some differentiation (by - ;; putting an italic 8 underneath, for instance) would be good. - ((:treble :treble8) +glyph-g-clef+) - (:bass +glyph-f-clef+) - (:c +glyph-c-clef+))) - -(defun new-draw-clef (stream name x staff-step) +(defun draw-clef (stream name x staff-step) (sdl::draw-shape stream *font* (ecase name - ;; FIXME: while using the same glyph for :TREBLE and :TREBLE8 is - ;; fine from a musical point of view, some differentiation (by - ;; putting an italic 8 underneath, for instance) would be good. + ;; FIXME: while using the same glyph for :TREBLE + ;; and :TREBLE8 is fine from a musical point of + ;; view, some differentiation (by putting an + ;; italic 8 underneath, for instance) would be + ;; good. ((:treble :treble8) :g-clef) (:bass :f-clef) (:c :c-clef)) @@ -272,45 +264,52 @@ (define-presentation-method present (object (type clef) stream (view score-view) &key) (with-output-as-presentation (stream object 'clef) - (new-draw-clef stream name x staff-step))) + (draw-clef stream name x staff-step))) ;;;;;;;;;;;;;;;;;; rest -(define-pixmap-recording (draw-rest (duration)) - (ecase duration - (1 +glyph-whole-rest+) - (1/2 +glyph-half-rest+) - (1/4 +glyph-quarter-rest+) - (1/8 +glyph-eighth-rest+) - (1/16 +glyph-sixteenth-rest+) - (1/32 +glyph-thirtysecondth-rest+) - (1/64 +glyph-sixtyfourth-rest+) - (1/128 +glyph-onehundredandtwentyeigth-rest+))) +(defun draw-rest (stream duration x staff-step) + (sdl::draw-shape stream *font* + (ecase duration + (1 :whole-rest) + (1/2 :half-rest) + (1/4 :quarter-rest) + (1/8 :8th-rest) + (1/16 :16th-rest) + (1/32 :32nd-rest) + (1/64 :64th-rest) + ;; FIXME 128th + ) + x (staff-step (- staff-step)))) ;;;;;;;;;;;;;;;;;; flags down -(define-pixmap-recording (draw-flags-down (nb)) - (ecase nb - (1 +glyph-flags-down-one+) - (2 +glyph-flags-down-two+) - (3 +glyph-flags-down-three+) - (4 +glyph-flags-down-four+) - (5 +glyph-flags-down-five+))) +(defun draw-flags-down (stream nb x staff-step) + (sdl::draw-shape stream *font* + (ecase nb + (1 :flags-down-1) + (2 :flags-down-2) + (3 :flags-down-3) + (4 :flags-down-4) + (5 :flags-down-5)) + x (staff-step (- staff-step)))) ;;;;;;;;;;;;;;;;;; flags up -(define-pixmap-recording (draw-flags-up (nb)) - (ecase nb - (1 +glyph-flags-up-one+) - (2 +glyph-flags-up-two+) - (3 +glyph-flags-up-three+) - (4 +glyph-flags-up-four+) - (5 +glyph-flags-up-five+))) +(defun draw-flags-up (stream nb x staff-step) + (sdl::draw-shape stream *font* + (ecase nb + (1 :flags-up-1) + (2 :flags-up-2) + (3 :flags-up-3) + (4 :flags-up-4) + (5 :flags-up-5)) + x (staff-step (- staff-step)))) ;;;;;;;;;;;;;;;;;; dot -(define-pixmap-recording (draw-dot ()) - +glyph-dot+) +(defun draw-dot (stream x staff-step) + (sdl::draw-shape stream *font* :dot x (staff-step (- staff-step)))) ;;;;;;;;;;;;;;;;;; staff line @@ -652,58 +651,60 @@ (xx2 (round (- x2 (staff-step 10)))) (y1 (- (round (staff-step (+ staff-step 11/3))))) (thickness (round (staff-step 2/3)))) - (draw-antialiased-glyph pane +glyph-large-tie-left-up+ xx1 staff-step) - (draw-antialiased-glyph pane +glyph-large-tie-right-up+ xx2 staff-step) + (sdl::draw-shape pane *font* :large-tie-up-left xx1 (staff-step (- staff-step))) + (sdl::draw-shape pane *font* :large-tie-up-right xx2 (staff-step (- staff-step))) (draw-rectangle* pane xx1 y1 xx2 (+ y1 thickness))) - (let ((glyph-no (cond ((> dist 18) +glyph-large-tie-ten-up+) - ((> dist 17) +glyph-large-tie-nine-up+) - ((> dist 16) +glyph-large-tie-eight-up+) - ((> dist 15) +glyph-large-tie-seven-up+) - ((> dist 14) +glyph-large-tie-six-up+) - ((> dist 13) +glyph-large-tie-five-up+) - ((> dist 12) +glyph-large-tie-four-up+) - ((> dist 11) +glyph-large-tie-three-up+) - ((> dist 10) +glyph-large-tie-two-up+) - ((> dist 9) +glyph-large-tie-one-up+) - ((> dist 8) +glyph-small-tie-eight-up+) - ((> dist 7) +glyph-small-tie-seven-up+) - ((> dist 6) +glyph-small-tie-six-up+) - ((> dist 5) +glyph-small-tie-five-up+) - ((> dist 4) +glyph-small-tie-four-up+) - ((> dist 3) +glyph-small-tie-three-up+) - ((> dist 2) +glyph-small-tie-two-up+) - (t +glyph-small-tie-one-up+)))) - (draw-antialiased-glyph pane glyph-no (round (* 0.5 (+ x1 x2))) staff-step))))) + (let ((glyph-name (cond ((> dist 18) :large-tie-10-up) + ((> dist 17) :large-tie-9-up) + ((> dist 16) :large-tie-8-up) + ((> dist 15) :large-tie-7-up) + ((> dist 14) :large-tie-6-up) + ((> dist 13) :large-tie-5-up) + ((> dist 12) :large-tie-4-up) + ((> dist 11) :large-tie-3-up) + ((> dist 10) :large-tie-2-up) + ((> dist 9) :large-tie-1-up) + ((> dist 8) :small-tie-8-up) + ((> dist 7) :small-tie-7-up) + ((> dist 6) :small-tie-6-up) + ((> dist 5) :small-tie-5-up) + ((> dist 4) :small-tie-4-up) + ((> dist 3) :small-tie-3-up) + ((> dist 2) :small-tie-2-up) + (t :small-tie-1-up)))) + (sdl::draw-shape pane *font* glyph-name + (round (* 0.5 (+ x1 x2))) (staff-step (- staff-step))))))) (defun draw-tie-down (pane x1 x2 staff-step) (let ((dist (/ (- x2 x1) (staff-step 4/3)))) (if (> dist 19) (let ((xx1 (round (+ x1 (staff-step 10)))) (xx2 (round (- x2 (staff-step 10)))) - (y1 (- (round (staff-step (+ staff-step 11/3))))) + (y1 (- (round (staff-step (- staff-step 8/3))))) (thickness (round (staff-step 2/3)))) - (draw-antialiased-glyph pane +glyph-large-tie-left-down+ xx1 staff-step) - (draw-antialiased-glyph pane +glyph-large-tie-right-down+ xx2 staff-step) + (sdl::draw-shape pane *font* :large-tie-down-left xx1 (staff-step (- staff-step))) + (sdl::draw-shape pane *font* :large-tie-down-right xx2 (staff-step (- staff-step))) (draw-rectangle* pane xx1 y1 xx2 (+ y1 thickness))) - (let ((glyph-no (cond ((> dist 18) +glyph-large-tie-ten-down+) - ((> dist 17) +glyph-large-tie-nine-down+) - ((> dist 16) +glyph-large-tie-eight-down+) - ((> dist 15) +glyph-large-tie-seven-down+) - ((> dist 14) +glyph-large-tie-six-down+) - ((> dist 13) +glyph-large-tie-five-down+) - ((> dist 12) +glyph-large-tie-four-down+) - ((> dist 11) +glyph-large-tie-three-down+) - ((> dist 10) +glyph-large-tie-two-down+) - ((> dist 9) +glyph-large-tie-one-down+) - ((> dist 8) +glyph-small-tie-eight-down+) - ((> dist 7) +glyph-small-tie-seven-down+) - ((> dist 6) +glyph-small-tie-six-down+) - ((> dist 5) +glyph-small-tie-five-down+) - ((> dist 4) +glyph-small-tie-four-down+) - ((> dist 3) +glyph-small-tie-three-down+) - ((> dist 2) +glyph-small-tie-two-down+) - (t +glyph-small-tie-one-down+)))) - (draw-antialiased-glyph pane glyph-no (round (* 0.5 (+ x1 x2))) staff-step))))) + (let ((glyph-name (cond ((> dist 18) :large-tie-10-down) + ((> dist 17) :large-tie-9-down) + ((> dist 16) :large-tie-8-down) + ((> dist 15) :large-tie-7-down) + ((> dist 14) :large-tie-6-down) + ((> dist 13) :large-tie-5-down) + ((> dist 12) :large-tie-4-down) + ((> dist 11) :large-tie-3-down) + ((> dist 10) :large-tie-2-down) + ((> dist 9) :large-tie-1-down) + ((> dist 8) :small-tie-8-down) + ((> dist 7) :small-tie-7-down) + ((> dist 6) :small-tie-6-down) + ((> dist 5) :small-tie-5-down) + ((> dist 4) :small-tie-4-down) + ((> dist 3) :small-tie-3-down) + ((> dist 2) :small-tie-2-down) + (t :small-tie-1-down)))) + (sdl::draw-shape pane *font* glyph-name + (round (* 0.5 (+ x1 x2))) (staff-step (- staff-step))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[gsharp-cvs] CVS gsharp
by crhodes 02 Jun '06

02 Jun '06

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

1 0

[gsharp-cvs] CVS gsharp
by crhodes 02 Jun '06

02 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv19736 Modified Files: sdl.lisp Log Message: Fix large-tie glyphs and whole-rest glyph. (Note that there is clearly an offset problem: the half- and whole- rests do not lie on / hang cleanly from staff lines, with or without this change) --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/01 18:57:40 1.19 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/02 12:37:47 1.20 @@ -885,43 +885,43 @@ (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 (round (* 2.0 sld))))) + (large-tie-up sld slt 2.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-2-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 2.33 sld))))) + (large-tie-up sld slt 2.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-3-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 2.67 sld))))) + (large-tie-up sld slt 2.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-4-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 3.0 sld))))) + (large-tie-up sld slt 3.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-5-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 3.33 sld))))) + (large-tie-up sld slt 3.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-6-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 3.67 sld))))) + (large-tie-up sld slt 3.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-7-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 4.0 sld))))) + (large-tie-up sld slt 4.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-8-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 4.33 sld))))) + (large-tie-up sld slt 4.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-9-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 4.67 sld))))) + (large-tie-up sld slt 4.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-10-up))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-up sld slt (round (* 5.0 sld))))) + (large-tie-up sld slt 5.0))) (defun large-tie-down (sld slt width-multiplier) (let* ((thickness (round (* 0.33 sld))) @@ -940,43 +940,43 @@ (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 (round (* 2.0 sld))))) + (large-tie-down sld slt 2.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-2-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 2.33 sld))))) + (large-tie-down sld slt 2.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-3-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 2.67 sld))))) + (large-tie-down sld slt 2.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-4-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 3.0 sld))))) + (large-tie-down sld slt 3.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-5-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 3.33 sld))))) + (large-tie-down sld slt 3.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-6-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 3.67 sld))))) + (large-tie-down sld slt 3.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-7-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 4.0 sld))))) + (large-tie-down sld slt 4.0))) (defmethod compute-design ((font font) (shape (eql :large-tie-8-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 4.33 sld))))) + (large-tie-down sld slt 4.33))) (defmethod compute-design ((font font) (shape (eql :large-tie-9-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 4.67 sld))))) + (large-tie-down sld slt 4.67))) (defmethod compute-design ((font font) (shape (eql :large-tie-10-down))) (with-slots ((sld staff-line-distance) (slt staff-line-thickness)) font - (large-tie-down sld slt (round (* 5.0 sld))))) + (large-tie-down sld slt 5.0))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1155,7 +1155,7 @@ (flet ((c (x y) (complex x y))) (translate (xyscale (translate +unit-square+ #c(-0.5 0)) notehead-width (* 0.5 sld)) - (c xoffset (* yoffset (* 0.5 sld))))))) + (c xoffset (+ yoffset (* 0.5 sld))))))) (defmethod compute-design ((font font) (shape (eql :half-rest))) (with-slots ((sld staff-line-distance) notehead-width xoffset yoffset) font

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 01 Jun '06

01 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv5096 Modified Files: bezier.lisp fontview.lisp sdl.lisp Log Message: Fixed a bug in bezier.lisp that made the resulting pixmap positioned in the wrong place sometimes. Fixed a bug in sdl.lisp that computed the wrong xoffset (in particular for noteheads). Fixed the whole notehead so that its vertical position is not offset as it should. Fixed the C clef so that it no longer goes below the bottom line. Improved the font viewer by having the bounding box of the glyph drawn in :pixel mode. --- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/01 04:55:37 1.3 +++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/01 18:57:40 1.4 @@ -703,6 +703,8 @@ (defun render-through-pixmap (design medium positive-areas negative-areas) (multiple-value-bind (min-x min-y) (bounding-rectangle* design) + (setf min-x (floor min-x) + min-y (floor min-y)) (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) *pixmaps*))) (when (null pixmap) --- /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/01 04:55:37 1.2 +++ /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/01 18:57:40 1.3 @@ -9,9 +9,9 @@ ((font :initform (make-instance 'sdl::font :staff-line-distance 6)) (shape :initform :g-clef) (grid :initform t) - (staff :initform nil) + (staff :initform t) (staff-offset :initform 0) - (view :initform :pixel) + (view :initform :antialiased) (zoom :initform 1) (hoffset :initform 300) (voffset :initform 300)) @@ -72,6 +72,24 @@ do (draw-rectangle* pane x -300 (1+ x) 300 :ink +blue+)) (loop for x from 0 below 300 by (* 4 zoom) do (draw-rectangle* pane x -300 (1+ x) 300 :ink +blue+)) + ;; draw the bounding rectangle + (draw-rectangle* pane + (* zoom min-x) (* zoom min-y) + (* zoom max-x) (1+ (* zoom min-y)) + :ink +red+) + (draw-rectangle* pane + (* zoom min-x) (* zoom max-y) + (* zoom max-x) (1+ (* zoom max-y)) + :ink +red+) + (draw-rectangle* pane + (* zoom min-x) (* zoom min-y) + (1+ (* zoom min-x)) (* zoom max-y) + :ink +red+) + (draw-rectangle* pane + (* zoom max-x) (* zoom min-y) + (1+ (* zoom max-x)) (* zoom max-y) + :ink +red+) + ;; draw the reference point (draw-rectangle* pane -300 0 300 1 :ink +red+) (draw-rectangle* pane 0 -300 1 300 :ink +red+)))))))) --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/01 11:01:26 1.18 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/01 18:57:40 1.19 @@ -151,7 +151,7 @@ beam-hang-sit-offset) font (setf staff-line-thickness (round (/ (staff-line-distance font) 10))) (setf xoffset - (if (oddp (round (* 1.5 staff-line-distance))) 1.5 0)) + (if (oddp (round (* 1.5 staff-line-distance))) 0.5 0)) (setf yoffset (if (oddp staff-line-thickness) 0.5 0)) (setf dot-diameter @@ -610,12 +610,12 @@ (mf (c xc (- staff-line-thickness)) -- (c xc 0))))))) (clim:region-union (climi::close-path (mf (c 0 top) -- (c xa top) -- - (c xa (- (- top) staff-line-thickness)) -- - (c 0 (- (- top) staff-line-thickness)) -- (c 0 top))) + (c xa (- top)) -- + (c 0 (- top)) -- (c 0 top))) (clim:region-union (climi::close-path (mf (c xb top) -- (c xc top) -- - (c xc (- (- top) staff-line-thickness)) -- - (c xb (- (- top) staff-line-thickness)) -- (c xb top))) + (c xc (- top)) -- + (c xb (- top)) -- (c xb top))) (translate r (c 0 staff-line-thickness)))))))) ;;; @@ -712,7 +712,7 @@ (complex xoffset yoffset)))) (defmethod compute-design ((font font) (shape (eql :whole-notehead))) - (with-slots ((sld staff-line-distance)) font + (with-slots (xoffset yoffset (sld staff-line-distance)) font (let ((op (scale (superellipse #c(0.75 0.0) #c(0.0 0.58) #c(-0.75 0.0) #c(0.0 -0.58) 0.7) sld)) @@ -720,7 +720,8 @@ #c(-0.3 0.0) #c(0.0 -0.35) 0.8) -0.3) sld))) - (clim:region-difference op (climi::reverse-path ip))))) + (translate (clim:region-difference op (climi::reverse-path ip)) + (complex xoffset yoffset))))) (defmethod compute-design ((font font) (shape (eql :half-notehead))) (with-slots (xoffset yoffset (sld staff-line-distance)) font

1 0

[gsharp-cvs] CVS gsharp
by crhodes 01 Jun '06

01 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv31532 Modified Files: sdl.lisp Log Message: Fix a bug in the C clef. It's still not symmetrical about the X axis, but the weird zooming point in the curve is fixed. --- /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/05/31 19:51:58 1.17 +++ /project/gsharp/cvsroot/gsharp/sdl.lisp 2006/06/01 11:01:26 1.18 @@ -598,7 +598,7 @@ (c (+ xd (* 0.5 dot-width)) (+ yd dot-width)) right ++ (c (+ xd dot-width) (+ yd (* 0.5 dot-width))) down ++ (c (+ xd (* 0.5 dot-width)) yd) left ++ - (c xd (* yd (* 0.5 dot-width))) up ++ (c xf top) right ++ + (c xd (+ yd (* 0.5 dot-width))) up ++ (c xf top) right ++ (c xk yk) down ++ (c xh (- yh staff-line-thickness)) ++ (c xl yl) & (c xl yl) ++ down (c xi 0))) (q (translate (yscale p -1) (c 0 (- staff-line-thickness))))

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 01 Jun '06

01 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv13899 Modified Files: gui.lisp Log Message: Removed bogus menu entry. --- /project/gsharp/cvsroot/gsharp/gui.lisp 2006/05/23 11:43:29 1.63 +++ /project/gsharp/cvsroot/gsharp/gui.lisp 2006/06/01 04:57:10 1.64 @@ -233,6 +233,7 @@ :errorp nil :menu '(("File" :menu file-command-table) ("Buffer" :menu buffer-command-table) + ("Stuff" :menu segment-command-table) ("Segment" :menu segment-command-table) ("Layer" :menu layer-command-table) ("Slice" :menu slice-command-table)

1 0

[gsharp-cvs] CVS gsharp
by rstrandh 01 Jun '06

01 Jun '06

Update of /project/gsharp/cvsroot/gsharp In directory clnet:/tmp/cvs-serv13742 Modified Files: bezier.lisp fontview.lisp Log Message: Moved things around a bit inside bezier.lisp to make it easier to render to an array from the font viewer. Implemented pixel viewing in the font viewer. Initial results indicate that the G-clef is pretty good, and there must be something wrong either with the way the pixmap gets generated or with the way it gets copied to the pane (it is too far down). Initial result also indicate that the C-clef is completely wrong and incredibly ugly at sizes above 6. --- /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/05/30 02:13:26 1.2 +++ /project/gsharp/cvsroot/gsharp/bezier.lisp 2006/06/01 04:55:37 1.3 @@ -662,23 +662,25 @@ repeat (nb-lines lines) do (render-scan-lines array pixel-value i (crossings lines i) min-x min-y)))) -(defun render-to-array (positive-areas negative-areas min-x min-y max-x max-y) - (setf min-x (* 4 (floor min-x)) - min-y (* 4 (floor min-y)) - max-x (* 4 (ceiling max-x)) - max-y (* 4 (ceiling max-y))) - (let ((result (make-array (list (- max-y min-y) (- max-x min-x)) - :element-type 'bit :initial-element 1)) - (transformation (make-scaling-transformation* 4 4))) - (loop for area in positive-areas - do (let* ((transformed-area (transform-region transformation area)) - (polygon (polygonalize transformed-area))) - (render-polygon result polygon 0 min-x min-y))) - (loop for area in negative-areas - do (let* ((transformed-area (transform-region transformation area)) - (polygon (polygonalize transformed-area))) - (render-polygon result polygon 1 min-x min-y))) - result)) +(defun render-to-array (positive-areas negative-areas) + (multiple-value-bind (min-x min-y max-x max-y) + (bounding-rectangle-of-areas positive-areas) + (setf min-x (* 4 (floor min-x)) + min-y (* 4 (floor min-y)) + max-x (* 4 (ceiling max-x)) + max-y (* 4 (ceiling max-y))) + (let ((result (make-array (list (- max-y min-y) (- max-x min-x)) + :element-type 'bit :initial-element 1)) + (transformation (make-scaling-transformation* 4 4))) + (loop for area in positive-areas + do (let* ((transformed-area (transform-region transformation area)) + (polygon (polygonalize transformed-area))) + (render-polygon result polygon 0 min-x min-y))) + (loop for area in negative-areas + do (let* ((transformed-area (transform-region transformation area)) + (polygon (polygonalize transformed-area))) + (render-polygon result polygon 1 min-x min-y))) + result))) (defparameter *x* 0) (defparameter *y* 0) @@ -699,12 +701,12 @@ (+ (* a 1.0) (* 1-a b)))))) (defun render-through-pixmap (design medium positive-areas negative-areas) - (multiple-value-bind (min-x min-y max-x max-y) - (bounding-rectangle-of-areas positive-areas) + (multiple-value-bind (min-x min-y) + (bounding-rectangle* design) (let ((pixmap (gethash (list (medium-sheet medium) (resolve-ink medium) design) *pixmaps*))) (when (null pixmap) - (let* ((picture (render-to-array positive-areas negative-areas min-x min-y max-x max-y)) + (let* ((picture (render-to-array positive-areas negative-areas)) (height (array-dimension picture 0)) (width (array-dimension picture 1)) (reduced-picture (make-array (list (/ height 4) (/ width 4)) :initial-element 16))) @@ -741,6 +743,20 @@ (multiple-value-bind (*x* *y*) (transform-position (translation design) 0 0) (medium-draw-design* medium (original-region design)))) +(defgeneric render-design-to-array (design)) + +(defmethod render-design-to-array ((design bezier-area)) + (render-to-array (list design) '())) + +(defmethod render-design-to-array ((design bezier-union)) + (render-to-array (areas design) '())) + +(defmethod render-design-to-array ((design bezier-difference)) + (render-to-array (positive-areas design) (negative-areas design))) + +(defmethod render-design-to-array ((design translated-region)) + (render-design-to-array (original-region design))) + (defmethod draw-design (sheet design &rest args &key &allow-other-keys) (climi::with-medium-options (sheet args) (medium-draw-design* medium design))) --- /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/05/31 19:55:19 1.1 +++ /project/gsharp/cvsroot/gsharp/fontview.lisp 2006/06/01 04:55:37 1.2 @@ -8,10 +8,10 @@ (define-application-frame fontview () ((font :initform (make-instance 'sdl::font :staff-line-distance 6)) (shape :initform :g-clef) - (grid :initform nil) + (grid :initform t) (staff :initform nil) (staff-offset :initform 0) - (view :initform :antialiased) + (view :initform :pixel) (zoom :initform 1) (hoffset :initform 300) (voffset :initform 300)) @@ -41,9 +41,39 @@ (* 10 sld) (+ y down))))))))) (defun display-pixel-view (frame pane) - (declare (ignore pane)) (with-slots (font shape grid zoom hoffset voffset) frame - nil)) + (with-translation (pane hoffset voffset) + (let ((design (sdl::ensure-design font shape))) + (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* design) + (setf min-x (* 4 (floor min-x)) + min-y (* 4 (floor min-y)) + max-x (* 4 (ceiling max-x)) + max-y (* 4 (ceiling max-y))) + (let ((array (climi::render-design-to-array design))) + (loop for y from min-y below max-y + for y-index from 0 + do (loop with x0 = nil + for x from min-x below max-x + for x-index from 0 + do (if (zerop (aref array y-index x-index)) + (when (null x0) + (setf x0 x)) + (unless (null x0) + (draw-rectangle* pane (* x0 zoom) (* y zoom) (* x zoom) (* (1+ y) zoom)) + (setf x0 nil))) + finally (unless (null x0) + (draw-rectangle* pane (* x0 zoom) (* y zoom) (* x zoom) (* (1+ y) zoom))))) + (when grid + (loop for y downfrom 0 above -300 by (* 4 zoom) + do (draw-rectangle* pane -300 y 300 (1+ y) :ink +blue+)) + (loop for y from 0 below 300 by (* 4 zoom) + do (draw-rectangle* pane -300 y 300 (1+ y) :ink +blue+)) + (loop for x downfrom 0 above -300 by (* 4 zoom) + do (draw-rectangle* pane x -300 (1+ x) 300 :ink +blue+)) + (loop for x from 0 below 300 by (* 4 zoom) + do (draw-rectangle* pane x -300 (1+ x) 300 :ink +blue+)) + (draw-rectangle* pane -300 0 300 1 :ink +red+) + (draw-rectangle* pane 0 -300 1 300 :ink +red+)))))))) (defun display-entry (frame pane) (with-slots (view) frame

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

gsharp-cvs June 2006